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 arguments env)
42 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
45 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
47 665c255d 2023-08-04 jrmu (define (thunk? obj)
48 665c255d 2023-08-04 jrmu (tagged-list? obj 'thunk))
49 665c255d 2023-08-04 jrmu (define (thunk-exp thunk)
50 665c255d 2023-08-04 jrmu (cadr thunk))
51 665c255d 2023-08-04 jrmu (define (thunk-env thunk)
52 665c255d 2023-08-04 jrmu (caddr thunk))
53 665c255d 2023-08-04 jrmu (define (evaluated-thunk? obj)
54 665c255d 2023-08-04 jrmu (tagged-list? obj 'evaluated-thunk))
55 665c255d 2023-08-04 jrmu (define (thunk-value evaluated-thunk)
56 665c255d 2023-08-04 jrmu (cadr evaluated-thunk))
57 665c255d 2023-08-04 jrmu (define (delay-it exp env)
58 665c255d 2023-08-04 jrmu `(thunk ,exp ,env))
59 665c255d 2023-08-04 jrmu (define (actual-value exp env)
60 665c255d 2023-08-04 jrmu (force-it (eval exp env)))
61 665c255d 2023-08-04 jrmu (define (force-it obj)
62 665c255d 2023-08-04 jrmu (cond ((thunk? obj)
63 665c255d 2023-08-04 jrmu (let ((result (actual-value
64 665c255d 2023-08-04 jrmu (thunk-exp obj)
65 665c255d 2023-08-04 jrmu (thunk-env obj))))
66 665c255d 2023-08-04 jrmu (set-car! obj 'evaluated-thunk)
67 665c255d 2023-08-04 jrmu (set-car! (cdr obj) result)
68 665c255d 2023-08-04 jrmu (set-cdr! (cdr obj) '())
70 665c255d 2023-08-04 jrmu ((evaluated-thunk? obj)
71 665c255d 2023-08-04 jrmu (thunk-value obj))
72 665c255d 2023-08-04 jrmu (else obj)))
74 665c255d 2023-08-04 jrmu (define (list-of-arg-values exps env)
75 665c255d 2023-08-04 jrmu (if (no-operands? exps)
77 665c255d 2023-08-04 jrmu (cons (actual-value (first-operand exps) env)
78 665c255d 2023-08-04 jrmu (list-of-arg-values (rest-operands exps) env))))
79 665c255d 2023-08-04 jrmu (define (list-of-delayed-args exps env)
80 665c255d 2023-08-04 jrmu (if (no-operands? exps)
82 665c255d 2023-08-04 jrmu (cons (delay-it (first-operand exps) env)
83 665c255d 2023-08-04 jrmu (list-of-delayed-args (rest-operands exps) env))))
85 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
86 665c255d 2023-08-04 jrmu (if (pair? exp)
87 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
90 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
91 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
92 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
93 665c255d 2023-08-04 jrmu ((string? exp) true)
94 665c255d 2023-08-04 jrmu (else false)))
95 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
96 665c255d 2023-08-04 jrmu (define (quoted? exp)
97 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
98 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
100 665c255d 2023-08-04 jrmu ;; assignment/definition
101 665c255d 2023-08-04 jrmu (define (assignment? exp)
102 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
103 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
104 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
105 665c255d 2023-08-04 jrmu (define (make-assignment var val)
106 665c255d 2023-08-04 jrmu (list 'set! var val))
107 665c255d 2023-08-04 jrmu (define (definition? exp)
108 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
109 665c255d 2023-08-04 jrmu (define (definition-variable exp)
110 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
112 665c255d 2023-08-04 jrmu (caadr exp)))
113 665c255d 2023-08-04 jrmu (define (definition-value exp)
114 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
115 665c255d 2023-08-04 jrmu (caddr exp)
116 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
117 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
118 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
119 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
120 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
123 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
124 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
125 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
128 665c255d 2023-08-04 jrmu (define (make-definition var val)
129 665c255d 2023-08-04 jrmu `(define ,var ,val))
131 665c255d 2023-08-04 jrmu ;; make-unbound!
133 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
134 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
135 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
136 665c255d 2023-08-04 jrmu ;; (cadr exp))
137 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
138 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
142 665c255d 2023-08-04 jrmu ;; if/and/or
143 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
144 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
145 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
146 665c255d 2023-08-04 jrmu (define (if-alternative exp)
147 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
148 665c255d 2023-08-04 jrmu (cadddr exp)
150 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
151 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
152 665c255d 2023-08-04 jrmu (define (eval-if exp env)
153 665c255d 2023-08-04 jrmu (if (true? (actual-value (if-predicate exp) env))
154 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
155 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
157 665c255d 2023-08-04 jrmu (define (and? exp)
158 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
159 665c255d 2023-08-04 jrmu (define (and-clauses exp)
161 665c255d 2023-08-04 jrmu (define (or? exp)
162 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
163 665c255d 2023-08-04 jrmu (define (or-clauses exp)
165 665c255d 2023-08-04 jrmu (define (eval-and exp env)
166 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
167 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
168 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
169 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
170 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
171 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
172 665c255d 2023-08-04 jrmu (define (eval-or exp env)
173 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
174 665c255d 2023-08-04 jrmu (if (null? clauses)
176 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
177 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
178 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
181 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
182 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
183 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
184 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
185 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
186 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
188 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
190 665c255d 2023-08-04 jrmu (cons (map list vars vals)
192 665c255d 2023-08-04 jrmu (define (let? exp)
193 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
194 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
195 665c255d 2023-08-04 jrmu (define (let-vars exp)
196 665c255d 2023-08-04 jrmu (map car (cadr exp)))
197 665c255d 2023-08-04 jrmu (define (let-vals exp)
198 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
199 665c255d 2023-08-04 jrmu (define (let-body exp)
200 665c255d 2023-08-04 jrmu (cddr exp))
201 665c255d 2023-08-04 jrmu (define (let->combination exp)
202 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
203 665c255d 2023-08-04 jrmu (let-vals exp)))
204 665c255d 2023-08-04 jrmu (define (named-let? exp)
205 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
206 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
207 665c255d 2023-08-04 jrmu (define (named-let-name exp)
208 665c255d 2023-08-04 jrmu (cadr exp))
209 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
210 665c255d 2023-08-04 jrmu (map car (caddr exp)))
211 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
212 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
213 665c255d 2023-08-04 jrmu (define (named-let-body exp)
214 665c255d 2023-08-04 jrmu (cdddr exp))
215 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
216 665c255d 2023-08-04 jrmu (sequence->exp
217 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
218 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
219 665c255d 2023-08-04 jrmu (named-let-body exp)))
220 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
221 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
222 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
225 665c255d 2023-08-04 jrmu (cons (map list vars vals)
228 665c255d 2023-08-04 jrmu (define (letrec? exp)
229 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
231 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
232 665c255d 2023-08-04 jrmu (map car (cadr exp)))
233 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
234 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
235 665c255d 2023-08-04 jrmu (define (letrec-body exp)
236 665c255d 2023-08-04 jrmu (cddr exp))
237 665c255d 2023-08-04 jrmu (define (letrec->let exp)
238 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
239 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
241 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
242 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
243 665c255d 2023-08-04 jrmu (make-assignment var val))
246 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
247 665c255d 2023-08-04 jrmu (make-let vars
248 665c255d 2023-08-04 jrmu unassigneds
249 665c255d 2023-08-04 jrmu (append assignments body))))
254 665c255d 2023-08-04 jrmu (define (let*? exp)
255 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
256 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
257 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
258 665c255d 2023-08-04 jrmu (define let*-body let-body)
259 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
260 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
261 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
262 665c255d 2023-08-04 jrmu (make-let (list (car vars))
263 665c255d 2023-08-04 jrmu (list (car vals))
264 665c255d 2023-08-04 jrmu (let*-body exp))
265 665c255d 2023-08-04 jrmu (make-let (list (car vars))
266 665c255d 2023-08-04 jrmu (list (car vals))
267 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
268 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
269 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
270 665c255d 2023-08-04 jrmu (if (null? vars)
271 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
272 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
275 665c255d 2023-08-04 jrmu (define (do? exp)
276 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
277 665c255d 2023-08-04 jrmu (define (do-vars exp)
278 665c255d 2023-08-04 jrmu (map car (cadr exp)))
279 665c255d 2023-08-04 jrmu (define (do-inits exp)
280 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
281 665c255d 2023-08-04 jrmu (define (do-steps exp)
282 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
283 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
284 665c255d 2023-08-04 jrmu (car var-init-step)
285 665c255d 2023-08-04 jrmu (caddr var-init-step)))
286 665c255d 2023-08-04 jrmu (cadr exp)))
287 665c255d 2023-08-04 jrmu (define (do-test exp)
288 665c255d 2023-08-04 jrmu (caaddr exp))
289 665c255d 2023-08-04 jrmu (define (do-expressions exp)
290 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
291 665c255d 2023-08-04 jrmu (caddr exp)
292 665c255d 2023-08-04 jrmu (cdaddr exp)))
293 665c255d 2023-08-04 jrmu (define (do-commands exp)
294 665c255d 2023-08-04 jrmu (cdddr exp))
295 665c255d 2023-08-04 jrmu (define (do->combination exp)
296 665c255d 2023-08-04 jrmu (make-named-let
298 665c255d 2023-08-04 jrmu (do-vars exp)
299 665c255d 2023-08-04 jrmu (do-inits exp)
302 665c255d 2023-08-04 jrmu (do-test exp)
303 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
304 665c255d 2023-08-04 jrmu (sequence->exp
305 665c255d 2023-08-04 jrmu (append (do-commands exp)
306 665c255d 2023-08-04 jrmu (list (make-application
308 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
311 665c255d 2023-08-04 jrmu ;; begin/sequence
312 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
313 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
314 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
315 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
316 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
317 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
318 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
319 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
320 665c255d 2023-08-04 jrmu (else (make-begin seq))))
321 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
322 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
323 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
324 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
325 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
327 665c255d 2023-08-04 jrmu ;; application
328 665c255d 2023-08-04 jrmu (define (make-application op args)
329 665c255d 2023-08-04 jrmu (cons op args))
330 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
331 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
332 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
333 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
334 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
335 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
338 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
339 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
340 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
341 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
342 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
343 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
344 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
345 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
346 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
347 665c255d 2023-08-04 jrmu (caddr clause))
348 665c255d 2023-08-04 jrmu (define (cond->if exp)
349 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
350 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
351 665c255d 2023-08-04 jrmu (if (null? clauses)
352 665c255d 2023-08-04 jrmu 'false ; no else clause
353 665c255d 2023-08-04 jrmu (let ((first (car clauses))
354 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
355 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
356 665c255d 2023-08-04 jrmu (if (null? rest)
357 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
358 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
360 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
361 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
362 665c255d 2023-08-04 jrmu (make-application
363 665c255d 2023-08-04 jrmu (cond-extended-proc first)
364 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
365 665c255d 2023-08-04 jrmu (expand-clauses rest))
366 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
367 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
368 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
369 665c255d 2023-08-04 jrmu (define (true? x)
370 665c255d 2023-08-04 jrmu (not (eq? x false)))
371 665c255d 2023-08-04 jrmu (define (false? x)
372 665c255d 2023-08-04 jrmu (eq? x false))
374 665c255d 2023-08-04 jrmu ;; procedure
375 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
376 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
377 665c255d 2023-08-04 jrmu ;; (define (scan-out-defines body)
378 665c255d 2023-08-04 jrmu ;; (let* ((definitions (filter definition? body))
379 665c255d 2023-08-04 jrmu ;; (vars (map definition-variable definitions))
380 665c255d 2023-08-04 jrmu ;; (unassigneds (map (lambda (var) ''*unassigned*)
382 665c255d 2023-08-04 jrmu ;; (vals (map definition-value definitions))
383 665c255d 2023-08-04 jrmu ;; (assignments
384 665c255d 2023-08-04 jrmu ;; (map (lambda (var val)
385 665c255d 2023-08-04 jrmu ;; (make-assignment var val))
386 665c255d 2023-08-04 jrmu ;; vars vals))
387 665c255d 2023-08-04 jrmu ;; (exps (remove definition? body)))
388 665c255d 2023-08-04 jrmu ;; (if (null? definitions)
391 665c255d 2023-08-04 jrmu ;; (make-let vars
392 665c255d 2023-08-04 jrmu ;; unassigneds
393 665c255d 2023-08-04 jrmu ;; (append assignments exps))))))
394 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
395 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
396 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
397 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
398 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
400 665c255d 2023-08-04 jrmu ;; environment
401 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
402 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
403 665c255d 2023-08-04 jrmu (define the-empty-environment '())
404 665c255d 2023-08-04 jrmu (define (make-frame variables values)
405 665c255d 2023-08-04 jrmu (cons variables values))
406 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
407 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
408 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
409 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
410 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
411 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
412 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
413 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
414 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
415 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
416 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
417 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
418 665c255d 2023-08-04 jrmu (define (env-loop env)
419 665c255d 2023-08-04 jrmu (define (scan vars vals)
420 665c255d 2023-08-04 jrmu (cond ((null? vars)
421 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
422 665c255d 2023-08-04 jrmu ((eq? var (car vars))
423 665c255d 2023-08-04 jrmu (let ((val (car vals)))
424 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
425 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
427 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
428 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
429 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
430 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
431 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
432 665c255d 2023-08-04 jrmu (frame-values frame)))))
433 665c255d 2023-08-04 jrmu (env-loop env))
434 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
435 665c255d 2023-08-04 jrmu (define (env-loop env)
436 665c255d 2023-08-04 jrmu (define (scan vars vals)
437 665c255d 2023-08-04 jrmu (cond ((null? vars)
438 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
439 665c255d 2023-08-04 jrmu ((eq? var (car vars))
440 665c255d 2023-08-04 jrmu (set-car! vals val))
441 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
442 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
443 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
444 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
445 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
446 665c255d 2023-08-04 jrmu (frame-values frame)))))
447 665c255d 2023-08-04 jrmu (env-loop env))
448 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
449 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
450 665c255d 2023-08-04 jrmu (define (scan vars vals)
451 665c255d 2023-08-04 jrmu (cond ((null? vars)
452 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
453 665c255d 2023-08-04 jrmu ((eq? var (car vars))
454 665c255d 2023-08-04 jrmu (set-car! vals val))
455 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
456 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
457 665c255d 2023-08-04 jrmu (frame-values frame))))
459 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
460 665c255d 2023-08-04 jrmu (define (scan vars vals)
461 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
462 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
463 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
464 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
465 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
466 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
467 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
468 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
469 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
470 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
471 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
472 665c255d 2023-08-04 jrmu (scan vars vals))))
474 665c255d 2023-08-04 jrmu ;; primitives
475 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
476 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
477 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
478 665c255d 2023-08-04 jrmu (define primitive-procedures
479 665c255d 2023-08-04 jrmu (list (list 'car car)
480 665c255d 2023-08-04 jrmu (list 'cdr cdr)
481 665c255d 2023-08-04 jrmu (list 'caar caar)
482 665c255d 2023-08-04 jrmu (list 'cadr cadr)
483 665c255d 2023-08-04 jrmu (list 'cddr cddr)
484 665c255d 2023-08-04 jrmu (list 'cons cons)
485 665c255d 2023-08-04 jrmu (list 'null? null?)
486 665c255d 2023-08-04 jrmu (list '* *)
487 665c255d 2023-08-04 jrmu (list '/ /)
488 665c255d 2023-08-04 jrmu (list '+ +)
489 665c255d 2023-08-04 jrmu (list '- -)
490 665c255d 2023-08-04 jrmu (list '= =)
491 665c255d 2023-08-04 jrmu (list '< <)
492 665c255d 2023-08-04 jrmu (list '> >)
493 665c255d 2023-08-04 jrmu (list '<= <=)
494 665c255d 2023-08-04 jrmu (list '>= >=)
495 665c255d 2023-08-04 jrmu (list 'remainder remainder)
496 665c255d 2023-08-04 jrmu (list 'eq? eq?)
497 665c255d 2023-08-04 jrmu (list 'equal? equal?)
498 665c255d 2023-08-04 jrmu (list 'display display)))
499 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
501 665c255d 2023-08-04 jrmu primitive-procedures))
502 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
503 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
504 665c255d 2023-08-04 jrmu primitive-procedures))
505 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
506 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
507 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
509 665c255d 2023-08-04 jrmu ;; driver-loop
510 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
511 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
512 665c255d 2023-08-04 jrmu (define (driver-loop)
513 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
514 665c255d 2023-08-04 jrmu (let ((input (read)))
515 665c255d 2023-08-04 jrmu (let ((output (actual-value input the-global-environment)))
516 665c255d 2023-08-04 jrmu (announce-output output-prompt)
517 665c255d 2023-08-04 jrmu (user-print output)))
518 665c255d 2023-08-04 jrmu (driver-loop))
519 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
520 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
522 665c255d 2023-08-04 jrmu (define (announce-output string)
523 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
524 665c255d 2023-08-04 jrmu (define (user-print object)
525 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
526 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
527 665c255d 2023-08-04 jrmu (procedure-parameters object)
528 665c255d 2023-08-04 jrmu (procedure-body object)
529 665c255d 2023-08-04 jrmu '<procedure-env>))
530 665c255d 2023-08-04 jrmu (display object)))
531 665c255d 2023-08-04 jrmu (define (setup-environment)
532 665c255d 2023-08-04 jrmu (let ((initial-env
533 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
534 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
535 665c255d 2023-08-04 jrmu the-empty-environment)))
536 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
537 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
538 665c255d 2023-08-04 jrmu initial-env))
539 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
541 665c255d 2023-08-04 jrmu ;; auxiliary
542 665c255d 2023-08-04 jrmu (define (test-case actual expected)
544 665c255d 2023-08-04 jrmu (display "Actual: ")
545 665c255d 2023-08-04 jrmu (display actual)
547 665c255d 2023-08-04 jrmu (display "Expected: ")
548 665c255d 2023-08-04 jrmu (display expected)
550 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
551 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
552 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
553 665c255d 2023-08-04 jrmu (test-case (force-it (geval exp)) expected))
556 665c255d 2023-08-04 jrmu ;; Exercise 4.30. Cy D. Fect, a reformed C programmer, is worried that some side effects may never take place, because the lazy evaluator doesn't force the expressions in a sequence. Since the value of an expression in a sequence other than the last one is not used (the expression is there only for its effect, such as assigning to a variable or printing), there can be no subsequent use of this value (e.g., as an argument to a primitive procedure) that will cause it to be forced. Cy thus thinks that when evaluating sequences, we must force all expressions in the sequence except the final one. He proposes to modify eval-sequence from section 4.1.1 to use actual-value rather than eval:
558 665c255d 2023-08-04 jrmu ;; (define (eval-sequence exps env)
559 665c255d 2023-08-04 jrmu ;; (cond ((last-exp? exps) (eval (first-exp exps) env))
560 665c255d 2023-08-04 jrmu ;; (else (actual-value (first-exp exps) env)
561 665c255d 2023-08-04 jrmu ;; (eval-sequence (rest-exps exps) env))))
563 665c255d 2023-08-04 jrmu ;; a. Ben Bitdiddle thinks Cy is wrong. He shows Cy the for-each procedure described in exercise 2.23, which gives an important example of a sequence with side effects:
565 665c255d 2023-08-04 jrmu ;; (define (for-each proc items)
566 665c255d 2023-08-04 jrmu ;; (if (null? items)
568 665c255d 2023-08-04 jrmu ;; (begin (proc (car items))
569 665c255d 2023-08-04 jrmu ;; (for-each proc (cdr items)))))
571 665c255d 2023-08-04 jrmu ;; He claims that the evaluator in the text (with the original eval-sequence) handles this correctly:
573 665c255d 2023-08-04 jrmu ;;; L-Eval input:
574 665c255d 2023-08-04 jrmu ;; (for-each (lambda (x) (newline) (display x))
575 665c255d 2023-08-04 jrmu ;; (list 57 321 88))
579 665c255d 2023-08-04 jrmu ;; ;;; L-Eval value:
582 665c255d 2023-08-04 jrmu ;; Explain why Ben is right about the behavior of for-each.
584 665c255d 2023-08-04 jrmu ;; proc is an operator and hence the thunk will be forced for proc
585 665c255d 2023-08-04 jrmu ;; display is a primitive and this will therefore force the thunk for (car items)
587 665c255d 2023-08-04 jrmu ;; b. Cy agrees that Ben is right about the for-each example, but says that that's not the kind of program he was thinking about when he proposed his change to eval-sequence. He defines the following two procedures in the lazy evaluator:
590 665c255d 2023-08-04 jrmu '(define (p1 x)
591 665c255d 2023-08-04 jrmu (set! x (cons x '(2)))
594 665c255d 2023-08-04 jrmu '(define (p2 x)
595 665c255d 2023-08-04 jrmu (define (p e)
598 665c255d 2023-08-04 jrmu (p (set! x (cons x '(2))))))
599 665c255d 2023-08-04 jrmu (test-eval '(p1 1) '(1 2))
600 665c255d 2023-08-04 jrmu (test-eval '(p2 1) 1)
602 665c255d 2023-08-04 jrmu ;; What are the values of (p1 1) and (p2 1) with the original eval-sequence? What would the values be with Cy's proposed change to eval-sequence?
604 665c255d 2023-08-04 jrmu ;; with Cy's change, it would be '(1 2) for both
606 665c255d 2023-08-04 jrmu ;; c. Cy also points out that changing eval-sequence as he proposes does not affect the behavior of the example in part a. Explain why this is true.
608 665c255d 2023-08-04 jrmu ;; the primitives were forcing the evaluation of the thunks anyway
610 665c255d 2023-08-04 jrmu ;; d. How do you think sequences ought to be treated in the lazy evaluator? Do you like Cy's approach, the approach in the text, or some other approach?
612 665c255d 2023-08-04 jrmu ;; The one in the text is better. Cy's approach would partially defeat the whole purpose of delayed evaluation.
615 665c255d 2023-08-04 jrmu ;; test-suite
617 665c255d 2023-08-04 jrmu ;; procedure definitions
620 665c255d 2023-08-04 jrmu '(define (assoc key records)
621 665c255d 2023-08-04 jrmu (cond ((null? records) false)
622 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
623 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
626 665c255d 2023-08-04 jrmu '(define (map proc list)
627 665c255d 2023-08-04 jrmu (if (null? list)
629 665c255d 2023-08-04 jrmu (cons (proc (car list))
630 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
633 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
634 665c255d 2023-08-04 jrmu (if (null? sequence)
636 665c255d 2023-08-04 jrmu (op (car sequence)
637 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
639 665c255d 2023-08-04 jrmu ;; all special forms
640 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
641 665c255d 2023-08-04 jrmu (test-eval '10 10)
642 665c255d 2023-08-04 jrmu (geval '(define x 3))
643 665c255d 2023-08-04 jrmu (test-eval 'x 3)
644 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
645 665c255d 2023-08-04 jrmu (test-eval 'x -25)
646 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
647 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
648 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
649 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
650 665c255d 2023-08-04 jrmu (else 'failed))
652 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
655 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
656 665c255d 2023-08-04 jrmu (+ x y (* x y)))
657 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
661 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
662 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
663 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
664 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
665 665c255d 2023-08-04 jrmu (test-eval 'x -2)
666 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
667 665c255d 2023-08-04 jrmu (test-eval 'x -2)
668 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
669 665c255d 2023-08-04 jrmu (test-eval 'x 25)
670 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
671 665c255d 2023-08-04 jrmu (test-eval 'x 2)
672 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
673 665c255d 2023-08-04 jrmu (test-eval 'x 25)
674 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
675 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
681 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
682 665c255d 2023-08-04 jrmu (else false))
686 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
687 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
688 665c255d 2023-08-04 jrmu ((map (lambda (x)
689 665c255d 2023-08-04 jrmu (* x (+ x 1)))
690 665c255d 2023-08-04 jrmu '(2 4 1 9))
692 665c255d 2023-08-04 jrmu (lambda (x)
693 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
694 665c255d 2023-08-04 jrmu (else 'never-reach))
696 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
699 665c255d 2023-08-04 jrmu ;; procedure definition and application
701 665c255d 2023-08-04 jrmu '(define (factorial n)
702 665c255d 2023-08-04 jrmu (if (= n 0)
704 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
705 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
710 665c255d 2023-08-04 jrmu '(map (lambda (x)
711 665c255d 2023-08-04 jrmu (* x (+ x 1)))
712 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
713 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
714 665c255d 2023-08-04 jrmu ;; accumulate
717 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
720 665c255d 2023-08-04 jrmu ;; make-let
722 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
729 665c255d 2023-08-04 jrmu '(let ((x 3))
733 665c255d 2023-08-04 jrmu '(let ((x 3)
738 665c255d 2023-08-04 jrmu '(let ((x 3)
740 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
744 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
746 665c255d 2023-08-04 jrmu '(let ((x 6)
747 665c255d 2023-08-04 jrmu (y (let ((x 2))
749 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
758 665c255d 2023-08-04 jrmu '(let* ((x 3)
759 665c255d 2023-08-04 jrmu (y (+ x 2))
760 665c255d 2023-08-04 jrmu (z (+ x y 5)))
769 665c255d 2023-08-04 jrmu '(let* ((x 3))
770 665c255d 2023-08-04 jrmu (let* ((y 5))
775 665c255d 2023-08-04 jrmu '(let* ((x 3)
776 665c255d 2023-08-04 jrmu (y (+ x 1)))
777 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
781 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
783 665c255d 2023-08-04 jrmu '(let* ((x 6)
784 665c255d 2023-08-04 jrmu (y (let* ((x 2)
785 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
788 665c255d 2023-08-04 jrmu (z (+ x y)))
792 665c255d 2023-08-04 jrmu ;; named-let
795 665c255d 2023-08-04 jrmu '(let eight ()
801 665c255d 2023-08-04 jrmu '(let loop ((count 0))
802 665c255d 2023-08-04 jrmu (if (= 100 count)
804 665c255d 2023-08-04 jrmu (loop (+ count 1))))
807 665c255d 2023-08-04 jrmu '(define (prime? x)
808 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
809 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
810 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
811 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
813 665c255d 2023-08-04 jrmu '(let primes ((x 2)
815 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
816 665c255d 2023-08-04 jrmu ((prime? x)
818 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
819 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
820 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))
823 665c255d 2023-08-04 jrmu '(define (fib n)
824 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
827 665c255d 2023-08-04 jrmu (if (= count 0)
829 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
830 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
834 665c255d 2023-08-04 jrmu '(let ((y 0))
835 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
836 665c255d 2023-08-04 jrmu ((= x 5) y)
837 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
848 665c255d 2023-08-04 jrmu '(let ((y 0))
850 665c255d 2023-08-04 jrmu ((= y 5) y)
851 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
855 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
856 665c255d 2023-08-04 jrmu ((null? y))
857 665c255d 2023-08-04 jrmu (set! y (cdr y)))
860 665c255d 2023-08-04 jrmu '(let ((y 0))
861 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
862 665c255d 2023-08-04 jrmu ((= x 5) y)
863 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
866 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
867 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
868 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
869 665c255d 2023-08-04 jrmu ((null? x) sum)))
872 665c255d 2023-08-04 jrmu '(let ((z '()))
873 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
874 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
875 665c255d 2023-08-04 jrmu ((null? x) y x z)
876 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
877 665c255d 2023-08-04 jrmu '(4 3 2 1))
881 665c255d 2023-08-04 jrmu ;; make-unbound!
882 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
884 665c255d 2023-08-04 jrmu ;; (test-eval
885 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
886 665c255d 2023-08-04 jrmu ;; (let ((x 5))
887 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
888 665c255d 2023-08-04 jrmu ;; (* x x)))
891 665c255d 2023-08-04 jrmu ;; (test-eval
892 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
893 665c255d 2023-08-04 jrmu ;; (let ((x 5))
894 665c255d 2023-08-04 jrmu ;; (define y x)
895 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
896 665c255d 2023-08-04 jrmu ;; (* y x)))
899 665c255d 2023-08-04 jrmu ;; (test-eval
900 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
901 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
902 665c255d 2023-08-04 jrmu ;; (define a x)
903 665c255d 2023-08-04 jrmu ;; (define b y)
904 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
905 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
906 665c255d 2023-08-04 jrmu ;; (* a b x y)))
907 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
909 665c255d 2023-08-04 jrmu ;; (test-eval
910 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
911 665c255d 2023-08-04 jrmu ;; (let ((x 5))
912 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
913 665c255d 2023-08-04 jrmu ;; (+ x 4)))
916 665c255d 2023-08-04 jrmu ;; (test-eval
917 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
918 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
919 665c255d 2023-08-04 jrmu ;; (+ a c d))
920 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
922 665c255d 2023-08-04 jrmu ;; (test-eval
923 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
924 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
925 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
926 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
927 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
928 665c255d 2023-08-04 jrmu ;; (define z b)
929 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
930 665c255d 2023-08-04 jrmu ;; (* (+ a z)
931 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
932 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
933 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
935 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
936 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
937 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
938 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
940 665c255d 2023-08-04 jrmu ;; scan-out-defines
943 665c255d 2023-08-04 jrmu '(define (f x)
944 665c255d 2023-08-04 jrmu (define (even? n)
945 665c255d 2023-08-04 jrmu (if (= n 0)
947 665c255d 2023-08-04 jrmu (odd? (- n 1))))
948 665c255d 2023-08-04 jrmu (define (odd? n)
949 665c255d 2023-08-04 jrmu (if (= n 0)
951 665c255d 2023-08-04 jrmu (even? (- n 1))))
952 665c255d 2023-08-04 jrmu (even? x)))
953 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
954 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
957 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
958 665c255d 2023-08-04 jrmu ;; (define y x)
959 665c255d 2023-08-04 jrmu ;; (define x 3)
960 665c255d 2023-08-04 jrmu ;; (+ x y)))
961 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
966 665c255d 2023-08-04 jrmu '(define (f x)
967 665c255d 2023-08-04 jrmu (letrec ((even?
968 665c255d 2023-08-04 jrmu (lambda (n)
969 665c255d 2023-08-04 jrmu (if (= n 0)
971 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
973 665c255d 2023-08-04 jrmu (lambda (n)
974 665c255d 2023-08-04 jrmu (if (= n 0)
976 665c255d 2023-08-04 jrmu (even? (- n 1))))))
977 665c255d 2023-08-04 jrmu (even? x))))
978 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
979 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
982 665c255d 2023-08-04 jrmu '(letrec ((fact
983 665c255d 2023-08-04 jrmu (lambda (n)
984 665c255d 2023-08-04 jrmu (if (= n 1)
986 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
991 665c255d 2023-08-04 jrmu ;; delayed-evaluation
994 665c255d 2023-08-04 jrmu '(define (try a b)
995 665c255d 2023-08-04 jrmu (if (= a 0) 1 b)))
996 665c255d 2023-08-04 jrmu (test-eval '(try 0 (/ 1 0)) 1)
999 665c255d 2023-08-04 jrmu '(define (unless condition usual-value exceptional-value)
1000 665c255d 2023-08-04 jrmu (if condition exceptional-value usual-value)))
1001 665c255d 2023-08-04 jrmu (test-eval
1002 665c255d 2023-08-04 jrmu '(let ((a 4) (b 0))
1003 665c255d 2023-08-04 jrmu (unless (= b 0)
1005 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1008 665c255d 2023-08-04 jrmu (test-eval
1009 665c255d 2023-08-04 jrmu '(let ((a 4) (b 2))
1010 665c255d 2023-08-04 jrmu (unless (= b 0)
1012 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1017 665c255d 2023-08-04 jrmu '(define (factorial n)
1018 665c255d 2023-08-04 jrmu (unless (= n 1)
1019 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))
1021 665c255d 2023-08-04 jrmu (test-eval
1022 665c255d 2023-08-04 jrmu '(factorial 8)
1025 665c255d 2023-08-04 jrmu (geval '(define count 0))
1026 665c255d 2023-08-04 jrmu (geval '(define (id x)
1027 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1030 665c255d 2023-08-04 jrmu (geval '(define w (id (id 10))))
1031 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1032 665c255d 2023-08-04 jrmu (test-eval 'w 10)
1033 665c255d 2023-08-04 jrmu (test-eval 'count 2)
1034 665c255d 2023-08-04 jrmu (test-eval
1035 665c255d 2023-08-04 jrmu '(let ((f (lambda (x) (+ x 1))))
1038 665c255d 2023-08-04 jrmu (geval '(define count 0))
1039 665c255d 2023-08-04 jrmu (geval '(define (id x)
1040 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1043 665c255d 2023-08-04 jrmu '(define (square x)
1045 665c255d 2023-08-04 jrmu (test-eval
1046 665c255d 2023-08-04 jrmu '(square (id 10))
1048 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1049 665c255d 2023-08-04 jrmu ;; would be 2 without memoization
