1 665c255d 2023-08-04 jrmu ;; (define apply-in-underlying-scheme apply)
2 665c255d 2023-08-04 jrmu ;; (define eval-in-underlying-scheme eval)
4 665c255d 2023-08-04 jrmu (define (eval exp env)
5 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
6 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
7 665c255d 2023-08-04 jrmu ((quoted? exp) (text-of-quotation exp))
8 665c255d 2023-08-04 jrmu ((assignment? exp) (eval-assignment exp env))
9 665c255d 2023-08-04 jrmu ((definition? exp) (eval-definition 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 ((application? exp)
22 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
23 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
25 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
27 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
28 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
29 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
30 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
31 665c255d 2023-08-04 jrmu (eval-sequence
32 665c255d 2023-08-04 jrmu (procedure-body procedure)
33 665c255d 2023-08-04 jrmu (extend-environment
34 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
36 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
39 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
40 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
41 665c255d 2023-08-04 jrmu (if (no-operands? exps)
43 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
44 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
46 665c255d 2023-08-04 jrmu (define (eval-if exp env)
47 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
48 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
49 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
50 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
51 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
52 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
53 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
54 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
55 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
56 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
59 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
60 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
61 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
64 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
65 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
66 665c255d 2023-08-04 jrmu ((string? exp) true)
67 665c255d 2023-08-04 jrmu (else false)))
68 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
69 665c255d 2023-08-04 jrmu (define (quoted? exp)
70 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
72 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
73 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
74 665c255d 2023-08-04 jrmu (if (pair? exp)
75 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
77 665c255d 2023-08-04 jrmu (define (assignment? exp)
78 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
79 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
80 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
81 665c255d 2023-08-04 jrmu (define (definition? exp)
82 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
83 665c255d 2023-08-04 jrmu (define (definition-variable exp)
84 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
86 665c255d 2023-08-04 jrmu (caadr exp)))
87 665c255d 2023-08-04 jrmu (define (definition-value exp)
88 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
90 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
91 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
92 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
93 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
94 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
95 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
96 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
97 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
98 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
99 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
100 665c255d 2023-08-04 jrmu (define (if-alternative exp)
101 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
102 665c255d 2023-08-04 jrmu (cadddr exp)
104 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
105 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
106 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
107 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
108 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
109 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
110 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
112 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
113 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
114 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
115 665c255d 2023-08-04 jrmu (else (make-begin seq))))
116 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
117 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
118 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
119 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
120 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
121 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
122 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
123 665c255d 2023-08-04 jrmu (define (true? x)
124 665c255d 2023-08-04 jrmu (not (eq? x false)))
125 665c255d 2023-08-04 jrmu (define (false? x)
126 665c255d 2023-08-04 jrmu (eq? x false))
127 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
128 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
129 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
130 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
131 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
132 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
133 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
134 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
135 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
136 665c255d 2023-08-04 jrmu (define the-empty-environment '())
137 665c255d 2023-08-04 jrmu (define (make-frame variables values)
138 665c255d 2023-08-04 jrmu (cons variables values))
139 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
140 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
141 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
142 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
143 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
144 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
145 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
146 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
147 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
148 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
149 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
150 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
151 665c255d 2023-08-04 jrmu (define (env-loop env)
152 665c255d 2023-08-04 jrmu (define (scan vars vals)
153 665c255d 2023-08-04 jrmu (cond ((null? vars)
154 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
155 665c255d 2023-08-04 jrmu ((eq? var (car vars))
156 665c255d 2023-08-04 jrmu (car vals))
157 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
158 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
159 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
160 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
161 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
162 665c255d 2023-08-04 jrmu (frame-values frame)))))
163 665c255d 2023-08-04 jrmu (env-loop env))
164 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
165 665c255d 2023-08-04 jrmu (define (env-loop env)
166 665c255d 2023-08-04 jrmu (define (scan vars vals)
167 665c255d 2023-08-04 jrmu (cond ((null? vars)
168 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
169 665c255d 2023-08-04 jrmu ((eq? var (car vars))
170 665c255d 2023-08-04 jrmu (set-car! vals val))
171 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
172 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
173 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
174 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
175 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
176 665c255d 2023-08-04 jrmu (frame-values frame)))))
177 665c255d 2023-08-04 jrmu (env-loop env))
178 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
179 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
180 665c255d 2023-08-04 jrmu (define (scan vars vals)
181 665c255d 2023-08-04 jrmu (cond ((null? vars)
182 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
183 665c255d 2023-08-04 jrmu ((eq? var (car vars))
184 665c255d 2023-08-04 jrmu (set-car! vals val))
185 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
186 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
187 665c255d 2023-08-04 jrmu (frame-values frame))))
188 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
189 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
191 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
192 665c255d 2023-08-04 jrmu (define primitive-procedures
193 665c255d 2023-08-04 jrmu (list (list 'car car)
194 665c255d 2023-08-04 jrmu (list 'cdr cdr)
195 665c255d 2023-08-04 jrmu (list 'caar caar)
196 665c255d 2023-08-04 jrmu (list 'cadr cadr)
197 665c255d 2023-08-04 jrmu (list 'cddr cddr)
198 665c255d 2023-08-04 jrmu (list 'cons cons)
199 665c255d 2023-08-04 jrmu (list 'null? null?)
200 665c255d 2023-08-04 jrmu (list '* *)
201 665c255d 2023-08-04 jrmu (list '/ /)
202 665c255d 2023-08-04 jrmu (list '+ +)
203 665c255d 2023-08-04 jrmu (list '- -)
204 665c255d 2023-08-04 jrmu (list '= =)
205 665c255d 2023-08-04 jrmu (list 'eq? eq?)
206 665c255d 2023-08-04 jrmu (list 'equal? equal?)
207 665c255d 2023-08-04 jrmu (list 'display display)))
208 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
210 665c255d 2023-08-04 jrmu primitive-procedures))
212 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
213 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
214 665c255d 2023-08-04 jrmu primitive-procedures))
215 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
216 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
217 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
218 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
219 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
220 665c255d 2023-08-04 jrmu (define (driver-loop)
221 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
222 665c255d 2023-08-04 jrmu (let ((input (read)))
223 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
224 665c255d 2023-08-04 jrmu (announce-output output-prompt)
225 665c255d 2023-08-04 jrmu (user-print output)))
226 665c255d 2023-08-04 jrmu (driver-loop))
227 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
228 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
230 665c255d 2023-08-04 jrmu (define (announce-output string)
231 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
232 665c255d 2023-08-04 jrmu (define (user-print object)
233 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
234 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
235 665c255d 2023-08-04 jrmu (procedure-parameters object)
236 665c255d 2023-08-04 jrmu (procedure-body object)
237 665c255d 2023-08-04 jrmu '<procedure-env>))
238 665c255d 2023-08-04 jrmu (display object)))
239 665c255d 2023-08-04 jrmu (define (setup-environment)
240 665c255d 2023-08-04 jrmu (let ((initial-env
241 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
242 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
243 665c255d 2023-08-04 jrmu the-empty-environment)))
244 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
245 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
246 665c255d 2023-08-04 jrmu initial-env))
247 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
249 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
251 665c255d 2023-08-04 jrmu (cons (map (lambda (var val)
252 665c255d 2023-08-04 jrmu (list var val))
255 665c255d 2023-08-04 jrmu (define (let? exp)
256 665c255d 2023-08-04 jrmu (tagged-list? exp 'let))
257 665c255d 2023-08-04 jrmu (define (let-vars exp)
258 665c255d 2023-08-04 jrmu (map car (cadr exp)))
259 665c255d 2023-08-04 jrmu (define (let-vals exp)
260 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
261 665c255d 2023-08-04 jrmu (define (let-body exp)
262 665c255d 2023-08-04 jrmu (cddr exp))
263 665c255d 2023-08-04 jrmu (define (let->combination exp)
264 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
265 665c255d 2023-08-04 jrmu (let-vals exp)))
266 665c255d 2023-08-04 jrmu (define (make-application op args)
267 665c255d 2023-08-04 jrmu (cons op args))
269 665c255d 2023-08-04 jrmu (define (test-case actual expected)
271 665c255d 2023-08-04 jrmu (display "Actual: ")
272 665c255d 2023-08-04 jrmu (display actual)
274 665c255d 2023-08-04 jrmu (display "Expected: ")
275 665c255d 2023-08-04 jrmu (display expected)
278 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
279 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
281 665c255d 2023-08-04 jrmu ;; Exercise 4.4. Recall the definitions of the special forms and and or from chapter 1:
283 665c255d 2023-08-04 jrmu ;; and: The expressions are evaluated from left to right. If any expression evaluates to false, false is returned; any remaining expressions are not evaluated. If all the expressions evaluate to true values, the value of the last expression is returned. If there are no expressions then true is returned.
285 665c255d 2023-08-04 jrmu ;; or: The expressions are evaluated from left to right. If any expression evaluates to a true value, that value is returned; any remaining expressions are not evaluated. If all expressions evaluate to false, or if there are no expressions, then false is returned.
287 665c255d 2023-08-04 jrmu ;; Install and and or as new special forms for the evaluator by defining appropriate syntax procedures and evaluation procedures eval-and and eval-or. Alternatively, show how to implement and and or as derived expressions.
289 665c255d 2023-08-04 jrmu (define (and? exp)
290 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
291 665c255d 2023-08-04 jrmu (define (and-clauses exp)
293 665c255d 2023-08-04 jrmu ;; (define (and->if exp)
294 665c255d 2023-08-04 jrmu ;; (define (expand-clauses clauses)
295 665c255d 2023-08-04 jrmu ;; (cond ((null? clauses) 'true)
296 665c255d 2023-08-04 jrmu ;; ((null? (cdr clauses)) (car clauses))
297 665c255d 2023-08-04 jrmu ;; (else (make-if (car clauses)
298 665c255d 2023-08-04 jrmu ;; (expand-clauses (cdr clauses))
299 665c255d 2023-08-04 jrmu ;; 'false))))
300 665c255d 2023-08-04 jrmu ;; (expand-clauses (and-clauses exp)))
301 665c255d 2023-08-04 jrmu (define (or? exp)
302 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
303 665c255d 2023-08-04 jrmu (define (or-clauses exp)
305 665c255d 2023-08-04 jrmu ;; the problem with this definition is that each clause will be evaluated twice; this is unacceptable if there are side effects
306 665c255d 2023-08-04 jrmu ;; (define (or->if exp)
307 665c255d 2023-08-04 jrmu ;; (define (expand-clauses clauses)
308 665c255d 2023-08-04 jrmu ;; (if (null? clauses)
310 665c255d 2023-08-04 jrmu ;; (make-if (car clauses)
311 665c255d 2023-08-04 jrmu ;; (car clauses)
312 665c255d 2023-08-04 jrmu ;; (expand-clauses (cdr clauses)))))
313 665c255d 2023-08-04 jrmu ;; (expand-clauses (or-clauses exp)))
316 665c255d 2023-08-04 jrmu ;; we can also install and/or as special forms
318 665c255d 2023-08-04 jrmu (define (eval-and exp env)
319 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
320 665c255d 2023-08-04 jrmu (cond ((null? clauses) true)
321 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (eval (car clauses) env))
322 665c255d 2023-08-04 jrmu (else (and (eval (car clauses) env)
323 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses))))))
324 665c255d 2023-08-04 jrmu (eval-clauses (and-clauses exp)))
325 665c255d 2023-08-04 jrmu (define (eval-or exp env)
326 665c255d 2023-08-04 jrmu (define (eval-clauses clauses)
327 665c255d 2023-08-04 jrmu (if (null? clauses)
329 665c255d 2023-08-04 jrmu (or (eval (car clauses) env)
330 665c255d 2023-08-04 jrmu (eval-clauses (cdr clauses)))))
331 665c255d 2023-08-04 jrmu (eval-clauses (or-clauses exp)))
334 665c255d 2023-08-04 jrmu ;; Exercise 4.5. Scheme allows an additional syntax for cond clauses, (<test> => <recipient>). If <test> evaluates to a true value, then <recipient> is evaluated. Its value must be a procedure of one argument; this procedure is then invoked on the value of the <test>, and the result is returned as the value of the cond expression. For example
336 665c255d 2023-08-04 jrmu ;; (cond ((assoc 'b '((a 1) (b 2))) => cadr)
337 665c255d 2023-08-04 jrmu ;; (else false))
339 665c255d 2023-08-04 jrmu ;; returns 2. Modify the handling of cond so that it supports this extended syntax.
341 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
342 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
343 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
344 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
345 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
346 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
347 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
348 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
349 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
350 665c255d 2023-08-04 jrmu (caddr clause))
351 665c255d 2023-08-04 jrmu (define (cond->if exp)
352 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
354 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
355 665c255d 2023-08-04 jrmu (if (null? clauses)
356 665c255d 2023-08-04 jrmu 'false ; no else clause
357 665c255d 2023-08-04 jrmu (let ((first (car clauses))
358 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
359 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
360 665c255d 2023-08-04 jrmu (if (null? rest)
361 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
362 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
364 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
365 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
366 665c255d 2023-08-04 jrmu (make-application
367 665c255d 2023-08-04 jrmu (cond-extended-proc first)
368 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
369 665c255d 2023-08-04 jrmu (expand-clauses rest))
370 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
371 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
372 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
375 665c255d 2023-08-04 jrmu ;; procedure definitions
378 665c255d 2023-08-04 jrmu '(define (assoc key records)
379 665c255d 2023-08-04 jrmu (cond ((null? records) false)
380 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
381 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
384 665c255d 2023-08-04 jrmu '(define (map proc list)
385 665c255d 2023-08-04 jrmu (if (null? list)
387 665c255d 2023-08-04 jrmu (cons (proc (car list))
388 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
391 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
392 665c255d 2023-08-04 jrmu (if (null? sequence)
394 665c255d 2023-08-04 jrmu (op (car sequence)
395 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
401 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
402 665c255d 2023-08-04 jrmu (else false)))
406 665c255d 2023-08-04 jrmu (geval '((lambda (x)
407 665c255d 2023-08-04 jrmu (accumulate + 0 x))
408 665c255d 2023-08-04 jrmu (map (lambda (x)
409 665c255d 2023-08-04 jrmu (* x (+ x 1)))
410 665c255d 2023-08-04 jrmu '(2 4 1 9))))
415 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
416 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
417 665c255d 2023-08-04 jrmu ((map (lambda (x)
418 665c255d 2023-08-04 jrmu (* x (+ x 1)))
419 665c255d 2023-08-04 jrmu '(2 4 1 9))
421 665c255d 2023-08-04 jrmu (lambda (x)
422 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
423 665c255d 2023-08-04 jrmu (else 'never-reach)))
425 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
428 665c255d 2023-08-04 jrmu ;; test-suite
430 665c255d 2023-08-04 jrmu ;; make-let
431 665c255d 2023-08-04 jrmu (test-case (geval (make-let '(x y) '(3 5) '((+ x y))))
435 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
436 665c255d 2023-08-04 jrmu (test-case (geval '(and 0 true x)) 11)
437 665c255d 2023-08-04 jrmu (test-case (geval '(and 0 true x false)) false)
438 665c255d 2023-08-04 jrmu (test-case (geval '(and 0 true x (set! x -2) false)) false)
439 665c255d 2023-08-04 jrmu (test-case (geval 'x) -2)
440 665c255d 2023-08-04 jrmu (test-case (geval '(and 0 true x false (set! x -5))) false)
441 665c255d 2023-08-04 jrmu (test-case (geval 'x) -2)
442 665c255d 2023-08-04 jrmu (test-case (geval '(or false (set! x 25))) 'ok)
443 665c255d 2023-08-04 jrmu (test-case (geval 'x) 25)
444 665c255d 2023-08-04 jrmu (test-case (geval '(or (set! x 2) (set! x 4))) 'ok)
445 665c255d 2023-08-04 jrmu (test-case (geval 'x) 2)
446 665c255d 2023-08-04 jrmu (test-case (geval '(or false (set! x 25) true false)) 'ok)
447 665c255d 2023-08-04 jrmu (test-case (geval 'x) 25)
448 665c255d 2023-08-04 jrmu (test-case (geval '(or ((lambda (x) x) 5))) 5)
449 665c255d 2023-08-04 jrmu (test-case (geval '(or (begin (set! x (+ x 1)) x))) 26)
452 665c255d 2023-08-04 jrmu ;; all special forms
453 665c255d 2023-08-04 jrmu (test-case (geval '(begin 5 6)) 6)
454 665c255d 2023-08-04 jrmu (test-case (geval '10) 10)
455 665c255d 2023-08-04 jrmu (geval '(define x 3))
456 665c255d 2023-08-04 jrmu (test-case (geval 'x) 3)
457 665c255d 2023-08-04 jrmu (test-case (geval '(set! x -25)) 'ok)
458 665c255d 2023-08-04 jrmu (test-case (geval 'x) -25)
459 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
460 665c255d 2023-08-04 jrmu (test-case (geval '(z 3 4)) 15)
461 665c255d 2023-08-04 jrmu (test-case (geval '(cond ((= x -2) 'x=-2)
462 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
463 665c255d 2023-08-04 jrmu (else 'failed)))
465 665c255d 2023-08-04 jrmu (test-case (geval '(if true false true)) false)
466 665c255d 2023-08-04 jrmu (test-case (geval
467 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
468 665c255d 2023-08-04 jrmu (+ x y (* x y))))
469 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
471 665c255d 2023-08-04 jrmu ;; procedure definition and application
473 665c255d 2023-08-04 jrmu '(define (factorial n)
474 665c255d 2023-08-04 jrmu (if (= n 0)
476 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
477 665c255d 2023-08-04 jrmu (test-case (geval '(factorial 5)) 120)
482 665c255d 2023-08-04 jrmu (geval '(map (lambda (x)
483 665c255d 2023-08-04 jrmu (* x (+ x 1)))
484 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3)))
485 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
486 665c255d 2023-08-04 jrmu ;; accumulate
490 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5)))
