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))
94 665c255d 2023-08-04 jrmu ;; if/and/or
95 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
96 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
97 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
98 665c255d 2023-08-04 jrmu (define (if-alternative exp)
99 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
100 665c255d 2023-08-04 jrmu (cadddr exp)
102 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
103 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
104 665c255d 2023-08-04 jrmu (define (eval-if exp env)
105 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
106 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
107 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
109 665c255d 2023-08-04 jrmu (define (and? exp)
110 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
111 665c255d 2023-08-04 jrmu (define (and-clauses exp)
113 665c255d 2023-08-04 jrmu (define (or? exp)
114 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
115 665c255d 2023-08-04 jrmu (define (or-clauses exp)
117 665c255d 2023-08-04 jrmu (define (eval-and exp env)
118 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
119 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
120 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
121 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
122 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
123 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
124 665c255d 2023-08-04 jrmu (define (eval-or exp env)
125 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
126 665c255d 2023-08-04 jrmu (if (null? clauses)
128 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
129 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
130 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
133 665c255d 2023-08-04 jrmu ;; lambda/let/let*
134 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
135 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
136 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
137 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
138 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
140 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
142 665c255d 2023-08-04 jrmu (cons (map list vars vals)
144 665c255d 2023-08-04 jrmu (define (let? exp)
145 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
146 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
147 665c255d 2023-08-04 jrmu (define (let-vars exp)
148 665c255d 2023-08-04 jrmu (map car (cadr exp)))
149 665c255d 2023-08-04 jrmu (define (let-vals exp)
150 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
151 665c255d 2023-08-04 jrmu (define (let-body exp)
152 665c255d 2023-08-04 jrmu (cddr exp))
153 665c255d 2023-08-04 jrmu (define (let->combination exp)
154 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
155 665c255d 2023-08-04 jrmu (let-vals exp)))
156 665c255d 2023-08-04 jrmu (define (named-let? exp)
157 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
158 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
159 665c255d 2023-08-04 jrmu (define (named-let-name exp)
160 665c255d 2023-08-04 jrmu (cadr exp))
161 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
162 665c255d 2023-08-04 jrmu (map car (caddr exp)))
163 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
164 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
165 665c255d 2023-08-04 jrmu (define (named-let-body exp)
166 665c255d 2023-08-04 jrmu (cdddr exp))
167 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
168 665c255d 2023-08-04 jrmu (sequence->exp
169 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
170 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
171 665c255d 2023-08-04 jrmu (named-let-body exp)))
172 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
173 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
174 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
177 665c255d 2023-08-04 jrmu (cons (map list vars vals)
180 665c255d 2023-08-04 jrmu (define (make-application op args)
181 665c255d 2023-08-04 jrmu (cons op args))
183 665c255d 2023-08-04 jrmu (define (let*? exp)
184 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
185 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
186 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
187 665c255d 2023-08-04 jrmu (define let*-body let-body)
188 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
189 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
190 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
191 665c255d 2023-08-04 jrmu (make-let (list (car vars))
192 665c255d 2023-08-04 jrmu (list (car vals))
193 665c255d 2023-08-04 jrmu (let*-body exp))
194 665c255d 2023-08-04 jrmu (make-let (list (car vars))
195 665c255d 2023-08-04 jrmu (list (car vals))
196 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
197 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
198 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
199 665c255d 2023-08-04 jrmu (if (null? vars)
200 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
201 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
204 665c255d 2023-08-04 jrmu (define (do? exp)
205 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
206 665c255d 2023-08-04 jrmu (define (do-vars exp)
207 665c255d 2023-08-04 jrmu (map car (cadr exp)))
208 665c255d 2023-08-04 jrmu (define (do-inits exp)
209 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
210 665c255d 2023-08-04 jrmu (define (do-steps exp)
211 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
212 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
213 665c255d 2023-08-04 jrmu (car var-init-step)
214 665c255d 2023-08-04 jrmu (caddr var-init-step)))
215 665c255d 2023-08-04 jrmu (cadr exp)))
216 665c255d 2023-08-04 jrmu (define (do-test exp)
217 665c255d 2023-08-04 jrmu (caaddr exp))
218 665c255d 2023-08-04 jrmu (define (do-expressions exp)
219 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
220 665c255d 2023-08-04 jrmu (caddr exp)
221 665c255d 2023-08-04 jrmu (cdaddr exp)))
222 665c255d 2023-08-04 jrmu (define (do-commands exp)
223 665c255d 2023-08-04 jrmu (cdddr exp))
224 665c255d 2023-08-04 jrmu (define (do->combination exp)
225 665c255d 2023-08-04 jrmu (make-named-let
227 665c255d 2023-08-04 jrmu (do-vars exp)
228 665c255d 2023-08-04 jrmu (do-inits exp)
231 665c255d 2023-08-04 jrmu (do-test exp)
232 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
233 665c255d 2023-08-04 jrmu (sequence->exp
234 665c255d 2023-08-04 jrmu (append (do-commands exp)
235 665c255d 2023-08-04 jrmu (list (make-application
237 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
240 665c255d 2023-08-04 jrmu ;; begin/sequence
241 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
242 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
243 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
244 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
245 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
246 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
247 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
248 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
249 665c255d 2023-08-04 jrmu (else (make-begin seq))))
250 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
251 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
252 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
253 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
254 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
256 665c255d 2023-08-04 jrmu ;; application
257 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
258 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
259 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
260 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
261 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
262 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
265 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
266 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
267 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
268 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
269 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
270 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
271 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
272 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
273 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
274 665c255d 2023-08-04 jrmu (caddr clause))
275 665c255d 2023-08-04 jrmu (define (cond->if exp)
276 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
277 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
278 665c255d 2023-08-04 jrmu (if (null? clauses)
279 665c255d 2023-08-04 jrmu 'false ; no else clause
280 665c255d 2023-08-04 jrmu (let ((first (car clauses))
281 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
282 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
283 665c255d 2023-08-04 jrmu (if (null? rest)
284 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
285 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
287 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
288 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
289 665c255d 2023-08-04 jrmu (make-application
290 665c255d 2023-08-04 jrmu (cond-extended-proc first)
291 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
292 665c255d 2023-08-04 jrmu (expand-clauses rest))
293 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
294 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
295 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
296 665c255d 2023-08-04 jrmu (define (true? x)
297 665c255d 2023-08-04 jrmu (not (eq? x false)))
298 665c255d 2023-08-04 jrmu (define (false? x)
299 665c255d 2023-08-04 jrmu (eq? x false))
301 665c255d 2023-08-04 jrmu ;; procedure
302 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
303 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
304 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
305 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
306 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
307 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
308 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
310 665c255d 2023-08-04 jrmu ;; environment
311 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
312 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
313 665c255d 2023-08-04 jrmu (define the-empty-environment '())
314 665c255d 2023-08-04 jrmu (define (make-frame variables values)
315 665c255d 2023-08-04 jrmu (cons variables values))
316 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
317 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
318 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
319 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
320 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
321 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
322 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
323 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
324 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
325 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
326 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
327 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
328 665c255d 2023-08-04 jrmu (define (env-loop env)
329 665c255d 2023-08-04 jrmu (define (scan vars vals)
330 665c255d 2023-08-04 jrmu (cond ((null? vars)
331 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
332 665c255d 2023-08-04 jrmu ((eq? var (car vars))
333 665c255d 2023-08-04 jrmu (car vals))
334 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
335 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
336 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
337 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
338 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
339 665c255d 2023-08-04 jrmu (frame-values frame)))))
340 665c255d 2023-08-04 jrmu (env-loop env))
341 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
342 665c255d 2023-08-04 jrmu (define (env-loop env)
343 665c255d 2023-08-04 jrmu (define (scan vars vals)
344 665c255d 2023-08-04 jrmu (cond ((null? vars)
345 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
346 665c255d 2023-08-04 jrmu ((eq? var (car vars))
347 665c255d 2023-08-04 jrmu (set-car! vals val))
348 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
349 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
350 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
351 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
352 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
353 665c255d 2023-08-04 jrmu (frame-values frame)))))
354 665c255d 2023-08-04 jrmu (env-loop env))
355 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
356 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
357 665c255d 2023-08-04 jrmu (define (scan vars vals)
358 665c255d 2023-08-04 jrmu (cond ((null? vars)
359 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
360 665c255d 2023-08-04 jrmu ((eq? var (car vars))
361 665c255d 2023-08-04 jrmu (set-car! vals val))
362 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
363 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
364 665c255d 2023-08-04 jrmu (frame-values frame))))
366 665c255d 2023-08-04 jrmu ;; primitives
367 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
368 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
369 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
370 665c255d 2023-08-04 jrmu (define primitive-procedures
371 665c255d 2023-08-04 jrmu (list (list 'car car)
372 665c255d 2023-08-04 jrmu (list 'cdr cdr)
373 665c255d 2023-08-04 jrmu (list 'caar caar)
374 665c255d 2023-08-04 jrmu (list 'cadr cadr)
375 665c255d 2023-08-04 jrmu (list 'cddr cddr)
376 665c255d 2023-08-04 jrmu (list 'cons cons)
377 665c255d 2023-08-04 jrmu (list 'null? null?)
378 665c255d 2023-08-04 jrmu (list '* *)
379 665c255d 2023-08-04 jrmu (list '/ /)
380 665c255d 2023-08-04 jrmu (list '+ +)
381 665c255d 2023-08-04 jrmu (list '- -)
382 665c255d 2023-08-04 jrmu (list '= =)
383 665c255d 2023-08-04 jrmu (list '< <)
384 665c255d 2023-08-04 jrmu (list '> >)
385 665c255d 2023-08-04 jrmu (list '<= <=)
386 665c255d 2023-08-04 jrmu (list '>= >=)
387 665c255d 2023-08-04 jrmu (list 'remainder remainder)
388 665c255d 2023-08-04 jrmu (list 'eq? eq?)
389 665c255d 2023-08-04 jrmu (list 'equal? equal?)
390 665c255d 2023-08-04 jrmu (list 'display display)))
391 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
393 665c255d 2023-08-04 jrmu primitive-procedures))
394 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
395 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
396 665c255d 2023-08-04 jrmu primitive-procedures))
397 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
398 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
399 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
401 665c255d 2023-08-04 jrmu ;; driver-loop
402 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
403 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
404 665c255d 2023-08-04 jrmu (define (driver-loop)
405 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
406 665c255d 2023-08-04 jrmu (let ((input (read)))
407 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
408 665c255d 2023-08-04 jrmu (announce-output output-prompt)
409 665c255d 2023-08-04 jrmu (user-print output)))
410 665c255d 2023-08-04 jrmu (driver-loop))
411 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
412 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
414 665c255d 2023-08-04 jrmu (define (announce-output string)
415 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
416 665c255d 2023-08-04 jrmu (define (user-print object)
417 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
418 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
419 665c255d 2023-08-04 jrmu (procedure-parameters object)
420 665c255d 2023-08-04 jrmu (procedure-body object)
421 665c255d 2023-08-04 jrmu '<procedure-env>))
422 665c255d 2023-08-04 jrmu (display object)))
423 665c255d 2023-08-04 jrmu (define (setup-environment)
424 665c255d 2023-08-04 jrmu (let ((initial-env
425 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
426 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
427 665c255d 2023-08-04 jrmu the-empty-environment)))
428 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
429 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
430 665c255d 2023-08-04 jrmu initial-env))
431 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
433 665c255d 2023-08-04 jrmu ;; auxiliary
434 665c255d 2023-08-04 jrmu (define (test-case actual expected)
436 665c255d 2023-08-04 jrmu (display "Actual: ")
437 665c255d 2023-08-04 jrmu (display actual)
439 665c255d 2023-08-04 jrmu (display "Expected: ")
440 665c255d 2023-08-04 jrmu (display expected)
442 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
443 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
444 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
445 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
447 665c255d 2023-08-04 jrmu ;; Exercise 4.13. Scheme allows us to create new bindings for variables by means of define, but provides no way to get rid of bindings. Implement for the evaluator a special form make-unbound! that removes the binding of a given symbol from the environment in which the make-unbound! expression is evaluated. This problem is not completely specified. For example, should we remove only the binding in the first frame of the environment? Complete the specification and justify any choices you make.
449 665c255d 2023-08-04 jrmu ;; we'll remove the binding only from the first frame of the environment in order to avoid remove bindings from other environments, which could potentially be confusing. For example:
451 665c255d 2023-08-04 jrmu ;; (let ((x 3) (y 4))
452 665c255d 2023-08-04 jrmu ;; ((lambda (z)
453 665c255d 2023-08-04 jrmu ;; (make-unbound! x)) 3)
454 665c255d 2023-08-04 jrmu ;; ((lambda ()
455 665c255d 2023-08-04 jrmu ;; (+ x 4))))
457 665c255d 2023-08-04 jrmu ;; if we were to remove bindings from other environments, then the first procedure would be able to unbind a variable which the second procedure depends on. It would break an environment extended from an enclosing environment
459 665c255d 2023-08-04 jrmu (define (unbound? exp)
460 665c255d 2023-08-04 jrmu (tagged-list? exp 'make-unbound!))
461 665c255d 2023-08-04 jrmu (define (unbound-var exp)
462 665c255d 2023-08-04 jrmu (cadr exp))
463 665c255d 2023-08-04 jrmu (define (eval-unbound exp env)
464 665c255d 2023-08-04 jrmu (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
465 665c255d 2023-08-04 jrmu (define (remove-binding-from-frame! var frame)
466 665c255d 2023-08-04 jrmu (define (scan vars vals)
467 665c255d 2023-08-04 jrmu (cond ((null? (cdr vars))
468 665c255d 2023-08-04 jrmu (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
469 665c255d 2023-08-04 jrmu ((eq? var (cadr vars))
470 665c255d 2023-08-04 jrmu (set-cdr! vars (cddr vars))
471 665c255d 2023-08-04 jrmu (set-cdr! vals (cddr vals)))
472 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
473 665c255d 2023-08-04 jrmu (let ((vars (frame-variables frame))
474 665c255d 2023-08-04 jrmu (vals (frame-values frame)))
475 665c255d 2023-08-04 jrmu (if (eq? var (car vars))
476 665c255d 2023-08-04 jrmu (begin (set-car! frame (cdr vars))
477 665c255d 2023-08-04 jrmu (set-cdr! frame (cdr vals)))
478 665c255d 2023-08-04 jrmu (scan vars vals))))
480 665c255d 2023-08-04 jrmu ;; make-unbound!
483 665c255d 2023-08-04 jrmu '(let ((x 3))
484 665c255d 2023-08-04 jrmu (let ((x 5))
485 665c255d 2023-08-04 jrmu (make-unbound! x)
490 665c255d 2023-08-04 jrmu '(let ((x 3))
491 665c255d 2023-08-04 jrmu (let ((x 5))
492 665c255d 2023-08-04 jrmu (define y x)
493 665c255d 2023-08-04 jrmu (make-unbound! x)
498 665c255d 2023-08-04 jrmu '(let ((y -1) (x 3))
499 665c255d 2023-08-04 jrmu (let ((y 0.5) (x 5))
500 665c255d 2023-08-04 jrmu (define a x)
501 665c255d 2023-08-04 jrmu (define b y)
502 665c255d 2023-08-04 jrmu (make-unbound! x)
503 665c255d 2023-08-04 jrmu (make-unbound! y)
504 665c255d 2023-08-04 jrmu (* a b x y)))
505 665c255d 2023-08-04 jrmu (* 5 3 -1 0.5))
508 665c255d 2023-08-04 jrmu '(let ((x 3) (y 4))
509 665c255d 2023-08-04 jrmu (let ((x 5))
510 665c255d 2023-08-04 jrmu (make-unbound! x)
515 665c255d 2023-08-04 jrmu '(let ((a 1) (b 2) (c 3) (d 4))
516 665c255d 2023-08-04 jrmu (make-unbound! b)
521 665c255d 2023-08-04 jrmu '(let ((x 4) (y 5))
522 665c255d 2023-08-04 jrmu (let ((a 1) (b 2) (c 3))
523 665c255d 2023-08-04 jrmu (let ((x (+ a b)) (y (+ c a)))
524 665c255d 2023-08-04 jrmu (make-unbound! x)
525 665c255d 2023-08-04 jrmu (let ((a x) (b (+ x y)))
526 665c255d 2023-08-04 jrmu (define z b)
527 665c255d 2023-08-04 jrmu (make-unbound! b)
529 665c255d 2023-08-04 jrmu (+ a b y))))))
531 665c255d 2023-08-04 jrmu (+ 4 2 4)))
533 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
534 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
535 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
536 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
538 665c255d 2023-08-04 jrmu ;; test-suite
540 665c255d 2023-08-04 jrmu ;; procedure definitions
543 665c255d 2023-08-04 jrmu '(define (assoc key records)
544 665c255d 2023-08-04 jrmu (cond ((null? records) false)
545 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
546 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
549 665c255d 2023-08-04 jrmu '(define (map proc list)
550 665c255d 2023-08-04 jrmu (if (null? list)
552 665c255d 2023-08-04 jrmu (cons (proc (car list))
553 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
556 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
557 665c255d 2023-08-04 jrmu (if (null? sequence)
559 665c255d 2023-08-04 jrmu (op (car sequence)
560 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
562 665c255d 2023-08-04 jrmu ;; all special forms
563 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
564 665c255d 2023-08-04 jrmu (test-eval '10 10)
565 665c255d 2023-08-04 jrmu (geval '(define x 3))
566 665c255d 2023-08-04 jrmu (test-eval 'x 3)
567 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
568 665c255d 2023-08-04 jrmu (test-eval 'x -25)
569 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
570 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
571 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
572 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
573 665c255d 2023-08-04 jrmu (else 'failed))
575 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
577 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
578 665c255d 2023-08-04 jrmu (+ x y (* x y)))
579 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
583 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
584 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
585 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
586 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
587 665c255d 2023-08-04 jrmu (test-eval 'x -2)
588 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
589 665c255d 2023-08-04 jrmu (test-eval 'x -2)
590 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
591 665c255d 2023-08-04 jrmu (test-eval 'x 25)
592 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
593 665c255d 2023-08-04 jrmu (test-eval 'x 2)
594 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
595 665c255d 2023-08-04 jrmu (test-eval 'x 25)
596 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
597 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
603 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
604 665c255d 2023-08-04 jrmu (else false))
608 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
609 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
610 665c255d 2023-08-04 jrmu ((map (lambda (x)
611 665c255d 2023-08-04 jrmu (* x (+ x 1)))
612 665c255d 2023-08-04 jrmu '(2 4 1 9))
614 665c255d 2023-08-04 jrmu (lambda (x)
615 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
616 665c255d 2023-08-04 jrmu (else 'never-reach))
618 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
621 665c255d 2023-08-04 jrmu ;; procedure definition and application
623 665c255d 2023-08-04 jrmu '(define (factorial n)
624 665c255d 2023-08-04 jrmu (if (= n 0)
626 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
627 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
632 665c255d 2023-08-04 jrmu '(map (lambda (x)
633 665c255d 2023-08-04 jrmu (* x (+ x 1)))
634 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
635 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
636 665c255d 2023-08-04 jrmu ;; accumulate
639 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
642 665c255d 2023-08-04 jrmu ;; make-let
644 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
651 665c255d 2023-08-04 jrmu '(let ((x 3))
655 665c255d 2023-08-04 jrmu '(let ((x 3)
660 665c255d 2023-08-04 jrmu '(let ((x 3)
662 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
666 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
668 665c255d 2023-08-04 jrmu '(let ((x 6)
669 665c255d 2023-08-04 jrmu (y (let ((x 2))
671 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
680 665c255d 2023-08-04 jrmu '(let* ((x 3)
681 665c255d 2023-08-04 jrmu (y (+ x 2))
682 665c255d 2023-08-04 jrmu (z (+ x y 5)))
691 665c255d 2023-08-04 jrmu '(let* ((x 3))
692 665c255d 2023-08-04 jrmu (let* ((y 5))
697 665c255d 2023-08-04 jrmu '(let* ((x 3)
698 665c255d 2023-08-04 jrmu (y (+ x 1)))
699 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
703 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
705 665c255d 2023-08-04 jrmu '(let* ((x 6)
706 665c255d 2023-08-04 jrmu (y (let* ((x 2)
707 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
710 665c255d 2023-08-04 jrmu (z (+ x y)))
714 665c255d 2023-08-04 jrmu ;; named-let
717 665c255d 2023-08-04 jrmu '(let eight ()
723 665c255d 2023-08-04 jrmu '(let loop ((count 0))
724 665c255d 2023-08-04 jrmu (if (= 100 count)
726 665c255d 2023-08-04 jrmu (loop (+ count 1))))
729 665c255d 2023-08-04 jrmu '(define (prime? x)
730 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
731 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
732 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
733 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
735 665c255d 2023-08-04 jrmu '(let primes ((x 2)
737 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
738 665c255d 2023-08-04 jrmu ((prime? x)
740 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
741 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
742 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))
745 665c255d 2023-08-04 jrmu '(define (fib n)
746 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
749 665c255d 2023-08-04 jrmu (if (= count 0)
751 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
752 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
756 665c255d 2023-08-04 jrmu '(let ((y 0))
757 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
758 665c255d 2023-08-04 jrmu ((= x 5) y)
759 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
770 665c255d 2023-08-04 jrmu '(let ((y 0))
772 665c255d 2023-08-04 jrmu ((= y 5) y)
773 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
777 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
778 665c255d 2023-08-04 jrmu ((null? y))
779 665c255d 2023-08-04 jrmu (set! y (cdr y)))
782 665c255d 2023-08-04 jrmu '(let ((y 0))
783 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
784 665c255d 2023-08-04 jrmu ((= x 5) y)
785 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
788 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
789 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
790 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
791 665c255d 2023-08-04 jrmu ((null? x) sum)))
794 665c255d 2023-08-04 jrmu '(let ((z '()))
795 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
796 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
797 665c255d 2023-08-04 jrmu ((null? x) y x z)
798 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
799 665c255d 2023-08-04 jrmu '(4 3 2 1))
