-
Notifications
You must be signed in to change notification settings - Fork 0
/
class.rkt
256 lines (224 loc) · 8.84 KB
/
class.rkt
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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
#lang plai-typed
(define-type ExprC
[numC (n : number)]
[plusC (lhs : ExprC)
(rhs : ExprC)]
[multC (lhs : ExprC)
(rhs : ExprC)]
[argC]
[thisC]
[newC (class-name : symbol)
(args : (listof ExprC))]
[if0C (cnd : ExprC)
(thn : ExprC)
(els : ExprC)]
[getC (obj-expr : ExprC)
(field-name : symbol)]
[setC (obj-expr : ExprC)
(field-name : symbol)
(new-val : ExprC)]
[sendC (obj-expr : ExprC)
(method-name : symbol)
(arg-expr : ExprC)]
[ssendC (obj-expr : ExprC)
(class-name : symbol)
(method-name : symbol)
(arg-expr : ExprC)])
(define-type ClassC
[classC (name : symbol)
(field-names : (listof symbol))
(methods : (listof MethodC))])
(define-type MethodC
[methodC (name : symbol)
(body-expr : ExprC)])
(define-type Value
[numV (n : number)]
[objV (class-name : symbol)
(field-values : (listof (boxof Value)))])
(module+ test
(print-only-errors true))
;; ----------------------------------------
(define (make-find [name-of : ('a -> symbol)])
(lambda ([name : symbol] [vals : (listof 'a)]) : 'a
(cond
[(empty? vals)
(error 'find "not found")]
[else (if (equal? name (name-of (first vals)))
(first vals)
((make-find name-of) name (rest vals)))])))
(define find-class : (symbol (listof ClassC) -> ClassC)
(make-find classC-name))
(define find-method : (symbol (listof MethodC) -> MethodC)
(make-find methodC-name))
;; A non-list pair:
(define-type (Pair 'a 'b)
[kons (first : 'a) (rest : 'b)])
(define (get-field [name : symbol]
[field-names : (listof symbol)]
[vals : (listof (boxof Value))])
;; Pair fields and values, find by field name,
;; then extract value from pair
(kons-rest ((make-find kons-first)
name
(map2 kons field-names vals))))
(module+ test
(test/exn (find-class 'a empty)
"not found")
(test (find-class 'a (list (classC 'a empty empty)))
(classC 'a empty empty))
(test (find-class 'b (list (classC 'a empty empty)
(classC 'b empty empty)))
(classC 'b empty empty))
(test (get-field 'a
(list 'a 'b)
(list (box (numV 0)) (box (numV 1))))
(box (numV 0))))
;; ----------------------------------------
(define interp : (ExprC (listof ClassC) Value Value -> Value)
(lambda (a classes this-val arg-val)
(local [(define (recur expr)
(interp expr classes this-val arg-val))]
(type-case ExprC a
[numC (n) (numV n)]
[plusC (l r) (num+ (recur l) (recur r))]
[multC (l r) (num* (recur l) (recur r))]
[thisC () this-val]
[argC () arg-val]
[if0C (cnd thn els)
(type-case Value (recur cnd)
[numV (n) (if (= n 0) (recur thn) (recur els))]
[else
(error 'interp "not a number")])]
[newC (class-name field-exprs)
(local [(define c (find-class class-name classes))
(define vals (map recur field-exprs))]
(if (= (length vals) (length (classC-field-names c)))
(objV class-name (map box vals))
(error 'interp "wrong field count")))]
[getC (obj-expr field-name)
(type-case Value (recur obj-expr)
[objV (class-name field-vals)
(type-case ClassC (find-class class-name classes)
[classC (name field-names methods)
(unbox (get-field field-name field-names
field-vals))])]
[else (error 'interp "not an object")])]
[setC (obj-expr field-name new-val)
(type-case Value (recur obj-expr)
[objV (class-name field-vals)
(type-case ClassC (find-class class-name classes)
[classC (name field-names methods)
(local [(define val (recur new-val))]
(begin
(set-box! (get-field field-name field-names
field-vals) val)
(objV class-name field-vals)))])]
[else (error 'interp "not an object")])]
[sendC (obj-expr method-name arg-expr)
(local [(define obj (recur obj-expr))
(define arg-val (recur arg-expr))]
(type-case Value obj
[objV (class-name field-vals)
(call-method class-name method-name classes
obj arg-val)]
[else (error 'interp "not an object")]))]
[ssendC (obj-expr class-name method-name arg-expr)
(local [(define obj (recur obj-expr))
(define arg-val (recur arg-expr))]
(call-method class-name method-name classes
obj arg-val))]))))
(define (call-method class-name method-name classes
obj arg-val)
(type-case ClassC (find-class class-name classes)
[classC (name field-names methods)
(type-case MethodC (find-method method-name methods)
[methodC (name body-expr)
(interp body-expr
classes
obj
arg-val)])]))
(define (num-op [op : (number number -> number)]
[op-name : symbol]
[x : Value]
[y : Value]) : Value
(cond
[(and (numV? x) (numV? y))
(numV (op (numV-n x) (numV-n y)))]
[else (error 'interp "not a number")]))
(define (num+ x y) (num-op + '+ x y))
(define (num* x y) (num-op * '* x y))
;; ----------------------------------------
;; Examples
(module+ test
(define posn-class
(classC
'posn
(list 'x 'y)
(list (methodC 'mdist
(plusC (getC (thisC) 'x) (getC (thisC) 'y)))
(methodC 'addDist
(plusC (sendC (thisC) 'mdist (numC 0))
(sendC (argC) 'mdist (numC 0))))
(methodC 'addX
(plusC (getC (thisC) 'x) (argC)))
(methodC 'multY (multC (argC) (getC (thisC) 'y)))
(methodC 'factory12 (newC 'posn (list (numC 1) (numC 2))))
(methodC 'setY (setC (thisC) 'y (argC))))))
(define posn3D-class
(classC
'posn3D
(list 'x 'y 'z)
(list (methodC 'mdist (plusC (getC (thisC) 'z)
(ssendC (thisC) 'posn 'mdist (argC))))
(methodC 'addDist (ssendC (thisC) 'posn 'addDist (argC))))))
(define posn27 (newC 'posn (list (numC 2) (numC 7))))
(define posn20 (newC 'posn (list (numC 2) (numC 0))))
(define posn531 (newC 'posn3D (list (numC 5) (numC 3) (numC 1))))
(define posn501 (newC 'posn3D (list (numC 5) (numC 0) (numC 1))))
(define (interp-posn a)
(interp a (list posn-class posn3D-class) (numV -1) (numV -1))))
;; ----------------------------------------
(module+ test
(test (interp (numC 10)
empty (numV -1) (numV -1))
(numV 10))
(test (interp (plusC (numC 10) (numC 17))
empty (numV -1) (numV -1))
(numV 27))
(test (interp (multC (numC 10) (numC 7))
empty (numV -1) (numV -1))
(numV 70))
(test (interp-posn (newC 'posn (list (numC 2) (numC 7))))
(objV 'posn (list (box (numV 2)) (box (numV 7)))))
(test (interp-posn (sendC posn27 'mdist (numC 0)))
(numV 9))
(test (interp-posn (sendC posn27 'addX (numC 10)))
(numV 12))
(test (interp-posn (sendC (ssendC posn27 'posn 'factory12 (numC 0))
'multY
(numC 15)))
(numV 30))
(test (interp-posn (sendC posn531 'addDist posn27))
(numV 18))
(test (interp-posn (setC posn531 'y (numC 0)))
(interp-posn posn501))
(test (interp-posn (sendC posn27 'setY (numC 0)))
(interp-posn posn20))
(test (interp-posn (if0C (numC 0) posn27 posn531))
(interp-posn posn27))
(test (interp-posn (if0C (numC 1) posn27 posn531))
(interp-posn posn531))
(test/exn (interp-posn (if0C posn27 posn27 posn531))
"not a number")
(test/exn (interp-posn (plusC (numC 1) posn27))
"not a number")
(test/exn (interp-posn (getC (numC 1) 'x))
"not an object")
(test/exn (interp-posn (setC (numC 1) 'x (numC 0)))
"not an object")
(test/exn (interp-posn (sendC (numC 1) 'mdist (numC 0)))
"not an object")
(test/exn (interp-posn (ssendC (numC 1) 'posn 'mdist (numC 0)))
"not an object")
(test/exn (interp-posn (newC 'posn (list (numC 0))))
"wrong field count"))