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
85
86
87
88
89
90
91
92
93
|
;; -*-theme-d-*-
;; Copyright (C) 2016-2020 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.
;; Expected results: translation and running OK
(define-proper-program (tests test769)
(import (standard-library core)
(standard-library object-string-conversion)
(standard-library console-io)
(standard-library string-utilities))
(define-virtual-gen-proc initialize)
(define-syntax create2
(syntax-rules ()
((create clas arg ...)
(force-pure-expr
(let ((tmp (create clas)))
(initialize tmp arg ...)
tmp)))))
(define-class <graphics-context>
(construct ((i-x1 <integer>) (i-y1 <integer>)
(i-width1 <integer>) (i-height1 <integer>)))
(fields
(i-x <integer> public public i-x1)
(i-y <integer> public public i-y1)
(i-width <integer> public public i-width1)
(i-height <integer> public public i-height1)))
(define-class <widget>
(fields
(context (:maybe <graphics-context>) public module null)
(widget-parent (:maybe <widget>) public module null)))
(define-class <label>
(superclass <widget>)
(fields (str-text <string> public module "")))
(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>)
(str-text <string>))
<none> nonpure)
(logger-print "initialize label")
((generic-proc-dispatch-without-result
initialize
(<widget> <graphics-context> <widget>)
())
label context widget-parent)
(field-set! label 'str-text str-text))
(define-simple-virtual-method atom->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
(create2 <widget> (create <graphics-context> 100 100 400 200) null))
(label
(create2 <label> (create <graphics-context> 100 100 200 50)
widget-parent
"Hello")))
(console-display-line (field-ref label 'str-text))
(console-display-line (field-ref label 'context))
(console-display-line (field-ref
(cast <widget>
(field-ref label 'widget-parent))
'context)))))
|
