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 ((if? exp) (eval-if exp env))
10 665c255d 2023-08-04 jrmu ((and? exp) (eval-and exp env))
11 665c255d 2023-08-04 jrmu ((or? exp) (eval-or exp env))
12 665c255d 2023-08-04 jrmu ((lambda? exp)
13 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
14 665c255d 2023-08-04 jrmu (lambda-body exp)
16 665c255d 2023-08-04 jrmu ((begin? exp)
17 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
18 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
19 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
20 665c255d 2023-08-04 jrmu ((let*? exp) (eval (let*->nested-lets exp) env))
21 665c255d 2023-08-04 jrmu ((named-let? exp) (eval (named-let->combination exp) env))
22 665c255d 2023-08-04 jrmu ((do? exp) (eval (do->combination exp) env))
23 665c255d 2023-08-04 jrmu ((application? exp)
24 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
25 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
27 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
28 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
29 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
30 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
31 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
32 665c255d 2023-08-04 jrmu (eval-sequence
33 665c255d 2023-08-04 jrmu (procedure-body procedure)
34 665c255d 2023-08-04 jrmu (extend-environment
35 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
37 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
40 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
42 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
43 665c255d 2023-08-04 jrmu (if (no-operands? exps)
45 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
46 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
48 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
49 665c255d 2023-08-04 jrmu (if (pair? exp)
50 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
53 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
54 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
55 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
56 665c255d 2023-08-04 jrmu ((string? exp) true)
57 665c255d 2023-08-04 jrmu (else false)))
58 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
59 665c255d 2023-08-04 jrmu (define (quoted? exp)
60 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
61 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
63 665c255d 2023-08-04 jrmu ;; assignment/definition
64 665c255d 2023-08-04 jrmu (define (assignment? exp)
65 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
66 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
67 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
68 665c255d 2023-08-04 jrmu (define (definition? exp)
69 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
70 665c255d 2023-08-04 jrmu (define (definition-variable exp)
71 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
73 665c255d 2023-08-04 jrmu (caadr exp)))
74 665c255d 2023-08-04 jrmu (define (definition-value exp)
75 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
77 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
78 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
79 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
80 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
81 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
84 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
85 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
86 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
89 665c255d 2023-08-04 jrmu (define (make-definition var val)
90 665c255d 2023-08-04 jrmu `(define ,var ,val))
93 665c255d 2023-08-04 jrmu ;; if/and/or
94 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
95 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
96 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
97 665c255d 2023-08-04 jrmu (define (if-alternative exp)
98 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
99 665c255d 2023-08-04 jrmu (cadddr exp)
101 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
102 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
103 665c255d 2023-08-04 jrmu (define (eval-if exp env)
104 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
105 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
106 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
108 665c255d 2023-08-04 jrmu (define (and? exp)
109 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
110 665c255d 2023-08-04 jrmu (define (and-clauses exp)
112 665c255d 2023-08-04 jrmu (define (or? exp)
113 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
114 665c255d 2023-08-04 jrmu (define (or-clauses exp)
116 665c255d 2023-08-04 jrmu (define (eval-and exp env)
117 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
118 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
119 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
120 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
121 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
122 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
123 665c255d 2023-08-04 jrmu (define (eval-or exp env)
124 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
125 665c255d 2023-08-04 jrmu (if (null? clauses)
127 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
128 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
129 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
132 665c255d 2023-08-04 jrmu ;; lambda/let/let*
133 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
134 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
135 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
136 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
137 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
139 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
141 665c255d 2023-08-04 jrmu (cons (map list vars vals)
143 665c255d 2023-08-04 jrmu (define (let? exp)
144 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
145 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
146 665c255d 2023-08-04 jrmu (define (let-vars exp)
147 665c255d 2023-08-04 jrmu (map car (cadr exp)))
148 665c255d 2023-08-04 jrmu (define (let-vals exp)
149 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
150 665c255d 2023-08-04 jrmu (define (let-body exp)
151 665c255d 2023-08-04 jrmu (cddr exp))
152 665c255d 2023-08-04 jrmu (define (let->combination exp)
153 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
154 665c255d 2023-08-04 jrmu (let-vals exp)))
155 665c255d 2023-08-04 jrmu (define (named-let? exp)
156 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
157 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
158 665c255d 2023-08-04 jrmu (define (named-let-name exp)
159 665c255d 2023-08-04 jrmu (cadr exp))
160 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
161 665c255d 2023-08-04 jrmu (map car (caddr exp)))
162 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
163 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
164 665c255d 2023-08-04 jrmu (define (named-let-body exp)
165 665c255d 2023-08-04 jrmu (cdddr exp))
166 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
167 665c255d 2023-08-04 jrmu (sequence->exp
168 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
169 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
170 665c255d 2023-08-04 jrmu (named-let-body exp)))
171 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
172 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
173 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
176 665c255d 2023-08-04 jrmu (cons (map list vars vals)
179 665c255d 2023-08-04 jrmu (define (make-application op args)
180 665c255d 2023-08-04 jrmu (cons op args))
182 665c255d 2023-08-04 jrmu (define (let*? exp)
183 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
184 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
185 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
186 665c255d 2023-08-04 jrmu (define let*-body let-body)
187 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
188 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
189 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
190 665c255d 2023-08-04 jrmu (make-let (list (car vars))
191 665c255d 2023-08-04 jrmu (list (car vals))
192 665c255d 2023-08-04 jrmu (let*-body exp))
193 665c255d 2023-08-04 jrmu (make-let (list (car vars))
194 665c255d 2023-08-04 jrmu (list (car vals))
195 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
196 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
197 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
198 665c255d 2023-08-04 jrmu (if (null? vars)
199 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
200 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
203 665c255d 2023-08-04 jrmu (define (do? exp)
204 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
205 665c255d 2023-08-04 jrmu (define (do-vars exp)
206 665c255d 2023-08-04 jrmu (map car (cadr exp)))
207 665c255d 2023-08-04 jrmu (define (do-inits exp)
208 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
209 665c255d 2023-08-04 jrmu (define (do-steps exp)
210 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
211 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
212 665c255d 2023-08-04 jrmu (car var-init-step)
213 665c255d 2023-08-04 jrmu (caddr var-init-step)))
214 665c255d 2023-08-04 jrmu (cadr exp)))
215 665c255d 2023-08-04 jrmu (define (do-test exp)
216 665c255d 2023-08-04 jrmu (caaddr exp))
217 665c255d 2023-08-04 jrmu (define (do-expressions exp)
218 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
219 665c255d 2023-08-04 jrmu (caddr exp)
220 665c255d 2023-08-04 jrmu (cdaddr exp)))
221 665c255d 2023-08-04 jrmu (define (do-commands exp)
222 665c255d 2023-08-04 jrmu (cdddr exp))
223 665c255d 2023-08-04 jrmu (define (do->combination exp)
224 665c255d 2023-08-04 jrmu (make-named-let
226 665c255d 2023-08-04 jrmu (do-vars exp)
227 665c255d 2023-08-04 jrmu (do-inits exp)
230 665c255d 2023-08-04 jrmu (do-test exp)
231 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
232 665c255d 2023-08-04 jrmu (sequence->exp
233 665c255d 2023-08-04 jrmu (append (do-commands exp)
234 665c255d 2023-08-04 jrmu (list (make-application
236 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
239 665c255d 2023-08-04 jrmu ;; begin/sequence
240 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
241 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
242 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
243 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
244 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
245 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
246 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
247 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
248 665c255d 2023-08-04 jrmu (else (make-begin seq))))
249 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
250 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
251 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
252 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
253 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
255 665c255d 2023-08-04 jrmu ;; application
256 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
257 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
258 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
259 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
260 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
261 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
264 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
265 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
266 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
267 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
268 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
269 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
270 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
271 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
272 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
273 665c255d 2023-08-04 jrmu (caddr clause))
274 665c255d 2023-08-04 jrmu (define (cond->if exp)
275 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
276 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
277 665c255d 2023-08-04 jrmu (if (null? clauses)
278 665c255d 2023-08-04 jrmu 'false ; no else clause
279 665c255d 2023-08-04 jrmu (let ((first (car clauses))
280 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
281 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
282 665c255d 2023-08-04 jrmu (if (null? rest)
283 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
284 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
286 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
287 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
288 665c255d 2023-08-04 jrmu (make-application
289 665c255d 2023-08-04 jrmu (cond-extended-proc first)
290 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
291 665c255d 2023-08-04 jrmu (expand-clauses rest))
292 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
293 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
294 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
295 665c255d 2023-08-04 jrmu (define (true? x)
296 665c255d 2023-08-04 jrmu (not (eq? x false)))
297 665c255d 2023-08-04 jrmu (define (false? x)
298 665c255d 2023-08-04 jrmu (eq? x false))
300 665c255d 2023-08-04 jrmu ;; procedure
301 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
302 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
303 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
304 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
305 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
306 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
307 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
309 665c255d 2023-08-04 jrmu ;; environment
310 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
311 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
312 665c255d 2023-08-04 jrmu (define the-empty-environment '())
313 665c255d 2023-08-04 jrmu (define (make-frame variables values)
314 665c255d 2023-08-04 jrmu (cons variables values))
315 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
316 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
317 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
318 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
319 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
320 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
321 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
322 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
323 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
324 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
325 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
326 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
327 665c255d 2023-08-04 jrmu (define (env-loop env)
328 665c255d 2023-08-04 jrmu (define (scan vars vals)
329 665c255d 2023-08-04 jrmu (cond ((null? vars)
330 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
331 665c255d 2023-08-04 jrmu ((eq? var (car vars))
332 665c255d 2023-08-04 jrmu (car vals))
333 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
334 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
335 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
336 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
337 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
338 665c255d 2023-08-04 jrmu (frame-values frame)))))
339 665c255d 2023-08-04 jrmu (env-loop env))
340 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
341 665c255d 2023-08-04 jrmu (define (env-loop env)
342 665c255d 2023-08-04 jrmu (define (scan vars vals)
343 665c255d 2023-08-04 jrmu (cond ((null? vars)
344 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
345 665c255d 2023-08-04 jrmu ((eq? var (car vars))
346 665c255d 2023-08-04 jrmu (set-car! vals val))
347 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
348 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
349 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
350 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
351 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
352 665c255d 2023-08-04 jrmu (frame-values frame)))))
353 665c255d 2023-08-04 jrmu (env-loop env))
354 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
355 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
356 665c255d 2023-08-04 jrmu (define (scan vars vals)
357 665c255d 2023-08-04 jrmu (cond ((null? vars)
358 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
359 665c255d 2023-08-04 jrmu ((eq? var (car vars))
360 665c255d 2023-08-04 jrmu (set-car! vals val))
361 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
362 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
363 665c255d 2023-08-04 jrmu (frame-values frame))))
365 665c255d 2023-08-04 jrmu ;; primitives
366 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
367 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
368 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
369 665c255d 2023-08-04 jrmu (define primitive-procedures
370 665c255d 2023-08-04 jrmu (list (list 'car car)
371 665c255d 2023-08-04 jrmu (list 'cdr cdr)
372 665c255d 2023-08-04 jrmu (list 'caar caar)
373 665c255d 2023-08-04 jrmu (list 'cadr cadr)
374 665c255d 2023-08-04 jrmu (list 'cddr cddr)
375 665c255d 2023-08-04 jrmu (list 'cons cons)
376 665c255d 2023-08-04 jrmu (list 'null? null?)
377 665c255d 2023-08-04 jrmu (list '* *)
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 'remainder remainder)
387 665c255d 2023-08-04 jrmu (list 'eq? eq?)
388 665c255d 2023-08-04 jrmu (list 'equal? equal?)
389 665c255d 2023-08-04 jrmu (list 'display display)))
390 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
392 665c255d 2023-08-04 jrmu primitive-procedures))
393 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
394 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
395 665c255d 2023-08-04 jrmu primitive-procedures))
396 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
397 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
398 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
400 665c255d 2023-08-04 jrmu ;; driver-loop
401 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
402 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
403 665c255d 2023-08-04 jrmu (define (driver-loop)
404 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
405 665c255d 2023-08-04 jrmu (let ((input (read)))
406 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
407 665c255d 2023-08-04 jrmu (announce-output output-prompt)
408 665c255d 2023-08-04 jrmu (user-print output)))
409 665c255d 2023-08-04 jrmu (driver-loop))
410 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
411 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
413 665c255d 2023-08-04 jrmu (define (announce-output string)
414 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
415 665c255d 2023-08-04 jrmu (define (user-print object)
416 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
417 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
418 665c255d 2023-08-04 jrmu (procedure-parameters object)
419 665c255d 2023-08-04 jrmu (procedure-body object)
420 665c255d 2023-08-04 jrmu '<procedure-env>))
421 665c255d 2023-08-04 jrmu (display object)))
422 665c255d 2023-08-04 jrmu (define (setup-environment)
423 665c255d 2023-08-04 jrmu (let ((initial-env
424 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
425 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
426 665c255d 2023-08-04 jrmu the-empty-environment)))
427 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
428 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
429 665c255d 2023-08-04 jrmu initial-env))
430 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
432 665c255d 2023-08-04 jrmu ;; auxiliary
433 665c255d 2023-08-04 jrmu (define (test-case actual expected)
435 665c255d 2023-08-04 jrmu (display "Actual: ")
436 665c255d 2023-08-04 jrmu (display actual)
438 665c255d 2023-08-04 jrmu (display "Expected: ")
439 665c255d 2023-08-04 jrmu (display expected)
441 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
442 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
443 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
444 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
446 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.
448 665c255d 2023-08-04 jrmu ;; test-suite
450 665c255d 2023-08-04 jrmu ;; procedure definitions
453 665c255d 2023-08-04 jrmu '(define (assoc key records)
454 665c255d 2023-08-04 jrmu (cond ((null? records) false)
455 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
456 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
459 665c255d 2023-08-04 jrmu '(define (map proc list)
460 665c255d 2023-08-04 jrmu (if (null? list)
462 665c255d 2023-08-04 jrmu (cons (proc (car list))
463 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
466 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
467 665c255d 2023-08-04 jrmu (if (null? sequence)
469 665c255d 2023-08-04 jrmu (op (car sequence)
470 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
472 665c255d 2023-08-04 jrmu ;; all special forms
473 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
474 665c255d 2023-08-04 jrmu (test-eval '10 10)
475 665c255d 2023-08-04 jrmu (geval '(define x 3))
476 665c255d 2023-08-04 jrmu (test-eval 'x 3)
477 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
478 665c255d 2023-08-04 jrmu (test-eval 'x -25)
479 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
480 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
481 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
482 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
483 665c255d 2023-08-04 jrmu (else 'failed))
485 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
487 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
488 665c255d 2023-08-04 jrmu (+ x y (* x y)))
489 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
493 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
494 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
495 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
496 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
497 665c255d 2023-08-04 jrmu (test-eval 'x -2)
498 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
499 665c255d 2023-08-04 jrmu (test-eval 'x -2)
500 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
501 665c255d 2023-08-04 jrmu (test-eval 'x 25)
502 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
503 665c255d 2023-08-04 jrmu (test-eval 'x 2)
504 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
505 665c255d 2023-08-04 jrmu (test-eval 'x 25)
506 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
507 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
513 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
514 665c255d 2023-08-04 jrmu (else false))
518 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
519 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
520 665c255d 2023-08-04 jrmu ((map (lambda (x)
521 665c255d 2023-08-04 jrmu (* x (+ x 1)))
522 665c255d 2023-08-04 jrmu '(2 4 1 9))
524 665c255d 2023-08-04 jrmu (lambda (x)
525 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
526 665c255d 2023-08-04 jrmu (else 'never-reach))
528 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
531 665c255d 2023-08-04 jrmu ;; procedure definition and application
533 665c255d 2023-08-04 jrmu '(define (factorial n)
534 665c255d 2023-08-04 jrmu (if (= n 0)
536 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
537 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
542 665c255d 2023-08-04 jrmu '(map (lambda (x)
543 665c255d 2023-08-04 jrmu (* x (+ x 1)))
544 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
545 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
546 665c255d 2023-08-04 jrmu ;; accumulate
549 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
552 665c255d 2023-08-04 jrmu ;; make-let
554 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
561 665c255d 2023-08-04 jrmu '(let ((x 3))
565 665c255d 2023-08-04 jrmu '(let ((x 3)
570 665c255d 2023-08-04 jrmu '(let ((x 3)
572 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
576 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
578 665c255d 2023-08-04 jrmu '(let ((x 6)
579 665c255d 2023-08-04 jrmu (y (let ((x 2))
581 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
590 665c255d 2023-08-04 jrmu '(let* ((x 3)
591 665c255d 2023-08-04 jrmu (y (+ x 2))
592 665c255d 2023-08-04 jrmu (z (+ x y 5)))
601 665c255d 2023-08-04 jrmu '(let* ((x 3))
602 665c255d 2023-08-04 jrmu (let* ((y 5))
607 665c255d 2023-08-04 jrmu '(let* ((x 3)
608 665c255d 2023-08-04 jrmu (y (+ x 1)))
609 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
613 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
615 665c255d 2023-08-04 jrmu '(let* ((x 6)
616 665c255d 2023-08-04 jrmu (y (let* ((x 2)
617 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
620 665c255d 2023-08-04 jrmu (z (+ x y)))
624 665c255d 2023-08-04 jrmu ;; named-let
627 665c255d 2023-08-04 jrmu '(let eight ()
633 665c255d 2023-08-04 jrmu '(let loop ((count 0))
634 665c255d 2023-08-04 jrmu (if (= 100 count)
636 665c255d 2023-08-04 jrmu (loop (+ count 1))))
639 665c255d 2023-08-04 jrmu '(define (prime? x)
640 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
641 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
642 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
643 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
645 665c255d 2023-08-04 jrmu '(let primes ((x 2)
647 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
648 665c255d 2023-08-04 jrmu ((prime? x)
650 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
651 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
652 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))
655 665c255d 2023-08-04 jrmu '(define (fib n)
656 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
659 665c255d 2023-08-04 jrmu (if (= count 0)
661 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
662 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
666 665c255d 2023-08-04 jrmu '(let ((y 0))
667 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
668 665c255d 2023-08-04 jrmu ((= x 5) y)
669 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
680 665c255d 2023-08-04 jrmu '(let ((y 0))
682 665c255d 2023-08-04 jrmu ((= y 5) y)
683 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
687 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
688 665c255d 2023-08-04 jrmu ((null? y))
689 665c255d 2023-08-04 jrmu (set! y (cdr y)))
692 665c255d 2023-08-04 jrmu '(let ((y 0))
693 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
694 665c255d 2023-08-04 jrmu ((= x 5) y)
695 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
698 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
699 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
700 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
701 665c255d 2023-08-04 jrmu ((null? x) sum)))
704 665c255d 2023-08-04 jrmu '(let ((z '()))
705 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
706 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
707 665c255d 2023-08-04 jrmu ((null? x) y x z)
708 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
709 665c255d 2023-08-04 jrmu '(4 3 2 1))
