Blame


1 665c255d 2023-08-04 jrmu ;; (define apply-in-underlying-scheme apply)
2 665c255d 2023-08-04 jrmu ;; (define eval-in-underlying-scheme eval)
3 665c255d 2023-08-04 jrmu
4 665c255d 2023-08-04 jrmu (define (assoc key records)
5 665c255d 2023-08-04 jrmu (cond ((null? records) false)
6 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
7 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
8 665c255d 2023-08-04 jrmu
9 665c255d 2023-08-04 jrmu (define (make-table)
10 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
11 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
12 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
13 665c255d 2023-08-04 jrmu (if subtable
14 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
15 665c255d 2023-08-04 jrmu (if record
16 665c255d 2023-08-04 jrmu (cdr record)
17 665c255d 2023-08-04 jrmu false))
18 665c255d 2023-08-04 jrmu false)))
19 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
20 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
21 665c255d 2023-08-04 jrmu (if subtable
22 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
23 665c255d 2023-08-04 jrmu (if record
24 665c255d 2023-08-04 jrmu (set-cdr! record value)
25 665c255d 2023-08-04 jrmu (set-cdr! subtable
26 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
27 665c255d 2023-08-04 jrmu (cdr subtable)))))
28 665c255d 2023-08-04 jrmu (set-cdr! local-table
29 665c255d 2023-08-04 jrmu (cons (list key-1
30 665c255d 2023-08-04 jrmu (cons key-2 value))
31 665c255d 2023-08-04 jrmu (cdr local-table)))))
32 665c255d 2023-08-04 jrmu 'ok)
33 665c255d 2023-08-04 jrmu (define (dispatch m)
34 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
35 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
36 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
37 665c255d 2023-08-04 jrmu dispatch))
38 665c255d 2023-08-04 jrmu (define operation-table (make-table))
39 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
40 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
41 665c255d 2023-08-04 jrmu
42 665c255d 2023-08-04 jrmu ;; Exercise 4.3. Rewrite eval so that the dispatch is done in data-directed style. Compare this with the data-directed differentiation procedure of exercise 2.73. (You may use the car of a compound expression as the type of the expression, as is appropriate for the syntax implemented in this section.
43 665c255d 2023-08-04 jrmu
44 665c255d 2023-08-04 jrmu (define (form? exp)
45 665c255d 2023-08-04 jrmu (pair? exp))
46 665c255d 2023-08-04 jrmu (define (form-type exp)
47 665c255d 2023-08-04 jrmu (car exp))
48 665c255d 2023-08-04 jrmu
49 665c255d 2023-08-04 jrmu (define (eval exp env)
50 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) exp)
51 665c255d 2023-08-04 jrmu ((variable? exp) (lookup-variable-value exp env))
52 665c255d 2023-08-04 jrmu ((and (form? exp)
53 665c255d 2023-08-04 jrmu (get (form-type exp) 'eval))
54 665c255d 2023-08-04 jrmu ((get (form-type exp) 'eval) exp env))
55 665c255d 2023-08-04 jrmu ((application? exp)
56 665c255d 2023-08-04 jrmu (apply (eval (operator exp) env)
57 665c255d 2023-08-04 jrmu (list-of-values (operands exp) env)))
58 665c255d 2023-08-04 jrmu (else
59 665c255d 2023-08-04 jrmu (error "Unknown expression type -- EVAL" exp))))
60 665c255d 2023-08-04 jrmu
61 665c255d 2023-08-04 jrmu (define (apply procedure arguments)
62 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? procedure)
63 665c255d 2023-08-04 jrmu (apply-primitive-procedure procedure arguments))
64 665c255d 2023-08-04 jrmu ((compound-procedure? procedure)
65 665c255d 2023-08-04 jrmu (eval-sequence
66 665c255d 2023-08-04 jrmu (procedure-body procedure)
67 665c255d 2023-08-04 jrmu (extend-environment
68 665c255d 2023-08-04 jrmu (procedure-parameters procedure)
69 665c255d 2023-08-04 jrmu arguments
70 665c255d 2023-08-04 jrmu (procedure-environment procedure))))
71 665c255d 2023-08-04 jrmu (else
72 665c255d 2023-08-04 jrmu (error
73 665c255d 2023-08-04 jrmu "Unknown procedure type -- APPLY" procedure))))
74 665c255d 2023-08-04 jrmu (define (list-of-values exps env)
75 665c255d 2023-08-04 jrmu (if (no-operands? exps)
76 665c255d 2023-08-04 jrmu '()
77 665c255d 2023-08-04 jrmu (cons (eval (first-operand exps) env)
78 665c255d 2023-08-04 jrmu (list-of-values (rest-operands exps) env))))
79 665c255d 2023-08-04 jrmu
80 665c255d 2023-08-04 jrmu (define (eval-if exp env)
81 665c255d 2023-08-04 jrmu (if (true? (eval (if-predicate exp) env))
82 665c255d 2023-08-04 jrmu (eval (if-consequent exp) env)
83 665c255d 2023-08-04 jrmu (eval (if-alternative exp) env)))
84 665c255d 2023-08-04 jrmu (define (eval-sequence exps env)
85 665c255d 2023-08-04 jrmu (cond ((last-exp? exps) (eval (first-exp exps) env))
86 665c255d 2023-08-04 jrmu (else (eval (first-exp exps) env)
87 665c255d 2023-08-04 jrmu (eval-sequence (rest-exps exps) env))))
88 665c255d 2023-08-04 jrmu (define (eval-assignment exp env)
89 665c255d 2023-08-04 jrmu (set-variable-value! (assignment-variable exp)
90 665c255d 2023-08-04 jrmu (eval (assignment-value exp) env)
91 665c255d 2023-08-04 jrmu env)
92 665c255d 2023-08-04 jrmu 'ok)
93 665c255d 2023-08-04 jrmu (define (eval-definition exp env)
94 665c255d 2023-08-04 jrmu (define-variable! (definition-variable exp)
95 665c255d 2023-08-04 jrmu (eval (definition-value exp) env)
96 665c255d 2023-08-04 jrmu env)
97 665c255d 2023-08-04 jrmu 'ok)
98 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
99 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
100 665c255d 2023-08-04 jrmu ((string? exp) true)
101 665c255d 2023-08-04 jrmu (else false)))
102 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
103 665c255d 2023-08-04 jrmu (define (quoted? exp)
104 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
105 665c255d 2023-08-04 jrmu
106 665c255d 2023-08-04 jrmu (define (text-of-quotation exp env) (cadr exp))
107 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
108 665c255d 2023-08-04 jrmu (if (pair? exp)
109 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
110 665c255d 2023-08-04 jrmu false))
111 665c255d 2023-08-04 jrmu (define (assignment? exp)
112 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
113 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
114 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
115 665c255d 2023-08-04 jrmu (define (definition? exp)
116 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
117 665c255d 2023-08-04 jrmu (define (definition-variable exp)
118 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
119 665c255d 2023-08-04 jrmu (cadr exp)
120 665c255d 2023-08-04 jrmu (caadr exp)))
121 665c255d 2023-08-04 jrmu (define (definition-value exp)
122 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
123 665c255d 2023-08-04 jrmu (caddr exp)
124 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
125 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
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)))
131 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
132 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
133 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
134 665c255d 2023-08-04 jrmu (define (if-alternative exp)
135 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
136 665c255d 2023-08-04 jrmu (cadddr exp)
137 665c255d 2023-08-04 jrmu 'false))
138 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
139 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
140 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
141 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
142 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
143 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
144 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
145 665c255d 2023-08-04 jrmu
146 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
147 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
148 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
149 665c255d 2023-08-04 jrmu (else (make-begin seq))))
150 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
151 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
152 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
153 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
154 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
155 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
156 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
157 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
158 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
159 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
160 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
161 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
162 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
163 665c255d 2023-08-04 jrmu (define (cond->if exp)
164 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
165 665c255d 2023-08-04 jrmu
166 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
167 665c255d 2023-08-04 jrmu (if (null? clauses)
168 665c255d 2023-08-04 jrmu 'false ; no else clause
169 665c255d 2023-08-04 jrmu (let ((first (car clauses))
170 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
171 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
172 665c255d 2023-08-04 jrmu (if (null? rest)
173 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
174 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
175 665c255d 2023-08-04 jrmu clauses))
176 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
177 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
178 665c255d 2023-08-04 jrmu (expand-clauses rest))))))
179 665c255d 2023-08-04 jrmu (define (true? x)
180 665c255d 2023-08-04 jrmu (not (eq? x false)))
181 665c255d 2023-08-04 jrmu (define (false? x)
182 665c255d 2023-08-04 jrmu (eq? x false))
183 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
184 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
185 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
186 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
187 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
188 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
189 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
190 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
191 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
192 665c255d 2023-08-04 jrmu (define the-empty-environment '())
193 665c255d 2023-08-04 jrmu (define (make-frame variables values)
194 665c255d 2023-08-04 jrmu (cons variables values))
195 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
196 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
197 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
198 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
199 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
200 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
201 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
202 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
203 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
204 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
205 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
206 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
207 665c255d 2023-08-04 jrmu (define (env-loop env)
208 665c255d 2023-08-04 jrmu (define (scan vars vals)
209 665c255d 2023-08-04 jrmu (cond ((null? vars)
210 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
211 665c255d 2023-08-04 jrmu ((eq? var (car vars))
212 665c255d 2023-08-04 jrmu (car vals))
213 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
214 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
215 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
216 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
217 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
218 665c255d 2023-08-04 jrmu (frame-values frame)))))
219 665c255d 2023-08-04 jrmu (env-loop env))
220 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
221 665c255d 2023-08-04 jrmu (define (env-loop env)
222 665c255d 2023-08-04 jrmu (define (scan vars vals)
223 665c255d 2023-08-04 jrmu (cond ((null? vars)
224 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
225 665c255d 2023-08-04 jrmu ((eq? var (car vars))
226 665c255d 2023-08-04 jrmu (set-car! vals val))
227 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
228 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
229 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
230 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
231 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
232 665c255d 2023-08-04 jrmu (frame-values frame)))))
233 665c255d 2023-08-04 jrmu (env-loop env))
234 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
235 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
236 665c255d 2023-08-04 jrmu (define (scan vars vals)
237 665c255d 2023-08-04 jrmu (cond ((null? vars)
238 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
239 665c255d 2023-08-04 jrmu ((eq? var (car vars))
240 665c255d 2023-08-04 jrmu (set-car! vals val))
241 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
242 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
243 665c255d 2023-08-04 jrmu (frame-values frame))))
244 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
245 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
246 665c255d 2023-08-04 jrmu
247 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
248 665c255d 2023-08-04 jrmu (define primitive-procedures
249 665c255d 2023-08-04 jrmu (list (list 'car car)
250 665c255d 2023-08-04 jrmu (list 'cdr cdr)
251 665c255d 2023-08-04 jrmu (list 'cons cons)
252 665c255d 2023-08-04 jrmu (list 'null? null?)
253 665c255d 2023-08-04 jrmu (list '* *)
254 665c255d 2023-08-04 jrmu (list '/ /)
255 665c255d 2023-08-04 jrmu (list '+ +)
256 665c255d 2023-08-04 jrmu (list '- -)
257 665c255d 2023-08-04 jrmu (list '= =)
258 665c255d 2023-08-04 jrmu (list 'display display)))
259 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
260 665c255d 2023-08-04 jrmu (map car
261 665c255d 2023-08-04 jrmu primitive-procedures))
262 665c255d 2023-08-04 jrmu
263 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
264 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
265 665c255d 2023-08-04 jrmu primitive-procedures))
266 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
267 665c255d 2023-08-04 jrmu (apply-in-underlying-scheme
268 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
269 665c255d 2023-08-04 jrmu (define input-prompt ";;; M-Eval input:")
270 665c255d 2023-08-04 jrmu (define output-prompt ";;; M-Eval value:")
271 665c255d 2023-08-04 jrmu (define (driver-loop)
272 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
273 665c255d 2023-08-04 jrmu (let ((input (read)))
274 665c255d 2023-08-04 jrmu (let ((output (eval input the-global-environment)))
275 665c255d 2023-08-04 jrmu (announce-output output-prompt)
276 665c255d 2023-08-04 jrmu (user-print output)))
277 665c255d 2023-08-04 jrmu (driver-loop))
278 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
279 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
280 665c255d 2023-08-04 jrmu
281 665c255d 2023-08-04 jrmu (define (announce-output string)
282 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
283 665c255d 2023-08-04 jrmu (define (user-print object)
284 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
285 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
286 665c255d 2023-08-04 jrmu (procedure-parameters object)
287 665c255d 2023-08-04 jrmu (procedure-body object)
288 665c255d 2023-08-04 jrmu '<procedure-env>))
289 665c255d 2023-08-04 jrmu (display object)))
290 665c255d 2023-08-04 jrmu (define (setup-environment)
291 665c255d 2023-08-04 jrmu (let ((initial-env
292 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
293 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
294 665c255d 2023-08-04 jrmu the-empty-environment)))
295 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
296 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
297 665c255d 2023-08-04 jrmu initial-env))
298 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
299 665c255d 2023-08-04 jrmu
300 665c255d 2023-08-04 jrmu (define (let? exp)
301 665c255d 2023-08-04 jrmu (tagged-list? exp 'let))
302 665c255d 2023-08-04 jrmu (define (let-vars exp)
303 665c255d 2023-08-04 jrmu (map car (cadr exp)))
304 665c255d 2023-08-04 jrmu (define (let-vals exp)
305 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
306 665c255d 2023-08-04 jrmu (define (let-body exp)
307 665c255d 2023-08-04 jrmu (cddr exp))
308 665c255d 2023-08-04 jrmu (define (let->combination exp)
309 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
310 665c255d 2023-08-04 jrmu (let-vals exp)))
311 665c255d 2023-08-04 jrmu (define (make-application op args)
312 665c255d 2023-08-04 jrmu (cons op args))
313 665c255d 2023-08-04 jrmu
314 665c255d 2023-08-04 jrmu (define (test-case actual expected)
315 665c255d 2023-08-04 jrmu (newline)
316 665c255d 2023-08-04 jrmu (display "Actual: ")
317 665c255d 2023-08-04 jrmu (display actual)
318 665c255d 2023-08-04 jrmu (newline)
319 665c255d 2023-08-04 jrmu (display "Expected: ")
320 665c255d 2023-08-04 jrmu (display expected)
321 665c255d 2023-08-04 jrmu (newline))
322 665c255d 2023-08-04 jrmu
323 665c255d 2023-08-04 jrmu (put 'quote 'eval text-of-quotation)
324 665c255d 2023-08-04 jrmu (put 'set! 'eval eval-assignment)
325 665c255d 2023-08-04 jrmu (put 'define 'eval eval-definition)
326 665c255d 2023-08-04 jrmu (put 'if 'eval eval-if)
327 665c255d 2023-08-04 jrmu (put 'lambda
328 665c255d 2023-08-04 jrmu 'eval
329 665c255d 2023-08-04 jrmu (lambda (exp env)
330 665c255d 2023-08-04 jrmu (make-procedure (lambda-parameters exp)
331 665c255d 2023-08-04 jrmu (lambda-body exp)
332 665c255d 2023-08-04 jrmu env)))
333 665c255d 2023-08-04 jrmu (put 'begin
334 665c255d 2023-08-04 jrmu 'eval
335 665c255d 2023-08-04 jrmu (lambda (exp env)
336 665c255d 2023-08-04 jrmu (eval-sequence (begin-actions exp) env)))
337 665c255d 2023-08-04 jrmu (put 'cond
338 665c255d 2023-08-04 jrmu 'eval
339 665c255d 2023-08-04 jrmu (lambda (exp env)
340 665c255d 2023-08-04 jrmu (eval (cond->if exp) env)))
341 665c255d 2023-08-04 jrmu (put 'let
342 665c255d 2023-08-04 jrmu 'eval
343 665c255d 2023-08-04 jrmu (lambda (exp env)
344 665c255d 2023-08-04 jrmu (eval (let->combination exp) env)))
345 665c255d 2023-08-04 jrmu
346 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
347 665c255d 2023-08-04 jrmu (eval exp the-global-environment))
348 665c255d 2023-08-04 jrmu
349 665c255d 2023-08-04 jrmu ;; test-suite
350 665c255d 2023-08-04 jrmu
351 665c255d 2023-08-04 jrmu (test-case (geval '(begin 5 6)) 6)
352 665c255d 2023-08-04 jrmu (test-case (geval '10) 10)
353 665c255d 2023-08-04 jrmu (geval '(define x 3))
354 665c255d 2023-08-04 jrmu (test-case (geval 'x) 3)
355 665c255d 2023-08-04 jrmu (test-case (geval '(set! x -25)) 'ok)
356 665c255d 2023-08-04 jrmu (test-case (geval 'x) -25)
357 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
358 665c255d 2023-08-04 jrmu (test-case (geval '(z 3 4)) 15)
359 665c255d 2023-08-04 jrmu (test-case (geval '(cond ((= x -2) 'x=-2)
360 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
361 665c255d 2023-08-04 jrmu (else 'failed)))
362 665c255d 2023-08-04 jrmu 'x=-25)
363 665c255d 2023-08-04 jrmu (test-case (geval '(if true false true)) false)
364 665c255d 2023-08-04 jrmu (test-case (geval
365 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
366 665c255d 2023-08-04 jrmu (+ x y (* x y))))
367 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
368 665c255d 2023-08-04 jrmu
369 665c255d 2023-08-04 jrmu
370 665c255d 2023-08-04 jrmu (geval
371 665c255d 2023-08-04 jrmu '(define (factorial n)
372 665c255d 2023-08-04 jrmu (if (= n 0)
373 665c255d 2023-08-04 jrmu 1
374 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
375 665c255d 2023-08-04 jrmu (test-case (geval '(factorial 5)) 120)
376 665c255d 2023-08-04 jrmu
377 665c255d 2023-08-04 jrmu