-
Notifications
You must be signed in to change notification settings - Fork 17
/
exercise-5.43.rkt
235 lines (204 loc) · 9.76 KB
/
exercise-5.43.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
#lang eopl
;; Exercise 5.43 [★★] Modify letcc as defined in the preceding exercise so that the captured continuation becomes a new
;; kind of procedure, so instead of writing throw exp1 to exp2, one would write (exp2 exp1).
;; Grammar.
(define the-lexical-spec
'([whitespace (whitespace) skip]
[comment ("%" (arbno (not #\newline))) skip]
[identifier (letter (arbno (or letter digit "_" "-" "?"))) symbol]
[number (digit (arbno digit)) number]
[number ("-" digit (arbno digit)) number]))
(define the-grammar
'([program (expression) a-program]
[expression (number) const-exp]
[expression ("-" "(" expression "," expression ")") diff-exp]
[expression ("if" expression "then" expression "else" expression) if-exp]
[expression (identifier) var-exp]
[expression ("proc" "(" identifier ")" expression) proc-exp]
[expression ("(" expression expression ")") call-exp]
[expression ("let" identifier "=" expression "in" expression) let-exp]
[expression ("letrec" identifier "(" identifier ")" "=" expression "in" expression) letrec-exp]
[expression ("list" "(" (separated-list number ",") ")") const-list-exp]
[expression (unary-op "(" expression ")") unop-exp]
[expression ("try" expression "catch" "(" identifier ")" expression) try-exp]
[expression ("raise" expression) raise-exp]
[expression ("letcc" identifier "in" expression) letcc-exp]
[unary-op ("null?") null?-unop]
[unary-op ("car") car-unop]
[unary-op ("cdr") cdr-unop]
[unary-op ("zero?") zero?-unop]))
(sllgen:make-define-datatypes the-lexical-spec the-grammar)
(define scan&parse (sllgen:make-string-parser the-lexical-spec the-grammar))
;; Data structures.
(define environment?
(list-of (lambda (p)
(and (pair? p)
(symbol? (car p))))))
(define empty-env
(lambda ()
'()))
(define extend-env
(lambda (sym val old-env)
(cons (list sym val) old-env)))
(define extend-env-rec
(lambda (p-name b-var p-body saved-env)
(cons (list p-name b-var p-body)
saved-env)))
(define apply-env
(lambda (env search-sym)
(if (null? env)
(eopl:error 'apply-env "No binding for ~s" search-sym)
(let* ([binding (car env)]
[id (list-ref binding 0)]
[expval-or-bvar (list-ref binding 1)])
(cond [(not (eqv? search-sym id)) (apply-env (cdr env) search-sym)]
[(not (symbol? expval-or-bvar)) expval-or-bvar]
[else (let ([bvar (cadr binding)]
[body (caddr binding)])
(proc-val (procedure bvar body env)))])))))
(define-datatype proc proc?
[procedure [bvar symbol?]
[body expression?]
[env environment?]])
(define-datatype expval expval?
[num-val [value number?]]
[bool-val [boolean boolean?]]
[proc-val [proc proc?]]
[list-val [lst (list-of expval?)]]
[cont-val [cont continuation?]])
(define expval-extractor-error
(lambda (variant value)
(eopl:error 'expval-extractors "Looking for a ~s, found ~s" variant value)))
(define expval->num
(lambda (v)
(cases expval v
[num-val (num) num]
[else (expval-extractor-error 'num v)])))
(define expval->bool
(lambda (v)
(cases expval v
[bool-val (bool) bool]
[else (expval-extractor-error 'bool v)])))
(define expval->proc
(lambda (v)
(cases expval v
[proc-val (proc) proc]
[else (expval-extractor-error 'proc v)])))
(define expval->list
(lambda (v)
(cases expval v
[list-val (lst) lst]
[else (expval-extractor-error 'list v)])))
(define expval->cont
(lambda (v)
(cases expval v
[cont-val (cont) cont]
[else (expval-extractor-error 'cont v)])))
(define-datatype continuation continuation?
[end-cont]
[diff1-cont [exp2 expression?]
[env environment?]
[cont continuation?]
[saved-try-cont continuation?]]
[diff2-cont [val1 expval?]
[cont continuation?]]
[unop-arg-cont [unop unary-op?]
[cont continuation?]]
[if-test-cont [exp2 expression?]
[exp3 expression?]
[env environment?]
[cont continuation?]
[saved-try-cont continuation?]]
[rator-cont [rand expression?]
[env environment?]
[cont continuation?]
[saved-try-cont continuation?]]
[rand-cont [val1 expval?]
[cont continuation?]
[saved-try-cont continuation?]]
[try-cont [var symbol?]
[handler-exp expression?]
[env environment?]
[cont continuation?]
[saved-try-cont continuation?]]
[raise1-cont [saved-cont continuation?]])
;; Interpreter.
(define apply-unop
(lambda (unop val)
(cases unary-op unop
[null?-unop () (bool-val (null? (expval->list val)))]
[car-unop () (car (expval->list val))]
[cdr-unop () (list-val (cdr (expval->list val)))]
[zero?-unop () (bool-val (zero? (expval->num val)))])))
(define apply-procedure
(lambda (proc1 arg cont try-cont1)
(cases proc proc1
[procedure (var body saved-env) (value-of/k body (extend-env var arg saved-env) cont try-cont1)])))
(define apply-handler
(lambda (val cont)
(cases continuation cont
[try-cont (var handler-exp saved-env saved-cont saved-try-cont) (value-of/k handler-exp
(extend-env var val saved-env)
saved-cont
saved-try-cont)]
[end-cont () (eopl:error 'apply-handler "uncaught exception!")]
[else (eopl:error 'apply-handler "not a try-cont!")])))
(define apply-cont
(lambda (cont val)
(cases continuation cont
[end-cont () val]
[diff1-cont (exp2 saved-env saved-cont saved-try-cont) (value-of/k exp2
saved-env
(diff2-cont val saved-cont)
saved-try-cont)]
[diff2-cont (val1 saved-cont) (let ([n1 (expval->num val1)]
[n2 (expval->num val)])
(apply-cont saved-cont (num-val (- n1 n2))))]
[unop-arg-cont (unop cont) (apply-cont cont (apply-unop unop val))]
[if-test-cont (exp2 exp3 env cont saved-try-cont) (if (expval->bool val)
(value-of/k exp2 env cont saved-try-cont)
(value-of/k exp3 env cont saved-try-cont))]
[rator-cont (rand saved-env saved-cont saved-try-cont) (value-of/k rand
saved-env
(rand-cont val saved-cont saved-try-cont)
saved-try-cont)]
[rand-cont (val1 saved-cont saved-try-cont) (cases expval val1
[proc-val (proc) (apply-procedure proc
val
saved-cont
saved-try-cont)]
[cont-val (cont) (apply-cont cont val)]
[else (eopl:error 'apply-cont
"expect a procedure or a continuation")])]
[try-cont (var handler-exp saved-env saved-cont saved-try-cont) (apply-cont saved-cont val)]
[raise1-cont (saved-cont) (apply-handler val saved-cont)])))
(define value-of/k
(lambda (exp env cont try-cont1)
(cases expression exp
[const-exp (num) (apply-cont cont (num-val num))]
[const-list-exp (nums) (apply-cont cont (list-val (map num-val nums)))]
[var-exp (var) (apply-cont cont (apply-env env var))]
[diff-exp (exp1 exp2) (value-of/k exp1 env (diff1-cont exp2 env cont try-cont1) try-cont1)]
[unop-exp (unop exp1) (value-of/k exp1 env (unop-arg-cont unop cont) try-cont1)]
[if-exp (exp1 exp2 exp3) (value-of/k exp1 env (if-test-cont exp2 exp3 env cont try-cont1) try-cont1)]
[proc-exp (var body) (apply-cont cont (proc-val (procedure var body env)))]
[call-exp (rator rand) (value-of/k rator env (rator-cont rand env cont try-cont1) try-cont1)]
[let-exp (var exp1 body) (value-of/k (call-exp (proc-exp var body) exp1) env cont try-cont1)]
[letrec-exp (p-name b-var p-body letrec-body) (value-of/k letrec-body
(extend-env-rec p-name b-var p-body env)
cont
try-cont1)]
[try-exp (exp1 var handler-exp) (let ([try-cont2 (try-cont var handler-exp env cont try-cont1)])
(value-of/k exp1 env try-cont2 try-cont2))]
[raise-exp (exp1) (value-of/k exp1 env (raise1-cont try-cont1) try-cont1)]
[letcc-exp (var body) (value-of/k body (extend-env var (cont-val cont) env) cont try-cont1)])))
(define value-of-program
(lambda (pgm)
(cases program pgm
(a-program (body)
(value-of/k body (empty-env) (end-cont) (end-cont))))))
;; Interface.
(define run
(lambda (string)
(value-of-program (scan&parse string))))
(provide bool-val list-val num-val run)