1 ;; (define apply-in-underlying-scheme apply)
2 ;; (define eval-in-underlying-scheme eval)
3 
4 (define (assoc key records)
5   (cond ((null? records) false)
6         ((equal? key (caar records)) (car records))
7         (else (assoc key (cdr records)))))
8 
9 (define (make-table)
10   (let ((local-table (list '*table*)))
11     (define (lookup key-1 key-2)
12       (let ((subtable (assoc key-1 (cdr local-table))))
13         (if subtable
14             (let ((record (assoc key-2 (cdr subtable))))
15               (if record
16                   (cdr record)
17                   false))
18             false)))
19     (define (insert! key-1 key-2 value)
20       (let ((subtable (assoc key-1 (cdr local-table))))
21         (if subtable
22             (let ((record (assoc key-2 (cdr subtable))))
23               (if record
24                   (set-cdr! record value)
25                   (set-cdr! subtable
26                             (cons (cons key-2 value)
27                                   (cdr subtable)))))
28             (set-cdr! local-table
29                       (cons (list key-1
30                                   (cons key-2 value))
31                             (cdr local-table)))))
32       'ok)    
33     (define (dispatch m)
34       (cond ((eq? m 'lookup-proc) lookup)
35             ((eq? m 'insert-proc!) insert!)
36             (else (error "Unknown operation -- TABLE" m))))
37     dispatch))
38 (define operation-table (make-table))
39 (define get (operation-table 'lookup-proc))
40 (define put (operation-table 'insert-proc!))
41 
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.
43 
44 (define (form? exp)
45   (pair? exp))
46 (define (form-type exp)
47   (car exp))
48 
49 (define (eval exp env)
50   (cond ((self-evaluating? exp) exp)
51         ((variable? exp) (lookup-variable-value exp env))
52 	((and (form? exp)
53 	      (get (form-type exp) 'eval))
54 	 ((get (form-type exp) 'eval) exp env))
55 	((application? exp)
56          (apply (eval (operator exp) env)
57                 (list-of-values (operands exp) env)))
58         (else
59          (error "Unknown expression type -- EVAL" exp))))
60 
61 (define (apply procedure arguments)
62   (cond ((primitive-procedure? procedure)
63          (apply-primitive-procedure procedure arguments))
64         ((compound-procedure? procedure)
65          (eval-sequence
66            (procedure-body procedure)
67            (extend-environment
68              (procedure-parameters procedure)
69              arguments
70              (procedure-environment procedure))))
71         (else
72          (error
73           "Unknown procedure type -- APPLY" procedure))))
74 (define (list-of-values exps env)
75   (if (no-operands? exps)
76       '()
77       (cons (eval (first-operand exps) env)
78             (list-of-values (rest-operands exps) env))))
79 
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)
91                        env)
92   'ok)
93 (define (eval-definition exp env)
94   (define-variable! (definition-variable exp)
95                     (eval (definition-value exp) env)
96                     env)
97   'ok)
98 (define (self-evaluating? exp)
99   (cond ((number? exp) true)
100         ((string? exp) true)
101         (else false)))
102 (define (variable? exp) (symbol? exp))
103 (define (quoted? exp)
104   (tagged-list? exp 'quote))
105 
106 (define (text-of-quotation exp env) (cadr exp))
107 (define (tagged-list? exp tag)
108   (if (pair? exp)
109       (eq? (car exp) tag)
110       false))
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))
119       (cadr exp)
120       (caadr exp)))
121 (define (definition-value exp)
122   (if (symbol? (cadr exp))
123       (caddr exp)
124       (make-lambda (cdadr exp)   ; formal parameters
125                    (cddr exp)))) ; body
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)))
136       (cadddr exp)
137       'false))
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))
145 
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)))
165 
166 (define (expand-clauses clauses)
167   (if (null? clauses)
168       'false                          ; no else clause
169       (let ((first (car clauses))
170             (rest (cdr clauses)))
171         (if (cond-else-clause? first)
172             (if (null? rest)
173                 (sequence->exp (cond-actions first))
174                 (error "ELSE clause isn't last -- COND->IF"
175                        clauses))
176             (make-if (cond-predicate first)
177                      (sequence->exp (cond-actions first))
178                      (expand-clauses rest))))))
179 (define (true? x)
180   (not (eq? x false)))
181 (define (false? x)
182   (eq? x false))
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)
209       (cond ((null? vars)
210              (env-loop (enclosing-environment env)))
211             ((eq? var (car vars))
212              (car vals))
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)))))
219   (env-loop env))
220 (define (set-variable-value! var val env)
221   (define (env-loop env)
222     (define (scan vars vals)
223       (cond ((null? vars)
224              (env-loop (enclosing-environment env)))
225             ((eq? var (car vars))
226              (set-car! vals val))
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)))))
233   (env-loop env))
234 (define (define-variable! var val env)
235   (let ((frame (first-frame env)))
236     (define (scan vars vals)
237       (cond ((null? vars)
238              (add-binding-to-frame! var val frame))
239             ((eq? var (car vars))
240              (set-car! vals val))
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))
246 
247 (define (primitive-implementation proc) (cadr proc))
248 (define primitive-procedures
249   (list (list 'car car)
250         (list 'cdr cdr)
251         (list 'cons cons)
252         (list 'null? null?)
253 	(list '* *)
254 	(list '/ /)
255 	(list '+ +)
256 	(list '- -)
257 	(list '= =)
258 	(list 'display display)))
259 (define (primitive-procedure-names)
260   (map car
261        primitive-procedures))
262 
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)))
277   (driver-loop))
278 (define (prompt-for-input string)
279   (newline) (newline) (display string) (newline))
280 
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)
288                      '<procedure-env>))
289       (display object)))
290 (define (setup-environment)
291   (let ((initial-env
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)
297     initial-env))
298 (define the-global-environment (setup-environment))
299 
300 (define (let? exp)
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)
307   (cddr exp))
308 (define (let->combination exp)
309   (make-application (make-lambda (let-vars exp) (let-body exp))
310 		    (let-vals exp)))
311 (define (make-application op args)
312   (cons op args))
313 
314 (define (test-case actual expected)
315   (newline)
316   (display "Actual:   ")
317   (display actual)
318   (newline)
319   (display "Expected: ")
320   (display expected)
321   (newline))
322 
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)
327 (put 'lambda 
328      'eval
329      (lambda (exp env)
330        (make-procedure (lambda-parameters exp)
331 		       (lambda-body exp)
332 		       env)))
333 (put 'begin
334      'eval 
335      (lambda (exp env)
336        (eval-sequence (begin-actions exp) env)))
337 (put 'cond
338      'eval
339      (lambda (exp env)
340        (eval (cond->if exp) env)))
341 (put 'let
342      'eval
343      (lambda (exp env)
344        (eval (let->combination exp) env)))
345 
346 (define (geval exp) ;; eval globally
347   (eval exp the-global-environment))
348 
349 ;; test-suite
350 
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)
360 			 ((= x -25) 'x=-25)
361 			 (else 'failed)))
362 	   'x=-25)
363 (test-case (geval '(if true false true)) false)
364 (test-case (geval 
365 	    '(let ((x 4) (y 7))
366 	       (+ x y (* x y))))
367 	   (+ 4 7 (* 4 7)))
368 
369 
370 (geval
371  '(define (factorial n)
372     (if (= n 0)
373 	1
374 	(* n (factorial (- n 1))))))
375 (test-case (geval '(factorial 5)) 120)
376 
377