1 665c255d 2023-08-04 jrmu (define (eval exp env)
2 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
3 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
4 665c255d 2023-08-04 jrmu ((quoted? exp) (text-of-quotation exp))
5 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
6 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition exp env))
7 665c255d 2023-08-04 jrmu ((if? exp) (eval-if exp env))
8 665c255d 2023-08-04 jrmu ((and? exp) (eval-and exp env))
9 665c255d 2023-08-04 jrmu ((or? exp) (eval-or exp env))
10 665c255d 2023-08-04 jrmu ((lambda? exp)
11 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
12 665c255d 2023-08-04 jrmu (lambda-body exp)
14 665c255d 2023-08-04 jrmu ((begin? exp)
15 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env))
16 665c255d 2023-08-04 jrmu ((cond? exp) (eval (cond->if exp) env))
17 665c255d 2023-08-04 jrmu ((let? exp) (eval (let->combination exp) env))
18 665c255d 2023-08-04 jrmu ((let*? exp) (eval (let*->nested-lets exp) env))
19 665c255d 2023-08-04 jrmu ((named-let? exp) (eval (named-let->combination exp) env))
20 665c255d 2023-08-04 jrmu ((application? exp)
21 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
22 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
24 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
25 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
26 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
27 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
28 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
29 665c255d 2023-08-04 jrmu (eval-sequence
30 665c255d 2023-08-04 jrmu (procedure-body procedure)
31 665c255d 2023-08-04 jrmu (extend-environment
32 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
34 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
37 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
38 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
39 665c255d 2023-08-04 jrmu (if (no-operands? exps)
41 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
42 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
44 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
45 665c255d 2023-08-04 jrmu (if (pair? exp)
46 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
49 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
50 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
51 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
52 665c255d 2023-08-04 jrmu ((string? exp) true)
53 665c255d 2023-08-04 jrmu (else false)))
54 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
55 665c255d 2023-08-04 jrmu (define (quoted? exp)
56 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
57 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
59 665c255d 2023-08-04 jrmu ;; assignment/definition
60 665c255d 2023-08-04 jrmu (define (assignment? exp)
61 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
62 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
63 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
64 665c255d 2023-08-04 jrmu (define (definition? exp)
65 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
66 665c255d 2023-08-04 jrmu (define (definition-variable exp)
67 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
69 665c255d 2023-08-04 jrmu (caadr exp)))
70 665c255d 2023-08-04 jrmu (define (definition-value exp)
71 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
73 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
74 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
75 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
76 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
77 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
80 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
81 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
82 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
87 665c255d 2023-08-04 jrmu ;; if/and/or
88 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
89 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
90 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
91 665c255d 2023-08-04 jrmu (define (if-alternative exp)
92 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
93 665c255d 2023-08-04 jrmu (cadddr exp)
95 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
96 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
97 665c255d 2023-08-04 jrmu (define (eval-if exp env)
98 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
99 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
100 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
102 665c255d 2023-08-04 jrmu (define (and? exp)
103 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
104 665c255d 2023-08-04 jrmu (define (and-clauses exp)
106 665c255d 2023-08-04 jrmu (define (or? exp)
107 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
108 665c255d 2023-08-04 jrmu (define (or-clauses exp)
110 665c255d 2023-08-04 jrmu (define (eval-and exp env)
111 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
112 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
113 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
114 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
115 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
116 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
117 665c255d 2023-08-04 jrmu (define (eval-or exp env)
118 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
119 665c255d 2023-08-04 jrmu (if (null? clauses)
121 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
122 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
123 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
127 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
128 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
129 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
130 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
131 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
133 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
135 665c255d 2023-08-04 jrmu (cons (map (lambda (var val)
136 665c255d 2023-08-04 jrmu (list var val))
139 665c255d 2023-08-04 jrmu (define (let? exp)
140 665c255d 2023-08-04 jrmu (tagged-list? exp 'let))
141 665c255d 2023-08-04 jrmu (define (let-vars exp)
142 665c255d 2023-08-04 jrmu (map car (cadr exp)))
143 665c255d 2023-08-04 jrmu (define (let-vals exp)
144 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
145 665c255d 2023-08-04 jrmu (define (let-body exp)
146 665c255d 2023-08-04 jrmu (cddr exp))
147 665c255d 2023-08-04 jrmu (define (let->combination exp)
148 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
149 665c255d 2023-08-04 jrmu (let-vals exp)))
150 665c255d 2023-08-04 jrmu (define (make-application op args)
151 665c255d 2023-08-04 jrmu (cons op args))
153 665c255d 2023-08-04 jrmu (define (let*? exp)
154 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
155 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
156 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
157 665c255d 2023-08-04 jrmu (define let*-body let-body)
158 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
159 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
160 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
161 665c255d 2023-08-04 jrmu (make-let (list (car vars))
162 665c255d 2023-08-04 jrmu (list (car vals))
163 665c255d 2023-08-04 jrmu (let*-body exp))
164 665c255d 2023-08-04 jrmu (make-let (list (car vars))
165 665c255d 2023-08-04 jrmu (list (car vals))
166 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
167 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
168 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
169 665c255d 2023-08-04 jrmu (if (null? vars)
170 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
171 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
174 665c255d 2023-08-04 jrmu ;; begin/sequence
175 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
176 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
177 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
178 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
179 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
180 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
181 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
182 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
183 665c255d 2023-08-04 jrmu (else (make-begin seq))))
184 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
185 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
186 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
187 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
188 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
190 665c255d 2023-08-04 jrmu ;; application
191 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
192 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
193 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
194 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
195 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
196 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
199 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
200 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
201 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
202 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
203 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
204 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
205 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
206 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
207 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
208 665c255d 2023-08-04 jrmu (caddr clause))
209 665c255d 2023-08-04 jrmu (define (cond->if exp)
210 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
211 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
212 665c255d 2023-08-04 jrmu (if (null? clauses)
213 665c255d 2023-08-04 jrmu 'false ; no else clause
214 665c255d 2023-08-04 jrmu (let ((first (car clauses))
215 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
216 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
217 665c255d 2023-08-04 jrmu (if (null? rest)
218 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
219 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
221 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
222 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
223 665c255d 2023-08-04 jrmu (make-application
224 665c255d 2023-08-04 jrmu (cond-extended-proc first)
225 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
226 665c255d 2023-08-04 jrmu (expand-clauses rest))
227 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
228 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
229 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
230 665c255d 2023-08-04 jrmu (define (true? x)
231 665c255d 2023-08-04 jrmu (not (eq? x false)))
232 665c255d 2023-08-04 jrmu (define (false? x)
233 665c255d 2023-08-04 jrmu (eq? x false))
235 665c255d 2023-08-04 jrmu ;; procedure
236 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
237 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
238 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
239 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
240 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
241 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
242 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
244 665c255d 2023-08-04 jrmu ;; environment
245 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
246 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
247 665c255d 2023-08-04 jrmu (define the-empty-environment '())
248 665c255d 2023-08-04 jrmu (define (make-frame variables values)
249 665c255d 2023-08-04 jrmu (cons variables values))
250 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
251 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
252 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
253 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
254 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
255 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
256 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
257 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
258 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
259 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
260 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
261 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
262 665c255d 2023-08-04 jrmu (define (env-loop env)
263 665c255d 2023-08-04 jrmu (define (scan vars vals)
264 665c255d 2023-08-04 jrmu (cond ((null? vars)
265 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
266 665c255d 2023-08-04 jrmu ((eq? var (car vars))
267 665c255d 2023-08-04 jrmu (car vals))
268 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
269 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
270 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
271 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
272 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
273 665c255d 2023-08-04 jrmu (frame-values frame)))))
274 665c255d 2023-08-04 jrmu (env-loop env))
275 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
276 665c255d 2023-08-04 jrmu (define (env-loop env)
277 665c255d 2023-08-04 jrmu (define (scan vars vals)
278 665c255d 2023-08-04 jrmu (cond ((null? vars)
279 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
280 665c255d 2023-08-04 jrmu ((eq? var (car vars))
281 665c255d 2023-08-04 jrmu (set-car! vals val))
282 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
283 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
284 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
285 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
286 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
287 665c255d 2023-08-04 jrmu (frame-values frame)))))
288 665c255d 2023-08-04 jrmu (env-loop env))
289 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
290 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
291 665c255d 2023-08-04 jrmu (define (scan vars vals)
292 665c255d 2023-08-04 jrmu (cond ((null? vars)
293 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
294 665c255d 2023-08-04 jrmu ((eq? var (car vars))
295 665c255d 2023-08-04 jrmu (set-car! vals val))
296 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
297 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
298 665c255d 2023-08-04 jrmu (frame-values frame))))
299 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
300 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
302 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
303 665c255d 2023-08-04 jrmu (define primitive-procedures
304 665c255d 2023-08-04 jrmu (list (list 'car car)
305 665c255d 2023-08-04 jrmu (list 'cdr cdr)
306 665c255d 2023-08-04 jrmu (list 'caar caar)
307 665c255d 2023-08-04 jrmu (list 'cadr cadr)
308 665c255d 2023-08-04 jrmu (list 'cddr cddr)
309 665c255d 2023-08-04 jrmu (list 'cons cons)
310 665c255d 2023-08-04 jrmu (list 'null? null?)
311 665c255d 2023-08-04 jrmu (list '* *)
312 665c255d 2023-08-04 jrmu (list '/ /)
313 665c255d 2023-08-04 jrmu (list '+ +)
314 665c255d 2023-08-04 jrmu (list '- -)
315 665c255d 2023-08-04 jrmu (list '= =)
316 665c255d 2023-08-04 jrmu (list 'eq? eq?)
317 665c255d 2023-08-04 jrmu (list 'equal? equal?)
318 665c255d 2023-08-04 jrmu (list 'display display)))
319 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
321 665c255d 2023-08-04 jrmu primitive-procedures))
323 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
324 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
325 665c255d 2023-08-04 jrmu primitive-procedures))
326 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
327 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
328 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
330 665c255d 2023-08-04 jrmu ;; driver-loop
331 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
332 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
333 665c255d 2023-08-04 jrmu (define (driver-loop)
334 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
335 665c255d 2023-08-04 jrmu (let ((input (read)))
336 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
337 665c255d 2023-08-04 jrmu (announce-output output-prompt)
338 665c255d 2023-08-04 jrmu (user-print output)))
339 665c255d 2023-08-04 jrmu (driver-loop))
340 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
341 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
343 665c255d 2023-08-04 jrmu (define (announce-output string)
344 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
345 665c255d 2023-08-04 jrmu (define (user-print object)
346 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
347 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
348 665c255d 2023-08-04 jrmu (procedure-parameters object)
349 665c255d 2023-08-04 jrmu (procedure-body object)
350 665c255d 2023-08-04 jrmu '<procedure-env>))
351 665c255d 2023-08-04 jrmu (display object)))
352 665c255d 2023-08-04 jrmu (define (setup-environment)
353 665c255d 2023-08-04 jrmu (let ((initial-env
354 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
355 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
356 665c255d 2023-08-04 jrmu the-empty-environment)))
357 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
358 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
359 665c255d 2023-08-04 jrmu initial-env))
360 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
363 665c255d 2023-08-04 jrmu (define (test-case actual expected)
365 665c255d 2023-08-04 jrmu (display "Actual: ")
366 665c255d 2023-08-04 jrmu (display actual)
368 665c255d 2023-08-04 jrmu (display "Expected: ")
369 665c255d 2023-08-04 jrmu (display expected)
372 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
373 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
375 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
376 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
379 665c255d 2023-08-04 jrmu ;; Exercise 4.8. ``Named let'' is a variant of let that has the form
381 665c255d 2023-08-04 jrmu ;; (let <var> <bindings> <body>)
383 665c255d 2023-08-04 jrmu ;; The <bindings> and <body> are just as in ordinary let, except that <var> is bound within <body> to a procedure whose body is <body> and whose parameters are the variables in the <bindings>. Thus, one can repeatedly execute the <body> by invoking the procedure named <var>. For example, the iterative Fibonacci procedure (section 1.2.2) can be rewritten using named let as follows:
385 665c255d 2023-08-04 jrmu (define (named-let? exp)
386 665c255d 2023-08-04 jrmu (and (tagged-list exp 'let)
387 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
388 665c255d 2023-08-04 jrmu (define (named-let-name exp)
389 665c255d 2023-08-04 jrmu (cadr exp))
390 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
391 665c255d 2023-08-04 jrmu (map car (caddr exp)))
392 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
393 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
394 665c255d 2023-08-04 jrmu (define (named-let-body exp)
395 665c255d 2023-08-04 jrmu (cadddr exp))
398 665c255d 2023-08-04 jrmu (define (let-body exp)
399 665c255d 2023-08-04 jrmu (cddr exp))
400 665c255d 2023-08-04 jrmu (define (let->combination exp)
401 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
402 665c255d 2023-08-04 jrmu (let-vals exp)))
403 665c255d 2023-08-04 jrmu (define (make-application op args)
404 665c255d 2023-08-04 jrmu (cons op args))
408 665c255d 2023-08-04 jrmu '(define (fib n)
409 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
412 665c255d 2023-08-04 jrmu (if (= count 0)
414 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
415 665c255d 2023-08-04 jrmu (test-eval '(fib 10) 55)
418 665c255d 2023-08-04 jrmu '(let eight ()
424 665c255d 2023-08-04 jrmu (let loop (count 0)
425 665c255d 2023-08-04 jrmu (if (= 100 count)
427 665c255d 2023-08-04 jrmu (begin (set! count (+ count 1))
432 665c255d 2023-08-04 jrmu (define (fib n)
433 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
436 665c255d 2023-08-04 jrmu (if (= count 0)
438 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1)))))
444 665c255d 2023-08-04 jrmu ;; test-suite
446 665c255d 2023-08-04 jrmu ;; procedure definitions
449 665c255d 2023-08-04 jrmu '(define (assoc key records)
450 665c255d 2023-08-04 jrmu (cond ((null? records) false)
451 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
452 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
455 665c255d 2023-08-04 jrmu '(define (map proc list)
456 665c255d 2023-08-04 jrmu (if (null? list)
458 665c255d 2023-08-04 jrmu (cons (proc (car list))
459 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
462 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
463 665c255d 2023-08-04 jrmu (if (null? sequence)
465 665c255d 2023-08-04 jrmu (op (car sequence)
466 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
468 665c255d 2023-08-04 jrmu ;; all special forms
469 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
470 665c255d 2023-08-04 jrmu (test-eval '10 10)
471 665c255d 2023-08-04 jrmu (geval '(define x 3))
472 665c255d 2023-08-04 jrmu (test-eval 'x 3)
473 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
474 665c255d 2023-08-04 jrmu (test-eval 'x -25)
475 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
476 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
477 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
478 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
479 665c255d 2023-08-04 jrmu (else 'failed))
481 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
483 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
484 665c255d 2023-08-04 jrmu (+ x y (* x y)))
485 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
489 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
490 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
491 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
492 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
493 665c255d 2023-08-04 jrmu (test-eval 'x -2)
494 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
495 665c255d 2023-08-04 jrmu (test-eval 'x -2)
496 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
497 665c255d 2023-08-04 jrmu (test-eval 'x 25)
498 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
499 665c255d 2023-08-04 jrmu (test-eval 'x 2)
500 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
501 665c255d 2023-08-04 jrmu (test-eval 'x 25)
502 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
503 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
509 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
510 665c255d 2023-08-04 jrmu (else false))
514 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
515 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
516 665c255d 2023-08-04 jrmu ((map (lambda (x)
517 665c255d 2023-08-04 jrmu (* x (+ x 1)))
518 665c255d 2023-08-04 jrmu '(2 4 1 9))
520 665c255d 2023-08-04 jrmu (lambda (x)
521 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
522 665c255d 2023-08-04 jrmu (else 'never-reach))
524 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
527 665c255d 2023-08-04 jrmu ;; procedure definition and application
529 665c255d 2023-08-04 jrmu '(define (factorial n)
530 665c255d 2023-08-04 jrmu (if (= n 0)
532 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
533 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
538 665c255d 2023-08-04 jrmu '(map (lambda (x)
539 665c255d 2023-08-04 jrmu (* x (+ x 1)))
540 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
541 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
542 665c255d 2023-08-04 jrmu ;; accumulate
545 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
548 665c255d 2023-08-04 jrmu ;; make-let
550 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
557 665c255d 2023-08-04 jrmu '(let ((x 3))
561 665c255d 2023-08-04 jrmu '(let ((x 3)
566 665c255d 2023-08-04 jrmu '(let ((x 3)
568 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
572 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
574 665c255d 2023-08-04 jrmu '(let ((x 6)
575 665c255d 2023-08-04 jrmu (y (let ((x 2))
577 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
586 665c255d 2023-08-04 jrmu '(let* ((x 3)
587 665c255d 2023-08-04 jrmu (y (+ x 2))
588 665c255d 2023-08-04 jrmu (z (+ x y 5)))
597 665c255d 2023-08-04 jrmu '(let* ((x 3))
598 665c255d 2023-08-04 jrmu (let* ((y 5))
603 665c255d 2023-08-04 jrmu '(let* ((x 3)
604 665c255d 2023-08-04 jrmu (y (+ x 1)))
605 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
609 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
611 665c255d 2023-08-04 jrmu '(let* ((x 6)
612 665c255d 2023-08-04 jrmu (y (let* ((x 2)
613 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
616 665c255d 2023-08-04 jrmu (z (+ x y)))
