1 665c255d 2023-08-04 jrmu ;; (define apply-in-underlying-scheme apply)
3 665c255d 2023-08-04 jrmu (define (eval exp env)
4 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
5 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
6 665c255d 2023-08-04 jrmu ((quoted? exp) (text-of-quotation exp))
7 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
8 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition exp env))
9 665c255d 2023-08-04 jrmu ;; ((unbound? exp) (eval-unbound exp env))
10 665c255d 2023-08-04 jrmu ((if? exp) (eval-if exp env))
11 665c255d 2023-08-04 jrmu ((and? exp) (eval-and exp env))
12 665c255d 2023-08-04 jrmu ((or? exp) (eval-or exp env))
13 665c255d 2023-08-04 jrmu ((lambda? exp)
14 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
15 665c255d 2023-08-04 jrmu (lambda-body exp)
17 665c255d 2023-08-04 jrmu ((begin? exp)
18 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
19 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
20 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
21 665c255d 2023-08-04 jrmu ((let*? exp) (eval (let*->nested-lets exp) env))
22 665c255d 2023-08-04 jrmu ((named-let? exp) (eval (named-let->combination exp) env))
23 665c255d 2023-08-04 jrmu ((letrec? exp) (eval (letrec->let exp) env))
24 665c255d 2023-08-04 jrmu ((do? exp) (eval (do->combination exp) env))
25 665c255d 2023-08-04 jrmu ((application? exp)
26 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
27 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
29 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
30 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
31 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
32 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
33 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
34 665c255d 2023-08-04 jrmu (eval-sequence
35 665c255d 2023-08-04 jrmu (procedure-body procedure)
36 665c255d 2023-08-04 jrmu (extend-environment
37 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
39 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
42 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
44 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
45 665c255d 2023-08-04 jrmu (if (no-operands? exps)
47 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
48 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
50 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
51 665c255d 2023-08-04 jrmu (if (pair? exp)
52 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
55 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
56 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
57 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
58 665c255d 2023-08-04 jrmu ((string? exp) true)
59 665c255d 2023-08-04 jrmu (else false)))
60 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
61 665c255d 2023-08-04 jrmu (define (quoted? exp)
62 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
63 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
65 665c255d 2023-08-04 jrmu ;; assignment/definition
66 665c255d 2023-08-04 jrmu (define (assignment? exp)
67 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
68 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
69 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
70 665c255d 2023-08-04 jrmu (define (make-assignment var val)
71 665c255d 2023-08-04 jrmu (list 'set! var val))
72 665c255d 2023-08-04 jrmu (define (definition? exp)
73 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
74 665c255d 2023-08-04 jrmu (define (definition-variable exp)
75 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
77 665c255d 2023-08-04 jrmu (caadr exp)))
78 665c255d 2023-08-04 jrmu (define (definition-value exp)
79 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
81 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
82 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
83 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
84 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
85 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
88 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
89 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
90 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
93 665c255d 2023-08-04 jrmu (define (make-definition var val)
94 665c255d 2023-08-04 jrmu `(define ,var ,val))
96 665c255d 2023-08-04 jrmu ;; make-unbound!
98 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
99 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
100 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
101 665c255d 2023-08-04 jrmu ;; (cadr exp))
102 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
103 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
107 665c255d 2023-08-04 jrmu ;; if/and/or
108 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
109 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
110 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
111 665c255d 2023-08-04 jrmu (define (if-alternative exp)
112 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
113 665c255d 2023-08-04 jrmu (cadddr exp)
115 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
116 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
117 665c255d 2023-08-04 jrmu (define (eval-if exp env)
118 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
119 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
120 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
122 665c255d 2023-08-04 jrmu (define (and? exp)
123 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
124 665c255d 2023-08-04 jrmu (define (and-clauses exp)
126 665c255d 2023-08-04 jrmu (define (or? exp)
127 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
128 665c255d 2023-08-04 jrmu (define (or-clauses exp)
130 665c255d 2023-08-04 jrmu (define (eval-and exp env)
131 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
132 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
133 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
134 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
135 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
136 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
137 665c255d 2023-08-04 jrmu (define (eval-or exp env)
138 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
139 665c255d 2023-08-04 jrmu (if (null? clauses)
141 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
142 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
143 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
146 665c255d 2023-08-04 jrmu ;; lambda/let/let*
147 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
148 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
149 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
150 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
151 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
153 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
155 665c255d 2023-08-04 jrmu (cons (map list vars vals)
157 665c255d 2023-08-04 jrmu (define (let? exp)
158 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
159 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
160 665c255d 2023-08-04 jrmu (define (let-vars exp)
161 665c255d 2023-08-04 jrmu (map car (cadr exp)))
162 665c255d 2023-08-04 jrmu (define (let-vals exp)
163 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
164 665c255d 2023-08-04 jrmu (define (let-body exp)
165 665c255d 2023-08-04 jrmu (cddr exp))
166 665c255d 2023-08-04 jrmu (define (let->combination exp)
167 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
168 665c255d 2023-08-04 jrmu (let-vals exp)))
169 665c255d 2023-08-04 jrmu (define (named-let? exp)
170 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
171 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
172 665c255d 2023-08-04 jrmu (define (named-let-name exp)
173 665c255d 2023-08-04 jrmu (cadr exp))
174 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
175 665c255d 2023-08-04 jrmu (map car (caddr exp)))
176 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
177 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
178 665c255d 2023-08-04 jrmu (define (named-let-body exp)
179 665c255d 2023-08-04 jrmu (cdddr exp))
180 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
181 665c255d 2023-08-04 jrmu (sequence->exp
182 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
183 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
184 665c255d 2023-08-04 jrmu (named-let-body exp)))
185 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
186 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
187 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
190 665c255d 2023-08-04 jrmu (cons (map list vars vals)
193 665c255d 2023-08-04 jrmu (define (make-application op args)
194 665c255d 2023-08-04 jrmu (cons op args))
196 665c255d 2023-08-04 jrmu (define (let*? exp)
197 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
198 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
199 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
200 665c255d 2023-08-04 jrmu (define let*-body let-body)
201 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
202 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
203 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
204 665c255d 2023-08-04 jrmu (make-let (list (car vars))
205 665c255d 2023-08-04 jrmu (list (car vals))
206 665c255d 2023-08-04 jrmu (let*-body exp))
207 665c255d 2023-08-04 jrmu (make-let (list (car vars))
208 665c255d 2023-08-04 jrmu (list (car vals))
209 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
210 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
211 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
212 665c255d 2023-08-04 jrmu (if (null? vars)
213 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
214 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
217 665c255d 2023-08-04 jrmu (define (do? exp)
218 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
219 665c255d 2023-08-04 jrmu (define (do-vars exp)
220 665c255d 2023-08-04 jrmu (map car (cadr exp)))
221 665c255d 2023-08-04 jrmu (define (do-inits exp)
222 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
223 665c255d 2023-08-04 jrmu (define (do-steps exp)
224 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
225 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
226 665c255d 2023-08-04 jrmu (car var-init-step)
227 665c255d 2023-08-04 jrmu (caddr var-init-step)))
228 665c255d 2023-08-04 jrmu (cadr exp)))
229 665c255d 2023-08-04 jrmu (define (do-test exp)
230 665c255d 2023-08-04 jrmu (caaddr exp))
231 665c255d 2023-08-04 jrmu (define (do-expressions exp)
232 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
233 665c255d 2023-08-04 jrmu (caddr exp)
234 665c255d 2023-08-04 jrmu (cdaddr exp)))
235 665c255d 2023-08-04 jrmu (define (do-commands exp)
236 665c255d 2023-08-04 jrmu (cdddr exp))
237 665c255d 2023-08-04 jrmu (define (do->combination exp)
238 665c255d 2023-08-04 jrmu (make-named-let
240 665c255d 2023-08-04 jrmu (do-vars exp)
241 665c255d 2023-08-04 jrmu (do-inits exp)
244 665c255d 2023-08-04 jrmu (do-test exp)
245 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
246 665c255d 2023-08-04 jrmu (sequence->exp
247 665c255d 2023-08-04 jrmu (append (do-commands exp)
248 665c255d 2023-08-04 jrmu (list (make-application
250 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
253 665c255d 2023-08-04 jrmu ;; begin/sequence
254 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
255 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
256 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
257 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
258 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
259 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
260 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
261 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
262 665c255d 2023-08-04 jrmu (else (make-begin seq))))
263 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
264 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
265 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
266 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
267 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
269 665c255d 2023-08-04 jrmu ;; application
270 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
271 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
272 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
273 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
274 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
275 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
278 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
279 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
280 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
281 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
282 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
283 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
284 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
285 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
286 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
287 665c255d 2023-08-04 jrmu (caddr clause))
288 665c255d 2023-08-04 jrmu (define (cond->if exp)
289 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
290 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
291 665c255d 2023-08-04 jrmu (if (null? clauses)
292 665c255d 2023-08-04 jrmu 'false ; no else clause
293 665c255d 2023-08-04 jrmu (let ((first (car clauses))
294 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
295 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
296 665c255d 2023-08-04 jrmu (if (null? rest)
297 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
298 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
300 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
301 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
302 665c255d 2023-08-04 jrmu (make-application
303 665c255d 2023-08-04 jrmu (cond-extended-proc first)
304 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
305 665c255d 2023-08-04 jrmu (expand-clauses rest))
306 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
307 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
308 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
309 665c255d 2023-08-04 jrmu (define (true? x)
310 665c255d 2023-08-04 jrmu (not (eq? x false)))
311 665c255d 2023-08-04 jrmu (define (false? x)
312 665c255d 2023-08-04 jrmu (eq? x false))
314 665c255d 2023-08-04 jrmu ;; procedure
315 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
316 665c255d 2023-08-04 jrmu (list 'procedure parameters (scan-out-defines body) env))
317 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
318 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
319 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
320 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
322 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
323 665c255d 2023-08-04 jrmu (assignments
324 665c255d 2023-08-04 jrmu (map (lambda (var val)
325 665c255d 2023-08-04 jrmu (make-assignment var val))
326 665c255d 2023-08-04 jrmu vars vals))
327 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
328 665c255d 2023-08-04 jrmu (if (null? definitions)
331 665c255d 2023-08-04 jrmu (make-let vars
332 665c255d 2023-08-04 jrmu unassigneds
333 665c255d 2023-08-04 jrmu (append assignments exps))))))
334 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
335 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
336 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
337 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
338 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
340 665c255d 2023-08-04 jrmu ;; environment
341 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
342 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
343 665c255d 2023-08-04 jrmu (define the-empty-environment '())
344 665c255d 2023-08-04 jrmu (define (make-frame variables values)
345 665c255d 2023-08-04 jrmu (cons variables values))
346 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
347 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
348 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
349 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
350 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
351 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
352 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
353 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
354 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
355 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
356 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
357 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
358 665c255d 2023-08-04 jrmu (define (env-loop env)
359 665c255d 2023-08-04 jrmu (define (scan vars vals)
360 665c255d 2023-08-04 jrmu (cond ((null? vars)
361 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
362 665c255d 2023-08-04 jrmu ((eq? var (car vars))
363 665c255d 2023-08-04 jrmu (let ((val (car vals)))
364 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
365 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
367 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
368 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
369 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
370 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
371 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
372 665c255d 2023-08-04 jrmu (frame-values frame)))))
373 665c255d 2023-08-04 jrmu (env-loop env))
374 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
375 665c255d 2023-08-04 jrmu (define (env-loop env)
376 665c255d 2023-08-04 jrmu (define (scan vars vals)
377 665c255d 2023-08-04 jrmu (cond ((null? vars)
378 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
379 665c255d 2023-08-04 jrmu ((eq? var (car vars))
380 665c255d 2023-08-04 jrmu (set-car! vals val))
381 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
382 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
383 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
384 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
385 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
386 665c255d 2023-08-04 jrmu (frame-values frame)))))
387 665c255d 2023-08-04 jrmu (env-loop env))
388 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
389 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
390 665c255d 2023-08-04 jrmu (define (scan vars vals)
391 665c255d 2023-08-04 jrmu (cond ((null? vars)
392 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
393 665c255d 2023-08-04 jrmu ((eq? var (car vars))
394 665c255d 2023-08-04 jrmu (set-car! vals val))
395 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
396 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
397 665c255d 2023-08-04 jrmu (frame-values frame))))
399 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
400 665c255d 2023-08-04 jrmu (define (scan vars vals)
401 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
402 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
403 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
404 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
405 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
406 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
407 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
408 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
409 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
410 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
411 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
412 665c255d 2023-08-04 jrmu (scan vars vals))))
414 665c255d 2023-08-04 jrmu ;; primitives
415 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
416 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
417 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
418 665c255d 2023-08-04 jrmu (define primitive-procedures
419 665c255d 2023-08-04 jrmu (list (list 'car car)
420 665c255d 2023-08-04 jrmu (list 'cdr cdr)
421 665c255d 2023-08-04 jrmu (list 'caar caar)
422 665c255d 2023-08-04 jrmu (list 'cadr cadr)
423 665c255d 2023-08-04 jrmu (list 'cddr cddr)
424 665c255d 2023-08-04 jrmu (list 'cons cons)
425 665c255d 2023-08-04 jrmu (list 'null? null?)
426 665c255d 2023-08-04 jrmu (list '* *)
427 665c255d 2023-08-04 jrmu (list '/ /)
428 665c255d 2023-08-04 jrmu (list '+ +)
429 665c255d 2023-08-04 jrmu (list '- -)
430 665c255d 2023-08-04 jrmu (list '= =)
431 665c255d 2023-08-04 jrmu (list '< <)
432 665c255d 2023-08-04 jrmu (list '> >)
433 665c255d 2023-08-04 jrmu (list '<= <=)
434 665c255d 2023-08-04 jrmu (list '>= >=)
435 665c255d 2023-08-04 jrmu (list 'remainder remainder)
436 665c255d 2023-08-04 jrmu (list 'eq? eq?)
437 665c255d 2023-08-04 jrmu (list 'equal? equal?)
438 665c255d 2023-08-04 jrmu (list 'display display)))
439 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
441 665c255d 2023-08-04 jrmu primitive-procedures))
442 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
443 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
444 665c255d 2023-08-04 jrmu primitive-procedures))
445 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
446 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
447 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
449 665c255d 2023-08-04 jrmu ;; driver-loop
450 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
451 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
452 665c255d 2023-08-04 jrmu (define (driver-loop)
453 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
454 665c255d 2023-08-04 jrmu (let ((input (read)))
455 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
456 665c255d 2023-08-04 jrmu (announce-output output-prompt)
457 665c255d 2023-08-04 jrmu (user-print output)))
458 665c255d 2023-08-04 jrmu (driver-loop))
459 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
460 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
462 665c255d 2023-08-04 jrmu (define (announce-output string)
463 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
464 665c255d 2023-08-04 jrmu (define (user-print object)
465 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
466 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
467 665c255d 2023-08-04 jrmu (procedure-parameters object)
468 665c255d 2023-08-04 jrmu (procedure-body object)
469 665c255d 2023-08-04 jrmu '<procedure-env>))
470 665c255d 2023-08-04 jrmu (display object)))
471 665c255d 2023-08-04 jrmu (define (setup-environment)
472 665c255d 2023-08-04 jrmu (let ((initial-env
473 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
474 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
475 665c255d 2023-08-04 jrmu the-empty-environment)))
476 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
477 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
478 665c255d 2023-08-04 jrmu initial-env))
479 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
481 665c255d 2023-08-04 jrmu ;; auxiliary
482 665c255d 2023-08-04 jrmu (define (test-case actual expected)
484 665c255d 2023-08-04 jrmu (display "Actual: ")
485 665c255d 2023-08-04 jrmu (display actual)
487 665c255d 2023-08-04 jrmu (display "Expected: ")
488 665c255d 2023-08-04 jrmu (display expected)
490 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
491 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
492 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
493 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
497 665c255d 2023-08-04 jrmu ;; Exercise 4.20. Because internal definitions look sequential but are actually simultaneous, some people prefer to avoid them entirely, and use the special form letrec instead. Letrec looks like let, so it is not surprising that the variables it binds are bound simultaneously and have the same scope as each other. The sample procedure f above can be written without internal definitions, but with exactly the same meaning, as
499 665c255d 2023-08-04 jrmu ;; (define (f x)
500 665c255d 2023-08-04 jrmu ;; (letrec ((even?
501 665c255d 2023-08-04 jrmu ;; (lambda (n)
502 665c255d 2023-08-04 jrmu ;; (if (= n 0)
504 665c255d 2023-08-04 jrmu ;; (odd? (- n 1)))))
506 665c255d 2023-08-04 jrmu ;; (lambda (n)
507 665c255d 2023-08-04 jrmu ;; (if (= n 0)
509 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))))
510 665c255d 2023-08-04 jrmu ;; <rest of body of f>))
512 665c255d 2023-08-04 jrmu ;; Letrec expressions, which have the form
514 665c255d 2023-08-04 jrmu ;; (letrec ((<var1> <exp1>) ... (<varn> <expn>))
517 665c255d 2023-08-04 jrmu ;; are a variation on let in which the expressions <expk> that provide the initial values for the variables <vark> are evaluated in an environment that includes all the letrec bindings. This permits recursion in the bindings, such as the mutual recursion of even? and odd? in the example above, or the evaluation of 10 factorial with
519 665c255d 2023-08-04 jrmu ;; (letrec ((fact
520 665c255d 2023-08-04 jrmu ;; (lambda (n)
521 665c255d 2023-08-04 jrmu ;; (if (= n 1)
523 665c255d 2023-08-04 jrmu ;; (* n (fact (- n 1)))))))
524 665c255d 2023-08-04 jrmu ;; (fact 10))
527 665c255d 2023-08-04 jrmu ;; a. Implement letrec as a derived expression, by transforming a letrec expression into a let expression as shown in the text above or in exercise 4.18. That is, the letrec variables should be created with a let and then be assigned their values with set!.
529 665c255d 2023-08-04 jrmu ;; the two definitions above can be transformed to the following
531 665c255d 2023-08-04 jrmu ;; (let ((fact '*unassigned*))
532 665c255d 2023-08-04 jrmu ;; (set! fact (lambda (n)
533 665c255d 2023-08-04 jrmu ;; (if (= n 1)
535 665c255d 2023-08-04 jrmu ;; (* n (fact (- n 1))))))
536 665c255d 2023-08-04 jrmu ;; (fact 10))
538 665c255d 2023-08-04 jrmu ;; (define (f x)
539 665c255d 2023-08-04 jrmu ;; (let ((even? '*unassigned*)
540 665c255d 2023-08-04 jrmu ;; (odd? '*unassigned*))
541 665c255d 2023-08-04 jrmu ;; (set! even? (lambda (n)
542 665c255d 2023-08-04 jrmu ;; (if (= n 0)
544 665c255d 2023-08-04 jrmu ;; (odd? (- n 1)))))
545 665c255d 2023-08-04 jrmu ;; (set! odd? (lambda (n)
546 665c255d 2023-08-04 jrmu ;; (if (= n 0)
548 665c255d 2023-08-04 jrmu ;; (even? (- n 1)))))
549 665c255d 2023-08-04 jrmu ;; <rest of body of f>))
551 665c255d 2023-08-04 jrmu (define (letrec? exp)
552 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
554 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
555 665c255d 2023-08-04 jrmu (map car (cadr exp)))
556 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
557 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
558 665c255d 2023-08-04 jrmu (define (letrec-body exp)
559 665c255d 2023-08-04 jrmu (cddr exp))
560 665c255d 2023-08-04 jrmu (define (letrec->let exp)
561 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
562 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
564 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
565 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
566 665c255d 2023-08-04 jrmu (make-assignment var val))
569 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
570 665c255d 2023-08-04 jrmu (make-let vars
571 665c255d 2023-08-04 jrmu unassigneds
572 665c255d 2023-08-04 jrmu (append assignments body))))
577 665c255d 2023-08-04 jrmu ;; b. Louis Reasoner is confused by all this fuss about internal definitions. The way he sees it, if you don't like to use define inside a procedure, you can just use let. Illustrate what is loose about his reasoning by drawing an environment diagram that shows the environment in which the <rest of body of f> is evaluated during evaluation of the expression (f 5), with f defined as in this exercise. Draw an environment diagram for the same evaluation, but with let in place of letrec in the definition of f.
585 665c255d 2023-08-04 jrmu ;; test-suite
587 665c255d 2023-08-04 jrmu ;; procedure definitions
590 665c255d 2023-08-04 jrmu '(define (assoc key records)
591 665c255d 2023-08-04 jrmu (cond ((null? records) false)
592 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
593 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
596 665c255d 2023-08-04 jrmu '(define (map proc list)
597 665c255d 2023-08-04 jrmu (if (null? list)
599 665c255d 2023-08-04 jrmu (cons (proc (car list))
600 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
603 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
604 665c255d 2023-08-04 jrmu (if (null? sequence)
606 665c255d 2023-08-04 jrmu (op (car sequence)
607 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
609 665c255d 2023-08-04 jrmu ;; all special forms
610 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
611 665c255d 2023-08-04 jrmu (test-eval '10 10)
612 665c255d 2023-08-04 jrmu (geval '(define x 3))
613 665c255d 2023-08-04 jrmu (test-eval 'x 3)
614 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
615 665c255d 2023-08-04 jrmu (test-eval 'x -25)
616 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
617 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
618 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
619 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
620 665c255d 2023-08-04 jrmu (else 'failed))
622 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
624 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
625 665c255d 2023-08-04 jrmu (+ x y (* x y)))
626 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
630 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
631 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
632 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
633 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
634 665c255d 2023-08-04 jrmu (test-eval 'x -2)
635 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
636 665c255d 2023-08-04 jrmu (test-eval 'x -2)
637 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
638 665c255d 2023-08-04 jrmu (test-eval 'x 25)
639 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
640 665c255d 2023-08-04 jrmu (test-eval 'x 2)
641 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
642 665c255d 2023-08-04 jrmu (test-eval 'x 25)
643 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
644 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
650 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
651 665c255d 2023-08-04 jrmu (else false))
655 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
656 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
657 665c255d 2023-08-04 jrmu ((map (lambda (x)
658 665c255d 2023-08-04 jrmu (* x (+ x 1)))
659 665c255d 2023-08-04 jrmu '(2 4 1 9))
661 665c255d 2023-08-04 jrmu (lambda (x)
662 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
663 665c255d 2023-08-04 jrmu (else 'never-reach))
665 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
668 665c255d 2023-08-04 jrmu ;; procedure definition and application
670 665c255d 2023-08-04 jrmu '(define (factorial n)
671 665c255d 2023-08-04 jrmu (if (= n 0)
673 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
674 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
679 665c255d 2023-08-04 jrmu '(map (lambda (x)
680 665c255d 2023-08-04 jrmu (* x (+ x 1)))
681 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
682 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
683 665c255d 2023-08-04 jrmu ;; accumulate
686 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
689 665c255d 2023-08-04 jrmu ;; make-let
691 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
698 665c255d 2023-08-04 jrmu '(let ((x 3))
702 665c255d 2023-08-04 jrmu '(let ((x 3)
707 665c255d 2023-08-04 jrmu '(let ((x 3)
709 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
713 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
715 665c255d 2023-08-04 jrmu '(let ((x 6)
716 665c255d 2023-08-04 jrmu (y (let ((x 2))
718 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
727 665c255d 2023-08-04 jrmu '(let* ((x 3)
728 665c255d 2023-08-04 jrmu (y (+ x 2))
729 665c255d 2023-08-04 jrmu (z (+ x y 5)))
738 665c255d 2023-08-04 jrmu '(let* ((x 3))
739 665c255d 2023-08-04 jrmu (let* ((y 5))
744 665c255d 2023-08-04 jrmu '(let* ((x 3)
745 665c255d 2023-08-04 jrmu (y (+ x 1)))
746 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
750 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
752 665c255d 2023-08-04 jrmu '(let* ((x 6)
753 665c255d 2023-08-04 jrmu (y (let* ((x 2)
754 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
757 665c255d 2023-08-04 jrmu (z (+ x y)))
761 665c255d 2023-08-04 jrmu ;; named-let
764 665c255d 2023-08-04 jrmu '(let eight ()
770 665c255d 2023-08-04 jrmu '(let loop ((count 0))
771 665c255d 2023-08-04 jrmu (if (= 100 count)
773 665c255d 2023-08-04 jrmu (loop (+ count 1))))
776 665c255d 2023-08-04 jrmu '(define (prime? x)
777 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
778 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
779 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
780 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
782 665c255d 2023-08-04 jrmu '(let primes ((x 2)
784 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
785 665c255d 2023-08-04 jrmu ((prime? x)
787 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
788 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
789 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))
792 665c255d 2023-08-04 jrmu '(define (fib n)
793 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
796 665c255d 2023-08-04 jrmu (if (= count 0)
798 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
799 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
803 665c255d 2023-08-04 jrmu '(let ((y 0))
804 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
805 665c255d 2023-08-04 jrmu ((= x 5) y)
806 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
817 665c255d 2023-08-04 jrmu '(let ((y 0))
819 665c255d 2023-08-04 jrmu ((= y 5) y)
820 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
824 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
825 665c255d 2023-08-04 jrmu ((null? y))
826 665c255d 2023-08-04 jrmu (set! y (cdr y)))
829 665c255d 2023-08-04 jrmu '(let ((y 0))
830 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
831 665c255d 2023-08-04 jrmu ((= x 5) y)
832 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
835 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
836 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
837 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
838 665c255d 2023-08-04 jrmu ((null? x) sum)))
841 665c255d 2023-08-04 jrmu '(let ((z '()))
842 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
843 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
844 665c255d 2023-08-04 jrmu ((null? x) y x z)
845 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
846 665c255d 2023-08-04 jrmu '(4 3 2 1))
850 665c255d 2023-08-04 jrmu ;; make-unbound!
851 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
853 665c255d 2023-08-04 jrmu ;; (test-eval
854 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
855 665c255d 2023-08-04 jrmu ;; (let ((x 5))
856 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
857 665c255d 2023-08-04 jrmu ;; (* x x)))
860 665c255d 2023-08-04 jrmu ;; (test-eval
861 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
862 665c255d 2023-08-04 jrmu ;; (let ((x 5))
863 665c255d 2023-08-04 jrmu ;; (define y x)
864 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
865 665c255d 2023-08-04 jrmu ;; (* y x)))
868 665c255d 2023-08-04 jrmu ;; (test-eval
869 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
870 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
871 665c255d 2023-08-04 jrmu ;; (define a x)
872 665c255d 2023-08-04 jrmu ;; (define b y)
873 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
874 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
875 665c255d 2023-08-04 jrmu ;; (* a b x y)))
876 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
878 665c255d 2023-08-04 jrmu ;; (test-eval
879 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
880 665c255d 2023-08-04 jrmu ;; (let ((x 5))
881 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
882 665c255d 2023-08-04 jrmu ;; (+ x 4)))
885 665c255d 2023-08-04 jrmu ;; (test-eval
886 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
887 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
888 665c255d 2023-08-04 jrmu ;; (+ a c d))
889 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
891 665c255d 2023-08-04 jrmu ;; (test-eval
892 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
893 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
894 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
895 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
896 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
897 665c255d 2023-08-04 jrmu ;; (define z b)
898 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
899 665c255d 2023-08-04 jrmu ;; (* (+ a z)
900 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
901 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
902 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
904 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
905 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
906 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
907 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
909 665c255d 2023-08-04 jrmu ;; scan-out-defines
912 665c255d 2023-08-04 jrmu '(define (f x)
913 665c255d 2023-08-04 jrmu (define (even? n)
914 665c255d 2023-08-04 jrmu (if (= n 0)
916 665c255d 2023-08-04 jrmu (odd? (- n 1))))
917 665c255d 2023-08-04 jrmu (define (odd? n)
918 665c255d 2023-08-04 jrmu (if (= n 0)
920 665c255d 2023-08-04 jrmu (even? (- n 1))))
921 665c255d 2023-08-04 jrmu (even? x)))
922 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
923 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
926 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
927 665c255d 2023-08-04 jrmu ;; (define y x)
928 665c255d 2023-08-04 jrmu ;; (define x 3)
929 665c255d 2023-08-04 jrmu ;; (+ x y)))
930 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
935 665c255d 2023-08-04 jrmu '(define (f x)
936 665c255d 2023-08-04 jrmu (letrec ((even?
937 665c255d 2023-08-04 jrmu (lambda (n)
938 665c255d 2023-08-04 jrmu (if (= n 0)
940 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
942 665c255d 2023-08-04 jrmu (lambda (n)
943 665c255d 2023-08-04 jrmu (if (= n 0)
945 665c255d 2023-08-04 jrmu (even? (- n 1))))))
946 665c255d 2023-08-04 jrmu (even? x))))
947 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
948 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
951 665c255d 2023-08-04 jrmu '(letrec ((fact
952 665c255d 2023-08-04 jrmu (lambda (n)
953 665c255d 2023-08-04 jrmu (if (= n 1)
955 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
