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 ;; cons/car/cdr
559 665c255d 2023-08-04 jrmu '(define (cons x y)
560 665c255d 2023-08-04 jrmu (lambda (m) (m x y))))
562 665c255d 2023-08-04 jrmu '(define (car z)
563 665c255d 2023-08-04 jrmu (z (lambda (p q) p))))
565 665c255d 2023-08-04 jrmu '(define (cdr z)
566 665c255d 2023-08-04 jrmu (z (lambda (p q) q))))
568 665c255d 2023-08-04 jrmu '(define (list-ref items n)
569 665c255d 2023-08-04 jrmu (if (= n 0)
570 665c255d 2023-08-04 jrmu (car items)
571 665c255d 2023-08-04 jrmu (list-ref (cdr items) (- n 1)))))
573 665c255d 2023-08-04 jrmu '(define (map proc items)
574 665c255d 2023-08-04 jrmu (if (null? items)
576 665c255d 2023-08-04 jrmu (cons (proc (car items))
577 665c255d 2023-08-04 jrmu (map proc (cdr items))))))
579 665c255d 2023-08-04 jrmu '(define (scale-list items factor)
580 665c255d 2023-08-04 jrmu (map (lambda (x) (* x factor))
583 665c255d 2023-08-04 jrmu '(define (add-lists list1 list2)
584 665c255d 2023-08-04 jrmu (cond ((null? list1) list2)
585 665c255d 2023-08-04 jrmu ((null? list2) list1)
586 665c255d 2023-08-04 jrmu (else (cons (+ (car list1) (car list2))
587 665c255d 2023-08-04 jrmu (add-lists (cdr list1) (cdr list2)))))))
589 665c255d 2023-08-04 jrmu '(define ones (cons 1 ones)))
591 665c255d 2023-08-04 jrmu '(define integers (cons 1 (add-lists ones integers))))
592 665c255d 2023-08-04 jrmu (define (cons x y)
593 665c255d 2023-08-04 jrmu (lambda (m) (m x y)))
594 665c255d 2023-08-04 jrmu (define (car z)
595 665c255d 2023-08-04 jrmu (z (lambda (p q) p)))
596 665c255d 2023-08-04 jrmu (define (cdr z)
597 665c255d 2023-08-04 jrmu (z (lambda (p q) q)))
599 665c255d 2023-08-04 jrmu (define x (cons 3 5))
600 665c255d 2023-08-04 jrmu ;; x = (thunk 3)
601 665c255d 2023-08-04 jrmu ;; y = (thunk 5)
602 665c255d 2023-08-04 jrmu ;; x = procedure object
606 665c255d 2023-08-04 jrmu ;; z = (thunk x)
607 665c255d 2023-08-04 jrmu ;; z = procedure object
608 665c255d 2023-08-04 jrmu ;; m = (thunk (lambda (p q) p))
610 665c255d 2023-08-04 jrmu ;; m = (procedure (p q) (p) env)
611 665c255d 2023-08-04 jrmu ;; p = (thunk x)
612 665c255d 2023-08-04 jrmu ;; q = (thunk y)
613 665c255d 2023-08-04 jrmu ;; (thunk x)
614 665c255d 2023-08-04 jrmu ;; (thunk 3)
617 665c255d 2023-08-04 jrmu (define (cons x y)
618 665c255d 2023-08-04 jrmu (lambda (m) (m x y)))
619 665c255d 2023-08-04 jrmu (define (car z)
620 665c255d 2023-08-04 jrmu (z (lambda (p q) p)))
621 665c255d 2023-08-04 jrmu (define (cdr z)
622 665c255d 2023-08-04 jrmu (z (lambda (p q) q)))
623 665c255d 2023-08-04 jrmu (define a (cons 8 2))
625 665c255d 2023-08-04 jrmu ;; x = (thunk 8)
626 665c255d 2023-08-04 jrmu ;; y = (thunk 2)
627 665c255d 2023-08-04 jrmu ;; a = (procedure (m) ((m x y)) <env>)
631 665c255d 2023-08-04 jrmu ;; z = (thunk a)
632 665c255d 2023-08-04 jrmu ;; (z (lambda (p q) q))
633 665c255d 2023-08-04 jrmu ;; z = (procedure (m) ((m x y)) <env>)
634 665c255d 2023-08-04 jrmu ;; m = (thunk (lambda (p q) q))
636 665c255d 2023-08-04 jrmu ;; m = (procedure (p q) (q) <env>)
637 665c255d 2023-08-04 jrmu ;; p = (thunk x)
638 665c255d 2023-08-04 jrmu ;; q = (thunk y)
639 665c255d 2023-08-04 jrmu ;; (thunk y)
640 665c255d 2023-08-04 jrmu ;; (thunk 2)
647 665c255d 2023-08-04 jrmu ;; test-suite
649 665c255d 2023-08-04 jrmu ;; procedure definitions
652 665c255d 2023-08-04 jrmu '(define (assoc key records)
653 665c255d 2023-08-04 jrmu (cond ((null? records) false)
654 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
655 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
658 665c255d 2023-08-04 jrmu '(define (map proc list)
659 665c255d 2023-08-04 jrmu (if (null? list)
661 665c255d 2023-08-04 jrmu (cons (proc (car list))
662 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
665 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
666 665c255d 2023-08-04 jrmu (if (null? sequence)
668 665c255d 2023-08-04 jrmu (op (car sequence)
669 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
671 665c255d 2023-08-04 jrmu ;; all special forms
672 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
673 665c255d 2023-08-04 jrmu (test-eval '10 10)
674 665c255d 2023-08-04 jrmu (geval '(define x 3))
675 665c255d 2023-08-04 jrmu (test-eval 'x 3)
676 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
677 665c255d 2023-08-04 jrmu (test-eval 'x -25)
678 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
679 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
680 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
681 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
682 665c255d 2023-08-04 jrmu (else 'failed))
684 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
687 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
688 665c255d 2023-08-04 jrmu (+ x y (* x y)))
689 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
693 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
694 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
695 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
696 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
697 665c255d 2023-08-04 jrmu (test-eval 'x -2)
698 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
699 665c255d 2023-08-04 jrmu (test-eval 'x -2)
700 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
701 665c255d 2023-08-04 jrmu (test-eval 'x 25)
702 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
703 665c255d 2023-08-04 jrmu (test-eval 'x 2)
704 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
705 665c255d 2023-08-04 jrmu (test-eval 'x 25)
706 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
707 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
713 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
714 665c255d 2023-08-04 jrmu (else false))
718 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
719 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
720 665c255d 2023-08-04 jrmu ((map (lambda (x)
721 665c255d 2023-08-04 jrmu (* x (+ x 1)))
722 665c255d 2023-08-04 jrmu '(2 4 1 9))
724 665c255d 2023-08-04 jrmu (lambda (x)
725 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
726 665c255d 2023-08-04 jrmu (else 'never-reach))
728 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
731 665c255d 2023-08-04 jrmu ;; procedure definition and application
733 665c255d 2023-08-04 jrmu '(define (factorial n)
734 665c255d 2023-08-04 jrmu (if (= n 0)
736 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
737 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
742 665c255d 2023-08-04 jrmu '(map (lambda (x)
743 665c255d 2023-08-04 jrmu (* x (+ x 1)))
744 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
745 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
746 665c255d 2023-08-04 jrmu ;; accumulate
749 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
752 665c255d 2023-08-04 jrmu ;; make-let
754 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
761 665c255d 2023-08-04 jrmu '(let ((x 3))
765 665c255d 2023-08-04 jrmu '(let ((x 3)
770 665c255d 2023-08-04 jrmu '(let ((x 3)
772 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
776 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
778 665c255d 2023-08-04 jrmu '(let ((x 6)
779 665c255d 2023-08-04 jrmu (y (let ((x 2))
781 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
790 665c255d 2023-08-04 jrmu '(let* ((x 3)
791 665c255d 2023-08-04 jrmu (y (+ x 2))
792 665c255d 2023-08-04 jrmu (z (+ x y 5)))
801 665c255d 2023-08-04 jrmu '(let* ((x 3))
802 665c255d 2023-08-04 jrmu (let* ((y 5))
807 665c255d 2023-08-04 jrmu '(let* ((x 3)
808 665c255d 2023-08-04 jrmu (y (+ x 1)))
809 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
813 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
815 665c255d 2023-08-04 jrmu '(let* ((x 6)
816 665c255d 2023-08-04 jrmu (y (let* ((x 2)
817 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
820 665c255d 2023-08-04 jrmu (z (+ x y)))
824 665c255d 2023-08-04 jrmu ;; named-let
827 665c255d 2023-08-04 jrmu '(let eight ()
833 665c255d 2023-08-04 jrmu '(let loop ((count 0))
834 665c255d 2023-08-04 jrmu (if (= 100 count)
836 665c255d 2023-08-04 jrmu (loop (+ count 1))))
839 665c255d 2023-08-04 jrmu '(define (prime? x)
840 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
841 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
842 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
843 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
845 665c255d 2023-08-04 jrmu '(let primes ((x 2)
847 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
848 665c255d 2023-08-04 jrmu ((prime? x)
850 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
851 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
852 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))
855 665c255d 2023-08-04 jrmu '(define (fib n)
856 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
859 665c255d 2023-08-04 jrmu (if (= count 0)
861 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
862 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
866 665c255d 2023-08-04 jrmu '(let ((y 0))
867 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
868 665c255d 2023-08-04 jrmu ((= x 5) y)
869 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
880 665c255d 2023-08-04 jrmu '(let ((y 0))
882 665c255d 2023-08-04 jrmu ((= y 5) y)
883 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
887 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
888 665c255d 2023-08-04 jrmu ((null? y))
889 665c255d 2023-08-04 jrmu (set! y (cdr y)))
892 665c255d 2023-08-04 jrmu '(let ((y 0))
893 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
894 665c255d 2023-08-04 jrmu ((= x 5) y)
895 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
898 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
899 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
900 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
901 665c255d 2023-08-04 jrmu ((null? x) sum)))
904 665c255d 2023-08-04 jrmu '(let ((z '()))
905 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
906 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
907 665c255d 2023-08-04 jrmu ((null? x) y x z)
908 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
909 665c255d 2023-08-04 jrmu '(4 3 2 1))
913 665c255d 2023-08-04 jrmu ;; make-unbound!
914 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
916 665c255d 2023-08-04 jrmu ;; (test-eval
917 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
918 665c255d 2023-08-04 jrmu ;; (let ((x 5))
919 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
920 665c255d 2023-08-04 jrmu ;; (* x x)))
923 665c255d 2023-08-04 jrmu ;; (test-eval
924 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
925 665c255d 2023-08-04 jrmu ;; (let ((x 5))
926 665c255d 2023-08-04 jrmu ;; (define y x)
927 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
928 665c255d 2023-08-04 jrmu ;; (* y x)))
931 665c255d 2023-08-04 jrmu ;; (test-eval
932 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
933 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
934 665c255d 2023-08-04 jrmu ;; (define a x)
935 665c255d 2023-08-04 jrmu ;; (define b y)
936 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
937 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
938 665c255d 2023-08-04 jrmu ;; (* a b x y)))
939 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
941 665c255d 2023-08-04 jrmu ;; (test-eval
942 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
943 665c255d 2023-08-04 jrmu ;; (let ((x 5))
944 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
945 665c255d 2023-08-04 jrmu ;; (+ x 4)))
948 665c255d 2023-08-04 jrmu ;; (test-eval
949 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
950 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
951 665c255d 2023-08-04 jrmu ;; (+ a c d))
952 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
954 665c255d 2023-08-04 jrmu ;; (test-eval
955 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
956 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
957 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
958 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
959 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
960 665c255d 2023-08-04 jrmu ;; (define z b)
961 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
962 665c255d 2023-08-04 jrmu ;; (* (+ a z)
963 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
964 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
965 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
967 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
968 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
969 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
970 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
972 665c255d 2023-08-04 jrmu ;; scan-out-defines
975 665c255d 2023-08-04 jrmu '(define (f x)
976 665c255d 2023-08-04 jrmu (define (even? n)
977 665c255d 2023-08-04 jrmu (if (= n 0)
979 665c255d 2023-08-04 jrmu (odd? (- n 1))))
980 665c255d 2023-08-04 jrmu (define (odd? n)
981 665c255d 2023-08-04 jrmu (if (= n 0)
983 665c255d 2023-08-04 jrmu (even? (- n 1))))
984 665c255d 2023-08-04 jrmu (even? x)))
985 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
986 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
989 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
990 665c255d 2023-08-04 jrmu ;; (define y x)
991 665c255d 2023-08-04 jrmu ;; (define x 3)
992 665c255d 2023-08-04 jrmu ;; (+ x y)))
993 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
998 665c255d 2023-08-04 jrmu '(define (f x)
999 665c255d 2023-08-04 jrmu (letrec ((even?
1000 665c255d 2023-08-04 jrmu (lambda (n)
1001 665c255d 2023-08-04 jrmu (if (= n 0)
1003 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
1005 665c255d 2023-08-04 jrmu (lambda (n)
1006 665c255d 2023-08-04 jrmu (if (= n 0)
1008 665c255d 2023-08-04 jrmu (even? (- n 1))))))
1009 665c255d 2023-08-04 jrmu (even? x))))
1010 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
1011 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
1013 665c255d 2023-08-04 jrmu (test-eval
1014 665c255d 2023-08-04 jrmu '(letrec ((fact
1015 665c255d 2023-08-04 jrmu (lambda (n)
1016 665c255d 2023-08-04 jrmu (if (= n 1)
1018 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
1019 665c255d 2023-08-04 jrmu (fact 10))
1023 665c255d 2023-08-04 jrmu ;; delayed-evaluation
1026 665c255d 2023-08-04 jrmu '(define (try a b)
1027 665c255d 2023-08-04 jrmu (if (= a 0) 1 b)))
1028 665c255d 2023-08-04 jrmu (test-eval '(try 0 (/ 1 0)) 1)
1031 665c255d 2023-08-04 jrmu '(define (unless condition usual-value exceptional-value)
1032 665c255d 2023-08-04 jrmu (if condition exceptional-value usual-value)))
1033 665c255d 2023-08-04 jrmu (test-eval
1034 665c255d 2023-08-04 jrmu '(let ((a 4) (b 0))
1035 665c255d 2023-08-04 jrmu (unless (= b 0)
1037 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1040 665c255d 2023-08-04 jrmu (test-eval
1041 665c255d 2023-08-04 jrmu '(let ((a 4) (b 2))
1042 665c255d 2023-08-04 jrmu (unless (= b 0)
1044 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1049 665c255d 2023-08-04 jrmu '(define (factorial n)
1050 665c255d 2023-08-04 jrmu (unless (= n 1)
1051 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))
1053 665c255d 2023-08-04 jrmu (test-eval
1054 665c255d 2023-08-04 jrmu '(factorial 8)
1057 665c255d 2023-08-04 jrmu (geval '(define count 0))
1058 665c255d 2023-08-04 jrmu (geval '(define (id x)
1059 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1062 665c255d 2023-08-04 jrmu (geval '(define w (id (id 10))))
1063 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1064 665c255d 2023-08-04 jrmu (test-eval 'w 10)
1065 665c255d 2023-08-04 jrmu (test-eval 'count 2)
1066 665c255d 2023-08-04 jrmu (test-eval
1067 665c255d 2023-08-04 jrmu '(let ((f (lambda (x) (+ x 1))))
1070 665c255d 2023-08-04 jrmu (geval '(define count 0))
1071 665c255d 2023-08-04 jrmu (geval '(define (id x)
1072 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1075 665c255d 2023-08-04 jrmu '(define (square x)
1077 665c255d 2023-08-04 jrmu (test-eval
1078 665c255d 2023-08-04 jrmu '(square (id 10))
1080 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1081 665c255d 2023-08-04 jrmu ;; would be 2 without memoization
