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 ((analyze exp) env))
5 665c255d 2023-08-04 jrmu (define (analyze exp)
6 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp)
7 665c255d 2023-08-04 jrmu (analyze-self-evaluating exp))
8 665c255d 2023-08-04 jrmu ((quoted? exp) (analyze-quoted exp))
9 665c255d 2023-08-04 jrmu ((variable? exp) (analyze-variable exp))
10 665c255d 2023-08-04 jrmu ((assignment? exp) (analyze-assignment exp))
11 665c255d 2023-08-04 jrmu ((definition? exp) (analyze-definition exp))
12 665c255d 2023-08-04 jrmu ((if? exp) (analyze-if exp))
13 665c255d 2023-08-04 jrmu ((lambda? exp) (analyze-lambda exp))
14 665c255d 2023-08-04 jrmu ((let? exp) (analyze (let->combination exp)))
15 665c255d 2023-08-04 jrmu ((begin? exp) (analyze-sequence (begin-actions exp)))
16 665c255d 2023-08-04 jrmu ((cond? exp) (analyze (cond->if exp)))
17 665c255d 2023-08-04 jrmu ((application? exp) (analyze-application exp))
19 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ANALYZE" exp))))
20 665c255d 2023-08-04 jrmu (define (analyze-self-evaluating exp)
21 665c255d 2023-08-04 jrmu (lambda (env) exp))
22 665c255d 2023-08-04 jrmu (define (analyze-quoted exp)
23 665c255d 2023-08-04 jrmu (let ((qval (text-of-quotation exp)))
24 665c255d 2023-08-04 jrmu (lambda (env) qval)))
25 665c255d 2023-08-04 jrmu (define (analyze-variable exp)
26 665c255d 2023-08-04 jrmu (lambda (env) (lookup-variable-value exp env)))
27 665c255d 2023-08-04 jrmu (define (analyze-assignment exp)
28 665c255d 2023-08-04 jrmu (let ((var (assignment-variable exp))
29 665c255d 2023-08-04 jrmu (vproc (analyze (assignment-value exp))))
30 665c255d 2023-08-04 jrmu (lambda (env)
31 665c255d 2023-08-04 jrmu (set-variable-value! var (vproc env) env)
33 665c255d 2023-08-04 jrmu (define (analyze-definition exp)
34 665c255d 2023-08-04 jrmu (let ((var (definition-variable exp))
35 665c255d 2023-08-04 jrmu (vproc (analyze (definition-value exp))))
36 665c255d 2023-08-04 jrmu (lambda (env)
37 665c255d 2023-08-04 jrmu (define-variable! var (vproc env) env)
39 665c255d 2023-08-04 jrmu (define (analyze-if exp)
40 665c255d 2023-08-04 jrmu (let ((pproc (analyze (if-predicate exp)))
41 665c255d 2023-08-04 jrmu (cproc (analyze (if-consequent exp)))
42 665c255d 2023-08-04 jrmu (aproc (analyze (if-alternative exp))))
43 665c255d 2023-08-04 jrmu (lambda (env)
44 665c255d 2023-08-04 jrmu (if (true? (pproc env))
46 665c255d 2023-08-04 jrmu (aproc env)))))
47 665c255d 2023-08-04 jrmu (define (analyze-lambda exp)
48 665c255d 2023-08-04 jrmu (let ((vars (lambda-parameters exp))
49 665c255d 2023-08-04 jrmu (bproc (analyze-sequence (lambda-body exp))))
50 665c255d 2023-08-04 jrmu (lambda (env) (make-procedure vars bproc env))))
51 665c255d 2023-08-04 jrmu (define (analyze-sequence exps)
52 665c255d 2023-08-04 jrmu (define (sequentially proc1 proc2)
53 665c255d 2023-08-04 jrmu (lambda (env) (proc1 env) (proc2 env)))
54 665c255d 2023-08-04 jrmu (define (loop first-proc rest-procs)
55 665c255d 2023-08-04 jrmu (if (null? rest-procs)
57 665c255d 2023-08-04 jrmu (loop (sequentially first-proc (car rest-procs))
58 665c255d 2023-08-04 jrmu (cdr rest-procs))))
59 665c255d 2023-08-04 jrmu (let ((procs (map analyze exps)))
60 665c255d 2023-08-04 jrmu (if (null? procs)
61 665c255d 2023-08-04 jrmu (error "Empty sequence -- ANALYZE"))
62 665c255d 2023-08-04 jrmu (loop (car procs) (cdr procs))))
63 665c255d 2023-08-04 jrmu (define (analyze-application exp)
64 665c255d 2023-08-04 jrmu (let ((fproc (analyze (operator exp)))
65 665c255d 2023-08-04 jrmu (aprocs (map analyze (operands exp))))
66 665c255d 2023-08-04 jrmu (lambda (env)
67 665c255d 2023-08-04 jrmu (execute-application (fproc env)
68 665c255d 2023-08-04 jrmu (map (lambda (aproc) (aproc env))
70 665c255d 2023-08-04 jrmu (define (execute-application proc args)
71 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? proc)
72 665c255d 2023-08-04 jrmu (apply-primitive-procedure proc args))
73 665c255d 2023-08-04 jrmu ((compound-procedure? proc)
74 665c255d 2023-08-04 jrmu ((procedure-body proc)
75 665c255d 2023-08-04 jrmu (extend-environment (procedure-parameters proc)
77 665c255d 2023-08-04 jrmu (procedure-environment proc))))
80 665c255d 2023-08-04 jrmu "Unknown procedure type -- EXECUTE-APPLICATION"
84 665c255d 2023-08-04 jrmu ;; (define (eval exp env)
85 665c255d 2023-08-04 jrmu ;; (cond ((self-evaluating? exp) exp)
86 665c255d 2023-08-04 jrmu ;; ((variable? exp) (lookup-variable-value exp env))
87 665c255d 2023-08-04 jrmu ;; ((quoted? exp) (text-of-quotation exp))
88 665c255d 2023-08-04 jrmu ;; ((assignment? exp) (eval-assignment exp env))
89 665c255d 2023-08-04 jrmu ;; ((definition? exp) (eval-definition exp env))
90 665c255d 2023-08-04 jrmu ;; ;; ((unbound? exp) (eval-unbound exp env))
91 665c255d 2023-08-04 jrmu ;; ((if? exp) (eval-if exp env))
92 665c255d 2023-08-04 jrmu ;; ((and? exp) (eval-and exp env))
93 665c255d 2023-08-04 jrmu ;; ((or? exp) (eval-or exp env))
94 665c255d 2023-08-04 jrmu ;; ((lambda? exp)
95 665c255d 2023-08-04 jrmu ;; (make-procedure (lambda-parameters exp)
96 665c255d 2023-08-04 jrmu ;; (lambda-body exp)
98 665c255d 2023-08-04 jrmu ;; ((begin? exp)
99 665c255d 2023-08-04 jrmu ;; (eval-sequence (begin-actions exp) env))
100 665c255d 2023-08-04 jrmu ;; ((cond? exp) (eval (cond->if exp) env))
101 665c255d 2023-08-04 jrmu ;; ((let? exp) (eval (let->combination exp) env))
102 665c255d 2023-08-04 jrmu ;; ((let*? exp) (eval (let*->nested-lets exp) env))
103 665c255d 2023-08-04 jrmu ;; ((named-let? exp) (eval (named-let->combination exp) env))
104 665c255d 2023-08-04 jrmu ;; ((letrec? exp) (eval (letrec->let exp) env))
105 665c255d 2023-08-04 jrmu ;; ((do? exp) (eval (do->combination exp) env))
106 665c255d 2023-08-04 jrmu ;; ((application? exp)
107 665c255d 2023-08-04 jrmu ;; (apply (eval (operator exp) env)
108 665c255d 2023-08-04 jrmu ;; (list-of-values (operands exp) env)))
110 665c255d 2023-08-04 jrmu ;; (error "Unknown expression type -- EVAL" exp))))
111 665c255d 2023-08-04 jrmu ;; (define (apply procedure arguments)
112 665c255d 2023-08-04 jrmu ;; (cond ((primitive-procedure? procedure)
113 665c255d 2023-08-04 jrmu ;; (apply-primitive-procedure procedure arguments))
114 665c255d 2023-08-04 jrmu ;; ((compound-procedure? procedure)
115 665c255d 2023-08-04 jrmu ;; (eval-sequence
116 665c255d 2023-08-04 jrmu ;; (procedure-body procedure)
117 665c255d 2023-08-04 jrmu ;; (extend-environment
118 665c255d 2023-08-04 jrmu ;; (procedure-parameters procedure)
119 665c255d 2023-08-04 jrmu ;; arguments
120 665c255d 2023-08-04 jrmu ;; (procedure-environment procedure))))
123 665c255d 2023-08-04 jrmu ;; "Unknown procedure type -- APPLY" procedure))))
125 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
126 665c255d 2023-08-04 jrmu (if (no-operands? exps)
128 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
129 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
131 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
132 665c255d 2023-08-04 jrmu (if (pair? exp)
133 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
136 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
137 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
138 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
139 665c255d 2023-08-04 jrmu ((string? exp) true)
140 665c255d 2023-08-04 jrmu (else false)))
141 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
142 665c255d 2023-08-04 jrmu (define (quoted? exp)
143 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
144 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
146 665c255d 2023-08-04 jrmu ;; assignment/definition
147 665c255d 2023-08-04 jrmu (define (assignment? exp)
148 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
149 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
150 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
151 665c255d 2023-08-04 jrmu (define (make-assignment var val)
152 665c255d 2023-08-04 jrmu (list 'set! var val))
153 665c255d 2023-08-04 jrmu (define (definition? exp)
154 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
155 665c255d 2023-08-04 jrmu (define (definition-variable exp)
156 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
158 665c255d 2023-08-04 jrmu (caadr exp)))
159 665c255d 2023-08-04 jrmu (define (definition-value exp)
160 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
161 665c255d 2023-08-04 jrmu (caddr exp)
162 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
163 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
164 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
165 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
166 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
169 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
170 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
171 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
174 665c255d 2023-08-04 jrmu (define (make-definition var val)
175 665c255d 2023-08-04 jrmu `(define ,var ,val))
177 665c255d 2023-08-04 jrmu ;; make-unbound!
179 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
180 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
181 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
182 665c255d 2023-08-04 jrmu ;; (cadr exp))
183 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
184 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
188 665c255d 2023-08-04 jrmu ;; if/and/or
189 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
190 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
191 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
192 665c255d 2023-08-04 jrmu (define (if-alternative exp)
193 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
194 665c255d 2023-08-04 jrmu (cadddr exp)
196 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
197 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
198 665c255d 2023-08-04 jrmu (define (eval-if exp env)
199 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
200 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
201 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
203 665c255d 2023-08-04 jrmu (define (and? exp)
204 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
205 665c255d 2023-08-04 jrmu (define (and-clauses exp)
207 665c255d 2023-08-04 jrmu (define (or? exp)
208 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
209 665c255d 2023-08-04 jrmu (define (or-clauses exp)
211 665c255d 2023-08-04 jrmu (define (eval-and exp env)
212 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
213 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
214 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
215 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
216 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
217 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
218 665c255d 2023-08-04 jrmu (define (eval-or exp env)
219 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
220 665c255d 2023-08-04 jrmu (if (null? clauses)
222 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
223 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
224 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
227 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
228 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
229 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
230 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
231 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
232 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
234 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
236 665c255d 2023-08-04 jrmu (cons (map list vars vals)
238 665c255d 2023-08-04 jrmu (define (let? exp)
239 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
240 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
241 665c255d 2023-08-04 jrmu (define (let-vars exp)
242 665c255d 2023-08-04 jrmu (map car (cadr exp)))
243 665c255d 2023-08-04 jrmu (define (let-vals exp)
244 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
245 665c255d 2023-08-04 jrmu (define (let-body exp)
246 665c255d 2023-08-04 jrmu (cddr exp))
247 665c255d 2023-08-04 jrmu (define (let->combination exp)
248 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
249 665c255d 2023-08-04 jrmu (let-vals exp)))
250 665c255d 2023-08-04 jrmu (define (named-let? exp)
251 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
252 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
253 665c255d 2023-08-04 jrmu (define (named-let-name exp)
254 665c255d 2023-08-04 jrmu (cadr exp))
255 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
256 665c255d 2023-08-04 jrmu (map car (caddr exp)))
257 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
258 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
259 665c255d 2023-08-04 jrmu (define (named-let-body exp)
260 665c255d 2023-08-04 jrmu (cdddr exp))
261 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
262 665c255d 2023-08-04 jrmu (sequence->exp
263 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
264 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
265 665c255d 2023-08-04 jrmu (named-let-body exp)))
266 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
267 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
268 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
271 665c255d 2023-08-04 jrmu (cons (map list vars vals)
274 665c255d 2023-08-04 jrmu (define (letrec? exp)
275 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
277 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
278 665c255d 2023-08-04 jrmu (map car (cadr exp)))
279 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
280 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
281 665c255d 2023-08-04 jrmu (define (letrec-body exp)
282 665c255d 2023-08-04 jrmu (cddr exp))
283 665c255d 2023-08-04 jrmu (define (letrec->let exp)
284 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
285 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
287 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
288 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
289 665c255d 2023-08-04 jrmu (make-assignment var val))
292 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
293 665c255d 2023-08-04 jrmu (make-let vars
294 665c255d 2023-08-04 jrmu unassigneds
295 665c255d 2023-08-04 jrmu (append assignments body))))
300 665c255d 2023-08-04 jrmu (define (make-application op args)
301 665c255d 2023-08-04 jrmu (cons op args))
303 665c255d 2023-08-04 jrmu (define (let*? exp)
304 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
305 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
306 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
307 665c255d 2023-08-04 jrmu (define let*-body let-body)
308 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
309 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
310 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
311 665c255d 2023-08-04 jrmu (make-let (list (car vars))
312 665c255d 2023-08-04 jrmu (list (car vals))
313 665c255d 2023-08-04 jrmu (let*-body exp))
314 665c255d 2023-08-04 jrmu (make-let (list (car vars))
315 665c255d 2023-08-04 jrmu (list (car vals))
316 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
317 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
318 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
319 665c255d 2023-08-04 jrmu (if (null? vars)
320 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
321 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
324 665c255d 2023-08-04 jrmu (define (do? exp)
325 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
326 665c255d 2023-08-04 jrmu (define (do-vars exp)
327 665c255d 2023-08-04 jrmu (map car (cadr exp)))
328 665c255d 2023-08-04 jrmu (define (do-inits exp)
329 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
330 665c255d 2023-08-04 jrmu (define (do-steps exp)
331 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
332 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
333 665c255d 2023-08-04 jrmu (car var-init-step)
334 665c255d 2023-08-04 jrmu (caddr var-init-step)))
335 665c255d 2023-08-04 jrmu (cadr exp)))
336 665c255d 2023-08-04 jrmu (define (do-test exp)
337 665c255d 2023-08-04 jrmu (caaddr exp))
338 665c255d 2023-08-04 jrmu (define (do-expressions exp)
339 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
340 665c255d 2023-08-04 jrmu (caddr exp)
341 665c255d 2023-08-04 jrmu (cdaddr exp)))
342 665c255d 2023-08-04 jrmu (define (do-commands exp)
343 665c255d 2023-08-04 jrmu (cdddr exp))
344 665c255d 2023-08-04 jrmu (define (do->combination exp)
345 665c255d 2023-08-04 jrmu (make-named-let
347 665c255d 2023-08-04 jrmu (do-vars exp)
348 665c255d 2023-08-04 jrmu (do-inits exp)
351 665c255d 2023-08-04 jrmu (do-test exp)
352 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
353 665c255d 2023-08-04 jrmu (sequence->exp
354 665c255d 2023-08-04 jrmu (append (do-commands exp)
355 665c255d 2023-08-04 jrmu (list (make-application
357 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
360 665c255d 2023-08-04 jrmu ;; begin/sequence
361 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
362 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
363 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
364 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
365 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
366 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
367 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
368 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
369 665c255d 2023-08-04 jrmu (else (make-begin seq))))
370 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
371 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
372 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
373 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
374 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
376 665c255d 2023-08-04 jrmu ;; application
377 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
378 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
379 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
380 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
381 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
382 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
385 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
386 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
387 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
388 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
389 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
390 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
391 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
392 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
393 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
394 665c255d 2023-08-04 jrmu (caddr clause))
395 665c255d 2023-08-04 jrmu (define (cond->if exp)
396 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
397 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
398 665c255d 2023-08-04 jrmu (if (null? clauses)
399 665c255d 2023-08-04 jrmu 'false ; no else clause
400 665c255d 2023-08-04 jrmu (let ((first (car clauses))
401 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
402 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
403 665c255d 2023-08-04 jrmu (if (null? rest)
404 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
405 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
407 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
408 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
409 665c255d 2023-08-04 jrmu (make-application
410 665c255d 2023-08-04 jrmu (cond-extended-proc first)
411 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
412 665c255d 2023-08-04 jrmu (expand-clauses rest))
413 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
414 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
415 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
416 665c255d 2023-08-04 jrmu (define (true? x)
417 665c255d 2023-08-04 jrmu (not (eq? x false)))
418 665c255d 2023-08-04 jrmu (define (false? x)
419 665c255d 2023-08-04 jrmu (eq? x false))
421 665c255d 2023-08-04 jrmu ;; procedure
422 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
423 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
424 665c255d 2023-08-04 jrmu ;; (define (scan-out-defines body)
425 665c255d 2023-08-04 jrmu ;; (let* ((definitions (filter definition? body))
426 665c255d 2023-08-04 jrmu ;; (vars (map definition-variable definitions))
427 665c255d 2023-08-04 jrmu ;; (unassigneds (map (lambda (var) ''*unassigned*)
429 665c255d 2023-08-04 jrmu ;; (vals (map definition-value definitions))
430 665c255d 2023-08-04 jrmu ;; (assignments
431 665c255d 2023-08-04 jrmu ;; (map (lambda (var val)
432 665c255d 2023-08-04 jrmu ;; (make-assignment var val))
433 665c255d 2023-08-04 jrmu ;; vars vals))
434 665c255d 2023-08-04 jrmu ;; (exps (remove definition? body)))
435 665c255d 2023-08-04 jrmu ;; (if (null? definitions)
438 665c255d 2023-08-04 jrmu ;; (make-let vars
439 665c255d 2023-08-04 jrmu ;; unassigneds
440 665c255d 2023-08-04 jrmu ;; (append assignments exps))))))
441 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
442 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
443 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
444 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
445 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
447 665c255d 2023-08-04 jrmu ;; environment
448 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
449 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
450 665c255d 2023-08-04 jrmu (define the-empty-environment '())
451 665c255d 2023-08-04 jrmu (define (make-frame variables values)
452 665c255d 2023-08-04 jrmu (cons variables values))
453 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
454 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
455 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
456 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
457 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
458 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
459 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
460 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
461 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
462 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
463 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
464 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
465 665c255d 2023-08-04 jrmu (define (env-loop env)
466 665c255d 2023-08-04 jrmu (define (scan vars vals)
467 665c255d 2023-08-04 jrmu (cond ((null? vars)
468 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
469 665c255d 2023-08-04 jrmu ((eq? var (car vars))
470 665c255d 2023-08-04 jrmu (let ((val (car vals)))
471 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
472 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
474 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
475 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
476 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
477 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
478 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
479 665c255d 2023-08-04 jrmu (frame-values frame)))))
480 665c255d 2023-08-04 jrmu (env-loop env))
481 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
482 665c255d 2023-08-04 jrmu (define (env-loop env)
483 665c255d 2023-08-04 jrmu (define (scan vars vals)
484 665c255d 2023-08-04 jrmu (cond ((null? vars)
485 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
486 665c255d 2023-08-04 jrmu ((eq? var (car vars))
487 665c255d 2023-08-04 jrmu (set-car! vals val))
488 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
489 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
490 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
491 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
492 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
493 665c255d 2023-08-04 jrmu (frame-values frame)))))
494 665c255d 2023-08-04 jrmu (env-loop env))
495 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
496 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
497 665c255d 2023-08-04 jrmu (define (scan vars vals)
498 665c255d 2023-08-04 jrmu (cond ((null? vars)
499 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
500 665c255d 2023-08-04 jrmu ((eq? var (car vars))
501 665c255d 2023-08-04 jrmu (set-car! vals val))
502 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
503 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
504 665c255d 2023-08-04 jrmu (frame-values frame))))
506 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
507 665c255d 2023-08-04 jrmu (define (scan vars vals)
508 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
509 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
510 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
511 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
512 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
513 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
514 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
515 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
516 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
517 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
518 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
519 665c255d 2023-08-04 jrmu (scan vars vals))))
521 665c255d 2023-08-04 jrmu ;; primitives
522 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
523 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
524 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
525 665c255d 2023-08-04 jrmu (define primitive-procedures
526 665c255d 2023-08-04 jrmu (list (list 'car car)
527 665c255d 2023-08-04 jrmu (list 'cdr cdr)
528 665c255d 2023-08-04 jrmu (list 'caar caar)
529 665c255d 2023-08-04 jrmu (list 'cadr cadr)
530 665c255d 2023-08-04 jrmu (list 'cddr cddr)
531 665c255d 2023-08-04 jrmu (list 'cons cons)
532 665c255d 2023-08-04 jrmu (list 'null? null?)
533 665c255d 2023-08-04 jrmu (list '* *)
534 665c255d 2023-08-04 jrmu (list '/ /)
535 665c255d 2023-08-04 jrmu (list '+ +)
536 665c255d 2023-08-04 jrmu (list '- -)
537 665c255d 2023-08-04 jrmu (list '= =)
538 665c255d 2023-08-04 jrmu (list '< <)
539 665c255d 2023-08-04 jrmu (list '> >)
540 665c255d 2023-08-04 jrmu (list '<= <=)
541 665c255d 2023-08-04 jrmu (list '>= >=)
542 665c255d 2023-08-04 jrmu (list 'remainder remainder)
543 665c255d 2023-08-04 jrmu (list 'eq? eq?)
544 665c255d 2023-08-04 jrmu (list 'equal? equal?)
545 665c255d 2023-08-04 jrmu (list 'display display)))
546 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
548 665c255d 2023-08-04 jrmu primitive-procedures))
549 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
550 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
551 665c255d 2023-08-04 jrmu primitive-procedures))
552 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
553 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
554 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
556 665c255d 2023-08-04 jrmu ;; driver-loop
557 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
558 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
559 665c255d 2023-08-04 jrmu (define (driver-loop)
560 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
561 665c255d 2023-08-04 jrmu (let ((input (read)))
562 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
563 665c255d 2023-08-04 jrmu (announce-output output-prompt)
564 665c255d 2023-08-04 jrmu (user-print output)))
565 665c255d 2023-08-04 jrmu (driver-loop))
566 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
567 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
569 665c255d 2023-08-04 jrmu (define (announce-output string)
570 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
571 665c255d 2023-08-04 jrmu (define (user-print object)
572 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
573 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
574 665c255d 2023-08-04 jrmu (procedure-parameters object)
575 665c255d 2023-08-04 jrmu (procedure-body object)
576 665c255d 2023-08-04 jrmu '<procedure-env>))
577 665c255d 2023-08-04 jrmu (display object)))
578 665c255d 2023-08-04 jrmu (define (setup-environment)
579 665c255d 2023-08-04 jrmu (let ((initial-env
580 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
581 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
582 665c255d 2023-08-04 jrmu the-empty-environment)))
583 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
584 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
585 665c255d 2023-08-04 jrmu initial-env))
586 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
588 665c255d 2023-08-04 jrmu ;; auxiliary
589 665c255d 2023-08-04 jrmu (define (test-case actual expected)
591 665c255d 2023-08-04 jrmu (display "Actual: ")
592 665c255d 2023-08-04 jrmu (display actual)
594 665c255d 2023-08-04 jrmu (display "Expected: ")
595 665c255d 2023-08-04 jrmu (display expected)
597 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
598 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
599 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
600 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
603 665c255d 2023-08-04 jrmu ;; Exercise 4.23. Alyssa P. Hacker doesn't understand why analyze-sequence needs to be so complicated. All the other analysis procedures are straightforward transformations of the corresponding evaluation procedures (or eval clauses) in section 4.1.1. She expected analyze-sequence to look like this:
605 665c255d 2023-08-04 jrmu (define (analyze-sequence exps)
606 665c255d 2023-08-04 jrmu (define (execute-sequence procs env)
607 665c255d 2023-08-04 jrmu (cond ((null? (cdr procs)) ((car procs) env))
608 665c255d 2023-08-04 jrmu (else ((car procs) env)
609 665c255d 2023-08-04 jrmu (execute-sequence (cdr procs) env))))
610 665c255d 2023-08-04 jrmu (let ((procs (map analyze exps)))
611 665c255d 2023-08-04 jrmu (if (null? procs)
612 665c255d 2023-08-04 jrmu (error "Empty sequence -- ANALYZE"))
613 665c255d 2023-08-04 jrmu (lambda (env) (execute-sequence procs env))))
615 665c255d 2023-08-04 jrmu ;; Eva Lu Ator explains to Alyssa that the version in the text does more of the work of evaluating a sequence at analysis time. Alyssa's sequence-execution procedure, rather than having the calls to the individual execution procedures built in, loops through the procedures in order to call them: In effect, although the individual expressions in the sequence have been analyzed, the sequence itself has not been.
617 665c255d 2023-08-04 jrmu ;; Compare the two versions of analyze-sequence. For example, consider the common case (typical of procedure bodies) where the sequence has just one expression. What work will the execution procedure produced by Alyssa's program do? What about the execution procedure produced by the program in the text above? How do the two versions compare for a sequence with two expressions?
619 665c255d 2023-08-04 jrmu ;; In Alyssa's code, looping through the sequences takes place at evaluating, not during analysis
621 665c255d 2023-08-04 jrmu ;; in the code in the text, there is no looping as the applications are built right into the lambda expression:
623 665c255d 2023-08-04 jrmu (lambda (env)
624 665c255d 2023-08-04 jrmu ((lambda (env)
625 665c255d 2023-08-04 jrmu ((lambda (env)
626 665c255d 2023-08-04 jrmu (<proc1> env)
627 665c255d 2023-08-04 jrmu (<proc2> env)) env)
628 665c255d 2023-08-04 jrmu (<proc3> env))
630 665c255d 2023-08-04 jrmu (<proc4> env))
633 665c255d 2023-08-04 jrmu ;; test-suite
635 665c255d 2023-08-04 jrmu ;; procedure definitions
638 665c255d 2023-08-04 jrmu '(define (assoc key records)
639 665c255d 2023-08-04 jrmu (cond ((null? records) false)
640 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
641 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
644 665c255d 2023-08-04 jrmu '(define (map proc list)
645 665c255d 2023-08-04 jrmu (if (null? list)
647 665c255d 2023-08-04 jrmu (cons (proc (car list))
648 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
651 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
652 665c255d 2023-08-04 jrmu (if (null? sequence)
654 665c255d 2023-08-04 jrmu (op (car sequence)
655 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
657 665c255d 2023-08-04 jrmu ;; all special forms
658 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
659 665c255d 2023-08-04 jrmu (test-eval '10 10)
660 665c255d 2023-08-04 jrmu (geval '(define x 3))
661 665c255d 2023-08-04 jrmu (test-eval 'x 3)
662 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
663 665c255d 2023-08-04 jrmu (test-eval 'x -25)
664 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
665 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
666 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
667 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
668 665c255d 2023-08-04 jrmu (else 'failed))
670 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
673 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
674 665c255d 2023-08-04 jrmu (+ x y (* x y)))
675 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
679 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
680 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
681 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
682 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
683 665c255d 2023-08-04 jrmu (test-eval 'x -2)
684 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
685 665c255d 2023-08-04 jrmu (test-eval 'x -2)
686 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
687 665c255d 2023-08-04 jrmu (test-eval 'x 25)
688 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
689 665c255d 2023-08-04 jrmu (test-eval 'x 2)
690 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
691 665c255d 2023-08-04 jrmu (test-eval 'x 25)
692 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
693 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
699 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
700 665c255d 2023-08-04 jrmu (else false))
704 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
705 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
706 665c255d 2023-08-04 jrmu ((map (lambda (x)
707 665c255d 2023-08-04 jrmu (* x (+ x 1)))
708 665c255d 2023-08-04 jrmu '(2 4 1 9))
710 665c255d 2023-08-04 jrmu (lambda (x)
711 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
712 665c255d 2023-08-04 jrmu (else 'never-reach))
714 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
717 665c255d 2023-08-04 jrmu ;; procedure definition and application
719 665c255d 2023-08-04 jrmu '(define (factorial n)
720 665c255d 2023-08-04 jrmu (if (= n 0)
722 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
723 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
728 665c255d 2023-08-04 jrmu '(map (lambda (x)
729 665c255d 2023-08-04 jrmu (* x (+ x 1)))
730 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
731 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
732 665c255d 2023-08-04 jrmu ;; accumulate
735 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
738 665c255d 2023-08-04 jrmu ;; make-let
740 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
747 665c255d 2023-08-04 jrmu '(let ((x 3))
751 665c255d 2023-08-04 jrmu '(let ((x 3)
756 665c255d 2023-08-04 jrmu '(let ((x 3)
758 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
762 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
764 665c255d 2023-08-04 jrmu '(let ((x 6)
765 665c255d 2023-08-04 jrmu (y (let ((x 2))
767 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
776 665c255d 2023-08-04 jrmu '(let* ((x 3)
777 665c255d 2023-08-04 jrmu (y (+ x 2))
778 665c255d 2023-08-04 jrmu (z (+ x y 5)))
787 665c255d 2023-08-04 jrmu '(let* ((x 3))
788 665c255d 2023-08-04 jrmu (let* ((y 5))
793 665c255d 2023-08-04 jrmu '(let* ((x 3)
794 665c255d 2023-08-04 jrmu (y (+ x 1)))
795 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
799 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
801 665c255d 2023-08-04 jrmu '(let* ((x 6)
802 665c255d 2023-08-04 jrmu (y (let* ((x 2)
803 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
806 665c255d 2023-08-04 jrmu (z (+ x y)))
810 665c255d 2023-08-04 jrmu ;; named-let
813 665c255d 2023-08-04 jrmu '(let eight ()
819 665c255d 2023-08-04 jrmu '(let loop ((count 0))
820 665c255d 2023-08-04 jrmu (if (= 100 count)
822 665c255d 2023-08-04 jrmu (loop (+ count 1))))
825 665c255d 2023-08-04 jrmu '(define (prime? x)
826 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
827 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
828 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
829 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
831 665c255d 2023-08-04 jrmu '(let primes ((x 2)
833 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
834 665c255d 2023-08-04 jrmu ((prime? x)
836 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
837 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
838 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))
841 665c255d 2023-08-04 jrmu '(define (fib n)
842 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
845 665c255d 2023-08-04 jrmu (if (= count 0)
847 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
848 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
852 665c255d 2023-08-04 jrmu '(let ((y 0))
853 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
854 665c255d 2023-08-04 jrmu ((= x 5) y)
855 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
866 665c255d 2023-08-04 jrmu '(let ((y 0))
868 665c255d 2023-08-04 jrmu ((= y 5) y)
869 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
873 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
874 665c255d 2023-08-04 jrmu ((null? y))
875 665c255d 2023-08-04 jrmu (set! y (cdr y)))
878 665c255d 2023-08-04 jrmu '(let ((y 0))
879 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
880 665c255d 2023-08-04 jrmu ((= x 5) y)
881 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
884 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
885 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
886 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
887 665c255d 2023-08-04 jrmu ((null? x) sum)))
890 665c255d 2023-08-04 jrmu '(let ((z '()))
891 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
892 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
893 665c255d 2023-08-04 jrmu ((null? x) y x z)
894 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
895 665c255d 2023-08-04 jrmu '(4 3 2 1))
899 665c255d 2023-08-04 jrmu ;; make-unbound!
900 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
902 665c255d 2023-08-04 jrmu ;; (test-eval
903 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
904 665c255d 2023-08-04 jrmu ;; (let ((x 5))
905 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
906 665c255d 2023-08-04 jrmu ;; (* x x)))
909 665c255d 2023-08-04 jrmu ;; (test-eval
910 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
911 665c255d 2023-08-04 jrmu ;; (let ((x 5))
912 665c255d 2023-08-04 jrmu ;; (define y x)
913 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
914 665c255d 2023-08-04 jrmu ;; (* y x)))
917 665c255d 2023-08-04 jrmu ;; (test-eval
918 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
919 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
920 665c255d 2023-08-04 jrmu ;; (define a x)
921 665c255d 2023-08-04 jrmu ;; (define b y)
922 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
923 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
924 665c255d 2023-08-04 jrmu ;; (* a b x y)))
925 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
927 665c255d 2023-08-04 jrmu ;; (test-eval
928 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
929 665c255d 2023-08-04 jrmu ;; (let ((x 5))
930 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
931 665c255d 2023-08-04 jrmu ;; (+ x 4)))
934 665c255d 2023-08-04 jrmu ;; (test-eval
935 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
936 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
937 665c255d 2023-08-04 jrmu ;; (+ a c d))
938 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
940 665c255d 2023-08-04 jrmu ;; (test-eval
941 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
942 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
943 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
944 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
945 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
946 665c255d 2023-08-04 jrmu ;; (define z b)
947 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
948 665c255d 2023-08-04 jrmu ;; (* (+ a z)
949 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
950 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
951 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
953 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
954 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
955 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
956 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
958 665c255d 2023-08-04 jrmu ;; scan-out-defines
961 665c255d 2023-08-04 jrmu '(define (f x)
962 665c255d 2023-08-04 jrmu (define (even? n)
963 665c255d 2023-08-04 jrmu (if (= n 0)
965 665c255d 2023-08-04 jrmu (odd? (- n 1))))
966 665c255d 2023-08-04 jrmu (define (odd? n)
967 665c255d 2023-08-04 jrmu (if (= n 0)
969 665c255d 2023-08-04 jrmu (even? (- n 1))))
970 665c255d 2023-08-04 jrmu (even? x)))
971 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
972 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
975 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
976 665c255d 2023-08-04 jrmu ;; (define y x)
977 665c255d 2023-08-04 jrmu ;; (define x 3)
978 665c255d 2023-08-04 jrmu ;; (+ x y)))
979 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
984 665c255d 2023-08-04 jrmu '(define (f x)
985 665c255d 2023-08-04 jrmu (letrec ((even?
986 665c255d 2023-08-04 jrmu (lambda (n)
987 665c255d 2023-08-04 jrmu (if (= n 0)
989 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
991 665c255d 2023-08-04 jrmu (lambda (n)
992 665c255d 2023-08-04 jrmu (if (= n 0)
994 665c255d 2023-08-04 jrmu (even? (- n 1))))))
995 665c255d 2023-08-04 jrmu (even? x))))
996 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
997 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
1000 665c255d 2023-08-04 jrmu '(letrec ((fact
1001 665c255d 2023-08-04 jrmu (lambda (n)
1002 665c255d 2023-08-04 jrmu (if (= n 1)
1004 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
1005 665c255d 2023-08-04 jrmu (fact 10))
