-
Notifications
You must be signed in to change notification settings - Fork 0
/
class.rkt~
212 lines (187 loc) · 6.89 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
#lang plait
(define-type Exp
(numE [n : Number])
(plusE [lhs : Exp]
[rhs : Exp])
(multE [lhs : Exp]
[rhs : Exp])
(argE)
(thisE)
(newE [class-name : Symbol]
[args : (Listof Exp)])
(getE [obj-expr : Exp]
[field-name : Symbol])
(sendE [obj-expr : Exp]
[method-name : Symbol]
[arg-expr : Exp])
(ssendE [obj-expr : Exp]
[class-name : Symbol]
[method-name : Symbol]
[arg-expr : Exp])
;; Impl. 2
(if0E [tst-expr : Exp]
[thn-expr : Exp]
[els-expr : Exp]))
(define-type Class
(classC [field-names : (Listof Symbol)]
[methods : (Listof (Symbol * Exp))]))
(define-type Value
(numV [n : Number])
(objV [class-name : Symbol]
[field-values : (Listof Value)]))
(module+ test
(print-only-errors #t))
;; ----------------------------------------
(define (find [l : (Listof (Symbol * 'a))] [name : Symbol]) : 'a
(type-case (Listof (Symbol * 'a)) l
[empty
(error 'find (string-append "not found: " (symbol->string name)))]
[(cons p rst-l)
(if (symbol=? (fst p) name)
(snd p)
(find rst-l name))]))
(module+ test
(test (find (list (values 'a 1)) 'a)
1)
(test (find (list (values 'a 1) (values 'b 2)) 'b)
2)
(test/exn (find empty 'a)
"not found: a")
(test/exn (find (list (values 'a 1)) 'x)
"not found: x"))
;; ----------------------------------------
(define interp : (Exp (Listof (Symbol * Class)) Value Value -> Value)
(lambda (a classes this-val arg-val)
(local [(define (recur expr)
(interp expr classes this-val arg-val))]
(type-case Exp a
[(numE n) (numV n)]
[(plusE l r) (num+ (recur l) (recur r))]
[(multE l r) (num* (recur l) (recur r))]
[(thisE) this-val]
[(argE) arg-val]
[(newE class-name field-exprs)
(local [(define c (find classes class-name))
(define vals (map recur field-exprs))]
(if (= (length vals) (length (classC-field-names c)))
(objV class-name vals)
(error 'interp "wrong field count")))]
[(getE obj-expr field-name)
(type-case Value (recur obj-expr)
[(objV class-name field-vals)
(type-case Class (find classes class-name)
[(classC field-names methods)
(find (map2 (lambda (n v) (values n v))
field-names
field-vals)
field-name)])]
[else (error 'interp "not an object")])]
[(sendE 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")]))]
[(ssendE 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))]
;; Impl. 2
[(if0E tst-expr thn-expr els-expr)
(type-case Value (recur tst-expr)
[(numV n) (if (= n 0)
(recur thn-expr)
(recur els-expr))]
[else (error 'interp "not a number")])]))))
(define (call-method class-name method-name classes
obj arg-val)
(type-case Class (find classes class-name)
[(classC field-names methods)
(let ([body-expr (find methods method-name)])
(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
(values 'Posn
(classC
(list 'x 'y)
(list (values 'mdist
(plusE (getE (thisE) 'x) (getE (thisE) 'y)))
(values 'addDist
(plusE (sendE (thisE) 'mdist (numE 0))
(sendE (argE) 'mdist (numE 0))))
(values 'addX
(plusE (getE (thisE) 'x) (argE)))
(values 'multY (multE (argE) (getE (thisE) 'y)))
(values 'factory12 (newE 'Posn (list (numE 1) (numE 2))))))))
(define posn3D-class
(values 'Posn3D
(classC
(list 'x 'y 'z)
(list (values 'mdist (plusE (getE (thisE) 'z)
(ssendE (thisE) 'Posn 'mdist (argE))))
(values 'addDist (ssendE (thisE) 'Posn 'addDist (argE)))))))
(define posn27 (newE 'Posn (list (numE 2) (numE 7))))
(define posn531 (newE 'Posn3D (list (numE 5) (numE 3) (numE 1))))
(define (interp-posn a)
(interp a (list posn-class posn3D-class) (numV -1) (numV -1))))
;; ----------------------------------------
(module+ test
(test (interp (numE 10)
empty (objV 'Object empty) (numV 0))
(numV 10))
(test (interp (plusE (numE 10) (numE 17))
empty (objV 'Object empty) (numV 0))
(numV 27))
(test (interp (multE (numE 10) (numE 7))
empty (objV 'Object empty) (numV 0))
(numV 70))
;; Impl. 2
(test (interp (if0E (numE 1) (numE 2) (numE 3))
empty (objV 'Object empty) (numV 0))
(numV 3))
(test (interp (if0E (numE 0) (numE 2) (numE 3))
empty (objV 'Object empty) (numV 0))
(numV 2))
(test (interp-posn (newE 'Posn (list (numE 2) (numE 7))))
(objV 'Posn (list (numV 2) (numV 7))))
(test (interp-posn (sendE posn27 'mdist (numE 0)))
(numV 9))
(test (interp-posn (sendE posn27 'addX (numE 10)))
(numV 12))
(test (interp-posn (sendE (ssendE posn27 'Posn 'factory12 (numE 0))
'multY
(numE 15)))
(numV 30))
(test (interp-posn (sendE posn531 'addDist posn27))
(numV 18))
;; Impl. 2
(test/exn (interp-posn (if0E posn27 (numE 1) (numE 2)))
"not a number")
(test/exn (interp-posn (plusE (numE 1) posn27))
"not a number")
(test/exn (interp-posn (getE (numE 1) 'x))
"not an object")
(test/exn (interp-posn (sendE (numE 1) 'mdist (numE 0)))
"not an object")
(test/exn (interp-posn (ssendE (numE 1) 'Posn 'mdist (numE 0)))
"not an object")
(test/exn (interp-posn (newE 'Posn (list (numE 0))))
"wrong field count"))