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-list? exp) (eval (list->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))
101 665c255d 2023-08-04 jrmu (define (quoted-list? exp)
102 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'quote)
103 665c255d 2023-08-04 jrmu (pair? (cadr exp))))
104 665c255d 2023-08-04 jrmu (define (list->cons exp)
105 665c255d 2023-08-04 jrmu (if (pair? exp)
106 665c255d 2023-08-04 jrmu (make-cons (list->cons (car exp))
107 665c255d 2023-08-04 jrmu (list->cons (cdr exp)))
108 665c255d 2023-08-04 jrmu (make-quote exp)))
109 665c255d 2023-08-04 jrmu (define (make-quote exp)
110 665c255d 2023-08-04 jrmu `(quote ,exp))
111 665c255d 2023-08-04 jrmu (define (make-cons x y)
112 665c255d 2023-08-04 jrmu `(cons ,x ,y))
115 665c255d 2023-08-04 jrmu ;; assignment/definition
116 665c255d 2023-08-04 jrmu (define (assignment? exp)
117 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
118 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
119 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
120 665c255d 2023-08-04 jrmu (define (make-assignment var val)
121 665c255d 2023-08-04 jrmu (list 'set! var val))
122 665c255d 2023-08-04 jrmu (define (definition? exp)
123 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
124 665c255d 2023-08-04 jrmu (define (definition-variable exp)
125 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
127 665c255d 2023-08-04 jrmu (caadr exp)))
128 665c255d 2023-08-04 jrmu (define (definition-value exp)
129 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
130 665c255d 2023-08-04 jrmu (caddr exp)
131 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
132 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
133 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
134 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
135 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
138 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
139 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
140 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
143 665c255d 2023-08-04 jrmu (define (make-definition var val)
144 665c255d 2023-08-04 jrmu `(define ,var ,val))
146 665c255d 2023-08-04 jrmu ;; make-unbound!
148 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
149 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
150 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
151 665c255d 2023-08-04 jrmu ;; (cadr exp))
152 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
153 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
157 665c255d 2023-08-04 jrmu ;; if/and/or
158 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
159 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
160 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
161 665c255d 2023-08-04 jrmu (define (if-alternative exp)
162 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
163 665c255d 2023-08-04 jrmu (cadddr exp)
165 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
166 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
167 665c255d 2023-08-04 jrmu (define (eval-if exp env)
168 665c255d 2023-08-04 jrmu (if (true? (actual-value (if-predicate exp) env))
169 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
170 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
172 665c255d 2023-08-04 jrmu (define (and? exp)
173 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
174 665c255d 2023-08-04 jrmu (define (and-clauses exp)
176 665c255d 2023-08-04 jrmu (define (or? exp)
177 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
178 665c255d 2023-08-04 jrmu (define (or-clauses exp)
180 665c255d 2023-08-04 jrmu (define (eval-and exp env)
181 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
182 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
183 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
184 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
185 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
186 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
187 665c255d 2023-08-04 jrmu (define (eval-or exp env)
188 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
189 665c255d 2023-08-04 jrmu (if (null? clauses)
191 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
192 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
193 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
196 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
197 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
198 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
199 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
200 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
201 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
203 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
205 665c255d 2023-08-04 jrmu (cons (map list vars vals)
207 665c255d 2023-08-04 jrmu (define (let? exp)
208 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
209 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
210 665c255d 2023-08-04 jrmu (define (let-vars exp)
211 665c255d 2023-08-04 jrmu (map car (cadr exp)))
212 665c255d 2023-08-04 jrmu (define (let-vals exp)
213 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
214 665c255d 2023-08-04 jrmu (define (let-body exp)
215 665c255d 2023-08-04 jrmu (cddr exp))
216 665c255d 2023-08-04 jrmu (define (let->combination exp)
217 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
218 665c255d 2023-08-04 jrmu (let-vals exp)))
219 665c255d 2023-08-04 jrmu (define (named-let? exp)
220 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
221 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
222 665c255d 2023-08-04 jrmu (define (named-let-name exp)
223 665c255d 2023-08-04 jrmu (cadr exp))
224 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
225 665c255d 2023-08-04 jrmu (map car (caddr exp)))
226 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
227 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
228 665c255d 2023-08-04 jrmu (define (named-let-body exp)
229 665c255d 2023-08-04 jrmu (cdddr exp))
230 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
231 665c255d 2023-08-04 jrmu (sequence->exp
232 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
233 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
234 665c255d 2023-08-04 jrmu (named-let-body exp)))
235 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
236 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
237 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
240 665c255d 2023-08-04 jrmu (cons (map list vars vals)
243 665c255d 2023-08-04 jrmu (define (letrec? exp)
244 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
246 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
247 665c255d 2023-08-04 jrmu (map car (cadr exp)))
248 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
249 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
250 665c255d 2023-08-04 jrmu (define (letrec-body exp)
251 665c255d 2023-08-04 jrmu (cddr exp))
252 665c255d 2023-08-04 jrmu (define (letrec->let exp)
253 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
254 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
256 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
257 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
258 665c255d 2023-08-04 jrmu (make-assignment var val))
261 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
262 665c255d 2023-08-04 jrmu (make-let vars
263 665c255d 2023-08-04 jrmu unassigneds
264 665c255d 2023-08-04 jrmu (append assignments body))))
269 665c255d 2023-08-04 jrmu (define (let*? exp)
270 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
271 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
272 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
273 665c255d 2023-08-04 jrmu (define let*-body let-body)
274 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
275 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
276 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
277 665c255d 2023-08-04 jrmu (make-let (list (car vars))
278 665c255d 2023-08-04 jrmu (list (car vals))
279 665c255d 2023-08-04 jrmu (let*-body exp))
280 665c255d 2023-08-04 jrmu (make-let (list (car vars))
281 665c255d 2023-08-04 jrmu (list (car vals))
282 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
283 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
284 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
285 665c255d 2023-08-04 jrmu (if (null? vars)
286 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
287 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
290 665c255d 2023-08-04 jrmu (define (do? exp)
291 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
292 665c255d 2023-08-04 jrmu (define (do-vars exp)
293 665c255d 2023-08-04 jrmu (map car (cadr exp)))
294 665c255d 2023-08-04 jrmu (define (do-inits exp)
295 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
296 665c255d 2023-08-04 jrmu (define (do-steps exp)
297 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
298 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
299 665c255d 2023-08-04 jrmu (car var-init-step)
300 665c255d 2023-08-04 jrmu (caddr var-init-step)))
301 665c255d 2023-08-04 jrmu (cadr exp)))
302 665c255d 2023-08-04 jrmu (define (do-test exp)
303 665c255d 2023-08-04 jrmu (caaddr exp))
304 665c255d 2023-08-04 jrmu (define (do-expressions exp)
305 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
306 665c255d 2023-08-04 jrmu (caddr exp)
307 665c255d 2023-08-04 jrmu (cdaddr exp)))
308 665c255d 2023-08-04 jrmu (define (do-commands exp)
309 665c255d 2023-08-04 jrmu (cdddr exp))
310 665c255d 2023-08-04 jrmu (define (do->combination exp)
311 665c255d 2023-08-04 jrmu (make-named-let
313 665c255d 2023-08-04 jrmu (do-vars exp)
314 665c255d 2023-08-04 jrmu (do-inits exp)
317 665c255d 2023-08-04 jrmu (do-test exp)
318 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
319 665c255d 2023-08-04 jrmu (sequence->exp
320 665c255d 2023-08-04 jrmu (append (do-commands exp)
321 665c255d 2023-08-04 jrmu (list (make-application
323 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
326 665c255d 2023-08-04 jrmu ;; begin/sequence
327 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
328 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
329 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
330 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
331 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
332 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
333 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
334 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
335 665c255d 2023-08-04 jrmu (else (make-begin seq))))
336 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
337 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
338 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
339 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
340 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
342 665c255d 2023-08-04 jrmu ;; application
343 665c255d 2023-08-04 jrmu (define (make-application op args)
344 665c255d 2023-08-04 jrmu (cons op args))
345 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
346 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
347 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
348 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
349 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
350 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
353 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
354 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
355 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
356 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
357 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
358 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
359 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
360 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
361 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
362 665c255d 2023-08-04 jrmu (caddr clause))
363 665c255d 2023-08-04 jrmu (define (cond->if exp)
364 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
365 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
366 665c255d 2023-08-04 jrmu (if (null? clauses)
367 665c255d 2023-08-04 jrmu 'false ; no else clause
368 665c255d 2023-08-04 jrmu (let ((first (car clauses))
369 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
370 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
371 665c255d 2023-08-04 jrmu (if (null? rest)
372 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
373 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
375 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
376 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
377 665c255d 2023-08-04 jrmu (make-application
378 665c255d 2023-08-04 jrmu (cond-extended-proc first)
379 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
380 665c255d 2023-08-04 jrmu (expand-clauses rest))
381 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
382 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
383 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
384 665c255d 2023-08-04 jrmu (define (true? x)
385 665c255d 2023-08-04 jrmu (not (eq? x false)))
386 665c255d 2023-08-04 jrmu (define (false? x)
387 665c255d 2023-08-04 jrmu (eq? x false))
389 665c255d 2023-08-04 jrmu ;; procedure
390 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
391 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
392 665c255d 2023-08-04 jrmu ;; (define (scan-out-defines body)
393 665c255d 2023-08-04 jrmu ;; (let* ((definitions (filter definition? body))
394 665c255d 2023-08-04 jrmu ;; (vars (map definition-variable definitions))
395 665c255d 2023-08-04 jrmu ;; (unassigneds (map (lambda (var) ''*unassigned*)
397 665c255d 2023-08-04 jrmu ;; (vals (map definition-value definitions))
398 665c255d 2023-08-04 jrmu ;; (assignments
399 665c255d 2023-08-04 jrmu ;; (map (lambda (var val)
400 665c255d 2023-08-04 jrmu ;; (make-assignment var val))
401 665c255d 2023-08-04 jrmu ;; vars vals))
402 665c255d 2023-08-04 jrmu ;; (exps (remove definition? body)))
403 665c255d 2023-08-04 jrmu ;; (if (null? definitions)
406 665c255d 2023-08-04 jrmu ;; (make-let vars
407 665c255d 2023-08-04 jrmu ;; unassigneds
408 665c255d 2023-08-04 jrmu ;; (append assignments exps))))))
409 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
410 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
411 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
412 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
413 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
415 665c255d 2023-08-04 jrmu ;; environment
416 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
417 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
418 665c255d 2023-08-04 jrmu (define the-empty-environment '())
419 665c255d 2023-08-04 jrmu (define (make-frame variables values)
420 665c255d 2023-08-04 jrmu (cons variables values))
421 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
422 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
423 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
424 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
425 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
426 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
427 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
428 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
429 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
430 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
431 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
432 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
433 665c255d 2023-08-04 jrmu (define (env-loop env)
434 665c255d 2023-08-04 jrmu (define (scan vars vals)
435 665c255d 2023-08-04 jrmu (cond ((null? vars)
436 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
437 665c255d 2023-08-04 jrmu ((eq? var (car vars))
438 665c255d 2023-08-04 jrmu (let ((val (car vals)))
439 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
440 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
442 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
443 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
444 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
445 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
446 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
447 665c255d 2023-08-04 jrmu (frame-values frame)))))
448 665c255d 2023-08-04 jrmu (env-loop env))
449 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
450 665c255d 2023-08-04 jrmu (define (env-loop env)
451 665c255d 2023-08-04 jrmu (define (scan vars vals)
452 665c255d 2023-08-04 jrmu (cond ((null? vars)
453 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
454 665c255d 2023-08-04 jrmu ((eq? var (car vars))
455 665c255d 2023-08-04 jrmu (set-car! vals val))
456 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
457 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
458 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
459 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
460 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
461 665c255d 2023-08-04 jrmu (frame-values frame)))))
462 665c255d 2023-08-04 jrmu (env-loop env))
463 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
464 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
465 665c255d 2023-08-04 jrmu (define (scan vars vals)
466 665c255d 2023-08-04 jrmu (cond ((null? vars)
467 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
468 665c255d 2023-08-04 jrmu ((eq? var (car vars))
469 665c255d 2023-08-04 jrmu (set-car! vals val))
470 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
471 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
472 665c255d 2023-08-04 jrmu (frame-values frame))))
474 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
475 665c255d 2023-08-04 jrmu (define (scan vars vals)
476 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
477 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
478 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
479 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
480 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
481 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
482 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
483 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
484 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
485 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
486 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
487 665c255d 2023-08-04 jrmu (scan vars vals))))
489 665c255d 2023-08-04 jrmu ;; primitives
490 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
491 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
492 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
493 665c255d 2023-08-04 jrmu (define primitive-procedures
494 665c255d 2023-08-04 jrmu (list (list 'car car)
495 665c255d 2023-08-04 jrmu (list 'cdr cdr)
496 665c255d 2023-08-04 jrmu (list 'caar caar)
497 665c255d 2023-08-04 jrmu (list 'cadr cadr)
498 665c255d 2023-08-04 jrmu (list 'cddr cddr)
499 665c255d 2023-08-04 jrmu (list 'cons cons)
500 665c255d 2023-08-04 jrmu (list 'null? null?)
501 665c255d 2023-08-04 jrmu (list '* *)
502 665c255d 2023-08-04 jrmu (list '/ /)
503 665c255d 2023-08-04 jrmu (list '+ +)
504 665c255d 2023-08-04 jrmu (list '- -)
505 665c255d 2023-08-04 jrmu (list '= =)
506 665c255d 2023-08-04 jrmu (list '< <)
507 665c255d 2023-08-04 jrmu (list '> >)
508 665c255d 2023-08-04 jrmu (list '<= <=)
509 665c255d 2023-08-04 jrmu (list '>= >=)
510 665c255d 2023-08-04 jrmu (list 'remainder remainder)
511 665c255d 2023-08-04 jrmu (list 'eq? eq?)
512 665c255d 2023-08-04 jrmu (list 'equal? equal?)
513 665c255d 2023-08-04 jrmu (list 'display display)))
514 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
516 665c255d 2023-08-04 jrmu primitive-procedures))
517 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
518 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
519 665c255d 2023-08-04 jrmu primitive-procedures))
520 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
521 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
522 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
524 665c255d 2023-08-04 jrmu ;; driver-loop
525 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
526 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
527 665c255d 2023-08-04 jrmu (define (driver-loop)
528 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
529 665c255d 2023-08-04 jrmu (let ((input (read)))
530 665c255d 2023-08-04 jrmu (let ((output (actual-value input the-global-environment)))
531 665c255d 2023-08-04 jrmu (announce-output output-prompt)
532 665c255d 2023-08-04 jrmu (user-print output)))
533 665c255d 2023-08-04 jrmu (driver-loop))
534 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
535 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
537 665c255d 2023-08-04 jrmu (define (announce-output string)
538 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
539 665c255d 2023-08-04 jrmu (define (user-print object)
540 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
541 665c255d 2023-08-04 jrmu (if (eq? (lookup-variable-value 'cons the-global-environment)
543 665c255d 2023-08-04 jrmu (display 'cons)
544 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
545 665c255d 2023-08-04 jrmu (procedure-parameters object)
546 665c255d 2023-08-04 jrmu (procedure-body object)
547 665c255d 2023-08-04 jrmu '<procedure-env>)))
548 665c255d 2023-08-04 jrmu (display object)))
549 665c255d 2023-08-04 jrmu (define (setup-environment)
550 665c255d 2023-08-04 jrmu (let ((initial-env
551 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
552 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
553 665c255d 2023-08-04 jrmu the-empty-environment)))
554 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
555 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
556 665c255d 2023-08-04 jrmu initial-env))
557 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
559 665c255d 2023-08-04 jrmu ;; auxiliary
560 665c255d 2023-08-04 jrmu (define (test-case actual expected)
562 665c255d 2023-08-04 jrmu (display "Actual: ")
563 665c255d 2023-08-04 jrmu (display actual)
565 665c255d 2023-08-04 jrmu (display "Expected: ")
566 665c255d 2023-08-04 jrmu (display expected)
568 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
569 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
570 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
571 665c255d 2023-08-04 jrmu (test-case (force-it (geval exp)) expected))
573 665c255d 2023-08-04 jrmu ;; cons/car/cdr
576 665c255d 2023-08-04 jrmu '(define (cons x y)
577 665c255d 2023-08-04 jrmu (lambda (m) (m x y))))
579 665c255d 2023-08-04 jrmu '(define (car z)
580 665c255d 2023-08-04 jrmu (z (lambda (p q) p))))
582 665c255d 2023-08-04 jrmu '(define (cdr z)
583 665c255d 2023-08-04 jrmu (z (lambda (p q) q))))
585 665c255d 2023-08-04 jrmu '(define (list-ref items n)
586 665c255d 2023-08-04 jrmu (if (= n 0)
587 665c255d 2023-08-04 jrmu (car items)
588 665c255d 2023-08-04 jrmu (list-ref (cdr items) (- n 1)))))
590 665c255d 2023-08-04 jrmu '(define (map proc items)
591 665c255d 2023-08-04 jrmu (if (null? items)
593 665c255d 2023-08-04 jrmu (cons (proc (car items))
594 665c255d 2023-08-04 jrmu (map proc (cdr items))))))
596 665c255d 2023-08-04 jrmu '(define (scale-list items factor)
597 665c255d 2023-08-04 jrmu (map (lambda (x) (* x factor))
600 665c255d 2023-08-04 jrmu '(define (add-lists list1 list2)
601 665c255d 2023-08-04 jrmu (cond ((null? list1) list2)
602 665c255d 2023-08-04 jrmu ((null? list2) list1)
603 665c255d 2023-08-04 jrmu (else (cons (+ (car list1) (car list2))
604 665c255d 2023-08-04 jrmu (add-lists (cdr list1) (cdr list2)))))))
609 665c255d 2023-08-04 jrmu ;; Exercise 4.34. Modify the driver loop for the evaluator so that lazy pairs and lists will print in some reasonable way. (What are you going to do about infinite lists?) You may also need to modify the representation of lazy pairs so that the evaluator can identify them in order to print them.
613 665c255d 2023-08-04 jrmu '(car (cons (quote a) (quote ())))
616 665c255d 2023-08-04 jrmu '(cdr (cons (quote a) (quote ())))
619 665c255d 2023-08-04 jrmu '(car '(a))
622 665c255d 2023-08-04 jrmu '(cdr '(a))
625 665c255d 2023-08-04 jrmu '(car (cdr '(a b)))
628 665c255d 2023-08-04 jrmu '(car (car '((a b) c)))
631 665c255d 2023-08-04 jrmu '(car (cdr (car (cdr '((a c) (b d))))))
638 665c255d 2023-08-04 jrmu '(define ones (cons 1 ones)))
640 665c255d 2023-08-04 jrmu '(define integers (cons 1 (add-lists ones integers))))
642 665c255d 2023-08-04 jrmu '(list-ref integers 17)
646 665c255d 2023-08-04 jrmu '(car (cdr (add-lists '(1 2 3 4 5) '(2 3 4 5 6))))
650 665c255d 2023-08-04 jrmu '(define (integral integrand initial-value dt)
651 665c255d 2023-08-04 jrmu (define int
652 665c255d 2023-08-04 jrmu (cons initial-value
653 665c255d 2023-08-04 jrmu (add-lists (scale-list integrand dt)
657 665c255d 2023-08-04 jrmu '(define (solve f y0 dt)
658 665c255d 2023-08-04 jrmu (define y (integral dy y0 dt))
659 665c255d 2023-08-04 jrmu (define dy (map f y))
662 665c255d 2023-08-04 jrmu '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
666 665c255d 2023-08-04 jrmu ;; test-suite
668 665c255d 2023-08-04 jrmu ;; procedure definitions
671 665c255d 2023-08-04 jrmu '(define (assoc key records)
672 665c255d 2023-08-04 jrmu (cond ((null? records) false)
673 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
674 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
677 665c255d 2023-08-04 jrmu '(define (map proc list)
678 665c255d 2023-08-04 jrmu (if (null? list)
680 665c255d 2023-08-04 jrmu (cons (proc (car list))
681 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
684 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
685 665c255d 2023-08-04 jrmu (if (null? sequence)
687 665c255d 2023-08-04 jrmu (op (car sequence)
688 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
690 665c255d 2023-08-04 jrmu ;; all special forms
691 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
692 665c255d 2023-08-04 jrmu (test-eval '10 10)
693 665c255d 2023-08-04 jrmu (geval '(define x 3))
694 665c255d 2023-08-04 jrmu (test-eval 'x 3)
695 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
696 665c255d 2023-08-04 jrmu (test-eval 'x -25)
697 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
698 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
699 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
700 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
701 665c255d 2023-08-04 jrmu (else 'failed))
703 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
706 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
707 665c255d 2023-08-04 jrmu (+ x y (* x y)))
708 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
712 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
713 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
714 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
715 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
716 665c255d 2023-08-04 jrmu (test-eval 'x -2)
717 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
718 665c255d 2023-08-04 jrmu (test-eval 'x -2)
719 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
720 665c255d 2023-08-04 jrmu (test-eval 'x 25)
721 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
722 665c255d 2023-08-04 jrmu (test-eval 'x 2)
723 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
724 665c255d 2023-08-04 jrmu (test-eval 'x 25)
725 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
726 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
731 665c255d 2023-08-04 jrmu ;; (test-eval
732 665c255d 2023-08-04 jrmu ;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
733 665c255d 2023-08-04 jrmu ;; (else false))
736 665c255d 2023-08-04 jrmu ;; (test-eval
737 665c255d 2023-08-04 jrmu ;; '(cond ((= 3 4) 'not-true)
738 665c255d 2023-08-04 jrmu ;; ((= (* 2 4) 3) 'also-false)
739 665c255d 2023-08-04 jrmu ;; ((map (lambda (x)
740 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
741 665c255d 2023-08-04 jrmu ;; '(2 4 1 9))
743 665c255d 2023-08-04 jrmu ;; (lambda (x)
744 665c255d 2023-08-04 jrmu ;; (accumulate + 0 x)))
745 665c255d 2023-08-04 jrmu ;; (else 'never-reach))
747 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
750 665c255d 2023-08-04 jrmu ;; procedure definition and application
752 665c255d 2023-08-04 jrmu '(define (factorial n)
753 665c255d 2023-08-04 jrmu (if (= n 0)
755 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
756 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
760 665c255d 2023-08-04 jrmu ;; (test-eval
761 665c255d 2023-08-04 jrmu ;; '(map (lambda (x)
762 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
763 665c255d 2023-08-04 jrmu ;; '(2 1 4 2 8 3))
764 665c255d 2023-08-04 jrmu ;; '(6 2 20 6 72 12))
766 665c255d 2023-08-04 jrmu ;; accumulate
769 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
772 665c255d 2023-08-04 jrmu ;; make-let
774 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
781 665c255d 2023-08-04 jrmu '(let ((x 3))
785 665c255d 2023-08-04 jrmu '(let ((x 3)
790 665c255d 2023-08-04 jrmu '(let ((x 3)
792 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
796 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
798 665c255d 2023-08-04 jrmu '(let ((x 6)
799 665c255d 2023-08-04 jrmu (y (let ((x 2))
801 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
810 665c255d 2023-08-04 jrmu '(let* ((x 3)
811 665c255d 2023-08-04 jrmu (y (+ x 2))
812 665c255d 2023-08-04 jrmu (z (+ x y 5)))
821 665c255d 2023-08-04 jrmu '(let* ((x 3))
822 665c255d 2023-08-04 jrmu (let* ((y 5))
827 665c255d 2023-08-04 jrmu '(let* ((x 3)
828 665c255d 2023-08-04 jrmu (y (+ x 1)))
829 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
833 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
835 665c255d 2023-08-04 jrmu '(let* ((x 6)
836 665c255d 2023-08-04 jrmu (y (let* ((x 2)
837 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
840 665c255d 2023-08-04 jrmu (z (+ x y)))
844 665c255d 2023-08-04 jrmu ;; named-let
847 665c255d 2023-08-04 jrmu '(let eight ()
853 665c255d 2023-08-04 jrmu '(let loop ((count 0))
854 665c255d 2023-08-04 jrmu (if (= 100 count)
856 665c255d 2023-08-04 jrmu (loop (+ count 1))))
859 665c255d 2023-08-04 jrmu '(define (prime? x)
860 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
861 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
862 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
863 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
864 665c255d 2023-08-04 jrmu ;; (test-eval
865 665c255d 2023-08-04 jrmu ;; '(let primes ((x 2)
867 665c255d 2023-08-04 jrmu ;; (cond ((= n 0) '())
868 665c255d 2023-08-04 jrmu ;; ((prime? x)
870 665c255d 2023-08-04 jrmu ;; (primes (+ x 1) (- n 1))))
871 665c255d 2023-08-04 jrmu ;; (else (primes (+ x 1) n))))
872 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))
875 665c255d 2023-08-04 jrmu '(define (fib n)
876 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
879 665c255d 2023-08-04 jrmu (if (= count 0)
881 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
882 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
886 665c255d 2023-08-04 jrmu '(let ((y 0))
887 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
888 665c255d 2023-08-04 jrmu ((= x 5) y)
889 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
900 665c255d 2023-08-04 jrmu '(let ((y 0))
902 665c255d 2023-08-04 jrmu ((= y 5) y)
903 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
907 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
908 665c255d 2023-08-04 jrmu ((null? y))
909 665c255d 2023-08-04 jrmu (set! y (cdr y)))
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))))
918 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
919 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
920 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
921 665c255d 2023-08-04 jrmu ((null? x) sum)))
923 665c255d 2023-08-04 jrmu ;; (test-eval
924 665c255d 2023-08-04 jrmu ;; '(let ((z '()))
925 665c255d 2023-08-04 jrmu ;; (do ((x '(1 2 3 4) (cdr x))
926 665c255d 2023-08-04 jrmu ;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
927 665c255d 2023-08-04 jrmu ;; ((null? x) y x z)
928 665c255d 2023-08-04 jrmu ;; (set! z (cons (car x) z))))
929 665c255d 2023-08-04 jrmu ;; '(4 3 2 1))
933 665c255d 2023-08-04 jrmu ;; make-unbound!
934 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
936 665c255d 2023-08-04 jrmu ;; (test-eval
937 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
938 665c255d 2023-08-04 jrmu ;; (let ((x 5))
939 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
940 665c255d 2023-08-04 jrmu ;; (* x x)))
943 665c255d 2023-08-04 jrmu ;; (test-eval
944 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
945 665c255d 2023-08-04 jrmu ;; (let ((x 5))
946 665c255d 2023-08-04 jrmu ;; (define y x)
947 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
948 665c255d 2023-08-04 jrmu ;; (* y x)))
951 665c255d 2023-08-04 jrmu ;; (test-eval
952 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
953 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
954 665c255d 2023-08-04 jrmu ;; (define a x)
955 665c255d 2023-08-04 jrmu ;; (define b y)
956 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
957 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
958 665c255d 2023-08-04 jrmu ;; (* a b x y)))
959 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
961 665c255d 2023-08-04 jrmu ;; (test-eval
962 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
963 665c255d 2023-08-04 jrmu ;; (let ((x 5))
964 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
965 665c255d 2023-08-04 jrmu ;; (+ x 4)))
968 665c255d 2023-08-04 jrmu ;; (test-eval
969 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
970 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
971 665c255d 2023-08-04 jrmu ;; (+ a c d))
972 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
974 665c255d 2023-08-04 jrmu ;; (test-eval
975 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
976 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
977 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
978 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
979 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
980 665c255d 2023-08-04 jrmu ;; (define z b)
981 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
982 665c255d 2023-08-04 jrmu ;; (* (+ a z)
983 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
984 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
985 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
987 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
988 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
989 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
990 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
992 665c255d 2023-08-04 jrmu ;; scan-out-defines
995 665c255d 2023-08-04 jrmu '(define (f x)
996 665c255d 2023-08-04 jrmu (define (even? n)
997 665c255d 2023-08-04 jrmu (if (= n 0)
999 665c255d 2023-08-04 jrmu (odd? (- n 1))))
1000 665c255d 2023-08-04 jrmu (define (odd? n)
1001 665c255d 2023-08-04 jrmu (if (= n 0)
1003 665c255d 2023-08-04 jrmu (even? (- n 1))))
1004 665c255d 2023-08-04 jrmu (even? x)))
1005 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
1006 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
1009 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
1010 665c255d 2023-08-04 jrmu ;; (define y x)
1011 665c255d 2023-08-04 jrmu ;; (define x 3)
1012 665c255d 2023-08-04 jrmu ;; (+ x y)))
1013 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
1018 665c255d 2023-08-04 jrmu '(define (f x)
1019 665c255d 2023-08-04 jrmu (letrec ((even?
1020 665c255d 2023-08-04 jrmu (lambda (n)
1021 665c255d 2023-08-04 jrmu (if (= n 0)
1023 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
1025 665c255d 2023-08-04 jrmu (lambda (n)
1026 665c255d 2023-08-04 jrmu (if (= n 0)
1028 665c255d 2023-08-04 jrmu (even? (- n 1))))))
1029 665c255d 2023-08-04 jrmu (even? x))))
1030 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
1031 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
1033 665c255d 2023-08-04 jrmu (test-eval
1034 665c255d 2023-08-04 jrmu '(letrec ((fact
1035 665c255d 2023-08-04 jrmu (lambda (n)
1036 665c255d 2023-08-04 jrmu (if (= n 1)
1038 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
1039 665c255d 2023-08-04 jrmu (fact 10))
1043 665c255d 2023-08-04 jrmu ;; delayed-evaluation
1046 665c255d 2023-08-04 jrmu '(define (try a b)
1047 665c255d 2023-08-04 jrmu (if (= a 0) 1 b)))
1048 665c255d 2023-08-04 jrmu (test-eval '(try 0 (/ 1 0)) 1)
1051 665c255d 2023-08-04 jrmu '(define (unless condition usual-value exceptional-value)
1052 665c255d 2023-08-04 jrmu (if condition exceptional-value usual-value)))
1053 665c255d 2023-08-04 jrmu (test-eval
1054 665c255d 2023-08-04 jrmu '(let ((a 4) (b 0))
1055 665c255d 2023-08-04 jrmu (unless (= b 0)
1057 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1060 665c255d 2023-08-04 jrmu (test-eval
1061 665c255d 2023-08-04 jrmu '(let ((a 4) (b 2))
1062 665c255d 2023-08-04 jrmu (unless (= b 0)
1064 665c255d 2023-08-04 jrmu (begin (display "exception: returning 0")
1069 665c255d 2023-08-04 jrmu '(define (factorial n)
1070 665c255d 2023-08-04 jrmu (unless (= n 1)
1071 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))
1073 665c255d 2023-08-04 jrmu (test-eval
1074 665c255d 2023-08-04 jrmu '(factorial 8)
1077 665c255d 2023-08-04 jrmu (geval '(define count 0))
1078 665c255d 2023-08-04 jrmu (geval '(define (id x)
1079 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1082 665c255d 2023-08-04 jrmu (geval '(define w (id (id 10))))
1083 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1084 665c255d 2023-08-04 jrmu (test-eval 'w 10)
1085 665c255d 2023-08-04 jrmu (test-eval 'count 2)
1086 665c255d 2023-08-04 jrmu (test-eval
1087 665c255d 2023-08-04 jrmu '(let ((f (lambda (x) (+ x 1))))
1090 665c255d 2023-08-04 jrmu (geval '(define count 0))
1091 665c255d 2023-08-04 jrmu (geval '(define (id x)
1092 665c255d 2023-08-04 jrmu (set! count (+ count 1))
1095 665c255d 2023-08-04 jrmu '(define (square x)
1097 665c255d 2023-08-04 jrmu (test-eval
1098 665c255d 2023-08-04 jrmu '(square (id 10))
1100 665c255d 2023-08-04 jrmu (test-eval 'count 1)
1101 665c255d 2023-08-04 jrmu ;; would be 2 without memoization
1104 665c255d 2023-08-04 jrmu ;; streams
1107 665c255d 2023-08-04 jrmu '(define ones (cons 1 ones)))
1109 665c255d 2023-08-04 jrmu '(define integers (cons 1 (add-lists ones integers))))
1110 665c255d 2023-08-04 jrmu (test-eval
1111 665c255d 2023-08-04 jrmu '(list-ref integers 17)
1115 665c255d 2023-08-04 jrmu '(define (integral integrand initial-value dt)
1116 665c255d 2023-08-04 jrmu (define int
1117 665c255d 2023-08-04 jrmu (cons initial-value
1118 665c255d 2023-08-04 jrmu (add-lists (scale-list integrand dt)
1122 665c255d 2023-08-04 jrmu '(define (solve f y0 dt)
1123 665c255d 2023-08-04 jrmu (define y (integral dy y0 dt))
1124 665c255d 2023-08-04 jrmu (define dy (map f y))
1126 665c255d 2023-08-04 jrmu (test-eval
1127 665c255d 2023-08-04 jrmu '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
