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 ((application? exp)
20 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
21 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
23 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
24 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
25 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
26 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
27 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
28 665c255d 2023-08-04 jrmu (eval-sequence
29 665c255d 2023-08-04 jrmu (procedure-body procedure)
30 665c255d 2023-08-04 jrmu (extend-environment
31 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
33 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
36 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
37 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
38 665c255d 2023-08-04 jrmu (if (no-operands? exps)
40 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
41 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
43 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
44 665c255d 2023-08-04 jrmu (if (pair? exp)
45 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
48 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
49 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
50 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
51 665c255d 2023-08-04 jrmu ((string? exp) true)
52 665c255d 2023-08-04 jrmu (else false)))
53 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
54 665c255d 2023-08-04 jrmu (define (quoted? exp)
55 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
56 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
58 665c255d 2023-08-04 jrmu ;; assignment/definition
59 665c255d 2023-08-04 jrmu (define (assignment? exp)
60 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
61 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
62 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
63 665c255d 2023-08-04 jrmu (define (definition? exp)
64 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
65 665c255d 2023-08-04 jrmu (define (definition-variable exp)
66 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
68 665c255d 2023-08-04 jrmu (caadr exp)))
69 665c255d 2023-08-04 jrmu (define (definition-value exp)
70 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
72 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
73 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
74 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
75 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
76 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
79 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
80 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
81 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
86 665c255d 2023-08-04 jrmu ;; if/and/or
87 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
88 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
89 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
90 665c255d 2023-08-04 jrmu (define (if-alternative exp)
91 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
92 665c255d 2023-08-04 jrmu (cadddr exp)
94 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
95 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
96 665c255d 2023-08-04 jrmu (define (eval-if exp env)
97 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
98 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
99 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
101 665c255d 2023-08-04 jrmu (define (and? exp)
102 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
103 665c255d 2023-08-04 jrmu (define (and-clauses exp)
105 665c255d 2023-08-04 jrmu (define (or? exp)
106 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
107 665c255d 2023-08-04 jrmu (define (or-clauses exp)
109 665c255d 2023-08-04 jrmu (define (eval-and exp env)
110 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
111 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
112 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
113 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
114 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
115 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
116 665c255d 2023-08-04 jrmu (define (eval-or exp env)
117 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
118 665c255d 2023-08-04 jrmu (if (null? clauses)
120 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
121 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
122 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
126 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
127 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
128 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
129 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
130 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
132 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
134 665c255d 2023-08-04 jrmu (cons (map (lambda (var val)
135 665c255d 2023-08-04 jrmu (list var val))
138 665c255d 2023-08-04 jrmu (define (let? exp)
139 665c255d 2023-08-04 jrmu (tagged-list? exp 'let))
140 665c255d 2023-08-04 jrmu (define (let-vars exp)
141 665c255d 2023-08-04 jrmu (map car (cadr exp)))
142 665c255d 2023-08-04 jrmu (define (let-vals exp)
143 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
144 665c255d 2023-08-04 jrmu (define (let-body exp)
145 665c255d 2023-08-04 jrmu (cddr exp))
146 665c255d 2023-08-04 jrmu (define (let->combination exp)
147 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
148 665c255d 2023-08-04 jrmu (let-vals exp)))
149 665c255d 2023-08-04 jrmu (define (make-application op args)
150 665c255d 2023-08-04 jrmu (cons op args))
154 665c255d 2023-08-04 jrmu ;; begin/sequence
155 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
156 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
157 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
158 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
159 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
160 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
161 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
162 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
163 665c255d 2023-08-04 jrmu (else (make-begin seq))))
164 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
165 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
166 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
167 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
168 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
170 665c255d 2023-08-04 jrmu ;; application
171 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
172 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
173 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
174 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
175 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
176 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
179 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
180 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
181 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
182 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
183 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
184 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
185 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
186 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
187 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
188 665c255d 2023-08-04 jrmu (caddr clause))
189 665c255d 2023-08-04 jrmu (define (cond->if exp)
190 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
191 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
192 665c255d 2023-08-04 jrmu (if (null? clauses)
193 665c255d 2023-08-04 jrmu 'false ; no else clause
194 665c255d 2023-08-04 jrmu (let ((first (car clauses))
195 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
196 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
197 665c255d 2023-08-04 jrmu (if (null? rest)
198 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
199 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
201 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
202 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
203 665c255d 2023-08-04 jrmu (make-application
204 665c255d 2023-08-04 jrmu (cond-extended-proc first)
205 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
206 665c255d 2023-08-04 jrmu (expand-clauses rest))
207 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
208 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
209 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
210 665c255d 2023-08-04 jrmu (define (true? x)
211 665c255d 2023-08-04 jrmu (not (eq? x false)))
212 665c255d 2023-08-04 jrmu (define (false? x)
213 665c255d 2023-08-04 jrmu (eq? x false))
215 665c255d 2023-08-04 jrmu ;; procedure
216 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
217 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
218 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
219 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
220 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
221 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
222 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
224 665c255d 2023-08-04 jrmu ;; environment
225 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
226 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
227 665c255d 2023-08-04 jrmu (define the-empty-environment '())
228 665c255d 2023-08-04 jrmu (define (make-frame variables values)
229 665c255d 2023-08-04 jrmu (cons variables values))
230 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
231 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
232 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
233 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
234 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
235 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
236 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
237 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
238 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
239 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
240 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
241 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
242 665c255d 2023-08-04 jrmu (define (env-loop env)
243 665c255d 2023-08-04 jrmu (define (scan vars vals)
244 665c255d 2023-08-04 jrmu (cond ((null? vars)
245 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
246 665c255d 2023-08-04 jrmu ((eq? var (car vars))
247 665c255d 2023-08-04 jrmu (car vals))
248 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
249 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
250 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
251 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
252 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
253 665c255d 2023-08-04 jrmu (frame-values frame)))))
254 665c255d 2023-08-04 jrmu (env-loop env))
255 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
256 665c255d 2023-08-04 jrmu (define (env-loop env)
257 665c255d 2023-08-04 jrmu (define (scan vars vals)
258 665c255d 2023-08-04 jrmu (cond ((null? vars)
259 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
260 665c255d 2023-08-04 jrmu ((eq? var (car vars))
261 665c255d 2023-08-04 jrmu (set-car! vals val))
262 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
263 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
264 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
265 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
266 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
267 665c255d 2023-08-04 jrmu (frame-values frame)))))
268 665c255d 2023-08-04 jrmu (env-loop env))
269 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
270 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
271 665c255d 2023-08-04 jrmu (define (scan vars vals)
272 665c255d 2023-08-04 jrmu (cond ((null? vars)
273 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
274 665c255d 2023-08-04 jrmu ((eq? var (car vars))
275 665c255d 2023-08-04 jrmu (set-car! vals val))
276 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
277 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
278 665c255d 2023-08-04 jrmu (frame-values frame))))
279 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
280 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
282 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
283 665c255d 2023-08-04 jrmu (define primitive-procedures
284 665c255d 2023-08-04 jrmu (list (list 'car car)
285 665c255d 2023-08-04 jrmu (list 'cdr cdr)
286 665c255d 2023-08-04 jrmu (list 'caar caar)
287 665c255d 2023-08-04 jrmu (list 'cadr cadr)
288 665c255d 2023-08-04 jrmu (list 'cddr cddr)
289 665c255d 2023-08-04 jrmu (list 'cons cons)
290 665c255d 2023-08-04 jrmu (list 'null? null?)
291 665c255d 2023-08-04 jrmu (list '* *)
292 665c255d 2023-08-04 jrmu (list '/ /)
293 665c255d 2023-08-04 jrmu (list '+ +)
294 665c255d 2023-08-04 jrmu (list '- -)
295 665c255d 2023-08-04 jrmu (list '= =)
296 665c255d 2023-08-04 jrmu (list 'eq? eq?)
297 665c255d 2023-08-04 jrmu (list 'equal? equal?)
298 665c255d 2023-08-04 jrmu (list 'display display)))
299 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
301 665c255d 2023-08-04 jrmu primitive-procedures))
303 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
304 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
305 665c255d 2023-08-04 jrmu primitive-procedures))
306 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
307 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
308 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
310 665c255d 2023-08-04 jrmu ;; driver-loop
311 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
312 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
313 665c255d 2023-08-04 jrmu (define (driver-loop)
314 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
315 665c255d 2023-08-04 jrmu (let ((input (read)))
316 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
317 665c255d 2023-08-04 jrmu (announce-output output-prompt)
318 665c255d 2023-08-04 jrmu (user-print output)))
319 665c255d 2023-08-04 jrmu (driver-loop))
320 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
321 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
323 665c255d 2023-08-04 jrmu (define (announce-output string)
324 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
325 665c255d 2023-08-04 jrmu (define (user-print object)
326 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
327 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
328 665c255d 2023-08-04 jrmu (procedure-parameters object)
329 665c255d 2023-08-04 jrmu (procedure-body object)
330 665c255d 2023-08-04 jrmu '<procedure-env>))
331 665c255d 2023-08-04 jrmu (display object)))
332 665c255d 2023-08-04 jrmu (define (setup-environment)
333 665c255d 2023-08-04 jrmu (let ((initial-env
334 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
335 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
336 665c255d 2023-08-04 jrmu the-empty-environment)))
337 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
338 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
339 665c255d 2023-08-04 jrmu initial-env))
340 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
343 665c255d 2023-08-04 jrmu (define (test-case actual expected)
345 665c255d 2023-08-04 jrmu (display "Actual: ")
346 665c255d 2023-08-04 jrmu (display actual)
348 665c255d 2023-08-04 jrmu (display "Expected: ")
349 665c255d 2023-08-04 jrmu (display expected)
352 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
353 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
355 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
356 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
358 665c255d 2023-08-04 jrmu ;; Exercise 4.7. Let* is similar to let, except that the bindings of the let variables are performed sequentially from left to right, and each binding is made in an environment in which all of the preceding bindings are visible. For example
360 665c255d 2023-08-04 jrmu (let* ((x 3)
361 665c255d 2023-08-04 jrmu (y (+ x 2))
362 665c255d 2023-08-04 jrmu (z (+ x y 5)))
365 665c255d 2023-08-04 jrmu ;; returns 39. Explain how a let* expression can be rewritten as a set of nested let expressions, and write a procedure let*->nested-lets that performs this transformation. If we have already implemented let (exercise 4.6) and we want to extend the evaluator to handle let*, is it sufficient to add a clause to eval whose action is
367 665c255d 2023-08-04 jrmu ;; (eval (let*->nested-lets exp) env)
369 665c255d 2023-08-04 jrmu ;; or must we explicitly expand let* in terms of non-derived expressions?
371 665c255d 2023-08-04 jrmu (define (let*? exp)
372 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
373 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
374 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
375 665c255d 2023-08-04 jrmu (define let*-body let-body)
376 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
377 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
378 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
379 665c255d 2023-08-04 jrmu (make-let (list (car vars))
380 665c255d 2023-08-04 jrmu (list (car vals))
381 665c255d 2023-08-04 jrmu (let*-body exp))
382 665c255d 2023-08-04 jrmu (make-let (list (car vars))
383 665c255d 2023-08-04 jrmu (list (car vals))
384 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
385 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
386 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
387 665c255d 2023-08-04 jrmu (if (null? vars)
388 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
389 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
391 665c255d 2023-08-04 jrmu ;; test-suite
393 665c255d 2023-08-04 jrmu ;; procedure definitions
396 665c255d 2023-08-04 jrmu '(define (assoc key records)
397 665c255d 2023-08-04 jrmu (cond ((null? records) false)
398 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
399 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
402 665c255d 2023-08-04 jrmu '(define (map proc list)
403 665c255d 2023-08-04 jrmu (if (null? list)
405 665c255d 2023-08-04 jrmu (cons (proc (car list))
406 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
409 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
410 665c255d 2023-08-04 jrmu (if (null? sequence)
412 665c255d 2023-08-04 jrmu (op (car sequence)
413 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
415 665c255d 2023-08-04 jrmu ;; all special forms
416 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
417 665c255d 2023-08-04 jrmu (test-eval '10 10)
418 665c255d 2023-08-04 jrmu (geval '(define x 3))
419 665c255d 2023-08-04 jrmu (test-eval 'x 3)
420 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
421 665c255d 2023-08-04 jrmu (test-eval 'x -25)
422 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
423 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
424 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
425 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
426 665c255d 2023-08-04 jrmu (else 'failed))
428 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
430 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
431 665c255d 2023-08-04 jrmu (+ x y (* x y)))
432 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
436 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
437 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
438 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
439 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
440 665c255d 2023-08-04 jrmu (test-eval 'x -2)
441 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
442 665c255d 2023-08-04 jrmu (test-eval 'x -2)
443 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
444 665c255d 2023-08-04 jrmu (test-eval 'x 25)
445 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
446 665c255d 2023-08-04 jrmu (test-eval 'x 2)
447 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
448 665c255d 2023-08-04 jrmu (test-eval 'x 25)
449 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
450 665c255d 2023-08-04 jrmu (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
456 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
457 665c255d 2023-08-04 jrmu (else false))
461 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
462 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
463 665c255d 2023-08-04 jrmu ((map (lambda (x)
464 665c255d 2023-08-04 jrmu (* x (+ x 1)))
465 665c255d 2023-08-04 jrmu '(2 4 1 9))
467 665c255d 2023-08-04 jrmu (lambda (x)
468 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
469 665c255d 2023-08-04 jrmu (else 'never-reach))
471 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
474 665c255d 2023-08-04 jrmu ;; procedure definition and application
476 665c255d 2023-08-04 jrmu '(define (factorial n)
477 665c255d 2023-08-04 jrmu (if (= n 0)
479 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
480 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
485 665c255d 2023-08-04 jrmu '(map (lambda (x)
486 665c255d 2023-08-04 jrmu (* x (+ x 1)))
487 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
488 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
489 665c255d 2023-08-04 jrmu ;; accumulate
492 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
495 665c255d 2023-08-04 jrmu ;; make-let
497 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
504 665c255d 2023-08-04 jrmu '(let ((x 3))
508 665c255d 2023-08-04 jrmu '(let ((x 3)
513 665c255d 2023-08-04 jrmu '(let ((x 3)
515 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
519 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
521 665c255d 2023-08-04 jrmu '(let ((x 6)
522 665c255d 2023-08-04 jrmu (y (let ((x 2))
524 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
533 665c255d 2023-08-04 jrmu '(let* ((x 3)
534 665c255d 2023-08-04 jrmu (y (+ x 2))
535 665c255d 2023-08-04 jrmu (z (+ x y 5)))
544 665c255d 2023-08-04 jrmu '(let* ((x 3))
545 665c255d 2023-08-04 jrmu (let* ((y 5))
550 665c255d 2023-08-04 jrmu '(let* ((x 3)
551 665c255d 2023-08-04 jrmu (y (+ x 1)))
552 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
556 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
558 665c255d 2023-08-04 jrmu '(let* ((x 6)
559 665c255d 2023-08-04 jrmu (y (let* ((x 2)
560 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
563 665c255d 2023-08-04 jrmu (z (+ x y)))
