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 (cond ((eq? directive 'strict)
95 665c255d 2023-08-04 jrmu (cons (eval op env)
96 665c255d 2023-08-04 jrmu (list-of-delayed-args
97 665c255d 2023-08-04 jrmu (cdr directives)
100 665c255d 2023-08-04 jrmu ((eq? directive 'lazy)
101 665c255d 2023-08-04 jrmu (cons (simple-delay-it op env)
102 665c255d 2023-08-04 jrmu (list-of-delayed-args
103 665c255d 2023-08-04 jrmu (cdr directives)
106 665c255d 2023-08-04 jrmu ((eq? directive 'lazy-memo)
107 665c255d 2023-08-04 jrmu (cons (delay-it op env)
108 665c255d 2023-08-04 jrmu (list-of-delayed-args
109 665c255d 2023-08-04 jrmu (cdr directives)
113 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
114 665c255d 2023-08-04 jrmu (if (pair? exp)
115 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
118 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
119 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
120 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
121 665c255d 2023-08-04 jrmu ((string? exp) true)
122 665c255d 2023-08-04 jrmu (else false)))
123 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
124 665c255d 2023-08-04 jrmu (define (quoted? exp)
125 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
126 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
128 665c255d 2023-08-04 jrmu ;; assignment/definition
129 665c255d 2023-08-04 jrmu (define (assignment? exp)
130 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
131 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
132 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
133 665c255d 2023-08-04 jrmu (define (make-assignment var val)
134 665c255d 2023-08-04 jrmu (list 'set! var val))
135 665c255d 2023-08-04 jrmu (define (definition? exp)
136 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
137 665c255d 2023-08-04 jrmu (define (definition-variable exp)
138 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
140 665c255d 2023-08-04 jrmu (caadr exp)))
141 665c255d 2023-08-04 jrmu (define (definition-value exp)
142 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
143 665c255d 2023-08-04 jrmu (caddr exp)
144 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
145 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
146 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
147 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
148 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
151 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
152 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
153 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
156 665c255d 2023-08-04 jrmu (define (make-definition var val)
157 665c255d 2023-08-04 jrmu `(define ,var ,val))
159 665c255d 2023-08-04 jrmu ;; make-unbound!
161 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
162 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
163 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
164 665c255d 2023-08-04 jrmu ;; (cadr exp))
165 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
166 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
170 665c255d 2023-08-04 jrmu ;; if/and/or
171 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
172 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
173 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
174 665c255d 2023-08-04 jrmu (define (if-alternative exp)
175 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
176 665c255d 2023-08-04 jrmu (cadddr exp)
178 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
179 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
180 665c255d 2023-08-04 jrmu (define (eval-if exp env)
181 665c255d 2023-08-04 jrmu (if (true? (actual-value (if-predicate exp) env))
182 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
183 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
185 665c255d 2023-08-04 jrmu (define (and? exp)
186 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
187 665c255d 2023-08-04 jrmu (define (and-clauses exp)
189 665c255d 2023-08-04 jrmu (define (or? exp)
190 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
191 665c255d 2023-08-04 jrmu (define (or-clauses exp)
193 665c255d 2023-08-04 jrmu (define (eval-and exp env)
194 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
195 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
196 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
197 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
198 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
199 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
200 665c255d 2023-08-04 jrmu (define (eval-or exp env)
201 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
202 665c255d 2023-08-04 jrmu (if (null? clauses)
204 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
205 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
206 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
209 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
210 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
211 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
212 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
213 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
214 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
216 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
218 665c255d 2023-08-04 jrmu (cons (map list vars vals)
220 665c255d 2023-08-04 jrmu (define (let? exp)
221 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
222 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
223 665c255d 2023-08-04 jrmu (define (let-vars exp)
224 665c255d 2023-08-04 jrmu (map car (cadr exp)))
225 665c255d 2023-08-04 jrmu (define (let-vals exp)
226 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
227 665c255d 2023-08-04 jrmu (define (let-body exp)
228 665c255d 2023-08-04 jrmu (cddr exp))
229 665c255d 2023-08-04 jrmu (define (let->combination exp)
230 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
231 665c255d 2023-08-04 jrmu (let-vals exp)))
232 665c255d 2023-08-04 jrmu (define (named-let? exp)
233 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
234 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
235 665c255d 2023-08-04 jrmu (define (named-let-name exp)
236 665c255d 2023-08-04 jrmu (cadr exp))
237 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
238 665c255d 2023-08-04 jrmu (map car (caddr exp)))
239 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
240 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
241 665c255d 2023-08-04 jrmu (define (named-let-body exp)
242 665c255d 2023-08-04 jrmu (cdddr exp))
243 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
244 665c255d 2023-08-04 jrmu (sequence->exp
245 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
246 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
247 665c255d 2023-08-04 jrmu (named-let-body exp)))
248 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
249 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
250 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
253 665c255d 2023-08-04 jrmu (cons (map list vars vals)
256 665c255d 2023-08-04 jrmu (define (letrec? exp)
257 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
259 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
260 665c255d 2023-08-04 jrmu (map car (cadr exp)))
261 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
262 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
263 665c255d 2023-08-04 jrmu (define (letrec-body exp)
264 665c255d 2023-08-04 jrmu (cddr exp))
265 665c255d 2023-08-04 jrmu (define (letrec->let exp)
266 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
267 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
269 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
270 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
271 665c255d 2023-08-04 jrmu (make-assignment var val))
274 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
275 665c255d 2023-08-04 jrmu (make-let vars
276 665c255d 2023-08-04 jrmu unassigneds
277 665c255d 2023-08-04 jrmu (append assignments body))))
282 665c255d 2023-08-04 jrmu (define (let*? exp)
283 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
284 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
285 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
286 665c255d 2023-08-04 jrmu (define let*-body let-body)
287 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
288 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
289 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
290 665c255d 2023-08-04 jrmu (make-let (list (car vars))
291 665c255d 2023-08-04 jrmu (list (car vals))
292 665c255d 2023-08-04 jrmu (let*-body exp))
293 665c255d 2023-08-04 jrmu (make-let (list (car vars))
294 665c255d 2023-08-04 jrmu (list (car vals))
295 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
296 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
297 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
298 665c255d 2023-08-04 jrmu (if (null? vars)
299 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
300 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
303 665c255d 2023-08-04 jrmu (define (do? exp)
304 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
305 665c255d 2023-08-04 jrmu (define (do-vars exp)
306 665c255d 2023-08-04 jrmu (map car (cadr exp)))
307 665c255d 2023-08-04 jrmu (define (do-inits exp)
308 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
309 665c255d 2023-08-04 jrmu (define (do-steps exp)
310 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
311 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
312 665c255d 2023-08-04 jrmu (car var-init-step)
313 665c255d 2023-08-04 jrmu (caddr var-init-step)))
314 665c255d 2023-08-04 jrmu (cadr exp)))
315 665c255d 2023-08-04 jrmu (define (do-test exp)
316 665c255d 2023-08-04 jrmu (caaddr exp))
317 665c255d 2023-08-04 jrmu (define (do-expressions exp)
318 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
319 665c255d 2023-08-04 jrmu (caddr exp)
320 665c255d 2023-08-04 jrmu (cdaddr exp)))
321 665c255d 2023-08-04 jrmu (define (do-commands exp)
322 665c255d 2023-08-04 jrmu (cdddr exp))
323 665c255d 2023-08-04 jrmu (define (do->combination exp)
324 665c255d 2023-08-04 jrmu (make-named-let
326 665c255d 2023-08-04 jrmu (do-vars exp)
327 665c255d 2023-08-04 jrmu (do-inits exp)
330 665c255d 2023-08-04 jrmu (do-test exp)
331 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
332 665c255d 2023-08-04 jrmu (sequence->exp
333 665c255d 2023-08-04 jrmu (append (do-commands exp)
334 665c255d 2023-08-04 jrmu (list (make-application
336 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
339 665c255d 2023-08-04 jrmu ;; begin/sequence
340 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
341 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
342 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
343 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
344 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
345 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
346 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
347 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
348 665c255d 2023-08-04 jrmu (else (make-begin seq))))
349 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
350 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
351 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
352 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
353 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
355 665c255d 2023-08-04 jrmu ;; application
356 665c255d 2023-08-04 jrmu (define (make-application op args)
357 665c255d 2023-08-04 jrmu (cons op args))
358 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
359 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
360 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
361 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
362 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
363 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
366 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
367 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
368 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
369 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
370 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
371 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
372 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
373 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
374 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
375 665c255d 2023-08-04 jrmu (caddr clause))
376 665c255d 2023-08-04 jrmu (define (cond->if exp)
377 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
378 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
379 665c255d 2023-08-04 jrmu (if (null? clauses)
380 665c255d 2023-08-04 jrmu 'false ; no else clause
381 665c255d 2023-08-04 jrmu (let ((first (car clauses))
382 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
383 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
384 665c255d 2023-08-04 jrmu (if (null? rest)
385 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
386 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
388 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
389 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
390 665c255d 2023-08-04 jrmu (make-application
391 665c255d 2023-08-04 jrmu (cond-extended-proc first)
392 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
393 665c255d 2023-08-04 jrmu (expand-clauses rest))
394 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
395 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
396 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
397 665c255d 2023-08-04 jrmu (define (true? x)
398 665c255d 2023-08-04 jrmu (not (eq? x false)))
399 665c255d 2023-08-04 jrmu (define (false? x)
400 665c255d 2023-08-04 jrmu (eq? x false))
402 665c255d 2023-08-04 jrmu ;; procedure
403 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
404 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
405 665c255d 2023-08-04 jrmu ;; (define (scan-out-defines body)
406 665c255d 2023-08-04 jrmu ;; (let* ((definitions (filter definition? body))
407 665c255d 2023-08-04 jrmu ;; (vars (map definition-variable definitions))
408 665c255d 2023-08-04 jrmu ;; (unassigneds (map (lambda (var) ''*unassigned*)
410 665c255d 2023-08-04 jrmu ;; (vals (map definition-value definitions))
411 665c255d 2023-08-04 jrmu ;; (assignments
412 665c255d 2023-08-04 jrmu ;; (map (lambda (var val)
413 665c255d 2023-08-04 jrmu ;; (make-assignment var val))
414 665c255d 2023-08-04 jrmu ;; vars vals))
415 665c255d 2023-08-04 jrmu ;; (exps (remove definition? body)))
416 665c255d 2023-08-04 jrmu ;; (if (null? definitions)
419 665c255d 2023-08-04 jrmu ;; (make-let vars
420 665c255d 2023-08-04 jrmu ;; unassigneds
421 665c255d 2023-08-04 jrmu ;; (append assignments exps))))))
422 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
423 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
424 665c255d 2023-08-04 jrmu ;; (define (procedure-parameters p) (cadr p))
425 665c255d 2023-08-04 jrmu (define (procedure-parameters p)
426 665c255d 2023-08-04 jrmu (map (lambda (param)
427 665c255d 2023-08-04 jrmu (if (symbol? param)
429 665c255d 2023-08-04 jrmu (car param)))
431 665c255d 2023-08-04 jrmu (define (procedure-parameters-directives p)
432 665c255d 2023-08-04 jrmu (map (lambda (param)
433 665c255d 2023-08-04 jrmu (if (symbol? param)
435 665c255d 2023-08-04 jrmu (cadr param)))
437 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
438 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
440 665c255d 2023-08-04 jrmu ;; environment
441 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
442 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
443 665c255d 2023-08-04 jrmu (define the-empty-environment '())
444 665c255d 2023-08-04 jrmu (define (make-frame variables values)
445 665c255d 2023-08-04 jrmu (cons variables values))
446 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
447 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
448 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
449 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
450 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
451 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
452 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
453 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
454 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
455 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
456 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
457 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
458 665c255d 2023-08-04 jrmu (define (env-loop env)
459 665c255d 2023-08-04 jrmu (define (scan vars vals)
460 665c255d 2023-08-04 jrmu (cond ((null? vars)
461 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
462 665c255d 2023-08-04 jrmu ((eq? var (car vars))
463 665c255d 2023-08-04 jrmu (let ((val (car vals)))
464 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
465 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
467 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
468 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
469 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
470 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
471 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
472 665c255d 2023-08-04 jrmu (frame-values frame)))))
473 665c255d 2023-08-04 jrmu (env-loop env))
474 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
475 665c255d 2023-08-04 jrmu (define (env-loop env)
476 665c255d 2023-08-04 jrmu (define (scan vars vals)
477 665c255d 2023-08-04 jrmu (cond ((null? vars)
478 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
479 665c255d 2023-08-04 jrmu ((eq? var (car vars))
480 665c255d 2023-08-04 jrmu (set-car! vals val))
481 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
482 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
483 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
484 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
485 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
486 665c255d 2023-08-04 jrmu (frame-values frame)))))
487 665c255d 2023-08-04 jrmu (env-loop env))
488 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
489 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
490 665c255d 2023-08-04 jrmu (define (scan vars vals)
491 665c255d 2023-08-04 jrmu (cond ((null? vars)
492 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
493 665c255d 2023-08-04 jrmu ((eq? var (car vars))
494 665c255d 2023-08-04 jrmu (set-car! vals val))
495 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
496 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
497 665c255d 2023-08-04 jrmu (frame-values frame))))
499 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
500 665c255d 2023-08-04 jrmu (define (scan vars vals)
501 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
502 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
503 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
504 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
505 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
506 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
507 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
508 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
509 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
510 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
511 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
512 665c255d 2023-08-04 jrmu (scan vars vals))))
514 665c255d 2023-08-04 jrmu ;; primitives
515 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
516 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
517 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
518 665c255d 2023-08-04 jrmu (define primitive-procedures
519 665c255d 2023-08-04 jrmu (list (list 'car car)
520 665c255d 2023-08-04 jrmu (list 'cdr cdr)
521 665c255d 2023-08-04 jrmu (list 'caar caar)
522 665c255d 2023-08-04 jrmu (list 'cadr cadr)
523 665c255d 2023-08-04 jrmu (list 'cddr cddr)
524 665c255d 2023-08-04 jrmu (list 'cons cons)
525 665c255d 2023-08-04 jrmu (list 'null? null?)
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 '< <)
532 665c255d 2023-08-04 jrmu (list '> >)
533 665c255d 2023-08-04 jrmu (list '<= <=)
534 665c255d 2023-08-04 jrmu (list '>= >=)
535 665c255d 2023-08-04 jrmu (list 'remainder remainder)
536 665c255d 2023-08-04 jrmu (list 'eq? eq?)
537 665c255d 2023-08-04 jrmu (list 'equal? equal?)
538 665c255d 2023-08-04 jrmu (list 'display display)))
539 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
541 665c255d 2023-08-04 jrmu primitive-procedures))
542 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
543 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
544 665c255d 2023-08-04 jrmu primitive-procedures))
545 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
546 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
547 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
549 665c255d 2023-08-04 jrmu ;; driver-loop
550 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
551 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
552 665c255d 2023-08-04 jrmu (define (driver-loop)
553 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
554 665c255d 2023-08-04 jrmu (let ((input (read)))
555 665c255d 2023-08-04 jrmu (let ((output (actual-value input the-global-environment)))
556 665c255d 2023-08-04 jrmu (announce-output output-prompt)
557 665c255d 2023-08-04 jrmu (user-print output)))
558 665c255d 2023-08-04 jrmu (driver-loop))
559 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
560 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
562 665c255d 2023-08-04 jrmu (define (announce-output string)
563 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
564 665c255d 2023-08-04 jrmu (define (user-print object)
565 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
566 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
567 665c255d 2023-08-04 jrmu (procedure-parameters object)
568 665c255d 2023-08-04 jrmu (procedure-body object)
569 665c255d 2023-08-04 jrmu '<procedure-env>))
570 665c255d 2023-08-04 jrmu (display object)))
571 665c255d 2023-08-04 jrmu (define (setup-environment)
572 665c255d 2023-08-04 jrmu (let ((initial-env
573 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
574 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
575 665c255d 2023-08-04 jrmu the-empty-environment)))
576 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
577 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
578 665c255d 2023-08-04 jrmu initial-env))
579 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
581 665c255d 2023-08-04 jrmu ;; auxiliary
582 665c255d 2023-08-04 jrmu (define (test-case actual expected)
584 665c255d 2023-08-04 jrmu (display "Actual: ")
585 665c255d 2023-08-04 jrmu (display actual)
587 665c255d 2023-08-04 jrmu (display "Expected: ")
588 665c255d 2023-08-04 jrmu (display expected)
590 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
591 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
592 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
593 665c255d 2023-08-04 jrmu (test-case (force-it (geval exp)) expected))
595 665c255d 2023-08-04 jrmu ;; Exercise 4.31. The approach taken in this section is somewhat unpleasant, because it makes an 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
597 665c255d 2023-08-04 jrmu (define (f a (b lazy) c (d lazy-memo))
600 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.
602 665c255d 2023-08-04 jrmu (geval '(define count 0))
605 665c255d 2023-08-04 jrmu '(define (id (x lazy-memo))
606 665c255d 2023-08-04 jrmu (set! count (+ count 1))
610 665c255d 2023-08-04 jrmu '(define (f a (b lazy) c (d lazy-memo))
616 665c255d 2023-08-04 jrmu '(f (id 1) (id 2) (id 3) (id 4))
618 665c255d 2023-08-04 jrmu (test-eval 'count 3)
620 665c255d 2023-08-04 jrmu '(f 1 (id 2) 3 4)
622 665c255d 2023-08-04 jrmu (test-eval 'count 3)
624 665c255d 2023-08-04 jrmu '(define (g (a lazy-memo))
627 665c255d 2023-08-04 jrmu '(g (id 2))
629 665c255d 2023-08-04 jrmu (test-eval 'count 4)
631 665c255d 2023-08-04 jrmu '(define (h (a lazy))
634 665c255d 2023-08-04 jrmu '(h (id 2))
636 665c255d 2023-08-04 jrmu (test-eval 'count 6)
638 665c255d 2023-08-04 jrmu '(g (id (id 2)))
640 665c255d 2023-08-04 jrmu (test-eval 'count ...)
642 665c255d 2023-08-04 jrmu '(h (id (id 2)))
648 665c255d 2023-08-04 jrmu '(define (i a)
651 665c255d 2023-08-04 jrmu '(i (id 2))
657 665c255d 2023-08-04 jrmu '(i (id (id 2)))
662 665c255d 2023-08-04 jrmu (define (add-to-count (n lazy-memo)
663 665c255d 2023-08-04 jrmu (if (= n 0)
665 665c255d 2023-08-04 jrmu (begin (set! count (+ count 1))
666 665c255d 2023-08-04 jrmu (add-to-count (- n 1)))))
667 665c255d 2023-08-04 jrmu (define (subtract-from-count (n lazy))
668 665c255d 2023-08-04 jrmu (if (= n 0)
670 665c255d 2023-08-04 jrmu (begin (set! count (- count 1))
671 665c255d 2023-08-04 jrmu (subtract-from-count (- n 1)))))
673 665c255d 2023-08-04 jrmu '(add-to-count (id 5))
676 665c255d 2023-08-04 jrmu '(subtract-from-count (id 5))
678 665c255d 2023-08-04 jrmu (test-eval 'count ...)
679 665c255d 2023-08-04 jrmu (define (lazy-add (n
680 665c255d 2023-08-04 jrmu '(define (f a (b lazy) c (d lazy-memo))
687 665c255d 2023-08-04 jrmu '(f (id 1) (id 2) (id 3) (id 4))
690 665c255d 2023-08-04 jrmu ;; test-suite
692 665c255d 2023-08-04 jrmu ;; procedure definitions
695 665c255d 2023-08-04 jrmu '(define (assoc key records)
696 665c255d 2023-08-04 jrmu (cond ((null? records) false)
697 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
698 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
701 665c255d 2023-08-04 jrmu '(define (map proc list)
702 665c255d 2023-08-04 jrmu (if (null? list)
704 665c255d 2023-08-04 jrmu (cons (proc (car list))
705 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
708 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
709 665c255d 2023-08-04 jrmu (if (null? sequence)
711 665c255d 2023-08-04 jrmu (op (car sequence)
712 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
714 665c255d 2023-08-04 jrmu ;; all special forms
715 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
716 665c255d 2023-08-04 jrmu (test-eval '10 10)
717 665c255d 2023-08-04 jrmu (geval '(define x 3))
718 665c255d 2023-08-04 jrmu (test-eval 'x 3)
719 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
720 665c255d 2023-08-04 jrmu (test-eval 'x -25)
721 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
722 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
723 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
724 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
725 665c255d 2023-08-04 jrmu (else 'failed))
727 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
730 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
731 665c255d 2023-08-04 jrmu (+ x y (* x y)))
732 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
736 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
737 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
738 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
739 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
740 665c255d 2023-08-04 jrmu (test-eval 'x -2)
741 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
742 665c255d 2023-08-04 jrmu (test-eval 'x -2)
743 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
744 665c255d 2023-08-04 jrmu (test-eval 'x 25)
745 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
746 665c255d 2023-08-04 jrmu (test-eval 'x 2)
747 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
748 665c255d 2023-08-04 jrmu (test-eval 'x 25)
749 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
750 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
756 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
757 665c255d 2023-08-04 jrmu (else false))
761 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
762 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
763 665c255d 2023-08-04 jrmu ((map (lambda (x)
764 665c255d 2023-08-04 jrmu (* x (+ x 1)))
765 665c255d 2023-08-04 jrmu '(2 4 1 9))
767 665c255d 2023-08-04 jrmu (lambda (x)
768 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
769 665c255d 2023-08-04 jrmu (else 'never-reach))
771 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
774 665c255d 2023-08-04 jrmu ;; procedure definition and application
776 665c255d 2023-08-04 jrmu '(define (factorial n)
777 665c255d 2023-08-04 jrmu (if (= n 0)
779 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
780 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
785 665c255d 2023-08-04 jrmu '(map (lambda (x)
786 665c255d 2023-08-04 jrmu (* x (+ x 1)))
787 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
788 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
789 665c255d 2023-08-04 jrmu ;; accumulate
792 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
795 665c255d 2023-08-04 jrmu ;; make-let
797 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
804 665c255d 2023-08-04 jrmu '(let ((x 3))
808 665c255d 2023-08-04 jrmu '(let ((x 3)
813 665c255d 2023-08-04 jrmu '(let ((x 3)
815 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
819 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
821 665c255d 2023-08-04 jrmu '(let ((x 6)
822 665c255d 2023-08-04 jrmu (y (let ((x 2))
824 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
833 665c255d 2023-08-04 jrmu '(let* ((x 3)
834 665c255d 2023-08-04 jrmu (y (+ x 2))
835 665c255d 2023-08-04 jrmu (z (+ x y 5)))
844 665c255d 2023-08-04 jrmu '(let* ((x 3))
845 665c255d 2023-08-04 jrmu (let* ((y 5))
850 665c255d 2023-08-04 jrmu '(let* ((x 3)
851 665c255d 2023-08-04 jrmu (y (+ x 1)))
852 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
856 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
858 665c255d 2023-08-04 jrmu '(let* ((x 6)
859 665c255d 2023-08-04 jrmu (y (let* ((x 2)
860 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
863 665c255d 2023-08-04 jrmu (z (+ x y)))
867 665c255d 2023-08-04 jrmu ;; named-let
870 665c255d 2023-08-04 jrmu '(let eight ()
876 665c255d 2023-08-04 jrmu '(let loop ((count 0))
877 665c255d 2023-08-04 jrmu (if (= 100 count)
879 665c255d 2023-08-04 jrmu (loop (+ count 1))))
882 665c255d 2023-08-04 jrmu '(define (prime? x)
883 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
884 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
885 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
886 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
888 665c255d 2023-08-04 jrmu '(let primes ((x 2)
890 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
891 665c255d 2023-08-04 jrmu ((prime? x)
893 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
894 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
895 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))
898 665c255d 2023-08-04 jrmu '(define (fib n)
899 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
902 665c255d 2023-08-04 jrmu (if (= count 0)
904 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
905 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
909 665c255d 2023-08-04 jrmu '(let ((y 0))
910 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
911 665c255d 2023-08-04 jrmu ((= x 5) y)
912 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
923 665c255d 2023-08-04 jrmu '(let ((y 0))
925 665c255d 2023-08-04 jrmu ((= y 5) y)
926 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
930 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
931 665c255d 2023-08-04 jrmu ((null? y))
932 665c255d 2023-08-04 jrmu (set! y (cdr y)))
935 665c255d 2023-08-04 jrmu '(let ((y 0))
936 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
937 665c255d 2023-08-04 jrmu ((= x 5) y)
938 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
941 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
942 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
943 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
944 665c255d 2023-08-04 jrmu ((null? x) sum)))
947 665c255d 2023-08-04 jrmu '(let ((z '()))
948 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
949 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
950 665c255d 2023-08-04 jrmu ((null? x) y x z)
951 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
952 665c255d 2023-08-04 jrmu '(4 3 2 1))
956 665c255d 2023-08-04 jrmu ;; make-unbound!
957 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
959 665c255d 2023-08-04 jrmu ;; (test-eval
960 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
961 665c255d 2023-08-04 jrmu ;; (let ((x 5))
962 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
963 665c255d 2023-08-04 jrmu ;; (* x x)))
966 665c255d 2023-08-04 jrmu ;; (test-eval
967 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
968 665c255d 2023-08-04 jrmu ;; (let ((x 5))
969 665c255d 2023-08-04 jrmu ;; (define y x)
970 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
971 665c255d 2023-08-04 jrmu ;; (* y x)))
974 665c255d 2023-08-04 jrmu ;; (test-eval
975 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
976 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
977 665c255d 2023-08-04 jrmu ;; (define a x)
978 665c255d 2023-08-04 jrmu ;; (define b y)
979 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
980 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
981 665c255d 2023-08-04 jrmu ;; (* a b x y)))
982 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
984 665c255d 2023-08-04 jrmu ;; (test-eval
985 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
986 665c255d 2023-08-04 jrmu ;; (let ((x 5))
987 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
988 665c255d 2023-08-04 jrmu ;; (+ x 4)))
991 665c255d 2023-08-04 jrmu ;; (test-eval
992 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
993 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
994 665c255d 2023-08-04 jrmu ;; (+ a c d))
995 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
997 665c255d 2023-08-04 jrmu ;; (test-eval
998 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
999 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
1000 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
1001 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
1002 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
1003 665c255d 2023-08-04 jrmu ;; (define z b)
1004 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
1005 665c255d 2023-08-04 jrmu ;; (* (+ a z)
1006 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
1007 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
1008 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
1010 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
1011 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
1012 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
1013 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
1015 665c255d 2023-08-04 jrmu ;; scan-out-defines
1018 665c255d 2023-08-04 jrmu '(define (f x)
1019 665c255d 2023-08-04 jrmu (define (even? n)
1020 665c255d 2023-08-04 jrmu (if (= n 0)
1022 665c255d 2023-08-04 jrmu (odd? (- n 1))))
1023 665c255d 2023-08-04 jrmu (define (odd? n)
1024 665c255d 2023-08-04 jrmu (if (= n 0)
1026 665c255d 2023-08-04 jrmu (even? (- n 1))))
1027 665c255d 2023-08-04 jrmu (even? x)))
1028 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
1029 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
1032 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
1033 665c255d 2023-08-04 jrmu ;; (define y x)
1034 665c255d 2023-08-04 jrmu ;; (define x 3)
1035 665c255d 2023-08-04 jrmu ;; (+ x y)))
1036 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
1041 665c255d 2023-08-04 jrmu '(define (f x)
1042 665c255d 2023-08-04 jrmu (letrec ((even?
1043 665c255d 2023-08-04 jrmu (lambda (n)
1044 665c255d 2023-08-04 jrmu (if (= n 0)
1046 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
1048 665c255d 2023-08-04 jrmu (lambda (n)
1049 665c255d 2023-08-04 jrmu (if (= n 0)
1051 665c255d 2023-08-04 jrmu (even? (- n 1))))))
1052 665c255d 2023-08-04 jrmu (even? x))))
1053 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
1054 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
1056 665c255d 2023-08-04 jrmu (test-eval
1057 665c255d 2023-08-04 jrmu '(letrec ((fact
1058 665c255d 2023-08-04 jrmu (lambda (n)
1059 665c255d 2023-08-04 jrmu (if (= n 1)
1061 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
1062 665c255d 2023-08-04 jrmu (fact 10))
1066 665c255d 2023-08-04 jrmu ;; delayed-evaluation
1069 665c255d 2023-08-04 jrmu '(define (try a b)
1070 665c255d 2023-08-04 jrmu (if (= a 0) 1 b)))
1071 665c255d 2023-08-04 jrmu (test-eval '(try 0 (/ 1 0)) 1)
1074 665c255d 2023-08-04 jrmu '(define (unless condition usual-value exceptional-value)
1075 665c255d 2023-08-04 jrmu (if condition exceptional-value usual-value)))
1076 665c255d 2023-08-04 jrmu (test-eval
1077 665c255d 2023-08-04 jrmu '(let ((a 4) (b 0))
1078 665c255d 2023-08-04 jrmu (unless (= b 0)
1080 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1083 665c255d 2023-08-04 jrmu (test-eval
1084 665c255d 2023-08-04 jrmu '(let ((a 4) (b 2))
1085 665c255d 2023-08-04 jrmu (unless (= b 0)
1087 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1092 665c255d 2023-08-04 jrmu '(define (factorial n)
1093 665c255d 2023-08-04 jrmu (unless (= n 1)
1094 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))
1096 665c255d 2023-08-04 jrmu (test-eval
1097 665c255d 2023-08-04 jrmu '(factorial 8)
1100 665c255d 2023-08-04 jrmu (geval '(define count 0))
1101 665c255d 2023-08-04 jrmu (geval '(define (id x)
1102 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1105 665c255d 2023-08-04 jrmu (geval '(define w (id (id 10))))
1106 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1107 665c255d 2023-08-04 jrmu (test-eval 'w 10)
1108 665c255d 2023-08-04 jrmu (test-eval 'count 2)
1109 665c255d 2023-08-04 jrmu (test-eval
1110 665c255d 2023-08-04 jrmu '(let ((f (lambda (x) (+ x 1))))
1113 665c255d 2023-08-04 jrmu (geval '(define count 0))
1114 665c255d 2023-08-04 jrmu (geval '(define (id x)
1115 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1118 665c255d 2023-08-04 jrmu '(define (square x)
1120 665c255d 2023-08-04 jrmu (test-eval
1121 665c255d 2023-08-04 jrmu '(square (id 10))
1123 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1124 665c255d 2023-08-04 jrmu ;; would be 2 without memoization
1127 665c255d 2023-08-04 jrmu '(define (p1 x)
1128 665c255d 2023-08-04 jrmu (set! x (cons x '(2)))
1131 665c255d 2023-08-04 jrmu '(define (p2 x)
1132 665c255d 2023-08-04 jrmu (define (p e)
1135 665c255d 2023-08-04 jrmu (p (set! x (cons x '(2))))))
1136 665c255d 2023-08-04 jrmu (test-eval '(p1 1) '(1 2))
1137 665c255d 2023-08-04 jrmu (test-eval '(p2 1) 1)
