1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
;; -*-theme-d-*-
;; Copyright (C) 2016 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.
;; Expected results: translation and running OK
(define-proper-program (tests test402)
(import (standard-library core)
(standard-library string-utilities)
(standard-library object-string-conversion)
(standard-library console-io))
(define-class <graphics-context>
(fields
(i-x <integer> public public)
(i-y <integer> public public)
(i-width <integer> public public)
(i-height <integer> public public)))
(define-class <widget>
(fields
(context (:maybe <graphics-context>) public module null)
(widget-parent (:maybe <widget>) public module null)))
(define-class <label>
(superclass <widget>))
(define-simple-proc logger-print (((str-message <string>)) <none> nonpure)
(console-display-line str-message))
(define-simple-virtual-method initialize
(((widget <widget>) (context <graphics-context>)
(widget-parent (:maybe <widget>)))
<none> nonpure)
(logger-print "initialize widget")
(field-set! widget 'context context)
(field-set! widget 'widget-parent widget-parent))
(define-simple-virtual-method initialize
(((label <label>) (context <graphics-context>) (widget-parent <widget>))
<none> nonpure)
(logger-print "initialize label")
((generic-proc-dispatch-without-result
initialize
(<widget> <graphics-context> <widget>)
())
label context widget-parent))
(define-simple-virtual-method object->string (((context <graphics-context>))
<string>
pure)
(string-append "(graphics-context "
(integer->string (field-ref context 'i-x))
" "
(integer->string (field-ref context 'i-y))
" "
(integer->string (field-ref context 'i-width))
" "
(integer->string (field-ref context 'i-height))
")"))
(define-main-proc (() <none> nonpure)
(let* ((widget-parent
(let ((widget1 (create <widget>)))
(initialize widget1
(create <graphics-context> 100 100 400 200)
null)
widget1))
(label
(let ((label1 (create <label>)))
(initialize label1
(create <graphics-context> 100 100 200 50)
widget-parent)
label1)))
(console-display-line (field-ref label 'context))
(console-display-line (field-ref
(cast <widget>
(field-ref label 'widget-parent))
'context)))))
|
