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 (definition? exp)
70 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
71 665c255d 2023-08-04 jrmu (define (definition-variable exp)
72 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
74 665c255d 2023-08-04 jrmu (caadr exp)))
75 665c255d 2023-08-04 jrmu (define (definition-value exp)
76 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
78 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
79 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
80 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
81 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
82 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
85 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
86 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
87 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
90 665c255d 2023-08-04 jrmu (define (make-definition var val)
91 665c255d 2023-08-04 jrmu `(define ,var ,val))
93 665c255d 2023-08-04 jrmu ;; make-unbound!
95 665c255d 2023-08-04 jrmu (define (unbound? exp)
96 665c255d 2023-08-04 jrmu (tagged-list? exp 'make-unbound!))
97 665c255d 2023-08-04 jrmu (define (unbound-var exp)
99 665c255d 2023-08-04 jrmu (define (eval-unbound exp env)
100 665c255d 2023-08-04 jrmu (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
101 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
102 665c255d 2023-08-04 jrmu (define (scan vars vals)
103 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
104 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
105 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
106 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
107 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
108 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
109 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
110 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
111 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
112 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
113 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
114 665c255d 2023-08-04 jrmu (scan vars vals))))
116 665c255d 2023-08-04 jrmu ;; if/and/or
117 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
118 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
119 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
120 665c255d 2023-08-04 jrmu (define (if-alternative exp)
121 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
122 665c255d 2023-08-04 jrmu (cadddr exp)
124 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
125 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
126 665c255d 2023-08-04 jrmu (define (eval-if exp env)
127 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
128 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
129 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
131 665c255d 2023-08-04 jrmu (define (and? exp)
132 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
133 665c255d 2023-08-04 jrmu (define (and-clauses exp)
135 665c255d 2023-08-04 jrmu (define (or? exp)
136 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
137 665c255d 2023-08-04 jrmu (define (or-clauses exp)
139 665c255d 2023-08-04 jrmu (define (eval-and exp env)
140 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
141 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
142 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
143 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
144 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
145 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
146 665c255d 2023-08-04 jrmu (define (eval-or exp env)
147 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
148 665c255d 2023-08-04 jrmu (if (null? clauses)
150 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
151 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
152 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
155 665c255d 2023-08-04 jrmu ;; lambda/let/let*
156 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
157 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
158 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
159 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
160 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
162 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
164 665c255d 2023-08-04 jrmu (cons (map list vars vals)
166 665c255d 2023-08-04 jrmu (define (let? exp)
167 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
168 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
169 665c255d 2023-08-04 jrmu (define (let-vars exp)
170 665c255d 2023-08-04 jrmu (map car (cadr exp)))
171 665c255d 2023-08-04 jrmu (define (let-vals exp)
172 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
173 665c255d 2023-08-04 jrmu (define (let-body exp)
174 665c255d 2023-08-04 jrmu (cddr exp))
175 665c255d 2023-08-04 jrmu (define (let->combination exp)
176 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
177 665c255d 2023-08-04 jrmu (let-vals exp)))
178 665c255d 2023-08-04 jrmu (define (named-let? exp)
179 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
180 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
181 665c255d 2023-08-04 jrmu (define (named-let-name exp)
182 665c255d 2023-08-04 jrmu (cadr exp))
183 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
184 665c255d 2023-08-04 jrmu (map car (caddr exp)))
185 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
186 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
187 665c255d 2023-08-04 jrmu (define (named-let-body exp)
188 665c255d 2023-08-04 jrmu (cdddr exp))
189 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
190 665c255d 2023-08-04 jrmu (sequence->exp
191 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
192 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
193 665c255d 2023-08-04 jrmu (named-let-body exp)))
194 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
195 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
196 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
199 665c255d 2023-08-04 jrmu (cons (map list vars vals)
202 665c255d 2023-08-04 jrmu (define (make-application op args)
203 665c255d 2023-08-04 jrmu (cons op args))
205 665c255d 2023-08-04 jrmu (define (let*? exp)
206 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
207 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
208 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
209 665c255d 2023-08-04 jrmu (define let*-body let-body)
210 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
211 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
212 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
213 665c255d 2023-08-04 jrmu (make-let (list (car vars))
214 665c255d 2023-08-04 jrmu (list (car vals))
215 665c255d 2023-08-04 jrmu (let*-body exp))
216 665c255d 2023-08-04 jrmu (make-let (list (car vars))
217 665c255d 2023-08-04 jrmu (list (car vals))
218 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
219 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
220 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
221 665c255d 2023-08-04 jrmu (if (null? vars)
222 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
223 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
226 665c255d 2023-08-04 jrmu (define (do? exp)
227 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
228 665c255d 2023-08-04 jrmu (define (do-vars exp)
229 665c255d 2023-08-04 jrmu (map car (cadr exp)))
230 665c255d 2023-08-04 jrmu (define (do-inits exp)
231 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
232 665c255d 2023-08-04 jrmu (define (do-steps exp)
233 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
234 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
235 665c255d 2023-08-04 jrmu (car var-init-step)
236 665c255d 2023-08-04 jrmu (caddr var-init-step)))
237 665c255d 2023-08-04 jrmu (cadr exp)))
238 665c255d 2023-08-04 jrmu (define (do-test exp)
239 665c255d 2023-08-04 jrmu (caaddr exp))
240 665c255d 2023-08-04 jrmu (define (do-expressions exp)
241 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
242 665c255d 2023-08-04 jrmu (caddr exp)
243 665c255d 2023-08-04 jrmu (cdaddr exp)))
244 665c255d 2023-08-04 jrmu (define (do-commands exp)
245 665c255d 2023-08-04 jrmu (cdddr exp))
246 665c255d 2023-08-04 jrmu (define (do->combination exp)
247 665c255d 2023-08-04 jrmu (make-named-let
249 665c255d 2023-08-04 jrmu (do-vars exp)
250 665c255d 2023-08-04 jrmu (do-inits exp)
253 665c255d 2023-08-04 jrmu (do-test exp)
254 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
255 665c255d 2023-08-04 jrmu (sequence->exp
256 665c255d 2023-08-04 jrmu (append (do-commands exp)
257 665c255d 2023-08-04 jrmu (list (make-application
259 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
262 665c255d 2023-08-04 jrmu ;; begin/sequence
263 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
264 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
265 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
266 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
267 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
268 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
269 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
270 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
271 665c255d 2023-08-04 jrmu (else (make-begin seq))))
272 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
273 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
274 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
275 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
276 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
278 665c255d 2023-08-04 jrmu ;; application
279 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
280 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
281 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
282 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
283 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
284 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
287 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
288 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
289 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
290 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
291 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
292 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
293 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
294 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
295 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
296 665c255d 2023-08-04 jrmu (caddr clause))
297 665c255d 2023-08-04 jrmu (define (cond->if exp)
298 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
299 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
300 665c255d 2023-08-04 jrmu (if (null? clauses)
301 665c255d 2023-08-04 jrmu 'false ; no else clause
302 665c255d 2023-08-04 jrmu (let ((first (car clauses))
303 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
304 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
305 665c255d 2023-08-04 jrmu (if (null? rest)
306 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
307 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
309 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
310 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
311 665c255d 2023-08-04 jrmu (make-application
312 665c255d 2023-08-04 jrmu (cond-extended-proc first)
313 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
314 665c255d 2023-08-04 jrmu (expand-clauses rest))
315 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
316 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
317 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
318 665c255d 2023-08-04 jrmu (define (true? x)
319 665c255d 2023-08-04 jrmu (not (eq? x false)))
320 665c255d 2023-08-04 jrmu (define (false? x)
321 665c255d 2023-08-04 jrmu (eq? x false))
323 665c255d 2023-08-04 jrmu ;; procedure
324 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
325 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
326 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
327 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
328 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
329 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
330 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
332 665c255d 2023-08-04 jrmu ;; environment
333 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
334 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
335 665c255d 2023-08-04 jrmu (define the-empty-environment '())
336 665c255d 2023-08-04 jrmu (define (make-frame variables values)
337 665c255d 2023-08-04 jrmu (cons variables values))
338 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
339 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
340 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
341 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
342 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
343 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
344 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
345 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
346 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
347 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
348 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
349 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
350 665c255d 2023-08-04 jrmu (define (env-loop env)
351 665c255d 2023-08-04 jrmu (define (scan vars vals)
352 665c255d 2023-08-04 jrmu (cond ((null? vars)
353 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
354 665c255d 2023-08-04 jrmu ((eq? var (car vars))
355 665c255d 2023-08-04 jrmu (car vals))
356 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
357 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
358 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
359 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
360 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
361 665c255d 2023-08-04 jrmu (frame-values frame)))))
362 665c255d 2023-08-04 jrmu (env-loop env))
363 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
364 665c255d 2023-08-04 jrmu (define (env-loop env)
365 665c255d 2023-08-04 jrmu (define (scan vars vals)
366 665c255d 2023-08-04 jrmu (cond ((null? vars)
367 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
368 665c255d 2023-08-04 jrmu ((eq? var (car vars))
369 665c255d 2023-08-04 jrmu (set-car! vals val))
370 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
371 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
372 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
373 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
374 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
375 665c255d 2023-08-04 jrmu (frame-values frame)))))
376 665c255d 2023-08-04 jrmu (env-loop env))
377 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
378 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
379 665c255d 2023-08-04 jrmu (define (scan vars vals)
380 665c255d 2023-08-04 jrmu (cond ((null? vars)
381 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
382 665c255d 2023-08-04 jrmu ((eq? var (car vars))
383 665c255d 2023-08-04 jrmu (set-car! vals val))
384 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
385 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
386 665c255d 2023-08-04 jrmu (frame-values frame))))
388 665c255d 2023-08-04 jrmu ;; primitives
389 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
390 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
391 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
392 665c255d 2023-08-04 jrmu (define primitive-procedures
393 665c255d 2023-08-04 jrmu (list (list 'car car)
394 665c255d 2023-08-04 jrmu (list 'cdr cdr)
395 665c255d 2023-08-04 jrmu (list 'caar caar)
396 665c255d 2023-08-04 jrmu (list 'cadr cadr)
397 665c255d 2023-08-04 jrmu (list 'cddr cddr)
398 665c255d 2023-08-04 jrmu (list 'cons cons)
399 665c255d 2023-08-04 jrmu (list 'null? null?)
400 665c255d 2023-08-04 jrmu (list '* *)
401 665c255d 2023-08-04 jrmu (list '/ /)
402 665c255d 2023-08-04 jrmu (list '+ +)
403 665c255d 2023-08-04 jrmu (list '- -)
404 665c255d 2023-08-04 jrmu (list '= =)
405 665c255d 2023-08-04 jrmu (list '< <)
406 665c255d 2023-08-04 jrmu (list '> >)
407 665c255d 2023-08-04 jrmu (list '<= <=)
408 665c255d 2023-08-04 jrmu (list '>= >=)
409 665c255d 2023-08-04 jrmu (list 'remainder remainder)
410 665c255d 2023-08-04 jrmu (list 'eq? eq?)
411 665c255d 2023-08-04 jrmu (list 'equal? equal?)
412 665c255d 2023-08-04 jrmu (list 'display display)))
413 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
415 665c255d 2023-08-04 jrmu primitive-procedures))
416 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
417 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
418 665c255d 2023-08-04 jrmu primitive-procedures))
419 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
420 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
421 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
423 665c255d 2023-08-04 jrmu ;; driver-loop
424 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
425 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
426 665c255d 2023-08-04 jrmu (define (driver-loop)
427 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
428 665c255d 2023-08-04 jrmu (let ((input (read)))
429 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
430 665c255d 2023-08-04 jrmu (announce-output output-prompt)
431 665c255d 2023-08-04 jrmu (user-print output)))
432 665c255d 2023-08-04 jrmu (driver-loop))
433 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
434 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
436 665c255d 2023-08-04 jrmu (define (announce-output string)
437 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
438 665c255d 2023-08-04 jrmu (define (user-print object)
439 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
440 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
441 665c255d 2023-08-04 jrmu (procedure-parameters object)
442 665c255d 2023-08-04 jrmu (procedure-body object)
443 665c255d 2023-08-04 jrmu '<procedure-env>))
444 665c255d 2023-08-04 jrmu (display object)))
445 665c255d 2023-08-04 jrmu (define (setup-environment)
446 665c255d 2023-08-04 jrmu (let ((initial-env
447 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
448 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
449 665c255d 2023-08-04 jrmu the-empty-environment)))
450 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
451 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
452 665c255d 2023-08-04 jrmu initial-env))
453 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
455 665c255d 2023-08-04 jrmu ;; auxiliary
456 665c255d 2023-08-04 jrmu (define (test-case actual expected)
458 665c255d 2023-08-04 jrmu (display "Actual: ")
459 665c255d 2023-08-04 jrmu (display actual)
461 665c255d 2023-08-04 jrmu (display "Expected: ")
462 665c255d 2023-08-04 jrmu (display expected)
464 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
465 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
466 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
467 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
469 665c255d 2023-08-04 jrmu ;; Exercise 4.15. Given a one-argument procedure p and an object a, p is said to ``halt'' on a if evaluating the expression (p a) returns a value (as opposed to terminating with an error message or running forever). Show that it is impossible to write a procedure halts? that correctly determines whether p halts on a for any procedure p and object a. Use the following reasoning: If you had such a procedure halts?, you could implement the following program:
471 665c255d 2023-08-04 jrmu (define (run-forever) (run-forever))
473 665c255d 2023-08-04 jrmu (define (try p)
474 665c255d 2023-08-04 jrmu (if (halts? p p)
475 665c255d 2023-08-04 jrmu (run-forever)
478 665c255d 2023-08-04 jrmu ;; Now consider evaluating the expression (try try) and show that any possible outcome (either halting or running forever) violates the intended behavior of halts?.23
480 665c255d 2023-08-04 jrmu ;; If (try try) halts, (halts? try try) will be true. But then, according to the definition of try above, (try try) will run forever.
482 665c255d 2023-08-04 jrmu ;; On the other hand, if (try try) does not halt, then (halts? try try) will be false. However, according to the definition of try above, this means that (try try) will return 'halted and therefore halt.
484 665c255d 2023-08-04 jrmu ;; test-suite
486 665c255d 2023-08-04 jrmu ;; procedure definitions
489 665c255d 2023-08-04 jrmu '(define (assoc key records)
490 665c255d 2023-08-04 jrmu (cond ((null? records) false)
491 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
492 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
495 665c255d 2023-08-04 jrmu '(define (map proc list)
496 665c255d 2023-08-04 jrmu (if (null? list)
498 665c255d 2023-08-04 jrmu (cons (proc (car list))
499 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
502 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
503 665c255d 2023-08-04 jrmu (if (null? sequence)
505 665c255d 2023-08-04 jrmu (op (car sequence)
506 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
508 665c255d 2023-08-04 jrmu ;; all special forms
509 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
510 665c255d 2023-08-04 jrmu (test-eval '10 10)
511 665c255d 2023-08-04 jrmu (geval '(define x 3))
512 665c255d 2023-08-04 jrmu (test-eval 'x 3)
513 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
514 665c255d 2023-08-04 jrmu (test-eval 'x -25)
515 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
516 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
517 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
518 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
519 665c255d 2023-08-04 jrmu (else 'failed))
521 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
523 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
524 665c255d 2023-08-04 jrmu (+ x y (* x y)))
525 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
529 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
530 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
531 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
532 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
533 665c255d 2023-08-04 jrmu (test-eval 'x -2)
534 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
535 665c255d 2023-08-04 jrmu (test-eval 'x -2)
536 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
537 665c255d 2023-08-04 jrmu (test-eval 'x 25)
538 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
539 665c255d 2023-08-04 jrmu (test-eval 'x 2)
540 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
541 665c255d 2023-08-04 jrmu (test-eval 'x 25)
542 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
543 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
549 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
550 665c255d 2023-08-04 jrmu (else false))
554 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
555 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
556 665c255d 2023-08-04 jrmu ((map (lambda (x)
557 665c255d 2023-08-04 jrmu (* x (+ x 1)))
558 665c255d 2023-08-04 jrmu '(2 4 1 9))
560 665c255d 2023-08-04 jrmu (lambda (x)
561 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
562 665c255d 2023-08-04 jrmu (else 'never-reach))
564 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
567 665c255d 2023-08-04 jrmu ;; procedure definition and application
569 665c255d 2023-08-04 jrmu '(define (factorial n)
570 665c255d 2023-08-04 jrmu (if (= n 0)
572 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
573 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
578 665c255d 2023-08-04 jrmu '(map (lambda (x)
579 665c255d 2023-08-04 jrmu (* x (+ x 1)))
580 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
581 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
582 665c255d 2023-08-04 jrmu ;; accumulate
585 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
588 665c255d 2023-08-04 jrmu ;; make-let
590 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
597 665c255d 2023-08-04 jrmu '(let ((x 3))
601 665c255d 2023-08-04 jrmu '(let ((x 3)
606 665c255d 2023-08-04 jrmu '(let ((x 3)
608 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
612 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
614 665c255d 2023-08-04 jrmu '(let ((x 6)
615 665c255d 2023-08-04 jrmu (y (let ((x 2))
617 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
626 665c255d 2023-08-04 jrmu '(let* ((x 3)
627 665c255d 2023-08-04 jrmu (y (+ x 2))
628 665c255d 2023-08-04 jrmu (z (+ x y 5)))
637 665c255d 2023-08-04 jrmu '(let* ((x 3))
638 665c255d 2023-08-04 jrmu (let* ((y 5))
643 665c255d 2023-08-04 jrmu '(let* ((x 3)
644 665c255d 2023-08-04 jrmu (y (+ x 1)))
645 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
649 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
651 665c255d 2023-08-04 jrmu '(let* ((x 6)
652 665c255d 2023-08-04 jrmu (y (let* ((x 2)
653 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
656 665c255d 2023-08-04 jrmu (z (+ x y)))
660 665c255d 2023-08-04 jrmu ;; named-let
663 665c255d 2023-08-04 jrmu '(let eight ()
669 665c255d 2023-08-04 jrmu '(let loop ((count 0))
670 665c255d 2023-08-04 jrmu (if (= 100 count)
672 665c255d 2023-08-04 jrmu (loop (+ count 1))))
675 665c255d 2023-08-04 jrmu '(define (prime? x)
676 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
677 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
678 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
679 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
681 665c255d 2023-08-04 jrmu '(let primes ((x 2)
683 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
684 665c255d 2023-08-04 jrmu ((prime? x)
686 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
687 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
688 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))
691 665c255d 2023-08-04 jrmu '(define (fib n)
692 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
695 665c255d 2023-08-04 jrmu (if (= count 0)
697 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
698 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
702 665c255d 2023-08-04 jrmu '(let ((y 0))
703 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
704 665c255d 2023-08-04 jrmu ((= x 5) y)
705 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
716 665c255d 2023-08-04 jrmu '(let ((y 0))
718 665c255d 2023-08-04 jrmu ((= y 5) y)
719 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
723 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
724 665c255d 2023-08-04 jrmu ((null? y))
725 665c255d 2023-08-04 jrmu (set! y (cdr y)))
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))))
734 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
735 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
736 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
737 665c255d 2023-08-04 jrmu ((null? x) sum)))
740 665c255d 2023-08-04 jrmu '(let ((z '()))
741 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
742 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
743 665c255d 2023-08-04 jrmu ((null? x) y x z)
744 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
745 665c255d 2023-08-04 jrmu '(4 3 2 1))
747 665c255d 2023-08-04 jrmu ;; make-unbound!
750 665c255d 2023-08-04 jrmu '(let ((x 3))
751 665c255d 2023-08-04 jrmu (let ((x 5))
752 665c255d 2023-08-04 jrmu (make-unbound! x)
757 665c255d 2023-08-04 jrmu '(let ((x 3))
758 665c255d 2023-08-04 jrmu (let ((x 5))
759 665c255d 2023-08-04 jrmu (define y x)
760 665c255d 2023-08-04 jrmu (make-unbound! x)
765 665c255d 2023-08-04 jrmu '(let ((y -1) (x 3))
766 665c255d 2023-08-04 jrmu (let ((y 0.5) (x 5))
767 665c255d 2023-08-04 jrmu (define a x)
768 665c255d 2023-08-04 jrmu (define b y)
769 665c255d 2023-08-04 jrmu (make-unbound! x)
770 665c255d 2023-08-04 jrmu (make-unbound! y)
771 665c255d 2023-08-04 jrmu (* a b x y)))
772 665c255d 2023-08-04 jrmu (* 5 3 -1 0.5))
775 665c255d 2023-08-04 jrmu '(let ((x 3) (y 4))
776 665c255d 2023-08-04 jrmu (let ((x 5))
777 665c255d 2023-08-04 jrmu (make-unbound! x)
782 665c255d 2023-08-04 jrmu '(let ((a 1) (b 2) (c 3) (d 4))
783 665c255d 2023-08-04 jrmu (make-unbound! b)
788 665c255d 2023-08-04 jrmu '(let ((x 4) (y 5))
789 665c255d 2023-08-04 jrmu (let ((a 1) (b 2) (c 3))
790 665c255d 2023-08-04 jrmu (let ((x (+ a b)) (y (+ c a)))
791 665c255d 2023-08-04 jrmu (make-unbound! x)
792 665c255d 2023-08-04 jrmu (let ((a x) (b (+ x y)))
793 665c255d 2023-08-04 jrmu (define z b)
794 665c255d 2023-08-04 jrmu (make-unbound! b)
796 665c255d 2023-08-04 jrmu (+ a b y))))))
798 665c255d 2023-08-04 jrmu (+ 4 2 4)))
