1 665c255d 2023-08-04 jrmu ;; (define apply-in-underlying-scheme apply)
3 665c255d 2023-08-04 jrmu (define (eval exp env)
4 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
5 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
6 665c255d 2023-08-04 jrmu ((quoted? exp) (text-of-quotation exp))
7 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
8 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition exp env))
9 665c255d 2023-08-04 jrmu ;; ((unbound? exp) (eval-unbound exp env))
10 665c255d 2023-08-04 jrmu ((if? exp) (eval-if exp env))
11 665c255d 2023-08-04 jrmu ((and? exp) (eval-and exp env))
12 665c255d 2023-08-04 jrmu ((or? exp) (eval-or exp env))
13 665c255d 2023-08-04 jrmu ((lambda? exp)
14 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
15 665c255d 2023-08-04 jrmu (lambda-body exp)
17 665c255d 2023-08-04 jrmu ((begin? exp)
18 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
19 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
20 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
21 665c255d 2023-08-04 jrmu ((let*? exp) (eval (let*->nested-lets exp) env))
22 665c255d 2023-08-04 jrmu ((named-let? exp) (eval (named-let->combination exp) env))
23 665c255d 2023-08-04 jrmu ((letrec? exp) (eval (letrec->let exp) env))
24 665c255d 2023-08-04 jrmu ((do? exp) (eval (do->combination exp) env))
25 665c255d 2023-08-04 jrmu ((application? exp)
26 665c255d 2023-08-04 jrmu (apply (actual-value (operator exp) env)
27 665c255d 2023-08-04 jrmu (operands exp)
30 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
31 665c255d 2023-08-04 jrmu (define (apply procedure arguments env)
32 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
33 665c255d 2023-08-04 jrmu (apply-primitive-procedure
35 665c255d 2023-08-04 jrmu (list-of-arg-values arguments env)))
36 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
37 665c255d 2023-08-04 jrmu (eval-sequence
38 665c255d 2023-08-04 jrmu (procedure-body procedure)
39 665c255d 2023-08-04 jrmu (extend-environment
40 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
41 665c255d 2023-08-04 jrmu (list-of-delayed-args
42 665c255d 2023-08-04 jrmu (procedure-parameters-directives procedure)
45 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
48 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
50 665c255d 2023-08-04 jrmu (define (thunk? obj)
51 665c255d 2023-08-04 jrmu (tagged-list? obj 'thunk))
52 665c255d 2023-08-04 jrmu (define (thunk-exp thunk)
53 665c255d 2023-08-04 jrmu (cadr thunk))
54 665c255d 2023-08-04 jrmu (define (thunk-env thunk)
55 665c255d 2023-08-04 jrmu (caddr thunk))
56 665c255d 2023-08-04 jrmu (define (evaluated-thunk? obj)
57 665c255d 2023-08-04 jrmu (tagged-list? obj 'evaluated-thunk))
58 665c255d 2023-08-04 jrmu (define (thunk-value evaluated-thunk)
59 665c255d 2023-08-04 jrmu (cadr evaluated-thunk))
60 665c255d 2023-08-04 jrmu (define (simple-thunk? obj)
61 665c255d 2023-08-04 jrmu (tagged-list? obj 'simple-thunk))
62 665c255d 2023-08-04 jrmu (define (simple-delay-it exp env)
63 665c255d 2023-08-04 jrmu `(simple-thunk ,exp ,env))
64 665c255d 2023-08-04 jrmu (define (delay-it exp env)
65 665c255d 2023-08-04 jrmu `(thunk ,exp ,env))
66 665c255d 2023-08-04 jrmu (define (actual-value exp env)
67 665c255d 2023-08-04 jrmu (force-it (eval exp env)))
68 665c255d 2023-08-04 jrmu (define (force-it obj)
69 665c255d 2023-08-04 jrmu (cond ((thunk? obj)
70 665c255d 2023-08-04 jrmu (let ((result (actual-value
71 665c255d 2023-08-04 jrmu (thunk-exp obj)
72 665c255d 2023-08-04 jrmu (thunk-env obj))))
73 665c255d 2023-08-04 jrmu (set-car! obj 'evaluated-thunk)
74 665c255d 2023-08-04 jrmu (set-car! (cdr obj) result)
75 665c255d 2023-08-04 jrmu (set-cdr! (cdr obj) '())
77 665c255d 2023-08-04 jrmu ((evaluated-thunk? obj)
78 665c255d 2023-08-04 jrmu (thunk-value obj))
79 665c255d 2023-08-04 jrmu ((simple-thunk? obj)
80 665c255d 2023-08-04 jrmu (actual-value (thunk-exp obj)
81 665c255d 2023-08-04 jrmu (thunk-env obj)))
82 665c255d 2023-08-04 jrmu (else obj)))
84 665c255d 2023-08-04 jrmu (define (list-of-arg-values exps env)
85 665c255d 2023-08-04 jrmu (if (no-operands? exps)
87 665c255d 2023-08-04 jrmu (cons (actual-value (first-operand exps) env)
88 665c255d 2023-08-04 jrmu (list-of-arg-values (rest-operands exps) env))))
89 665c255d 2023-08-04 jrmu (define (list-of-delayed-args directives exps env)
90 665c255d 2023-08-04 jrmu (if (no-operands? exps)
92 665c255d 2023-08-04 jrmu (let* ((directive (car directives))
93 665c255d 2023-08-04 jrmu (op (first-operand exps))
94 665c255d 2023-08-04 jrmu (arg (cond ((eq? directive 'strict)
95 665c255d 2023-08-04 jrmu (eval op env))
96 665c255d 2023-08-04 jrmu ((eq? directive 'lazy)
97 665c255d 2023-08-04 jrmu (simple-delay-it op env))
98 665c255d 2023-08-04 jrmu ((eq? directive 'lazy-memo)
99 665c255d 2023-08-04 jrmu (delay-it op env))
101 665c255d 2023-08-04 jrmu (error "Unknown directive " directive)))))
103 665c255d 2023-08-04 jrmu (list-of-delayed-args
104 665c255d 2023-08-04 jrmu (cdr directives)
109 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
110 665c255d 2023-08-04 jrmu (if (pair? exp)
111 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
114 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
115 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
116 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
117 665c255d 2023-08-04 jrmu ((string? exp) true)
118 665c255d 2023-08-04 jrmu (else false)))
119 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
120 665c255d 2023-08-04 jrmu (define (quoted? exp)
121 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
122 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
124 665c255d 2023-08-04 jrmu ;; assignment/definition
125 665c255d 2023-08-04 jrmu (define (assignment? exp)
126 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
127 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
128 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
129 665c255d 2023-08-04 jrmu (define (make-assignment var val)
130 665c255d 2023-08-04 jrmu (list 'set! var val))
131 665c255d 2023-08-04 jrmu (define (definition? exp)
132 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
133 665c255d 2023-08-04 jrmu (define (definition-variable exp)
134 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
136 665c255d 2023-08-04 jrmu (caadr exp)))
137 665c255d 2023-08-04 jrmu (define (definition-value exp)
138 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
139 665c255d 2023-08-04 jrmu (caddr exp)
140 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
141 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
142 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
143 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
144 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
147 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
148 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
149 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
152 665c255d 2023-08-04 jrmu (define (make-definition var val)
153 665c255d 2023-08-04 jrmu `(define ,var ,val))
155 665c255d 2023-08-04 jrmu ;; make-unbound!
157 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
158 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
159 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
160 665c255d 2023-08-04 jrmu ;; (cadr exp))
161 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
162 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
166 665c255d 2023-08-04 jrmu ;; if/and/or
167 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
168 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
169 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
170 665c255d 2023-08-04 jrmu (define (if-alternative exp)
171 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
172 665c255d 2023-08-04 jrmu (cadddr exp)
174 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
175 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
176 665c255d 2023-08-04 jrmu (define (eval-if exp env)
177 665c255d 2023-08-04 jrmu (if (true? (actual-value (if-predicate exp) env))
178 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
179 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
181 665c255d 2023-08-04 jrmu (define (and? exp)
182 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
183 665c255d 2023-08-04 jrmu (define (and-clauses exp)
185 665c255d 2023-08-04 jrmu (define (or? exp)
186 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
187 665c255d 2023-08-04 jrmu (define (or-clauses exp)
189 665c255d 2023-08-04 jrmu (define (eval-and exp env)
190 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
191 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
192 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
193 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
194 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
195 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
196 665c255d 2023-08-04 jrmu (define (eval-or exp env)
197 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
198 665c255d 2023-08-04 jrmu (if (null? clauses)
200 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
201 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
202 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
205 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
206 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
207 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
208 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
209 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
210 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
212 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
214 665c255d 2023-08-04 jrmu (cons (map list vars vals)
216 665c255d 2023-08-04 jrmu (define (let? exp)
217 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
218 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
219 665c255d 2023-08-04 jrmu (define (let-vars exp)
220 665c255d 2023-08-04 jrmu (map car (cadr exp)))
221 665c255d 2023-08-04 jrmu (define (let-vals exp)
222 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
223 665c255d 2023-08-04 jrmu (define (let-body exp)
224 665c255d 2023-08-04 jrmu (cddr exp))
225 665c255d 2023-08-04 jrmu (define (let->combination exp)
226 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
227 665c255d 2023-08-04 jrmu (let-vals exp)))
228 665c255d 2023-08-04 jrmu (define (named-let? exp)
229 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
230 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
231 665c255d 2023-08-04 jrmu (define (named-let-name exp)
232 665c255d 2023-08-04 jrmu (cadr exp))
233 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
234 665c255d 2023-08-04 jrmu (map car (caddr exp)))
235 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
236 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
237 665c255d 2023-08-04 jrmu (define (named-let-body exp)
238 665c255d 2023-08-04 jrmu (cdddr exp))
239 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
240 665c255d 2023-08-04 jrmu (sequence->exp
241 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
242 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
243 665c255d 2023-08-04 jrmu (named-let-body exp)))
244 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
245 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
246 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
249 665c255d 2023-08-04 jrmu (cons (map list vars vals)
252 665c255d 2023-08-04 jrmu (define (letrec? exp)
253 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
255 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
256 665c255d 2023-08-04 jrmu (map car (cadr exp)))
257 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
258 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
259 665c255d 2023-08-04 jrmu (define (letrec-body exp)
260 665c255d 2023-08-04 jrmu (cddr exp))
261 665c255d 2023-08-04 jrmu (define (letrec->let exp)
262 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
263 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
265 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
266 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
267 665c255d 2023-08-04 jrmu (make-assignment var val))
270 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
271 665c255d 2023-08-04 jrmu (make-let vars
272 665c255d 2023-08-04 jrmu unassigneds
273 665c255d 2023-08-04 jrmu (append assignments body))))
278 665c255d 2023-08-04 jrmu (define (let*? exp)
279 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
280 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
281 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
282 665c255d 2023-08-04 jrmu (define let*-body let-body)
283 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
284 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
285 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
286 665c255d 2023-08-04 jrmu (make-let (list (car vars))
287 665c255d 2023-08-04 jrmu (list (car vals))
288 665c255d 2023-08-04 jrmu (let*-body exp))
289 665c255d 2023-08-04 jrmu (make-let (list (car vars))
290 665c255d 2023-08-04 jrmu (list (car vals))
291 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
292 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
293 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
294 665c255d 2023-08-04 jrmu (if (null? vars)
295 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
296 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
299 665c255d 2023-08-04 jrmu (define (do? exp)
300 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
301 665c255d 2023-08-04 jrmu (define (do-vars exp)
302 665c255d 2023-08-04 jrmu (map car (cadr exp)))
303 665c255d 2023-08-04 jrmu (define (do-inits exp)
304 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
305 665c255d 2023-08-04 jrmu (define (do-steps exp)
306 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
307 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
308 665c255d 2023-08-04 jrmu (car var-init-step)
309 665c255d 2023-08-04 jrmu (caddr var-init-step)))
310 665c255d 2023-08-04 jrmu (cadr exp)))
311 665c255d 2023-08-04 jrmu (define (do-test exp)
312 665c255d 2023-08-04 jrmu (caaddr exp))
313 665c255d 2023-08-04 jrmu (define (do-expressions exp)
314 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
315 665c255d 2023-08-04 jrmu (caddr exp)
316 665c255d 2023-08-04 jrmu (cdaddr exp)))
317 665c255d 2023-08-04 jrmu (define (do-commands exp)
318 665c255d 2023-08-04 jrmu (cdddr exp))
319 665c255d 2023-08-04 jrmu (define (do->combination exp)
320 665c255d 2023-08-04 jrmu (make-named-let
322 665c255d 2023-08-04 jrmu (do-vars exp)
323 665c255d 2023-08-04 jrmu (do-inits exp)
326 665c255d 2023-08-04 jrmu (do-test exp)
327 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
328 665c255d 2023-08-04 jrmu (sequence->exp
329 665c255d 2023-08-04 jrmu (append (do-commands exp)
330 665c255d 2023-08-04 jrmu (list (make-application
332 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
335 665c255d 2023-08-04 jrmu ;; begin/sequence
336 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
337 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
338 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
339 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
340 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
341 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
342 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
343 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
344 665c255d 2023-08-04 jrmu (else (make-begin seq))))
345 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
346 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
347 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
348 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
349 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
351 665c255d 2023-08-04 jrmu ;; application
352 665c255d 2023-08-04 jrmu (define (make-application op args)
353 665c255d 2023-08-04 jrmu (cons op args))
354 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
355 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
356 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
357 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
358 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
359 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
362 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
363 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
364 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
365 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
366 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
367 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
368 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
369 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
370 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
371 665c255d 2023-08-04 jrmu (caddr clause))
372 665c255d 2023-08-04 jrmu (define (cond->if exp)
373 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
374 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
375 665c255d 2023-08-04 jrmu (if (null? clauses)
376 665c255d 2023-08-04 jrmu 'false ; no else clause
377 665c255d 2023-08-04 jrmu (let ((first (car clauses))
378 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
379 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
380 665c255d 2023-08-04 jrmu (if (null? rest)
381 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
382 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
384 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
385 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
386 665c255d 2023-08-04 jrmu (make-application
387 665c255d 2023-08-04 jrmu (cond-extended-proc first)
388 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
389 665c255d 2023-08-04 jrmu (expand-clauses rest))
390 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
391 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
392 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
393 665c255d 2023-08-04 jrmu (define (true? x)
394 665c255d 2023-08-04 jrmu (not (eq? x false)))
395 665c255d 2023-08-04 jrmu (define (false? x)
396 665c255d 2023-08-04 jrmu (eq? x false))
398 665c255d 2023-08-04 jrmu ;; procedure
399 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
400 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
401 665c255d 2023-08-04 jrmu ;; (define (scan-out-defines body)
402 665c255d 2023-08-04 jrmu ;; (let* ((definitions (filter definition? body))
403 665c255d 2023-08-04 jrmu ;; (vars (map definition-variable definitions))
404 665c255d 2023-08-04 jrmu ;; (unassigneds (map (lambda (var) ''*unassigned*)
406 665c255d 2023-08-04 jrmu ;; (vals (map definition-value definitions))
407 665c255d 2023-08-04 jrmu ;; (assignments
408 665c255d 2023-08-04 jrmu ;; (map (lambda (var val)
409 665c255d 2023-08-04 jrmu ;; (make-assignment var val))
410 665c255d 2023-08-04 jrmu ;; vars vals))
411 665c255d 2023-08-04 jrmu ;; (exps (remove definition? body)))
412 665c255d 2023-08-04 jrmu ;; (if (null? definitions)
415 665c255d 2023-08-04 jrmu ;; (make-let vars
416 665c255d 2023-08-04 jrmu ;; unassigneds
417 665c255d 2023-08-04 jrmu ;; (append assignments exps))))))
418 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
419 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
420 665c255d 2023-08-04 jrmu ;; (define (procedure-parameters p) (cadr p))
421 665c255d 2023-08-04 jrmu (define (procedure-parameters p)
422 665c255d 2023-08-04 jrmu (map (lambda (param)
423 665c255d 2023-08-04 jrmu (if (symbol? param)
425 665c255d 2023-08-04 jrmu (car param)))
427 665c255d 2023-08-04 jrmu (define (procedure-parameters-directives p)
428 665c255d 2023-08-04 jrmu (map (lambda (param)
429 665c255d 2023-08-04 jrmu (if (symbol? param)
431 665c255d 2023-08-04 jrmu (cadr param)))
433 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
434 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
436 665c255d 2023-08-04 jrmu ;; environment
437 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
438 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
439 665c255d 2023-08-04 jrmu (define the-empty-environment '())
440 665c255d 2023-08-04 jrmu (define (make-frame variables values)
441 665c255d 2023-08-04 jrmu (cons variables values))
442 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
443 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
444 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
445 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
446 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
447 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
448 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
449 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
450 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
451 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
452 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
453 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
454 665c255d 2023-08-04 jrmu (define (env-loop env)
455 665c255d 2023-08-04 jrmu (define (scan vars vals)
456 665c255d 2023-08-04 jrmu (cond ((null? vars)
457 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
458 665c255d 2023-08-04 jrmu ((eq? var (car vars))
459 665c255d 2023-08-04 jrmu (let ((val (car vals)))
460 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
461 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
463 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
464 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
465 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
466 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
467 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
468 665c255d 2023-08-04 jrmu (frame-values frame)))))
469 665c255d 2023-08-04 jrmu (env-loop env))
470 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
471 665c255d 2023-08-04 jrmu (define (env-loop env)
472 665c255d 2023-08-04 jrmu (define (scan vars vals)
473 665c255d 2023-08-04 jrmu (cond ((null? vars)
474 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
475 665c255d 2023-08-04 jrmu ((eq? var (car vars))
476 665c255d 2023-08-04 jrmu (set-car! vals val))
477 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
478 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
479 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
480 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
481 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
482 665c255d 2023-08-04 jrmu (frame-values frame)))))
483 665c255d 2023-08-04 jrmu (env-loop env))
484 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
485 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
486 665c255d 2023-08-04 jrmu (define (scan vars vals)
487 665c255d 2023-08-04 jrmu (cond ((null? vars)
488 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
489 665c255d 2023-08-04 jrmu ((eq? var (car vars))
490 665c255d 2023-08-04 jrmu (set-car! vals val))
491 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
492 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
493 665c255d 2023-08-04 jrmu (frame-values frame))))
495 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
496 665c255d 2023-08-04 jrmu (define (scan vars vals)
497 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
498 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
499 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
500 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
501 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
502 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
503 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
504 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
505 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
506 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
507 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
508 665c255d 2023-08-04 jrmu (scan vars vals))))
510 665c255d 2023-08-04 jrmu ;; primitives
511 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
512 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
513 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
514 665c255d 2023-08-04 jrmu (define primitive-procedures
515 665c255d 2023-08-04 jrmu (list (list 'car car)
516 665c255d 2023-08-04 jrmu (list 'cdr cdr)
517 665c255d 2023-08-04 jrmu (list 'caar caar)
518 665c255d 2023-08-04 jrmu (list 'cadr cadr)
519 665c255d 2023-08-04 jrmu (list 'cddr cddr)
520 665c255d 2023-08-04 jrmu (list 'cons cons)
521 665c255d 2023-08-04 jrmu (list 'null? null?)
522 665c255d 2023-08-04 jrmu (list '* *)
523 665c255d 2023-08-04 jrmu (list '/ /)
524 665c255d 2023-08-04 jrmu (list '+ +)
525 665c255d 2023-08-04 jrmu (list '- -)
526 665c255d 2023-08-04 jrmu (list '= =)
527 665c255d 2023-08-04 jrmu (list '< <)
528 665c255d 2023-08-04 jrmu (list '> >)
529 665c255d 2023-08-04 jrmu (list '<= <=)
530 665c255d 2023-08-04 jrmu (list '>= >=)
531 665c255d 2023-08-04 jrmu (list 'remainder remainder)
532 665c255d 2023-08-04 jrmu (list 'eq? eq?)
533 665c255d 2023-08-04 jrmu (list 'equal? equal?)
534 665c255d 2023-08-04 jrmu (list 'display display)))
535 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
537 665c255d 2023-08-04 jrmu primitive-procedures))
538 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
539 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
540 665c255d 2023-08-04 jrmu primitive-procedures))
541 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
542 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
543 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
545 665c255d 2023-08-04 jrmu ;; driver-loop
546 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
547 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
548 665c255d 2023-08-04 jrmu (define (driver-loop)
549 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
550 665c255d 2023-08-04 jrmu (let ((input (read)))
551 665c255d 2023-08-04 jrmu (let ((output (actual-value input the-global-environment)))
552 665c255d 2023-08-04 jrmu (announce-output output-prompt)
553 665c255d 2023-08-04 jrmu (user-print output)))
554 665c255d 2023-08-04 jrmu (driver-loop))
555 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
556 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
558 665c255d 2023-08-04 jrmu (define (announce-output string)
559 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
560 665c255d 2023-08-04 jrmu (define (user-print object)
561 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
562 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
563 665c255d 2023-08-04 jrmu (procedure-parameters object)
564 665c255d 2023-08-04 jrmu (procedure-body object)
565 665c255d 2023-08-04 jrmu '<procedure-env>))
566 665c255d 2023-08-04 jrmu (display object)))
567 665c255d 2023-08-04 jrmu (define (setup-environment)
568 665c255d 2023-08-04 jrmu (let ((initial-env
569 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
570 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
571 665c255d 2023-08-04 jrmu the-empty-environment)))
572 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
573 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
574 665c255d 2023-08-04 jrmu initial-env))
575 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
577 665c255d 2023-08-04 jrmu ;; auxiliary
578 665c255d 2023-08-04 jrmu (define (test-case actual expected)
580 665c255d 2023-08-04 jrmu (display "Actual: ")
581 665c255d 2023-08-04 jrmu (display actual)
583 665c255d 2023-08-04 jrmu (display "Expected: ")
584 665c255d 2023-08-04 jrmu (display expected)
586 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
587 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
588 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
589 665c255d 2023-08-04 jrmu (test-case (force-it (geval exp)) expected))
591 665c255d 2023-08-04 jrmu ;; Exercise 4.31. The approach taken in this section is somewhat unpleasant, because it makes a3n incompatible change to Scheme. It might be nicer to implement lazy evaluation as an upward-compatible extension, that is, so that ordinary Scheme programs will work as before. We can do this by extending the syntax of procedure declarations to let the user control whether or not arguments are to be delayed. While we're at it, we may as well also give the user the choice between delaying with and without memoization. For example, the definition
593 665c255d 2023-08-04 jrmu ;; (define (f a (b lazy) c (d lazy-memo))
596 665c255d 2023-08-04 jrmu ;; would define f to be a procedure of four arguments, where the first and third arguments are evaluated when the procedure is called, the second argument is delayed, and the fourth argument is both delayed and memoized. Thus, ordinary procedure definitions will produce the same behavior as ordinary Scheme, while adding the lazy-memo declaration to each parameter of every compound procedure will produce the behavior of the lazy evaluator defined in this section. Design and implement the changes required to produce such an extension to Scheme. You will have to implement new syntax procedures to handle the new syntax for define. You must also arrange for eval or apply to determine when arguments are to be delayed, and to force or delay arguments accordingly, and you must arrange for forcing to memoize or not, as appropriate.
600 665c255d 2023-08-04 jrmu ;; test-suite
602 665c255d 2023-08-04 jrmu ;; procedure definitions
605 665c255d 2023-08-04 jrmu '(define (assoc key records)
606 665c255d 2023-08-04 jrmu (cond ((null? records) false)
607 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
608 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
611 665c255d 2023-08-04 jrmu '(define (map proc list)
612 665c255d 2023-08-04 jrmu (if (null? list)
614 665c255d 2023-08-04 jrmu (cons (proc (car list))
615 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
618 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
619 665c255d 2023-08-04 jrmu (if (null? sequence)
621 665c255d 2023-08-04 jrmu (op (car sequence)
622 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
624 665c255d 2023-08-04 jrmu ;; all special forms
625 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
626 665c255d 2023-08-04 jrmu (test-eval '10 10)
627 665c255d 2023-08-04 jrmu (geval '(define x 3))
628 665c255d 2023-08-04 jrmu (test-eval 'x 3)
629 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
630 665c255d 2023-08-04 jrmu (test-eval 'x -25)
631 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
632 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
633 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
634 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
635 665c255d 2023-08-04 jrmu (else 'failed))
637 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
640 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
641 665c255d 2023-08-04 jrmu (+ x y (* x y)))
642 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
646 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
647 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
648 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
649 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
650 665c255d 2023-08-04 jrmu (test-eval 'x -2)
651 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
652 665c255d 2023-08-04 jrmu (test-eval 'x -2)
653 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
654 665c255d 2023-08-04 jrmu (test-eval 'x 25)
655 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
656 665c255d 2023-08-04 jrmu (test-eval 'x 2)
657 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
658 665c255d 2023-08-04 jrmu (test-eval 'x 25)
659 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
660 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
666 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
667 665c255d 2023-08-04 jrmu (else false))
671 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
672 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
673 665c255d 2023-08-04 jrmu ((map (lambda (x)
674 665c255d 2023-08-04 jrmu (* x (+ x 1)))
675 665c255d 2023-08-04 jrmu '(2 4 1 9))
677 665c255d 2023-08-04 jrmu (lambda (x)
678 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
679 665c255d 2023-08-04 jrmu (else 'never-reach))
681 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
684 665c255d 2023-08-04 jrmu ;; procedure definition and application
686 665c255d 2023-08-04 jrmu '(define (factorial n)
687 665c255d 2023-08-04 jrmu (if (= n 0)
689 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
690 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
695 665c255d 2023-08-04 jrmu '(map (lambda (x)
696 665c255d 2023-08-04 jrmu (* x (+ x 1)))
697 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
698 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
699 665c255d 2023-08-04 jrmu ;; accumulate
702 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
705 665c255d 2023-08-04 jrmu ;; make-let
707 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
714 665c255d 2023-08-04 jrmu '(let ((x 3))
718 665c255d 2023-08-04 jrmu '(let ((x 3)
723 665c255d 2023-08-04 jrmu '(let ((x 3)
725 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
729 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
731 665c255d 2023-08-04 jrmu '(let ((x 6)
732 665c255d 2023-08-04 jrmu (y (let ((x 2))
734 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
743 665c255d 2023-08-04 jrmu '(let* ((x 3)
744 665c255d 2023-08-04 jrmu (y (+ x 2))
745 665c255d 2023-08-04 jrmu (z (+ x y 5)))
754 665c255d 2023-08-04 jrmu '(let* ((x 3))
755 665c255d 2023-08-04 jrmu (let* ((y 5))
760 665c255d 2023-08-04 jrmu '(let* ((x 3)
761 665c255d 2023-08-04 jrmu (y (+ x 1)))
762 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
766 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
768 665c255d 2023-08-04 jrmu '(let* ((x 6)
769 665c255d 2023-08-04 jrmu (y (let* ((x 2)
770 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
773 665c255d 2023-08-04 jrmu (z (+ x y)))
777 665c255d 2023-08-04 jrmu ;; named-let
780 665c255d 2023-08-04 jrmu '(let eight ()
786 665c255d 2023-08-04 jrmu '(let loop ((count 0))
787 665c255d 2023-08-04 jrmu (if (= 100 count)
789 665c255d 2023-08-04 jrmu (loop (+ count 1))))
792 665c255d 2023-08-04 jrmu '(define (prime? x)
793 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
794 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
795 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
796 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
798 665c255d 2023-08-04 jrmu '(let primes ((x 2)
800 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
801 665c255d 2023-08-04 jrmu ((prime? x)
803 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
804 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
805 665c255d 2023-08-04 jrmu '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
808 665c255d 2023-08-04 jrmu '(define (fib n)
809 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
812 665c255d 2023-08-04 jrmu (if (= count 0)
814 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
815 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
819 665c255d 2023-08-04 jrmu '(let ((y 0))
820 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
821 665c255d 2023-08-04 jrmu ((= x 5) y)
822 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
833 665c255d 2023-08-04 jrmu '(let ((y 0))
835 665c255d 2023-08-04 jrmu ((= y 5) y)
836 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
840 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
841 665c255d 2023-08-04 jrmu ((null? y))
842 665c255d 2023-08-04 jrmu (set! y (cdr y)))
845 665c255d 2023-08-04 jrmu '(let ((y 0))
846 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
847 665c255d 2023-08-04 jrmu ((= x 5) y)
848 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
851 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
852 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
853 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
854 665c255d 2023-08-04 jrmu ((null? x) sum)))
857 665c255d 2023-08-04 jrmu '(let ((z '()))
858 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
859 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
860 665c255d 2023-08-04 jrmu ((null? x) y x z)
861 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
862 665c255d 2023-08-04 jrmu '(4 3 2 1))
866 665c255d 2023-08-04 jrmu ;; make-unbound!
867 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
869 665c255d 2023-08-04 jrmu ;; (test-eval
870 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
871 665c255d 2023-08-04 jrmu ;; (let ((x 5))
872 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
873 665c255d 2023-08-04 jrmu ;; (* x x)))
876 665c255d 2023-08-04 jrmu ;; (test-eval
877 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
878 665c255d 2023-08-04 jrmu ;; (let ((x 5))
879 665c255d 2023-08-04 jrmu ;; (define y x)
880 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
881 665c255d 2023-08-04 jrmu ;; (* y x)))
884 665c255d 2023-08-04 jrmu ;; (test-eval
885 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
886 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
887 665c255d 2023-08-04 jrmu ;; (define a x)
888 665c255d 2023-08-04 jrmu ;; (define b y)
889 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
890 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
891 665c255d 2023-08-04 jrmu ;; (* a b x y)))
892 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
894 665c255d 2023-08-04 jrmu ;; (test-eval
895 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
896 665c255d 2023-08-04 jrmu ;; (let ((x 5))
897 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
898 665c255d 2023-08-04 jrmu ;; (+ x 4)))
901 665c255d 2023-08-04 jrmu ;; (test-eval
902 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
903 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
904 665c255d 2023-08-04 jrmu ;; (+ a c d))
905 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
907 665c255d 2023-08-04 jrmu ;; (test-eval
908 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
909 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
910 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
911 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
912 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
913 665c255d 2023-08-04 jrmu ;; (define z b)
914 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
915 665c255d 2023-08-04 jrmu ;; (* (+ a z)
916 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
917 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
918 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
920 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
921 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
922 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
923 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
925 665c255d 2023-08-04 jrmu ;; scan-out-defines
928 665c255d 2023-08-04 jrmu '(define (f x)
929 665c255d 2023-08-04 jrmu (define (even? n)
930 665c255d 2023-08-04 jrmu (if (= n 0)
932 665c255d 2023-08-04 jrmu (odd? (- n 1))))
933 665c255d 2023-08-04 jrmu (define (odd? n)
934 665c255d 2023-08-04 jrmu (if (= n 0)
936 665c255d 2023-08-04 jrmu (even? (- n 1))))
937 665c255d 2023-08-04 jrmu (even? x)))
938 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
939 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
942 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
943 665c255d 2023-08-04 jrmu ;; (define y x)
944 665c255d 2023-08-04 jrmu ;; (define x 3)
945 665c255d 2023-08-04 jrmu ;; (+ x y)))
946 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
951 665c255d 2023-08-04 jrmu '(define (f x)
952 665c255d 2023-08-04 jrmu (letrec ((even?
953 665c255d 2023-08-04 jrmu (lambda (n)
954 665c255d 2023-08-04 jrmu (if (= n 0)
956 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
958 665c255d 2023-08-04 jrmu (lambda (n)
959 665c255d 2023-08-04 jrmu (if (= n 0)
961 665c255d 2023-08-04 jrmu (even? (- n 1))))))
962 665c255d 2023-08-04 jrmu (even? x))))
963 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
964 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
967 665c255d 2023-08-04 jrmu '(letrec ((fact
968 665c255d 2023-08-04 jrmu (lambda (n)
969 665c255d 2023-08-04 jrmu (if (= n 1)
971 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
976 665c255d 2023-08-04 jrmu ;; delayed-evaluation
979 665c255d 2023-08-04 jrmu '(define (try (a lazy-memo) (b lazy-memo))
980 665c255d 2023-08-04 jrmu (if (= a 0) 1 b)))
981 665c255d 2023-08-04 jrmu (test-eval '(try 0 (/ 1 0)) 1)
984 665c255d 2023-08-04 jrmu '(define (unless (condition lazy-memo) (usual-value lazy-memo) (exceptional-value lazy-memo))
985 665c255d 2023-08-04 jrmu (if condition exceptional-value usual-value)))
987 665c255d 2023-08-04 jrmu '(let ((a 4) (b 0))
988 665c255d 2023-08-04 jrmu (unless (= b 0)
990 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
994 665c255d 2023-08-04 jrmu '(let ((a 4) (b 2))
995 665c255d 2023-08-04 jrmu (unless (= b 0)
997 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1002 665c255d 2023-08-04 jrmu '(define (factorial (n lazy-memo))
1003 665c255d 2023-08-04 jrmu (unless (= n 1)
1004 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))
1006 665c255d 2023-08-04 jrmu (test-eval
1007 665c255d 2023-08-04 jrmu '(factorial 8)
1010 665c255d 2023-08-04 jrmu (geval '(define count 0))
1011 665c255d 2023-08-04 jrmu (geval '(define (id (x lazy-memo))
1012 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1015 665c255d 2023-08-04 jrmu (geval '(define w (id (id 10))))
1016 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1017 665c255d 2023-08-04 jrmu (test-eval 'w 10)
1018 665c255d 2023-08-04 jrmu (test-eval 'count 2)
1019 665c255d 2023-08-04 jrmu (test-eval
1020 665c255d 2023-08-04 jrmu '(let ((f (lambda (x) (+ x 1))))
1023 665c255d 2023-08-04 jrmu (geval '(define count 0))
1024 665c255d 2023-08-04 jrmu (geval '(define (id (x lazy-memo))
1025 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1028 665c255d 2023-08-04 jrmu '(define (square (x lazy-memo))
1030 665c255d 2023-08-04 jrmu (test-eval
1031 665c255d 2023-08-04 jrmu '(square (id 10))
1033 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1034 665c255d 2023-08-04 jrmu ;; would be 2 without memoization
1037 665c255d 2023-08-04 jrmu '(define (p1 (x lazy-memo))
1038 665c255d 2023-08-04 jrmu (set! x (cons x '(2)))
1041 665c255d 2023-08-04 jrmu '(define (p2 (x lazy-memo))
1042 665c255d 2023-08-04 jrmu (define (p e)
1045 665c255d 2023-08-04 jrmu (p (set! x (cons x '(2))))))
1046 665c255d 2023-08-04 jrmu (test-eval '(p1 1) '(1 2))
1047 665c255d 2023-08-04 jrmu (test-eval '(p2 1) 1)
1049 665c255d 2023-08-04 jrmu (geval '(define count 0))
1052 665c255d 2023-08-04 jrmu '(define (id (x lazy-memo))
1053 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1057 665c255d 2023-08-04 jrmu '(define (f a (b lazy) c (d lazy-memo))
1062 665c255d 2023-08-04 jrmu (test-eval
1063 665c255d 2023-08-04 jrmu '(f (id 1) (id 2) (id 3) (id 4))
1065 665c255d 2023-08-04 jrmu (test-eval 'count 3)
1066 665c255d 2023-08-04 jrmu (test-eval
1067 665c255d 2023-08-04 jrmu '(f 1 (id 2) 3 4)
1069 665c255d 2023-08-04 jrmu (test-eval 'count 3)
1071 665c255d 2023-08-04 jrmu '(define (g (a lazy-memo))
1073 665c255d 2023-08-04 jrmu (test-eval
1074 665c255d 2023-08-04 jrmu '(g (id 2))
1076 665c255d 2023-08-04 jrmu (test-eval 'count 4)
1078 665c255d 2023-08-04 jrmu '(define (h (a lazy))
1080 665c255d 2023-08-04 jrmu (test-eval
1081 665c255d 2023-08-04 jrmu '(h (id 2))
1083 665c255d 2023-08-04 jrmu (test-eval 'count 6)
1084 665c255d 2023-08-04 jrmu (test-eval
1085 665c255d 2023-08-04 jrmu '(g (id (id 2)))
1087 665c255d 2023-08-04 jrmu (test-eval 'count 8)
1089 665c255d 2023-08-04 jrmu (test-eval
1090 665c255d 2023-08-04 jrmu '(h (id (id 2)))
1092 665c255d 2023-08-04 jrmu (test-eval
1096 665c255d 2023-08-04 jrmu '(define (i a)
1098 665c255d 2023-08-04 jrmu (test-eval
1099 665c255d 2023-08-04 jrmu '(i (id 2))
1101 665c255d 2023-08-04 jrmu (test-eval
1104 665c255d 2023-08-04 jrmu (test-eval
1105 665c255d 2023-08-04 jrmu '(i (id (id 2)))
1107 665c255d 2023-08-04 jrmu (test-eval 'count 15)
1109 665c255d 2023-08-04 jrmu '(define (add-to-count (n lazy-memo))
1110 665c255d 2023-08-04 jrmu (if (= n 0)
1112 665c255d 2023-08-04 jrmu (begin (set! count (+ count 1))
1113 665c255d 2023-08-04 jrmu (add-to-count (- n 1))))))
1115 665c255d 2023-08-04 jrmu '(define (subtract-from-count (n lazy))
1116 665c255d 2023-08-04 jrmu (if (= n 0)
1118 665c255d 2023-08-04 jrmu (begin (set! count (- count 1))
1119 665c255d 2023-08-04 jrmu (subtract-from-count (- n 1))))))
1120 665c255d 2023-08-04 jrmu (test-eval
1121 665c255d 2023-08-04 jrmu '(add-to-count (id 5))
1123 665c255d 2023-08-04 jrmu (test-eval 'count 21)
1124 665c255d 2023-08-04 jrmu ;; n = (thunk (id 5))
1125 665c255d 2023-08-04 jrmu ;; count = 16
1126 665c255d 2023-08-04 jrmu ;; count = 17
1127 665c255d 2023-08-04 jrmu ;; (add-to-count (- n 1))
1128 665c255d 2023-08-04 jrmu ;; n = (thunk (- n 1))
1130 665c255d 2023-08-04 jrmu ;; count = 18
1132 665c255d 2023-08-04 jrmu ;; count = 19
1134 665c255d 2023-08-04 jrmu ;; count = 20
1136 665c255d 2023-08-04 jrmu ;; count = 21
1138 665c255d 2023-08-04 jrmu (test-eval
1139 665c255d 2023-08-04 jrmu '(subtract-from-count (id 5))
1141 665c255d 2023-08-04 jrmu ;; n = (simple-thunk (id 5))
1142 665c255d 2023-08-04 jrmu ;; count = 22
1143 665c255d 2023-08-04 jrmu ;; (= 5 0)
1144 665c255d 2023-08-04 jrmu ;; count = 21
1145 665c255d 2023-08-04 jrmu ;; (subtract-from-count (- n 1))
1146 665c255d 2023-08-04 jrmu ;; n = (simple-thunk (- n 1))
1147 665c255d 2023-08-04 jrmu ;; n = (- n 1)
1148 665c255d 2023-08-04 jrmu ;; count = 22
1150 665c255d 2023-08-04 jrmu ;; count = 21
1151 665c255d 2023-08-04 jrmu ;; (subtract-from-count (- n 1))
1152 665c255d 2023-08-04 jrmu ;; n = (simple-thunk (- n 1))
1153 665c255d 2023-08-04 jrmu ;; count = 22
1155 665c255d 2023-08-04 jrmu ;; count = 21
1156 665c255d 2023-08-04 jrmu ;; (subtract-from-count (- n 1))
1157 665c255d 2023-08-04 jrmu ;; n = (simple-thunk (- n 1))
1158 665c255d 2023-08-04 jrmu ;; count = 22
1160 665c255d 2023-08-04 jrmu ;; count = 21
1162 665c255d 2023-08-04 jrmu ;; count = 22
1164 665c255d 2023-08-04 jrmu (test-eval 'count 22)
