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 ((do? exp) (eval (do->combination exp) env))
24 665c255d 2023-08-04 jrmu ((application? exp)
25 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
26 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
28 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
29 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
30 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
31 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
32 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
33 665c255d 2023-08-04 jrmu (eval-sequence
34 665c255d 2023-08-04 jrmu (procedure-body procedure)
35 665c255d 2023-08-04 jrmu (extend-environment
36 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
38 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
41 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
43 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
44 665c255d 2023-08-04 jrmu (if (no-operands? exps)
46 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
47 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
49 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
50 665c255d 2023-08-04 jrmu (if (pair? exp)
51 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
54 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
55 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
56 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
57 665c255d 2023-08-04 jrmu ((string? exp) true)
58 665c255d 2023-08-04 jrmu (else false)))
59 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
60 665c255d 2023-08-04 jrmu (define (quoted? exp)
61 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
62 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
64 665c255d 2023-08-04 jrmu ;; assignment/definition
65 665c255d 2023-08-04 jrmu (define (assignment? exp)
66 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
67 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
68 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
69 665c255d 2023-08-04 jrmu (define (make-assignment var val)
70 665c255d 2023-08-04 jrmu (list 'set! var val))
71 665c255d 2023-08-04 jrmu (define (definition? exp)
72 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
73 665c255d 2023-08-04 jrmu (define (definition-variable exp)
74 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
76 665c255d 2023-08-04 jrmu (caadr exp)))
77 665c255d 2023-08-04 jrmu (define (definition-value exp)
78 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
80 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
81 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
82 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
83 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
84 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
87 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
88 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
89 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
92 665c255d 2023-08-04 jrmu (define (make-definition var val)
93 665c255d 2023-08-04 jrmu `(define ,var ,val))
95 665c255d 2023-08-04 jrmu ;; make-unbound!
97 665c255d 2023-08-04 jrmu ;; (define (unbound? exp)
98 665c255d 2023-08-04 jrmu ;; (tagged-list? exp 'make-unbound!))
99 665c255d 2023-08-04 jrmu ;; (define (unbound-var exp)
100 665c255d 2023-08-04 jrmu ;; (cadr exp))
101 665c255d 2023-08-04 jrmu ;; (define (eval-unbound exp env)
102 665c255d 2023-08-04 jrmu ;; (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
106 665c255d 2023-08-04 jrmu ;; if/and/or
107 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
108 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
109 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
110 665c255d 2023-08-04 jrmu (define (if-alternative exp)
111 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
112 665c255d 2023-08-04 jrmu (cadddr exp)
114 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
115 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
116 665c255d 2023-08-04 jrmu (define (eval-if exp env)
117 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
118 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
119 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
121 665c255d 2023-08-04 jrmu (define (and? exp)
122 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
123 665c255d 2023-08-04 jrmu (define (and-clauses exp)
125 665c255d 2023-08-04 jrmu (define (or? exp)
126 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
127 665c255d 2023-08-04 jrmu (define (or-clauses exp)
129 665c255d 2023-08-04 jrmu (define (eval-and exp env)
130 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
131 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
132 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
133 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
134 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
135 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
136 665c255d 2023-08-04 jrmu (define (eval-or exp env)
137 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
138 665c255d 2023-08-04 jrmu (if (null? clauses)
140 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
141 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
142 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
145 665c255d 2023-08-04 jrmu ;; lambda/let/let*
146 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
147 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
148 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
149 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
150 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
152 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
154 665c255d 2023-08-04 jrmu (cons (map list vars vals)
156 665c255d 2023-08-04 jrmu (define (let? exp)
157 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
158 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
159 665c255d 2023-08-04 jrmu (define (let-vars exp)
160 665c255d 2023-08-04 jrmu (map car (cadr exp)))
161 665c255d 2023-08-04 jrmu (define (let-vals exp)
162 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
163 665c255d 2023-08-04 jrmu (define (let-body exp)
164 665c255d 2023-08-04 jrmu (cddr exp))
165 665c255d 2023-08-04 jrmu (define (let->combination exp)
166 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
167 665c255d 2023-08-04 jrmu (let-vals exp)))
168 665c255d 2023-08-04 jrmu (define (named-let? exp)
169 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
170 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
171 665c255d 2023-08-04 jrmu (define (named-let-name exp)
172 665c255d 2023-08-04 jrmu (cadr exp))
173 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
174 665c255d 2023-08-04 jrmu (map car (caddr exp)))
175 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
176 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
177 665c255d 2023-08-04 jrmu (define (named-let-body exp)
178 665c255d 2023-08-04 jrmu (cdddr exp))
179 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
180 665c255d 2023-08-04 jrmu (sequence->exp
181 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
182 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
183 665c255d 2023-08-04 jrmu (named-let-body exp)))
184 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
185 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
186 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
189 665c255d 2023-08-04 jrmu (cons (map list vars vals)
192 665c255d 2023-08-04 jrmu (define (make-application op args)
193 665c255d 2023-08-04 jrmu (cons op args))
195 665c255d 2023-08-04 jrmu (define (let*? exp)
196 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
197 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
198 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
199 665c255d 2023-08-04 jrmu (define let*-body let-body)
200 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
201 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
202 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
203 665c255d 2023-08-04 jrmu (make-let (list (car vars))
204 665c255d 2023-08-04 jrmu (list (car vals))
205 665c255d 2023-08-04 jrmu (let*-body exp))
206 665c255d 2023-08-04 jrmu (make-let (list (car vars))
207 665c255d 2023-08-04 jrmu (list (car vals))
208 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
209 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
210 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
211 665c255d 2023-08-04 jrmu (if (null? vars)
212 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
213 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
216 665c255d 2023-08-04 jrmu (define (do? exp)
217 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
218 665c255d 2023-08-04 jrmu (define (do-vars exp)
219 665c255d 2023-08-04 jrmu (map car (cadr exp)))
220 665c255d 2023-08-04 jrmu (define (do-inits exp)
221 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
222 665c255d 2023-08-04 jrmu (define (do-steps exp)
223 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
224 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
225 665c255d 2023-08-04 jrmu (car var-init-step)
226 665c255d 2023-08-04 jrmu (caddr var-init-step)))
227 665c255d 2023-08-04 jrmu (cadr exp)))
228 665c255d 2023-08-04 jrmu (define (do-test exp)
229 665c255d 2023-08-04 jrmu (caaddr exp))
230 665c255d 2023-08-04 jrmu (define (do-expressions exp)
231 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
232 665c255d 2023-08-04 jrmu (caddr exp)
233 665c255d 2023-08-04 jrmu (cdaddr exp)))
234 665c255d 2023-08-04 jrmu (define (do-commands exp)
235 665c255d 2023-08-04 jrmu (cdddr exp))
236 665c255d 2023-08-04 jrmu (define (do->combination exp)
237 665c255d 2023-08-04 jrmu (make-named-let
239 665c255d 2023-08-04 jrmu (do-vars exp)
240 665c255d 2023-08-04 jrmu (do-inits exp)
243 665c255d 2023-08-04 jrmu (do-test exp)
244 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
245 665c255d 2023-08-04 jrmu (sequence->exp
246 665c255d 2023-08-04 jrmu (append (do-commands exp)
247 665c255d 2023-08-04 jrmu (list (make-application
249 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
252 665c255d 2023-08-04 jrmu ;; begin/sequence
253 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
254 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
255 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
256 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
257 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
258 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
259 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
260 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
261 665c255d 2023-08-04 jrmu (else (make-begin seq))))
262 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
263 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
264 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
265 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
266 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
268 665c255d 2023-08-04 jrmu ;; application
269 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
270 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
271 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
272 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
273 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
274 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
277 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
278 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
279 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
280 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
281 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
282 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
283 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
284 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
285 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
286 665c255d 2023-08-04 jrmu (caddr clause))
287 665c255d 2023-08-04 jrmu (define (cond->if exp)
288 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
289 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
290 665c255d 2023-08-04 jrmu (if (null? clauses)
291 665c255d 2023-08-04 jrmu 'false ; no else clause
292 665c255d 2023-08-04 jrmu (let ((first (car clauses))
293 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
294 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
295 665c255d 2023-08-04 jrmu (if (null? rest)
296 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
297 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
299 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
300 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
301 665c255d 2023-08-04 jrmu (make-application
302 665c255d 2023-08-04 jrmu (cond-extended-proc first)
303 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
304 665c255d 2023-08-04 jrmu (expand-clauses rest))
305 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
306 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
307 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
308 665c255d 2023-08-04 jrmu (define (true? x)
309 665c255d 2023-08-04 jrmu (not (eq? x false)))
310 665c255d 2023-08-04 jrmu (define (false? x)
311 665c255d 2023-08-04 jrmu (eq? x false))
313 665c255d 2023-08-04 jrmu ;; procedure
314 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
315 665c255d 2023-08-04 jrmu (list 'procedure parameters (scan-out-defines body) env))
316 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
317 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
318 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
319 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
321 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
322 665c255d 2023-08-04 jrmu (assignments
323 665c255d 2023-08-04 jrmu (map (lambda (var val)
324 665c255d 2023-08-04 jrmu (make-assignment var val))
325 665c255d 2023-08-04 jrmu vars vals))
326 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
327 665c255d 2023-08-04 jrmu (if (null? definitions)
330 665c255d 2023-08-04 jrmu (make-let vars
331 665c255d 2023-08-04 jrmu unassigneds
332 665c255d 2023-08-04 jrmu (append assignments exps))))))
333 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
334 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
335 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
336 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
337 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
339 665c255d 2023-08-04 jrmu ;; environment
340 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
341 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
342 665c255d 2023-08-04 jrmu (define the-empty-environment '())
343 665c255d 2023-08-04 jrmu (define (make-frame variables values)
344 665c255d 2023-08-04 jrmu (cons variables values))
345 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
346 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
347 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
348 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
349 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
350 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
351 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
352 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
353 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
354 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
355 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
356 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
357 665c255d 2023-08-04 jrmu (define (env-loop env)
358 665c255d 2023-08-04 jrmu (define (scan vars vals)
359 665c255d 2023-08-04 jrmu (cond ((null? vars)
360 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
361 665c255d 2023-08-04 jrmu ((eq? var (car vars))
362 665c255d 2023-08-04 jrmu (let ((val (car vals)))
363 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
364 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
366 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
367 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
368 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
369 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
370 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
371 665c255d 2023-08-04 jrmu (frame-values frame)))))
372 665c255d 2023-08-04 jrmu (env-loop env))
373 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
374 665c255d 2023-08-04 jrmu (define (env-loop env)
375 665c255d 2023-08-04 jrmu (define (scan vars vals)
376 665c255d 2023-08-04 jrmu (cond ((null? vars)
377 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
378 665c255d 2023-08-04 jrmu ((eq? var (car vars))
379 665c255d 2023-08-04 jrmu (set-car! vals val))
380 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
381 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
382 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
383 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
384 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
385 665c255d 2023-08-04 jrmu (frame-values frame)))))
386 665c255d 2023-08-04 jrmu (env-loop env))
387 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
388 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
389 665c255d 2023-08-04 jrmu (define (scan vars vals)
390 665c255d 2023-08-04 jrmu (cond ((null? vars)
391 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
392 665c255d 2023-08-04 jrmu ((eq? var (car vars))
393 665c255d 2023-08-04 jrmu (set-car! vals val))
394 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
395 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
396 665c255d 2023-08-04 jrmu (frame-values frame))))
398 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
399 665c255d 2023-08-04 jrmu (define (scan vars vals)
400 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
401 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
402 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
403 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
404 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
405 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
406 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
407 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
408 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
409 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
410 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
411 665c255d 2023-08-04 jrmu (scan vars vals))))
413 665c255d 2023-08-04 jrmu ;; primitives
414 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
415 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
416 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
417 665c255d 2023-08-04 jrmu (define primitive-procedures
418 665c255d 2023-08-04 jrmu (list (list 'car car)
419 665c255d 2023-08-04 jrmu (list 'cdr cdr)
420 665c255d 2023-08-04 jrmu (list 'caar caar)
421 665c255d 2023-08-04 jrmu (list 'cadr cadr)
422 665c255d 2023-08-04 jrmu (list 'cddr cddr)
423 665c255d 2023-08-04 jrmu (list 'cons cons)
424 665c255d 2023-08-04 jrmu (list 'null? null?)
425 665c255d 2023-08-04 jrmu (list '* *)
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 'remainder remainder)
435 665c255d 2023-08-04 jrmu (list 'eq? eq?)
436 665c255d 2023-08-04 jrmu (list 'equal? equal?)
437 665c255d 2023-08-04 jrmu (list 'display display)))
438 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
440 665c255d 2023-08-04 jrmu primitive-procedures))
441 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
442 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
443 665c255d 2023-08-04 jrmu primitive-procedures))
444 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
445 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
446 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
448 665c255d 2023-08-04 jrmu ;; driver-loop
449 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
450 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
451 665c255d 2023-08-04 jrmu (define (driver-loop)
452 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
453 665c255d 2023-08-04 jrmu (let ((input (read)))
454 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
455 665c255d 2023-08-04 jrmu (announce-output output-prompt)
456 665c255d 2023-08-04 jrmu (user-print output)))
457 665c255d 2023-08-04 jrmu (driver-loop))
458 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
459 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
461 665c255d 2023-08-04 jrmu (define (announce-output string)
462 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
463 665c255d 2023-08-04 jrmu (define (user-print object)
464 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
465 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
466 665c255d 2023-08-04 jrmu (procedure-parameters object)
467 665c255d 2023-08-04 jrmu (procedure-body object)
468 665c255d 2023-08-04 jrmu '<procedure-env>))
469 665c255d 2023-08-04 jrmu (display object)))
470 665c255d 2023-08-04 jrmu (define (setup-environment)
471 665c255d 2023-08-04 jrmu (let ((initial-env
472 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
473 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
474 665c255d 2023-08-04 jrmu the-empty-environment)))
475 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
476 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
477 665c255d 2023-08-04 jrmu initial-env))
478 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
480 665c255d 2023-08-04 jrmu ;; auxiliary
481 665c255d 2023-08-04 jrmu (define (test-case actual expected)
483 665c255d 2023-08-04 jrmu (display "Actual: ")
484 665c255d 2023-08-04 jrmu (display actual)
486 665c255d 2023-08-04 jrmu (display "Expected: ")
487 665c255d 2023-08-04 jrmu (display expected)
489 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
490 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
491 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
492 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
497 665c255d 2023-08-04 jrmu ;; Exercise 4.19. Ben Bitdiddle, Alyssa P. Hacker, and Eva Lu Ator are arguing about the desired result of evaluating the expression
499 665c255d 2023-08-04 jrmu (let ((a 1))
500 665c255d 2023-08-04 jrmu (define (f x)
501 665c255d 2023-08-04 jrmu (define b (+ a x))
502 665c255d 2023-08-04 jrmu (define a 5)
506 665c255d 2023-08-04 jrmu ;; Ben asserts that the result should be obtained using the sequential rule for define: b is defined to be 11, then a is defined to be 5, so the result is 16. Alyssa objects that mutual recursion requires the simultaneous scope rule for internal procedure definitions, and that it is unreasonable to treat procedure names differently from other names. Thus, she argues for the mechanism implemented in exercise 4.16. This would lead to a being unassigned at the time that the value for b is to be computed. Hence, in Alyssa's view the procedure should produce an error. Eva has a third opinion. She says that if the definitions of a and b are truly meant to be simultaneous, then the value 5 for a should be used in evaluating b. Hence, in Eva's view a should be 5, b should be 15, and the result should be 20. Which (if any) of these viewpoints do you support? Can you devise a way to implement internal definitions so that they behave as Eva prefers?26
510 665c255d 2023-08-04 jrmu ;; test-suite
512 665c255d 2023-08-04 jrmu ;; procedure definitions
515 665c255d 2023-08-04 jrmu '(define (assoc key records)
516 665c255d 2023-08-04 jrmu (cond ((null? records) false)
517 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
518 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
521 665c255d 2023-08-04 jrmu '(define (map proc list)
522 665c255d 2023-08-04 jrmu (if (null? list)
524 665c255d 2023-08-04 jrmu (cons (proc (car list))
525 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
528 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
529 665c255d 2023-08-04 jrmu (if (null? sequence)
531 665c255d 2023-08-04 jrmu (op (car sequence)
532 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
534 665c255d 2023-08-04 jrmu ;; all special forms
535 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
536 665c255d 2023-08-04 jrmu (test-eval '10 10)
537 665c255d 2023-08-04 jrmu (geval '(define x 3))
538 665c255d 2023-08-04 jrmu (test-eval 'x 3)
539 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
540 665c255d 2023-08-04 jrmu (test-eval 'x -25)
541 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
542 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
543 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
544 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
545 665c255d 2023-08-04 jrmu (else 'failed))
547 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
549 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
550 665c255d 2023-08-04 jrmu (+ x y (* x y)))
551 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
555 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
556 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
557 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
558 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
559 665c255d 2023-08-04 jrmu (test-eval 'x -2)
560 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
561 665c255d 2023-08-04 jrmu (test-eval 'x -2)
562 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
563 665c255d 2023-08-04 jrmu (test-eval 'x 25)
564 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
565 665c255d 2023-08-04 jrmu (test-eval 'x 2)
566 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
567 665c255d 2023-08-04 jrmu (test-eval 'x 25)
568 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
569 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
575 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
576 665c255d 2023-08-04 jrmu (else false))
580 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
581 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
582 665c255d 2023-08-04 jrmu ((map (lambda (x)
583 665c255d 2023-08-04 jrmu (* x (+ x 1)))
584 665c255d 2023-08-04 jrmu '(2 4 1 9))
586 665c255d 2023-08-04 jrmu (lambda (x)
587 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
588 665c255d 2023-08-04 jrmu (else 'never-reach))
590 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
593 665c255d 2023-08-04 jrmu ;; procedure definition and application
595 665c255d 2023-08-04 jrmu '(define (factorial n)
596 665c255d 2023-08-04 jrmu (if (= n 0)
598 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
599 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
604 665c255d 2023-08-04 jrmu '(map (lambda (x)
605 665c255d 2023-08-04 jrmu (* x (+ x 1)))
606 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
607 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
608 665c255d 2023-08-04 jrmu ;; accumulate
611 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
614 665c255d 2023-08-04 jrmu ;; make-let
616 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
623 665c255d 2023-08-04 jrmu '(let ((x 3))
627 665c255d 2023-08-04 jrmu '(let ((x 3)
632 665c255d 2023-08-04 jrmu '(let ((x 3)
634 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
638 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
640 665c255d 2023-08-04 jrmu '(let ((x 6)
641 665c255d 2023-08-04 jrmu (y (let ((x 2))
643 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
652 665c255d 2023-08-04 jrmu '(let* ((x 3)
653 665c255d 2023-08-04 jrmu (y (+ x 2))
654 665c255d 2023-08-04 jrmu (z (+ x y 5)))
663 665c255d 2023-08-04 jrmu '(let* ((x 3))
664 665c255d 2023-08-04 jrmu (let* ((y 5))
669 665c255d 2023-08-04 jrmu '(let* ((x 3)
670 665c255d 2023-08-04 jrmu (y (+ x 1)))
671 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
675 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
677 665c255d 2023-08-04 jrmu '(let* ((x 6)
678 665c255d 2023-08-04 jrmu (y (let* ((x 2)
679 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
682 665c255d 2023-08-04 jrmu (z (+ x y)))
686 665c255d 2023-08-04 jrmu ;; named-let
689 665c255d 2023-08-04 jrmu '(let eight ()
695 665c255d 2023-08-04 jrmu '(let loop ((count 0))
696 665c255d 2023-08-04 jrmu (if (= 100 count)
698 665c255d 2023-08-04 jrmu (loop (+ count 1))))
701 665c255d 2023-08-04 jrmu '(define (prime? x)
702 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
703 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
704 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
705 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
707 665c255d 2023-08-04 jrmu '(let primes ((x 2)
709 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
710 665c255d 2023-08-04 jrmu ((prime? x)
712 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
713 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
714 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))
717 665c255d 2023-08-04 jrmu '(define (fib n)
718 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
721 665c255d 2023-08-04 jrmu (if (= count 0)
723 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
724 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
728 665c255d 2023-08-04 jrmu '(let ((y 0))
729 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
730 665c255d 2023-08-04 jrmu ((= x 5) y)
731 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
742 665c255d 2023-08-04 jrmu '(let ((y 0))
744 665c255d 2023-08-04 jrmu ((= y 5) y)
745 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
749 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
750 665c255d 2023-08-04 jrmu ((null? y))
751 665c255d 2023-08-04 jrmu (set! y (cdr y)))
754 665c255d 2023-08-04 jrmu '(let ((y 0))
755 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
756 665c255d 2023-08-04 jrmu ((= x 5) y)
757 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
760 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
761 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
762 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
763 665c255d 2023-08-04 jrmu ((null? x) sum)))
766 665c255d 2023-08-04 jrmu '(let ((z '()))
767 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
768 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
769 665c255d 2023-08-04 jrmu ((null? x) y x z)
770 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
771 665c255d 2023-08-04 jrmu '(4 3 2 1))
775 665c255d 2023-08-04 jrmu ;; make-unbound!
776 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
778 665c255d 2023-08-04 jrmu ;; (test-eval
779 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
780 665c255d 2023-08-04 jrmu ;; (let ((x 5))
781 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
782 665c255d 2023-08-04 jrmu ;; (* x x)))
785 665c255d 2023-08-04 jrmu ;; (test-eval
786 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
787 665c255d 2023-08-04 jrmu ;; (let ((x 5))
788 665c255d 2023-08-04 jrmu ;; (define y x)
789 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
790 665c255d 2023-08-04 jrmu ;; (* y x)))
793 665c255d 2023-08-04 jrmu ;; (test-eval
794 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
795 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
796 665c255d 2023-08-04 jrmu ;; (define a x)
797 665c255d 2023-08-04 jrmu ;; (define b y)
798 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
799 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
800 665c255d 2023-08-04 jrmu ;; (* a b x y)))
801 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
803 665c255d 2023-08-04 jrmu ;; (test-eval
804 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
805 665c255d 2023-08-04 jrmu ;; (let ((x 5))
806 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
807 665c255d 2023-08-04 jrmu ;; (+ x 4)))
810 665c255d 2023-08-04 jrmu ;; (test-eval
811 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
812 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
813 665c255d 2023-08-04 jrmu ;; (+ a c d))
814 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
816 665c255d 2023-08-04 jrmu ;; (test-eval
817 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
818 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
819 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
820 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
821 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
822 665c255d 2023-08-04 jrmu ;; (define z b)
823 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
824 665c255d 2023-08-04 jrmu ;; (* (+ a z)
825 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
826 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
827 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
829 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
830 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
831 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
832 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
834 665c255d 2023-08-04 jrmu ;; scan-out-defines
837 665c255d 2023-08-04 jrmu '(define (f x)
838 665c255d 2023-08-04 jrmu (define (even? n)
839 665c255d 2023-08-04 jrmu (if (= n 0)
841 665c255d 2023-08-04 jrmu (odd? (- n 1))))
842 665c255d 2023-08-04 jrmu (define (odd? n)
843 665c255d 2023-08-04 jrmu (if (= n 0)
845 665c255d 2023-08-04 jrmu (even? (- n 1))))
846 665c255d 2023-08-04 jrmu (even? x)))
847 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
848 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
851 665c255d 2023-08-04 jrmu ;; '(let ((x 5))
852 665c255d 2023-08-04 jrmu ;; (define y x)
853 665c255d 2023-08-04 jrmu ;; (define x 3)
854 665c255d 2023-08-04 jrmu ;; (+ x y)))
855 665c255d 2023-08-04 jrmu ;; signal an error because x is undefined if variables are scanned out
