1 ;; (define apply-in-underlying-scheme apply)
2 ;; (define eval-in-underlying-scheme eval)
4 (define (assoc key records)
5 (cond ((null? records) false)
6 ((equal? key (caar records)) (car records))
7 (else (assoc key (cdr records)))))
10 (let ((local-table (list '*table*)))
11 (define (lookup key-1 key-2)
12 (let ((subtable (assoc key-1 (cdr local-table))))
14 (let ((record (assoc key-2 (cdr subtable))))
19 (define (insert! key-1 key-2 value)
20 (let ((subtable (assoc key-1 (cdr local-table))))
22 (let ((record (assoc key-2 (cdr subtable))))
24 (set-cdr! record value)
26 (cons (cons key-2 value)
34 (cond ((eq? m 'lookup-proc) lookup)
35 ((eq? m 'insert-proc!) insert!)
36 (else (error "Unknown operation -- TABLE" m))))
38 (define operation-table (make-table))
39 (define get (operation-table 'lookup-proc))
40 (define put (operation-table 'insert-proc!))
42 ;; 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.
46 (define (form-type exp)
49 (define (eval exp env)
50 (cond ((self-evaluating? exp) exp)
51 ((variable? exp) (lookup-variable-value exp env))
53 (get (form-type exp) 'eval))
54 ((get (form-type exp) 'eval) exp env))
56 (apply (eval (operator exp) env)
57 (list-of-values (operands exp) env)))
59 (error "Unknown expression type -- EVAL" exp))))
61 (define (apply procedure arguments)
62 (cond ((primitive-procedure? procedure)
63 (apply-primitive-procedure procedure arguments))
64 ((compound-procedure? procedure)
66 (procedure-body procedure)
68 (procedure-parameters procedure)
70 (procedure-environment procedure))))
73 "Unknown procedure type -- APPLY" procedure))))
74 (define (list-of-values exps env)
75 (if (no-operands? exps)
77 (cons (eval (first-operand exps) env)
78 (list-of-values (rest-operands exps) env))))
80 (define (eval-if exp env)
81 (if (true? (eval (if-predicate exp) env))
82 (eval (if-consequent exp) env)
83 (eval (if-alternative exp) env)))
84 (define (eval-sequence exps env)
85 (cond ((last-exp? exps) (eval (first-exp exps) env))
86 (else (eval (first-exp exps) env)
87 (eval-sequence (rest-exps exps) env))))
88 (define (eval-assignment exp env)
89 (set-variable-value! (assignment-variable exp)
90 (eval (assignment-value exp) env)
93 (define (eval-definition exp env)
94 (define-variable! (definition-variable exp)
95 (eval (definition-value exp) env)
98 (define (self-evaluating? exp)
99 (cond ((number? exp) true)
102 (define (variable? exp) (symbol? exp))
103 (define (quoted? exp)
104 (tagged-list? exp 'quote))
106 (define (text-of-quotation exp env) (cadr exp))
107 (define (tagged-list? exp tag)
111 (define (assignment? exp)
112 (tagged-list? exp 'set!))
113 (define (assignment-variable exp) (cadr exp))
114 (define (assignment-value exp) (caddr exp))
115 (define (definition? exp)
116 (tagged-list? exp 'define))
117 (define (definition-variable exp)
118 (if (symbol? (cadr exp))
121 (define (definition-value exp)
122 (if (symbol? (cadr exp))
124 (make-lambda (cdadr exp) ; formal parameters
126 (define (lambda? exp) (tagged-list? exp 'lambda))
127 (define (lambda-parameters exp) (cadr exp))
128 (define (lambda-body exp) (cddr exp))
129 (define (make-lambda parameters body)
130 (cons 'lambda (cons parameters body)))
131 (define (if? exp) (tagged-list? exp 'if))
132 (define (if-predicate exp) (cadr exp))
133 (define (if-consequent exp) (caddr exp))
134 (define (if-alternative exp)
135 (if (not (null? (cdddr exp)))
138 (define (make-if predicate consequent alternative)
139 (list 'if predicate consequent alternative))
140 (define (begin? exp) (tagged-list? exp 'begin))
141 (define (begin-actions exp) (cdr exp))
142 (define (last-exp? seq) (null? (cdr seq)))
143 (define (first-exp seq) (car seq))
144 (define (rest-exps seq) (cdr seq))
146 (define (sequence->exp seq)
147 (cond ((null? seq) seq)
148 ((last-exp? seq) (first-exp seq))
149 (else (make-begin seq))))
150 (define (make-begin seq) (cons 'begin seq))
151 (define (application? exp) (pair? exp))
152 (define (operator exp) (car exp))
153 (define (operands exp) (cdr exp))
154 (define (no-operands? ops) (null? ops))
155 (define (first-operand ops) (car ops))
156 (define (rest-operands ops) (cdr ops))
157 (define (cond? exp) (tagged-list? exp 'cond))
158 (define (cond-clauses exp) (cdr exp))
159 (define (cond-else-clause? clause)
160 (eq? (cond-predicate clause) 'else))
161 (define (cond-predicate clause) (car clause))
162 (define (cond-actions clause) (cdr clause))
163 (define (cond->if exp)
164 (expand-clauses (cond-clauses exp)))
166 (define (expand-clauses clauses)
168 'false ; no else clause
169 (let ((first (car clauses))
170 (rest (cdr clauses)))
171 (if (cond-else-clause? first)
173 (sequence->exp (cond-actions first))
174 (error "ELSE clause isn't last -- COND->IF"
176 (make-if (cond-predicate first)
177 (sequence->exp (cond-actions first))
178 (expand-clauses rest))))))
183 (define (make-procedure parameters body env)
184 (list 'procedure parameters body env))
185 (define (compound-procedure? p)
186 (tagged-list? p 'procedure))
187 (define (procedure-parameters p) (cadr p))
188 (define (procedure-body p) (caddr p))
189 (define (procedure-environment p) (cadddr p))
190 (define (enclosing-environment env) (cdr env))
191 (define (first-frame env) (car env))
192 (define the-empty-environment '())
193 (define (make-frame variables values)
194 (cons variables values))
195 (define (frame-variables frame) (car frame))
196 (define (frame-values frame) (cdr frame))
197 (define (add-binding-to-frame! var val frame)
198 (set-car! frame (cons var (car frame)))
199 (set-cdr! frame (cons val (cdr frame))))
200 (define (extend-environment vars vals base-env)
201 (if (= (length vars) (length vals))
202 (cons (make-frame vars vals) base-env)
203 (if (< (length vars) (length vals))
204 (error "Too many arguments supplied" vars vals)
205 (error "Too few arguments supplied" vars vals))))
206 (define (lookup-variable-value var env)
207 (define (env-loop env)
208 (define (scan vars vals)
210 (env-loop (enclosing-environment env)))
211 ((eq? var (car vars))
213 (else (scan (cdr vars) (cdr vals)))))
214 (if (eq? env the-empty-environment)
215 (error "Unbound variable" var)
216 (let ((frame (first-frame env)))
217 (scan (frame-variables frame)
218 (frame-values frame)))))
220 (define (set-variable-value! var val env)
221 (define (env-loop env)
222 (define (scan vars vals)
224 (env-loop (enclosing-environment env)))
225 ((eq? var (car vars))
227 (else (scan (cdr vars) (cdr vals)))))
228 (if (eq? env the-empty-environment)
229 (error "Unbound variable -- SET!" var)
230 (let ((frame (first-frame env)))
231 (scan (frame-variables frame)
232 (frame-values frame)))))
234 (define (define-variable! var val env)
235 (let ((frame (first-frame env)))
236 (define (scan vars vals)
238 (add-binding-to-frame! var val frame))
239 ((eq? var (car vars))
241 (else (scan (cdr vars) (cdr vals)))))
242 (scan (frame-variables frame)
243 (frame-values frame))))
244 (define (primitive-procedure? proc)
245 (tagged-list? proc 'primitive))
247 (define (primitive-implementation proc) (cadr proc))
248 (define primitive-procedures
249 (list (list 'car car)
258 (list 'display display)))
259 (define (primitive-procedure-names)
261 primitive-procedures))
263 (define (primitive-procedure-objects)
264 (map (lambda (proc) (list 'primitive (cadr proc)))
265 primitive-procedures))
266 (define (apply-primitive-procedure proc args)
267 (apply-in-underlying-scheme
268 (primitive-implementation proc) args))
269 (define input-prompt ";;; M-Eval input:")
270 (define output-prompt ";;; M-Eval value:")
271 (define (driver-loop)
272 (prompt-for-input input-prompt)
273 (let ((input (read)))
274 (let ((output (eval input the-global-environment)))
275 (announce-output output-prompt)
276 (user-print output)))
278 (define (prompt-for-input string)
279 (newline) (newline) (display string) (newline))
281 (define (announce-output string)
282 (newline) (display string) (newline))
283 (define (user-print object)
284 (if (compound-procedure? object)
285 (display (list 'compound-procedure
286 (procedure-parameters object)
287 (procedure-body object)
290 (define (setup-environment)
292 (extend-environment (primitive-procedure-names)
293 (primitive-procedure-objects)
294 the-empty-environment)))
295 (define-variable! 'true true initial-env)
296 (define-variable! 'false false initial-env)
298 (define the-global-environment (setup-environment))
301 (tagged-list? exp 'let))
302 (define (let-vars exp)
303 (map car (cadr exp)))
304 (define (let-vals exp)
305 (map cadr (cadr exp)))
306 (define (let-body exp)
308 (define (let->combination exp)
309 (make-application (make-lambda (let-vars exp) (let-body exp))
311 (define (make-application op args)
314 (define (test-case actual expected)
319 (display "Expected: ")
323 (put 'quote 'eval text-of-quotation)
324 (put 'set! 'eval eval-assignment)
325 (put 'define 'eval eval-definition)
326 (put 'if 'eval eval-if)
330 (make-procedure (lambda-parameters exp)
336 (eval-sequence (begin-actions exp) env)))
340 (eval (cond->if exp) env)))
344 (eval (let->combination exp) env)))
346 (define (geval exp) ;; eval globally
347 (eval exp the-global-environment))
351 (test-case (geval '(begin 5 6)) 6)
352 (test-case (geval '10) 10)
353 (geval '(define x 3))
354 (test-case (geval 'x) 3)
355 (test-case (geval '(set! x -25)) 'ok)
356 (test-case (geval 'x) -25)
357 (geval '(define z (lambda (x y) (+ x (* x y)))))
358 (test-case (geval '(z 3 4)) 15)
359 (test-case (geval '(cond ((= x -2) 'x=-2)
363 (test-case (geval '(if true false true)) false)
371 '(define (factorial n)
374 (* n (factorial (- n 1))))))
375 (test-case (geval '(factorial 5)) 120)