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*/letrec
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 (letrec? exp)
194 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
196 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
197 665c255d 2023-08-04 jrmu (map car (cadr exp)))
198 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
199 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
200 665c255d 2023-08-04 jrmu (define (letrec-body exp)
201 665c255d 2023-08-04 jrmu (cddr exp))
202 665c255d 2023-08-04 jrmu (define (letrec->let exp)
203 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
204 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
206 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
207 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
208 665c255d 2023-08-04 jrmu (make-assignment var val))
211 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
212 665c255d 2023-08-04 jrmu (make-let vars
213 665c255d 2023-08-04 jrmu unassigneds
214 665c255d 2023-08-04 jrmu (append assignments body))))
219 665c255d 2023-08-04 jrmu (define (make-application op args)
220 665c255d 2023-08-04 jrmu (cons op args))
222 665c255d 2023-08-04 jrmu (define (let*? exp)
223 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
224 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
225 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
226 665c255d 2023-08-04 jrmu (define let*-body let-body)
227 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
228 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
229 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
230 665c255d 2023-08-04 jrmu (make-let (list (car vars))
231 665c255d 2023-08-04 jrmu (list (car vals))
232 665c255d 2023-08-04 jrmu (let*-body exp))
233 665c255d 2023-08-04 jrmu (make-let (list (car vars))
234 665c255d 2023-08-04 jrmu (list (car vals))
235 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
236 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
237 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
238 665c255d 2023-08-04 jrmu (if (null? vars)
239 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
240 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
243 665c255d 2023-08-04 jrmu (define (do? exp)
244 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
245 665c255d 2023-08-04 jrmu (define (do-vars exp)
246 665c255d 2023-08-04 jrmu (map car (cadr exp)))
247 665c255d 2023-08-04 jrmu (define (do-inits exp)
248 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
249 665c255d 2023-08-04 jrmu (define (do-steps exp)
250 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
251 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
252 665c255d 2023-08-04 jrmu (car var-init-step)
253 665c255d 2023-08-04 jrmu (caddr var-init-step)))
254 665c255d 2023-08-04 jrmu (cadr exp)))
255 665c255d 2023-08-04 jrmu (define (do-test exp)
256 665c255d 2023-08-04 jrmu (caaddr exp))
257 665c255d 2023-08-04 jrmu (define (do-expressions exp)
258 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
259 665c255d 2023-08-04 jrmu (caddr exp)
260 665c255d 2023-08-04 jrmu (cdaddr exp)))
261 665c255d 2023-08-04 jrmu (define (do-commands exp)
262 665c255d 2023-08-04 jrmu (cdddr exp))
263 665c255d 2023-08-04 jrmu (define (do->combination exp)
264 665c255d 2023-08-04 jrmu (make-named-let
266 665c255d 2023-08-04 jrmu (do-vars exp)
267 665c255d 2023-08-04 jrmu (do-inits exp)
270 665c255d 2023-08-04 jrmu (do-test exp)
271 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
272 665c255d 2023-08-04 jrmu (sequence->exp
273 665c255d 2023-08-04 jrmu (append (do-commands exp)
274 665c255d 2023-08-04 jrmu (list (make-application
276 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
279 665c255d 2023-08-04 jrmu ;; begin/sequence
280 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
281 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
282 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
283 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
284 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
285 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
286 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
287 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
288 665c255d 2023-08-04 jrmu (else (make-begin seq))))
289 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
290 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
291 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
292 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
293 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
295 665c255d 2023-08-04 jrmu ;; application
296 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
297 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
298 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
299 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
300 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
301 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
304 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
305 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
306 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
307 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
308 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
309 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
310 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
311 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
312 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
313 665c255d 2023-08-04 jrmu (caddr clause))
314 665c255d 2023-08-04 jrmu (define (cond->if exp)
315 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
316 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
317 665c255d 2023-08-04 jrmu (if (null? clauses)
318 665c255d 2023-08-04 jrmu 'false ; no else clause
319 665c255d 2023-08-04 jrmu (let ((first (car clauses))
320 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
321 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
322 665c255d 2023-08-04 jrmu (if (null? rest)
323 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
324 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
326 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
327 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
328 665c255d 2023-08-04 jrmu (make-application
329 665c255d 2023-08-04 jrmu (cond-extended-proc first)
330 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
331 665c255d 2023-08-04 jrmu (expand-clauses rest))
332 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
333 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
334 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
335 665c255d 2023-08-04 jrmu (define (true? x)
336 665c255d 2023-08-04 jrmu (not (eq? x false)))
337 665c255d 2023-08-04 jrmu (define (false? x)
338 665c255d 2023-08-04 jrmu (eq? x false))
340 665c255d 2023-08-04 jrmu ;; procedure
341 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
342 665c255d 2023-08-04 jrmu (list 'procedure parameters (scan-out-defines body) env))
343 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
344 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
345 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
346 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
348 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
349 665c255d 2023-08-04 jrmu (assignments
350 665c255d 2023-08-04 jrmu (map (lambda (var val)
351 665c255d 2023-08-04 jrmu (make-assignment var val))
352 665c255d 2023-08-04 jrmu vars vals))
353 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
354 665c255d 2023-08-04 jrmu (if (null? definitions)
357 665c255d 2023-08-04 jrmu (make-let vars
358 665c255d 2023-08-04 jrmu unassigneds
359 665c255d 2023-08-04 jrmu (append assignments exps))))))
360 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
361 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
362 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
363 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
364 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
366 665c255d 2023-08-04 jrmu ;; environment
367 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
368 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
369 665c255d 2023-08-04 jrmu (define the-empty-environment '())
370 665c255d 2023-08-04 jrmu (define (make-frame variables values)
371 665c255d 2023-08-04 jrmu (cons variables values))
372 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
373 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
374 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
375 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
376 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
377 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
378 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
379 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
380 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
381 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
382 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
383 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
384 665c255d 2023-08-04 jrmu (define (env-loop env)
385 665c255d 2023-08-04 jrmu (define (scan vars vals)
386 665c255d 2023-08-04 jrmu (cond ((null? vars)
387 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
388 665c255d 2023-08-04 jrmu ((eq? var (car vars))
389 665c255d 2023-08-04 jrmu (let ((val (car vals)))
390 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
391 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
393 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
394 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
395 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
396 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
397 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
398 665c255d 2023-08-04 jrmu (frame-values frame)))))
399 665c255d 2023-08-04 jrmu (env-loop env))
400 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
401 665c255d 2023-08-04 jrmu (define (env-loop env)
402 665c255d 2023-08-04 jrmu (define (scan vars vals)
403 665c255d 2023-08-04 jrmu (cond ((null? vars)
404 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
405 665c255d 2023-08-04 jrmu ((eq? var (car vars))
406 665c255d 2023-08-04 jrmu (set-car! vals val))
407 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
408 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
409 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
410 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
411 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
412 665c255d 2023-08-04 jrmu (frame-values frame)))))
413 665c255d 2023-08-04 jrmu (env-loop env))
414 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
415 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
416 665c255d 2023-08-04 jrmu (define (scan vars vals)
417 665c255d 2023-08-04 jrmu (cond ((null? vars)
418 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
419 665c255d 2023-08-04 jrmu ((eq? var (car vars))
420 665c255d 2023-08-04 jrmu (set-car! vals val))
421 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
422 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
423 665c255d 2023-08-04 jrmu (frame-values frame))))
425 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
426 665c255d 2023-08-04 jrmu (define (scan vars vals)
427 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
428 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
429 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
430 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
431 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
432 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
433 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
434 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
435 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
436 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
437 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
438 665c255d 2023-08-04 jrmu (scan vars vals))))
440 665c255d 2023-08-04 jrmu ;; primitives
441 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
442 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
443 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
444 665c255d 2023-08-04 jrmu (define primitive-procedures
445 665c255d 2023-08-04 jrmu (list (list 'car car)
446 665c255d 2023-08-04 jrmu (list 'cdr cdr)
447 665c255d 2023-08-04 jrmu (list 'caar caar)
448 665c255d 2023-08-04 jrmu (list 'cadr cadr)
449 665c255d 2023-08-04 jrmu (list 'cddr cddr)
450 665c255d 2023-08-04 jrmu (list 'cons cons)
451 665c255d 2023-08-04 jrmu (list 'null? null?)
452 665c255d 2023-08-04 jrmu (list '* *)
453 665c255d 2023-08-04 jrmu (list '/ /)
454 665c255d 2023-08-04 jrmu (list '+ +)
455 665c255d 2023-08-04 jrmu (list '- -)
456 665c255d 2023-08-04 jrmu (list '= =)
457 665c255d 2023-08-04 jrmu (list '< <)
458 665c255d 2023-08-04 jrmu (list '> >)
459 665c255d 2023-08-04 jrmu (list '<= <=)
460 665c255d 2023-08-04 jrmu (list '>= >=)
461 665c255d 2023-08-04 jrmu (list 'remainder remainder)
462 665c255d 2023-08-04 jrmu (list 'eq? eq?)
463 665c255d 2023-08-04 jrmu (list 'equal? equal?)
464 665c255d 2023-08-04 jrmu (list 'display display)))
465 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
467 665c255d 2023-08-04 jrmu primitive-procedures))
468 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
469 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
470 665c255d 2023-08-04 jrmu primitive-procedures))
471 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
472 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
473 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
475 665c255d 2023-08-04 jrmu ;; driver-loop
476 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
477 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
478 665c255d 2023-08-04 jrmu (define (driver-loop)
479 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
480 665c255d 2023-08-04 jrmu (let ((input (read)))
481 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
482 665c255d 2023-08-04 jrmu (announce-output output-prompt)
483 665c255d 2023-08-04 jrmu (user-print output)))
484 665c255d 2023-08-04 jrmu (driver-loop))
485 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
486 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
488 665c255d 2023-08-04 jrmu (define (announce-output string)
489 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
490 665c255d 2023-08-04 jrmu (define (user-print object)
491 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
492 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
493 665c255d 2023-08-04 jrmu (procedure-parameters object)
494 665c255d 2023-08-04 jrmu (procedure-body object)
495 665c255d 2023-08-04 jrmu '<procedure-env>))
496 665c255d 2023-08-04 jrmu (display object)))
497 665c255d 2023-08-04 jrmu (define (setup-environment)
498 665c255d 2023-08-04 jrmu (let ((initial-env
499 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
500 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
501 665c255d 2023-08-04 jrmu the-empty-environment)))
502 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
503 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
504 665c255d 2023-08-04 jrmu initial-env))
505 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
507 665c255d 2023-08-04 jrmu ;; auxiliary
508 665c255d 2023-08-04 jrmu (define (test-case actual expected)
510 665c255d 2023-08-04 jrmu (display "Actual: ")
511 665c255d 2023-08-04 jrmu (display actual)
513 665c255d 2023-08-04 jrmu (display "Expected: ")
514 665c255d 2023-08-04 jrmu (display expected)
516 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
517 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
518 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
519 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
523 665c255d 2023-08-04 jrmu ;; Exercise 4.21. Amazingly, Louis's intuition in exercise 4.20 is correct. It is indeed possible to specify recursive procedures without using letrec (or even define), although the method for accomplishing this is much more subtle than Louis imagined. The following expression computes 10 factorial by applying a recursive factorial procedure:
525 665c255d 2023-08-04 jrmu ((lambda (n)
526 665c255d 2023-08-04 jrmu ((lambda (fact)
527 665c255d 2023-08-04 jrmu (fact fact n))
528 665c255d 2023-08-04 jrmu (lambda (ft k)
529 665c255d 2023-08-04 jrmu (if (= k 1)
531 665c255d 2023-08-04 jrmu (* k (ft ft (- k 1)))))))
534 665c255d 2023-08-04 jrmu ;; a. Check (by evaluating the expression) that this really does compute factorials. Devise an analogous expression for computing Fibonacci numbers.
537 665c255d 2023-08-04 jrmu ;; ((lambda (n)
538 665c255d 2023-08-04 jrmu ;; ((lambda (fact)
539 665c255d 2023-08-04 jrmu ;; (fact fact n))
540 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
541 665c255d 2023-08-04 jrmu ;; (if (= k 1)
543 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))))
546 665c255d 2023-08-04 jrmu ;; ((lambda (fact)
547 665c255d 2023-08-04 jrmu ;; (fact fact 10))
548 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
549 665c255d 2023-08-04 jrmu ;; (if (= k 1)
551 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1))))))
553 665c255d 2023-08-04 jrmu ;; ((lambda (ft k)
554 665c255d 2023-08-04 jrmu ;; (if (= k 1)
556 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
557 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
558 665c255d 2023-08-04 jrmu ;; (if (= k 1)
560 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
563 665c255d 2023-08-04 jrmu ;; (if (= 10 1)
565 665c255d 2023-08-04 jrmu ;; (* 10 ((lambda (ft k)
566 665c255d 2023-08-04 jrmu ;; (if (= k 1)
568 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
569 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
570 665c255d 2023-08-04 jrmu ;; (if (= k 1)
572 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
573 665c255d 2023-08-04 jrmu ;; (- 10 1))))
575 665c255d 2023-08-04 jrmu ;; (* 10 ((lambda (ft k)
576 665c255d 2023-08-04 jrmu ;; (if (= k 1)
578 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
579 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
580 665c255d 2023-08-04 jrmu ;; (if (= k 1)
582 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
586 665c255d 2023-08-04 jrmu ;; (if (= 9 1)
588 665c255d 2023-08-04 jrmu ;; (* 9 ((lambda (ft k)
589 665c255d 2023-08-04 jrmu ;; (if (= k 1)
591 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
592 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
593 665c255d 2023-08-04 jrmu ;; (if (= k 1)
595 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
596 665c255d 2023-08-04 jrmu ;; (- 9 1)))))
599 665c255d 2023-08-04 jrmu ;; (* 9 ((lambda (ft k)
600 665c255d 2023-08-04 jrmu ;; (if (= k 1)
602 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
603 665c255d 2023-08-04 jrmu ;; (lambda (ft k)
604 665c255d 2023-08-04 jrmu ;; (if (= k 1)
606 665c255d 2023-08-04 jrmu ;; (* k (ft ft (- k 1)))))
609 665c255d 2023-08-04 jrmu ;; and so forth
612 665c255d 2023-08-04 jrmu ((lambda (n)
613 665c255d 2023-08-04 jrmu ((lambda (fib)
614 665c255d 2023-08-04 jrmu (fib fib n))
615 665c255d 2023-08-04 jrmu (lambda (ft k)
616 665c255d 2023-08-04 jrmu (if (<= k 1)
618 665c255d 2023-08-04 jrmu (+ (ft ft (- k 1)) (ft ft (- k 2)))))))
623 665c255d 2023-08-04 jrmu ;; b. Consider the following procedure, which includes mutually recursive internal definitions:
625 665c255d 2023-08-04 jrmu ;; (define (f x)
626 665c255d 2023-08-04 jrmu ;; (define (even? n)
627 665c255d 2023-08-04 jrmu ;; (if (= n 0)
629 665c255d 2023-08-04 jrmu ;; (odd? (- n 1))))
630 665c255d 2023-08-04 jrmu ;; (define (odd? n)
631 665c255d 2023-08-04 jrmu ;; (if (= n 0)
633 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))
634 665c255d 2023-08-04 jrmu ;; (even? x))
636 665c255d 2023-08-04 jrmu ;; Fill in the missing expressions to complete an alternative definition of f, which uses neither internal definitions nor letrec:
638 665c255d 2023-08-04 jrmu (define (f x)
639 665c255d 2023-08-04 jrmu ((lambda (even? odd?)
640 665c255d 2023-08-04 jrmu (even? even? odd? x))
641 665c255d 2023-08-04 jrmu (lambda (ev? od? n)
642 665c255d 2023-08-04 jrmu (if (= n 0) true (od? ev? od? (- n 1))))
643 665c255d 2023-08-04 jrmu (lambda (ev? od? n)
644 665c255d 2023-08-04 jrmu (if (= n 0) false (ev? ev? od? (- n 1))))))
646 665c255d 2023-08-04 jrmu (test-case (f 0) true)
647 665c255d 2023-08-04 jrmu (test-case (f 2) true)
648 665c255d 2023-08-04 jrmu (test-case (f 4) true)
649 665c255d 2023-08-04 jrmu (test-case (f 6) true)
650 665c255d 2023-08-04 jrmu (test-case (f 8) true)
651 665c255d 2023-08-04 jrmu (test-case (f 1) false)
652 665c255d 2023-08-04 jrmu (test-case (f 3) false)
653 665c255d 2023-08-04 jrmu (test-case (f 5) false)
654 665c255d 2023-08-04 jrmu (test-case (f 7) false)
655 665c255d 2023-08-04 jrmu (test-case (f 9) false)
658 665c255d 2023-08-04 jrmu ;; test-suite
660 665c255d 2023-08-04 jrmu ;; procedure definitions
663 665c255d 2023-08-04 jrmu '(define (assoc key records)
664 665c255d 2023-08-04 jrmu (cond ((null? records) false)
665 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
666 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
669 665c255d 2023-08-04 jrmu '(define (map proc list)
670 665c255d 2023-08-04 jrmu (if (null? list)
672 665c255d 2023-08-04 jrmu (cons (proc (car list))
673 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
676 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
677 665c255d 2023-08-04 jrmu (if (null? sequence)
679 665c255d 2023-08-04 jrmu (op (car sequence)
680 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
682 665c255d 2023-08-04 jrmu ;; all special forms
683 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
684 665c255d 2023-08-04 jrmu (test-eval '10 10)
685 665c255d 2023-08-04 jrmu (geval '(define x 3))
686 665c255d 2023-08-04 jrmu (test-eval 'x 3)
687 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
688 665c255d 2023-08-04 jrmu (test-eval 'x -25)
689 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
690 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
691 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
692 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
693 665c255d 2023-08-04 jrmu (else 'failed))
695 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
697 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
698 665c255d 2023-08-04 jrmu (+ x y (* x y)))
699 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
703 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
704 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
705 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
706 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
707 665c255d 2023-08-04 jrmu (test-eval 'x -2)
708 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
709 665c255d 2023-08-04 jrmu (test-eval 'x -2)
710 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
711 665c255d 2023-08-04 jrmu (test-eval 'x 25)
712 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
713 665c255d 2023-08-04 jrmu (test-eval 'x 2)
714 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
715 665c255d 2023-08-04 jrmu (test-eval 'x 25)
716 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
717 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
723 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
724 665c255d 2023-08-04 jrmu (else false))
728 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
729 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
730 665c255d 2023-08-04 jrmu ((map (lambda (x)
731 665c255d 2023-08-04 jrmu (* x (+ x 1)))
732 665c255d 2023-08-04 jrmu '(2 4 1 9))
734 665c255d 2023-08-04 jrmu (lambda (x)
735 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
736 665c255d 2023-08-04 jrmu (else 'never-reach))
738 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
741 665c255d 2023-08-04 jrmu ;; procedure definition and application
743 665c255d 2023-08-04 jrmu '(define (factorial n)
744 665c255d 2023-08-04 jrmu (if (= n 0)
746 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
747 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
752 665c255d 2023-08-04 jrmu '(map (lambda (x)
753 665c255d 2023-08-04 jrmu (* x (+ x 1)))
754 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
755 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
756 665c255d 2023-08-04 jrmu ;; accumulate
759 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
762 665c255d 2023-08-04 jrmu ;; make-let
764 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
771 665c255d 2023-08-04 jrmu '(let ((x 3))
775 665c255d 2023-08-04 jrmu '(let ((x 3)
780 665c255d 2023-08-04 jrmu '(let ((x 3)
782 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
786 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
788 665c255d 2023-08-04 jrmu '(let ((x 6)
789 665c255d 2023-08-04 jrmu (y (let ((x 2))
791 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
800 665c255d 2023-08-04 jrmu '(let* ((x 3)
801 665c255d 2023-08-04 jrmu (y (+ x 2))
802 665c255d 2023-08-04 jrmu (z (+ x y 5)))
811 665c255d 2023-08-04 jrmu '(let* ((x 3))
812 665c255d 2023-08-04 jrmu (let* ((y 5))
817 665c255d 2023-08-04 jrmu '(let* ((x 3)
818 665c255d 2023-08-04 jrmu (y (+ x 1)))
819 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
823 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
825 665c255d 2023-08-04 jrmu '(let* ((x 6)
826 665c255d 2023-08-04 jrmu (y (let* ((x 2)
827 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
830 665c255d 2023-08-04 jrmu (z (+ x y)))
834 665c255d 2023-08-04 jrmu ;; named-let
837 665c255d 2023-08-04 jrmu '(let eight ()
843 665c255d 2023-08-04 jrmu '(let loop ((count 0))
844 665c255d 2023-08-04 jrmu (if (= 100 count)
846 665c255d 2023-08-04 jrmu (loop (+ count 1))))
849 665c255d 2023-08-04 jrmu '(define (prime? x)
850 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
851 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
852 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
853 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
855 665c255d 2023-08-04 jrmu '(let primes ((x 2)
857 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
858 665c255d 2023-08-04 jrmu ((prime? x)
860 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
861 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
862 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))
865 665c255d 2023-08-04 jrmu '(define (fib n)
866 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
869 665c255d 2023-08-04 jrmu (if (= count 0)
871 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
872 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
876 665c255d 2023-08-04 jrmu '(let ((y 0))
877 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
878 665c255d 2023-08-04 jrmu ((= x 5) y)
879 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
890 665c255d 2023-08-04 jrmu '(let ((y 0))
892 665c255d 2023-08-04 jrmu ((= y 5) y)
893 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
897 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
898 665c255d 2023-08-04 jrmu ((null? y))
899 665c255d 2023-08-04 jrmu (set! y (cdr y)))
902 665c255d 2023-08-04 jrmu '(let ((y 0))
903 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
904 665c255d 2023-08-04 jrmu ((= x 5) y)
905 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
908 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
909 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
910 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
911 665c255d 2023-08-04 jrmu ((null? x) sum)))
914 665c255d 2023-08-04 jrmu '(let ((z '()))
915 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
916 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
917 665c255d 2023-08-04 jrmu ((null? x) y x z)
918 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
919 665c255d 2023-08-04 jrmu '(4 3 2 1))
923 665c255d 2023-08-04 jrmu ;; make-unbound!
924 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
926 665c255d 2023-08-04 jrmu ;; (test-eval
927 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
928 665c255d 2023-08-04 jrmu ;; (let ((x 5))
929 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
930 665c255d 2023-08-04 jrmu ;; (* x x)))
933 665c255d 2023-08-04 jrmu ;; (test-eval
934 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
935 665c255d 2023-08-04 jrmu ;; (let ((x 5))
936 665c255d 2023-08-04 jrmu ;; (define y x)
937 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
938 665c255d 2023-08-04 jrmu ;; (* y x)))
941 665c255d 2023-08-04 jrmu ;; (test-eval
942 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
943 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
944 665c255d 2023-08-04 jrmu ;; (define a x)
945 665c255d 2023-08-04 jrmu ;; (define b y)
946 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
947 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
948 665c255d 2023-08-04 jrmu ;; (* a b x y)))
949 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
951 665c255d 2023-08-04 jrmu ;; (test-eval
952 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
953 665c255d 2023-08-04 jrmu ;; (let ((x 5))
954 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
955 665c255d 2023-08-04 jrmu ;; (+ x 4)))
958 665c255d 2023-08-04 jrmu ;; (test-eval
959 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
960 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
961 665c255d 2023-08-04 jrmu ;; (+ a c d))
962 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
964 665c255d 2023-08-04 jrmu ;; (test-eval
965 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
966 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
967 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
968 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
969 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
970 665c255d 2023-08-04 jrmu ;; (define z b)
971 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
972 665c255d 2023-08-04 jrmu ;; (* (+ a z)
973 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
974 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
975 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
977 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
978 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
979 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
980 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
982 665c255d 2023-08-04 jrmu ;; scan-out-defines
985 665c255d 2023-08-04 jrmu '(define (f x)
986 665c255d 2023-08-04 jrmu (define (even? n)
987 665c255d 2023-08-04 jrmu (if (= n 0)
989 665c255d 2023-08-04 jrmu (odd? (- n 1))))
990 665c255d 2023-08-04 jrmu (define (odd? n)
991 665c255d 2023-08-04 jrmu (if (= n 0)
993 665c255d 2023-08-04 jrmu (even? (- n 1))))
994 665c255d 2023-08-04 jrmu (even? x)))
995 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
996 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
999 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
1000 665c255d 2023-08-04 jrmu ;; (define y x)
1001 665c255d 2023-08-04 jrmu ;; (define x 3)
1002 665c255d 2023-08-04 jrmu ;; (+ x y)))
1003 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
1008 665c255d 2023-08-04 jrmu '(define (f x)
1009 665c255d 2023-08-04 jrmu (letrec ((even?
1010 665c255d 2023-08-04 jrmu (lambda (n)
1011 665c255d 2023-08-04 jrmu (if (= n 0)
1013 665c255d 2023-08-04 jrmu (odd? (- n 1)))))
1015 665c255d 2023-08-04 jrmu (lambda (n)
1016 665c255d 2023-08-04 jrmu (if (= n 0)
1018 665c255d 2023-08-04 jrmu (even? (- n 1))))))
1019 665c255d 2023-08-04 jrmu (even? x))))
1020 665c255d 2023-08-04 jrmu (test-eval '(f 11) false)
1021 665c255d 2023-08-04 jrmu (test-eval '(f 16) true)
1023 665c255d 2023-08-04 jrmu (test-eval
1024 665c255d 2023-08-04 jrmu '(letrec ((fact
1025 665c255d 2023-08-04 jrmu (lambda (n)
1026 665c255d 2023-08-04 jrmu (if (= n 1)
1028 665c255d 2023-08-04 jrmu (* n (fact (- n 1)))))))
1029 665c255d 2023-08-04 jrmu (fact 10))
