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 ((quoted-pair? exp) (eval (quoted-pair->cons (text-of-quotation exp)) env))
8 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
9 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition exp env))
10 665c255d 2023-08-04 jrmu ;; ((unbound? exp) (eval-unbound exp env))
11 665c255d 2023-08-04 jrmu ((if? exp) (eval-if exp env))
12 665c255d 2023-08-04 jrmu ((and? exp) (eval-and exp env))
13 665c255d 2023-08-04 jrmu ((or? exp) (eval-or exp env))
14 665c255d 2023-08-04 jrmu ((lambda? exp)
15 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
16 665c255d 2023-08-04 jrmu (lambda-body exp)
18 665c255d 2023-08-04 jrmu ((begin? exp)
19 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
20 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
21 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
22 665c255d 2023-08-04 jrmu ((let*? exp) (eval (let*->nested-lets exp) env))
23 665c255d 2023-08-04 jrmu ((named-let? exp) (eval (named-let->combination exp) env))
24 665c255d 2023-08-04 jrmu ((letrec? exp) (eval (letrec->let exp) env))
25 665c255d 2023-08-04 jrmu ((do? exp) (eval (do->combination exp) env))
26 665c255d 2023-08-04 jrmu ((application? exp)
27 665c255d 2023-08-04 jrmu (apply (actual-value (operator exp) env)
28 665c255d 2023-08-04 jrmu (operands exp)
31 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
32 665c255d 2023-08-04 jrmu (define (apply procedure arguments env)
33 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
34 665c255d 2023-08-04 jrmu (apply-primitive-procedure
36 665c255d 2023-08-04 jrmu (list-of-arg-values arguments env)))
37 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
38 665c255d 2023-08-04 jrmu (eval-sequence
39 665c255d 2023-08-04 jrmu (procedure-body procedure)
40 665c255d 2023-08-04 jrmu (extend-environment
41 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
42 665c255d 2023-08-04 jrmu (list-of-delayed-args arguments env)
43 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
46 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
48 665c255d 2023-08-04 jrmu (define (thunk? obj)
49 665c255d 2023-08-04 jrmu (tagged-list? obj 'thunk))
50 665c255d 2023-08-04 jrmu (define (thunk-exp thunk)
51 665c255d 2023-08-04 jrmu (cadr thunk))
52 665c255d 2023-08-04 jrmu (define (thunk-env thunk)
53 665c255d 2023-08-04 jrmu (caddr thunk))
54 665c255d 2023-08-04 jrmu (define (evaluated-thunk? obj)
55 665c255d 2023-08-04 jrmu (tagged-list? obj 'evaluated-thunk))
56 665c255d 2023-08-04 jrmu (define (thunk-value evaluated-thunk)
57 665c255d 2023-08-04 jrmu (cadr evaluated-thunk))
58 665c255d 2023-08-04 jrmu (define (delay-it exp env)
59 665c255d 2023-08-04 jrmu `(thunk ,exp ,env))
60 665c255d 2023-08-04 jrmu (define (actual-value exp env)
61 665c255d 2023-08-04 jrmu (force-it (eval exp env)))
62 665c255d 2023-08-04 jrmu (define (force-it obj)
63 665c255d 2023-08-04 jrmu (cond ((thunk? obj)
64 665c255d 2023-08-04 jrmu (let ((result (actual-value
65 665c255d 2023-08-04 jrmu (thunk-exp obj)
66 665c255d 2023-08-04 jrmu (thunk-env obj))))
67 665c255d 2023-08-04 jrmu (set-car! obj 'evaluated-thunk)
68 665c255d 2023-08-04 jrmu (set-car! (cdr obj) result)
69 665c255d 2023-08-04 jrmu (set-cdr! (cdr obj) '())
71 665c255d 2023-08-04 jrmu ((evaluated-thunk? obj)
72 665c255d 2023-08-04 jrmu (thunk-value obj))
73 665c255d 2023-08-04 jrmu (else obj)))
75 665c255d 2023-08-04 jrmu (define (list-of-arg-values exps env)
76 665c255d 2023-08-04 jrmu (if (no-operands? exps)
78 665c255d 2023-08-04 jrmu (cons (actual-value (first-operand exps) env)
79 665c255d 2023-08-04 jrmu (list-of-arg-values (rest-operands exps) env))))
80 665c255d 2023-08-04 jrmu (define (list-of-delayed-args exps env)
81 665c255d 2023-08-04 jrmu (if (no-operands? exps)
83 665c255d 2023-08-04 jrmu (cons (delay-it (first-operand exps) env)
84 665c255d 2023-08-04 jrmu (list-of-delayed-args (rest-operands exps) env))))
86 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
87 665c255d 2023-08-04 jrmu (if (pair? exp)
88 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
91 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
92 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
93 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
94 665c255d 2023-08-04 jrmu ((string? exp) true)
95 665c255d 2023-08-04 jrmu (else false)))
96 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
97 665c255d 2023-08-04 jrmu (define (quoted? exp)
98 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'quote)
99 665c255d 2023-08-04 jrmu (not (pair? (cadr exp)))))
100 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
102 665c255d 2023-08-04 jrmu ;; assignment/definition
103 665c255d 2023-08-04 jrmu (define (assignment? exp)
104 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
105 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
106 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
107 665c255d 2023-08-04 jrmu (define (make-assignment var val)
108 665c255d 2023-08-04 jrmu (list 'set! var val))
109 665c255d 2023-08-04 jrmu (define (definition? exp)
110 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
111 665c255d 2023-08-04 jrmu (define (definition-variable exp)
112 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
114 665c255d 2023-08-04 jrmu (caadr exp)))
115 665c255d 2023-08-04 jrmu (define (definition-value exp)
116 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
117 665c255d 2023-08-04 jrmu (caddr exp)
118 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
119 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
120 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
121 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
122 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
125 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
126 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
127 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
130 665c255d 2023-08-04 jrmu (define (make-definition var val)
131 665c255d 2023-08-04 jrmu `(define ,var ,val))
133 665c255d 2023-08-04 jrmu ;; make-unbound!
135 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
136 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
137 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
138 665c255d 2023-08-04 jrmu ;; (cadr exp))
139 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
140 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
144 665c255d 2023-08-04 jrmu ;; if/and/or
145 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
146 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
147 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
148 665c255d 2023-08-04 jrmu (define (if-alternative exp)
149 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
150 665c255d 2023-08-04 jrmu (cadddr exp)
152 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
153 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
154 665c255d 2023-08-04 jrmu (define (eval-if exp env)
155 665c255d 2023-08-04 jrmu (if (true? (actual-value (if-predicate exp) env))
156 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
157 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
159 665c255d 2023-08-04 jrmu (define (and? exp)
160 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
161 665c255d 2023-08-04 jrmu (define (and-clauses exp)
163 665c255d 2023-08-04 jrmu (define (or? exp)
164 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
165 665c255d 2023-08-04 jrmu (define (or-clauses exp)
167 665c255d 2023-08-04 jrmu (define (eval-and exp env)
168 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
169 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
170 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
171 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
172 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
173 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
174 665c255d 2023-08-04 jrmu (define (eval-or exp env)
175 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
176 665c255d 2023-08-04 jrmu (if (null? clauses)
178 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
179 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
180 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
183 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
184 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
185 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
186 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
187 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
188 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
190 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
192 665c255d 2023-08-04 jrmu (cons (map list vars vals)
194 665c255d 2023-08-04 jrmu (define (let? exp)
195 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
196 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
197 665c255d 2023-08-04 jrmu (define (let-vars exp)
198 665c255d 2023-08-04 jrmu (map car (cadr exp)))
199 665c255d 2023-08-04 jrmu (define (let-vals exp)
200 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
201 665c255d 2023-08-04 jrmu (define (let-body exp)
202 665c255d 2023-08-04 jrmu (cddr exp))
203 665c255d 2023-08-04 jrmu (define (let->combination exp)
204 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
205 665c255d 2023-08-04 jrmu (let-vals exp)))
206 665c255d 2023-08-04 jrmu (define (named-let? exp)
207 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
208 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
209 665c255d 2023-08-04 jrmu (define (named-let-name exp)
210 665c255d 2023-08-04 jrmu (cadr exp))
211 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
212 665c255d 2023-08-04 jrmu (map car (caddr exp)))
213 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
214 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
215 665c255d 2023-08-04 jrmu (define (named-let-body exp)
216 665c255d 2023-08-04 jrmu (cdddr exp))
217 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
218 665c255d 2023-08-04 jrmu (sequence->exp
219 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
220 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
221 665c255d 2023-08-04 jrmu (named-let-body exp)))
222 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
223 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
224 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
227 665c255d 2023-08-04 jrmu (cons (map list vars vals)
230 665c255d 2023-08-04 jrmu (define (letrec? exp)
231 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
233 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
234 665c255d 2023-08-04 jrmu (map car (cadr exp)))
235 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
236 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
237 665c255d 2023-08-04 jrmu (define (letrec-body exp)
238 665c255d 2023-08-04 jrmu (cddr exp))
239 665c255d 2023-08-04 jrmu (define (letrec->let exp)
240 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
241 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
243 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
244 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
245 665c255d 2023-08-04 jrmu (make-assignment var val))
248 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
249 665c255d 2023-08-04 jrmu (make-let vars
250 665c255d 2023-08-04 jrmu unassigneds
251 665c255d 2023-08-04 jrmu (append assignments body))))
256 665c255d 2023-08-04 jrmu (define (let*? exp)
257 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
258 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
259 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
260 665c255d 2023-08-04 jrmu (define let*-body let-body)
261 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
262 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
263 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
264 665c255d 2023-08-04 jrmu (make-let (list (car vars))
265 665c255d 2023-08-04 jrmu (list (car vals))
266 665c255d 2023-08-04 jrmu (let*-body exp))
267 665c255d 2023-08-04 jrmu (make-let (list (car vars))
268 665c255d 2023-08-04 jrmu (list (car vals))
269 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
270 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
271 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
272 665c255d 2023-08-04 jrmu (if (null? vars)
273 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
274 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
277 665c255d 2023-08-04 jrmu (define (do? exp)
278 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
279 665c255d 2023-08-04 jrmu (define (do-vars exp)
280 665c255d 2023-08-04 jrmu (map car (cadr exp)))
281 665c255d 2023-08-04 jrmu (define (do-inits exp)
282 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
283 665c255d 2023-08-04 jrmu (define (do-steps exp)
284 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
285 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
286 665c255d 2023-08-04 jrmu (car var-init-step)
287 665c255d 2023-08-04 jrmu (caddr var-init-step)))
288 665c255d 2023-08-04 jrmu (cadr exp)))
289 665c255d 2023-08-04 jrmu (define (do-test exp)
290 665c255d 2023-08-04 jrmu (caaddr exp))
291 665c255d 2023-08-04 jrmu (define (do-expressions exp)
292 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
293 665c255d 2023-08-04 jrmu (caddr exp)
294 665c255d 2023-08-04 jrmu (cdaddr exp)))
295 665c255d 2023-08-04 jrmu (define (do-commands exp)
296 665c255d 2023-08-04 jrmu (cdddr exp))
297 665c255d 2023-08-04 jrmu (define (do->combination exp)
298 665c255d 2023-08-04 jrmu (make-named-let
300 665c255d 2023-08-04 jrmu (do-vars exp)
301 665c255d 2023-08-04 jrmu (do-inits exp)
304 665c255d 2023-08-04 jrmu (do-test exp)
305 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
306 665c255d 2023-08-04 jrmu (sequence->exp
307 665c255d 2023-08-04 jrmu (append (do-commands exp)
308 665c255d 2023-08-04 jrmu (list (make-application
310 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
313 665c255d 2023-08-04 jrmu ;; begin/sequence
314 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
315 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
316 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
317 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
318 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
319 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
320 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
321 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
322 665c255d 2023-08-04 jrmu (else (make-begin seq))))
323 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
324 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
325 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
326 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
327 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
329 665c255d 2023-08-04 jrmu ;; application
330 665c255d 2023-08-04 jrmu (define (make-application op args)
331 665c255d 2023-08-04 jrmu (cons op args))
332 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
333 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
334 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
335 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
336 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
337 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
340 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
341 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
342 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
343 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
344 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
345 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
346 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
347 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
348 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
349 665c255d 2023-08-04 jrmu (caddr clause))
350 665c255d 2023-08-04 jrmu (define (cond->if exp)
351 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
352 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
353 665c255d 2023-08-04 jrmu (if (null? clauses)
354 665c255d 2023-08-04 jrmu 'false ; no else clause
355 665c255d 2023-08-04 jrmu (let ((first (car clauses))
356 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
357 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
358 665c255d 2023-08-04 jrmu (if (null? rest)
359 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
360 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
362 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
363 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
364 665c255d 2023-08-04 jrmu (make-application
365 665c255d 2023-08-04 jrmu (cond-extended-proc first)
366 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
367 665c255d 2023-08-04 jrmu (expand-clauses rest))
368 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
369 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
370 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
371 665c255d 2023-08-04 jrmu (define (true? x)
372 665c255d 2023-08-04 jrmu (not (eq? x false)))
373 665c255d 2023-08-04 jrmu (define (false? x)
374 665c255d 2023-08-04 jrmu (eq? x false))
376 665c255d 2023-08-04 jrmu ;; procedure
377 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
378 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
379 665c255d 2023-08-04 jrmu ;; (define (scan-out-defines body)
380 665c255d 2023-08-04 jrmu ;; (let* ((definitions (filter definition? body))
381 665c255d 2023-08-04 jrmu ;; (vars (map definition-variable definitions))
382 665c255d 2023-08-04 jrmu ;; (unassigneds (map (lambda (var) ''*unassigned*)
384 665c255d 2023-08-04 jrmu ;; (vals (map definition-value definitions))
385 665c255d 2023-08-04 jrmu ;; (assignments
386 665c255d 2023-08-04 jrmu ;; (map (lambda (var val)
387 665c255d 2023-08-04 jrmu ;; (make-assignment var val))
388 665c255d 2023-08-04 jrmu ;; vars vals))
389 665c255d 2023-08-04 jrmu ;; (exps (remove definition? body)))
390 665c255d 2023-08-04 jrmu ;; (if (null? definitions)
393 665c255d 2023-08-04 jrmu ;; (make-let vars
394 665c255d 2023-08-04 jrmu ;; unassigneds
395 665c255d 2023-08-04 jrmu ;; (append assignments exps))))))
396 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
397 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
398 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
399 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
400 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
402 665c255d 2023-08-04 jrmu ;; environment
403 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
404 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
405 665c255d 2023-08-04 jrmu (define the-empty-environment '())
406 665c255d 2023-08-04 jrmu (define (make-frame variables values)
407 665c255d 2023-08-04 jrmu (cons variables values))
408 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
409 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
410 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
411 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
412 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
413 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
414 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
415 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
416 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
417 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
418 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
419 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
420 665c255d 2023-08-04 jrmu (define (env-loop env)
421 665c255d 2023-08-04 jrmu (define (scan vars vals)
422 665c255d 2023-08-04 jrmu (cond ((null? vars)
423 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
424 665c255d 2023-08-04 jrmu ((eq? var (car vars))
425 665c255d 2023-08-04 jrmu (let ((val (car vals)))
426 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
427 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
429 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
430 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
431 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
432 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
433 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
434 665c255d 2023-08-04 jrmu (frame-values frame)))))
435 665c255d 2023-08-04 jrmu (env-loop env))
436 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
437 665c255d 2023-08-04 jrmu (define (env-loop env)
438 665c255d 2023-08-04 jrmu (define (scan vars vals)
439 665c255d 2023-08-04 jrmu (cond ((null? vars)
440 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
441 665c255d 2023-08-04 jrmu ((eq? var (car vars))
442 665c255d 2023-08-04 jrmu (set-car! vals val))
443 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
444 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
445 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
446 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
447 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
448 665c255d 2023-08-04 jrmu (frame-values frame)))))
449 665c255d 2023-08-04 jrmu (env-loop env))
450 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
451 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
452 665c255d 2023-08-04 jrmu (define (scan vars vals)
453 665c255d 2023-08-04 jrmu (cond ((null? vars)
454 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
455 665c255d 2023-08-04 jrmu ((eq? var (car vars))
456 665c255d 2023-08-04 jrmu (set-car! vals val))
457 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
458 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
459 665c255d 2023-08-04 jrmu (frame-values frame))))
461 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
462 665c255d 2023-08-04 jrmu (define (scan vars vals)
463 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
464 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
465 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
466 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
467 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
468 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
469 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
470 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
471 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
472 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
473 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
474 665c255d 2023-08-04 jrmu (scan vars vals))))
476 665c255d 2023-08-04 jrmu ;; primitives
477 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
478 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
479 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
480 665c255d 2023-08-04 jrmu (define primitive-procedures
481 665c255d 2023-08-04 jrmu (list (list 'car car)
482 665c255d 2023-08-04 jrmu (list 'cdr cdr)
483 665c255d 2023-08-04 jrmu (list 'caar caar)
484 665c255d 2023-08-04 jrmu (list 'cadr cadr)
485 665c255d 2023-08-04 jrmu (list 'cddr cddr)
486 665c255d 2023-08-04 jrmu (list 'cons cons)
487 665c255d 2023-08-04 jrmu (list 'null? null?)
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 '<= <=)
496 665c255d 2023-08-04 jrmu (list '>= >=)
497 665c255d 2023-08-04 jrmu (list 'remainder remainder)
498 665c255d 2023-08-04 jrmu (list 'eq? eq?)
499 665c255d 2023-08-04 jrmu (list 'equal? equal?)
500 665c255d 2023-08-04 jrmu (list 'display display)))
501 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
503 665c255d 2023-08-04 jrmu primitive-procedures))
504 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
505 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
506 665c255d 2023-08-04 jrmu primitive-procedures))
507 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
508 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
509 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
511 665c255d 2023-08-04 jrmu ;; driver-loop
512 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
513 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
514 665c255d 2023-08-04 jrmu (define (driver-loop)
515 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
516 665c255d 2023-08-04 jrmu (let ((input (read)))
517 665c255d 2023-08-04 jrmu (let ((output (actual-value input the-global-environment)))
518 665c255d 2023-08-04 jrmu (announce-output output-prompt)
519 665c255d 2023-08-04 jrmu (user-print output)))
520 665c255d 2023-08-04 jrmu (driver-loop))
521 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
522 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
524 665c255d 2023-08-04 jrmu (define (announce-output string)
525 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
526 665c255d 2023-08-04 jrmu (define (user-print object)
527 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
528 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
529 665c255d 2023-08-04 jrmu (procedure-parameters object)
530 665c255d 2023-08-04 jrmu (procedure-body object)
531 665c255d 2023-08-04 jrmu '<procedure-env>))
532 665c255d 2023-08-04 jrmu (display object)))
533 665c255d 2023-08-04 jrmu (define (setup-environment)
534 665c255d 2023-08-04 jrmu (let ((initial-env
535 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
536 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
537 665c255d 2023-08-04 jrmu the-empty-environment)))
538 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
539 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
540 665c255d 2023-08-04 jrmu initial-env))
541 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
543 665c255d 2023-08-04 jrmu ;; auxiliary
544 665c255d 2023-08-04 jrmu (define (test-case actual expected)
546 665c255d 2023-08-04 jrmu (display "Actual: ")
547 665c255d 2023-08-04 jrmu (display actual)
549 665c255d 2023-08-04 jrmu (display "Expected: ")
550 665c255d 2023-08-04 jrmu (display expected)
552 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
553 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
554 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
555 665c255d 2023-08-04 jrmu (test-case (force-it (geval exp)) expected))
557 665c255d 2023-08-04 jrmu ;; Exercise 4.33. Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
559 665c255d 2023-08-04 jrmu (define (quoted-pair? exp)
560 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'quote)
561 665c255d 2023-08-04 jrmu (pair? (cadr exp))))
563 665c255d 2023-08-04 jrmu (define (quoted-pair->cons exp)
564 665c255d 2023-08-04 jrmu (if (pair? exp)
565 665c255d 2023-08-04 jrmu (make-cons (quoted-pair->cons (car exp))
566 665c255d 2023-08-04 jrmu (quoted-pair->cons (cdr exp)))
567 665c255d 2023-08-04 jrmu (make-quote exp)))
568 665c255d 2023-08-04 jrmu (define (make-quote exp)
569 665c255d 2023-08-04 jrmu `(quote ,exp))
570 665c255d 2023-08-04 jrmu (define (make-cons x y)
571 665c255d 2023-08-04 jrmu `(cons ,x ,y))
574 665c255d 2023-08-04 jrmu (quoted-pair->cons '(a))
575 665c255d 2023-08-04 jrmu '(cons 'a '()))
577 665c255d 2023-08-04 jrmu (quoted-pair->cons '(a b c))
578 665c255d 2023-08-04 jrmu '(cons 'a (cons 'b (cons 'c '()))))
580 665c255d 2023-08-04 jrmu (quoted-pair->cons
581 665c255d 2023-08-04 jrmu '((a b) c))
582 665c255d 2023-08-04 jrmu '(cons (cons 'a (cons 'b '())) (cons 'c '())))
584 665c255d 2023-08-04 jrmu (quoted-pair->cons
585 665c255d 2023-08-04 jrmu '((a c) (b d)))
586 665c255d 2023-08-04 jrmu '(cons (cons 'a (cons 'c '()))
587 665c255d 2023-08-04 jrmu (cons (cons 'b (cons 'd '())) '())))
589 665c255d 2023-08-04 jrmu (quoted-pair->cons
590 665c255d 2023-08-04 jrmu '(((a b) (c d (e)) f) g))
591 665c255d 2023-08-04 jrmu '(cons (cons (cons 'a (cons 'b '()))
592 665c255d 2023-08-04 jrmu (cons (cons 'c (cons 'd (cons (cons 'e '())
594 665c255d 2023-08-04 jrmu (cons 'f '())))
595 665c255d 2023-08-04 jrmu (cons 'g '())))
598 665c255d 2023-08-04 jrmu ;; (car '(a b c))
600 665c255d 2023-08-04 jrmu ;; if we have a quoted list, we need to transform it into the proper cons
602 665c255d 2023-08-04 jrmu ;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists.
604 665c255d 2023-08-04 jrmu ;; (quote (a))
606 665c255d 2023-08-04 jrmu '(car (cons (quote a) (quote ())))
609 665c255d 2023-08-04 jrmu '(cdr (cons (quote a) (quote ())))
612 665c255d 2023-08-04 jrmu '(car '(a))
615 665c255d 2023-08-04 jrmu '(cdr '(a))
618 665c255d 2023-08-04 jrmu '(car (cdr '(a b)))
621 665c255d 2023-08-04 jrmu '(car (car '((a b) c)))
624 665c255d 2023-08-04 jrmu '(car (cdr (car (cdr '((a c) (b d))))))
629 665c255d 2023-08-04 jrmu ;; cons/car/cdr
632 665c255d 2023-08-04 jrmu '(define (cons x y)
633 665c255d 2023-08-04 jrmu (lambda (m) (m x y))))
635 665c255d 2023-08-04 jrmu '(define (car z)
636 665c255d 2023-08-04 jrmu (z (lambda (p q) p))))
638 665c255d 2023-08-04 jrmu '(define (cdr z)
639 665c255d 2023-08-04 jrmu (z (lambda (p q) q))))
641 665c255d 2023-08-04 jrmu '(define (list-ref items n)
642 665c255d 2023-08-04 jrmu (if (= n 0)
643 665c255d 2023-08-04 jrmu (car items)
644 665c255d 2023-08-04 jrmu (list-ref (cdr items) (- n 1)))))
646 665c255d 2023-08-04 jrmu '(define (map proc items)
647 665c255d 2023-08-04 jrmu (if (null? items)
649 665c255d 2023-08-04 jrmu (cons (proc (car items))
650 665c255d 2023-08-04 jrmu (map proc (cdr items))))))
652 665c255d 2023-08-04 jrmu '(define (scale-list items factor)
653 665c255d 2023-08-04 jrmu (map (lambda (x) (* x factor))
656 665c255d 2023-08-04 jrmu '(define (add-lists list1 list2)
657 665c255d 2023-08-04 jrmu (cond ((null? list1) list2)
658 665c255d 2023-08-04 jrmu ((null? list2) list1)
659 665c255d 2023-08-04 jrmu (else (cons (+ (car list1) (car list2))
660 665c255d 2023-08-04 jrmu (add-lists (cdr list1) (cdr list2)))))))
665 665c255d 2023-08-04 jrmu '(define ones (cons 1 ones)))
667 665c255d 2023-08-04 jrmu '(define integers (cons 1 (add-lists ones integers))))
669 665c255d 2023-08-04 jrmu '(list-ref integers 17)
673 665c255d 2023-08-04 jrmu '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
677 665c255d 2023-08-04 jrmu '(define (integral integrand initial-value dt)
678 665c255d 2023-08-04 jrmu (define int
679 665c255d 2023-08-04 jrmu (cons initial-value
680 665c255d 2023-08-04 jrmu (add-lists (scale-list integrand dt)
684 665c255d 2023-08-04 jrmu '(define (solve f y0 dt)
685 665c255d 2023-08-04 jrmu (define y (integral dy y0 dt))
686 665c255d 2023-08-04 jrmu (define dy (map f y))
689 665c255d 2023-08-04 jrmu '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
693 665c255d 2023-08-04 jrmu ;; test-suite
695 665c255d 2023-08-04 jrmu ;; procedure definitions
698 665c255d 2023-08-04 jrmu '(define (assoc key records)
699 665c255d 2023-08-04 jrmu (cond ((null? records) false)
700 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
701 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
704 665c255d 2023-08-04 jrmu '(define (map proc list)
705 665c255d 2023-08-04 jrmu (if (null? list)
707 665c255d 2023-08-04 jrmu (cons (proc (car list))
708 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
711 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
712 665c255d 2023-08-04 jrmu (if (null? sequence)
714 665c255d 2023-08-04 jrmu (op (car sequence)
715 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
717 665c255d 2023-08-04 jrmu ;; all special forms
718 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
719 665c255d 2023-08-04 jrmu (test-eval '10 10)
720 665c255d 2023-08-04 jrmu (geval '(define x 3))
721 665c255d 2023-08-04 jrmu (test-eval 'x 3)
722 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
723 665c255d 2023-08-04 jrmu (test-eval 'x -25)
724 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
725 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
726 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
727 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
728 665c255d 2023-08-04 jrmu (else 'failed))
730 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
733 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
734 665c255d 2023-08-04 jrmu (+ x y (* x y)))
735 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
739 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
740 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
741 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
742 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
743 665c255d 2023-08-04 jrmu (test-eval 'x -2)
744 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
745 665c255d 2023-08-04 jrmu (test-eval 'x -2)
746 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
747 665c255d 2023-08-04 jrmu (test-eval 'x 25)
748 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
749 665c255d 2023-08-04 jrmu (test-eval 'x 2)
750 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
751 665c255d 2023-08-04 jrmu (test-eval 'x 25)
752 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
753 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
759 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
760 665c255d 2023-08-04 jrmu (else false))
764 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
765 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
766 665c255d 2023-08-04 jrmu ((map (lambda (x)
767 665c255d 2023-08-04 jrmu (* x (+ x 1)))
768 665c255d 2023-08-04 jrmu '(2 4 1 9))
770 665c255d 2023-08-04 jrmu (lambda (x)
771 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
772 665c255d 2023-08-04 jrmu (else 'never-reach))
774 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
777 665c255d 2023-08-04 jrmu ;; procedure definition and application
779 665c255d 2023-08-04 jrmu '(define (factorial n)
780 665c255d 2023-08-04 jrmu (if (= n 0)
782 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
783 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
788 665c255d 2023-08-04 jrmu '(map (lambda (x)
789 665c255d 2023-08-04 jrmu (* x (+ x 1)))
790 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
791 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
792 665c255d 2023-08-04 jrmu ;; accumulate
795 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
798 665c255d 2023-08-04 jrmu ;; make-let
800 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
807 665c255d 2023-08-04 jrmu '(let ((x 3))
811 665c255d 2023-08-04 jrmu '(let ((x 3)
816 665c255d 2023-08-04 jrmu '(let ((x 3)
818 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
822 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
824 665c255d 2023-08-04 jrmu '(let ((x 6)
825 665c255d 2023-08-04 jrmu (y (let ((x 2))
827 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
836 665c255d 2023-08-04 jrmu '(let* ((x 3)
837 665c255d 2023-08-04 jrmu (y (+ x 2))
838 665c255d 2023-08-04 jrmu (z (+ x y 5)))
847 665c255d 2023-08-04 jrmu '(let* ((x 3))
848 665c255d 2023-08-04 jrmu (let* ((y 5))
853 665c255d 2023-08-04 jrmu '(let* ((x 3)
854 665c255d 2023-08-04 jrmu (y (+ x 1)))
855 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
859 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
861 665c255d 2023-08-04 jrmu '(let* ((x 6)
862 665c255d 2023-08-04 jrmu (y (let* ((x 2)
863 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
866 665c255d 2023-08-04 jrmu (z (+ x y)))
870 665c255d 2023-08-04 jrmu ;; named-let
873 665c255d 2023-08-04 jrmu '(let eight ()
879 665c255d 2023-08-04 jrmu '(let loop ((count 0))
880 665c255d 2023-08-04 jrmu (if (= 100 count)
882 665c255d 2023-08-04 jrmu (loop (+ count 1))))
885 665c255d 2023-08-04 jrmu '(define (prime? x)
886 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
887 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
888 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
889 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
891 665c255d 2023-08-04 jrmu '(let primes ((x 2)
893 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
894 665c255d 2023-08-04 jrmu ((prime? x)
896 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
897 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
898 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))
901 665c255d 2023-08-04 jrmu '(define (fib n)
902 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
905 665c255d 2023-08-04 jrmu (if (= count 0)
907 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
908 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
912 665c255d 2023-08-04 jrmu '(let ((y 0))
913 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
914 665c255d 2023-08-04 jrmu ((= x 5) y)
915 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
926 665c255d 2023-08-04 jrmu '(let ((y 0))
928 665c255d 2023-08-04 jrmu ((= y 5) y)
929 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
933 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
934 665c255d 2023-08-04 jrmu ((null? y))
935 665c255d 2023-08-04 jrmu (set! y (cdr y)))
938 665c255d 2023-08-04 jrmu '(let ((y 0))
939 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
940 665c255d 2023-08-04 jrmu ((= x 5) y)
941 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
944 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
945 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
946 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
947 665c255d 2023-08-04 jrmu ((null? x) sum)))
950 665c255d 2023-08-04 jrmu '(let ((z '()))
951 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
952 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
953 665c255d 2023-08-04 jrmu ((null? x) y x z)
954 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
955 665c255d 2023-08-04 jrmu '(4 3 2 1))
959 665c255d 2023-08-04 jrmu ;; make-unbound!
960 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
962 665c255d 2023-08-04 jrmu ;; (test-eval
963 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
964 665c255d 2023-08-04 jrmu ;; (let ((x 5))
965 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
966 665c255d 2023-08-04 jrmu ;; (* x x)))
969 665c255d 2023-08-04 jrmu ;; (test-eval
970 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
971 665c255d 2023-08-04 jrmu ;; (let ((x 5))
972 665c255d 2023-08-04 jrmu ;; (define y x)
973 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
974 665c255d 2023-08-04 jrmu ;; (* y x)))
977 665c255d 2023-08-04 jrmu ;; (test-eval
978 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
979 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
980 665c255d 2023-08-04 jrmu ;; (define a x)
981 665c255d 2023-08-04 jrmu ;; (define b y)
982 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
983 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
984 665c255d 2023-08-04 jrmu ;; (* a b x y)))
985 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
987 665c255d 2023-08-04 jrmu ;; (test-eval
988 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
989 665c255d 2023-08-04 jrmu ;; (let ((x 5))
990 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
991 665c255d 2023-08-04 jrmu ;; (+ x 4)))
994 665c255d 2023-08-04 jrmu ;; (test-eval
995 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
996 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
997 665c255d 2023-08-04 jrmu ;; (+ a c d))
998 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
1000 665c255d 2023-08-04 jrmu ;; (test-eval
1001 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
1002 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
1003 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
1004 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
1005 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
1006 665c255d 2023-08-04 jrmu ;; (define z b)
1007 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
1008 665c255d 2023-08-04 jrmu ;; (* (+ a z)
1009 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
1010 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
1011 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
1013 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
1014 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
1015 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
1016 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
1018 665c255d 2023-08-04 jrmu ;; scan-out-defines
1021 665c255d 2023-08-04 jrmu '(define (f x)
1022 665c255d 2023-08-04 jrmu (define (even? n)
1023 665c255d 2023-08-04 jrmu (if (= n 0)
1025 665c255d 2023-08-04 jrmu (odd? (- n 1))))
1026 665c255d 2023-08-04 jrmu (define (odd? n)
1027 665c255d 2023-08-04 jrmu (if (= n 0)
1029 665c255d 2023-08-04 jrmu (even? (- n 1))))
1030 665c255d 2023-08-04 jrmu (even? x)))
1031 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
1032 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
1035 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
1036 665c255d 2023-08-04 jrmu ;; (define y x)
1037 665c255d 2023-08-04 jrmu ;; (define x 3)
1038 665c255d 2023-08-04 jrmu ;; (+ x y)))
1039 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
1044 665c255d 2023-08-04 jrmu '(define (f x)
1045 665c255d 2023-08-04 jrmu (letrec ((even?
1046 665c255d 2023-08-04 jrmu (lambda (n)
1047 665c255d 2023-08-04 jrmu (if (= n 0)
1049 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
1051 665c255d 2023-08-04 jrmu (lambda (n)
1052 665c255d 2023-08-04 jrmu (if (= n 0)
1054 665c255d 2023-08-04 jrmu (even? (- n 1))))))
1055 665c255d 2023-08-04 jrmu (even? x))))
1056 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
1057 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
1059 665c255d 2023-08-04 jrmu (test-eval
1060 665c255d 2023-08-04 jrmu '(letrec ((fact
1061 665c255d 2023-08-04 jrmu (lambda (n)
1062 665c255d 2023-08-04 jrmu (if (= n 1)
1064 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
1065 665c255d 2023-08-04 jrmu (fact 10))
1069 665c255d 2023-08-04 jrmu ;; delayed-evaluation
1072 665c255d 2023-08-04 jrmu '(define (try a b)
1073 665c255d 2023-08-04 jrmu (if (= a 0) 1 b)))
1074 665c255d 2023-08-04 jrmu (test-eval '(try 0 (/ 1 0)) 1)
1077 665c255d 2023-08-04 jrmu '(define (unless condition usual-value exceptional-value)
1078 665c255d 2023-08-04 jrmu (if condition exceptional-value usual-value)))
1079 665c255d 2023-08-04 jrmu (test-eval
1080 665c255d 2023-08-04 jrmu '(let ((a 4) (b 0))
1081 665c255d 2023-08-04 jrmu (unless (= b 0)
1083 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1086 665c255d 2023-08-04 jrmu (test-eval
1087 665c255d 2023-08-04 jrmu '(let ((a 4) (b 2))
1088 665c255d 2023-08-04 jrmu (unless (= b 0)
1090 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1095 665c255d 2023-08-04 jrmu '(define (factorial n)
1096 665c255d 2023-08-04 jrmu (unless (= n 1)
1097 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))
1099 665c255d 2023-08-04 jrmu (test-eval
1100 665c255d 2023-08-04 jrmu '(factorial 8)
1103 665c255d 2023-08-04 jrmu (geval '(define count 0))
1104 665c255d 2023-08-04 jrmu (geval '(define (id x)
1105 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1108 665c255d 2023-08-04 jrmu (geval '(define w (id (id 10))))
1109 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1110 665c255d 2023-08-04 jrmu (test-eval 'w 10)
1111 665c255d 2023-08-04 jrmu (test-eval 'count 2)
1112 665c255d 2023-08-04 jrmu (test-eval
1113 665c255d 2023-08-04 jrmu '(let ((f (lambda (x) (+ x 1))))
1116 665c255d 2023-08-04 jrmu (geval '(define count 0))
1117 665c255d 2023-08-04 jrmu (geval '(define (id x)
1118 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1121 665c255d 2023-08-04 jrmu '(define (square x)
1123 665c255d 2023-08-04 jrmu (test-eval
1124 665c255d 2023-08-04 jrmu '(square (id 10))
1126 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1127 665c255d 2023-08-04 jrmu ;; would be 2 without memoization
1130 665c255d 2023-08-04 jrmu ;; streams
1133 665c255d 2023-08-04 jrmu '(define ones (cons 1 ones)))
1135 665c255d 2023-08-04 jrmu '(define integers (cons 1 (add-lists ones integers))))
1136 665c255d 2023-08-04 jrmu (test-eval
1137 665c255d 2023-08-04 jrmu '(list-ref integers 17)
1141 665c255d 2023-08-04 jrmu '(define (integral integrand initial-value dt)
1142 665c255d 2023-08-04 jrmu (define int
1143 665c255d 2023-08-04 jrmu (cons initial-value
1144 665c255d 2023-08-04 jrmu (add-lists (scale-list integrand dt)
1148 665c255d 2023-08-04 jrmu '(define (solve f y0 dt)
1149 665c255d 2023-08-04 jrmu (define y (integral dy y0 dt))
1150 665c255d 2023-08-04 jrmu (define dy (map f y))
1152 665c255d 2023-08-04 jrmu (test-eval
1153 665c255d 2023-08-04 jrmu '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
