1 (define (eval exp env)
2   (cond ((self-evaluating? exp) exp)
3         ((variable? exp) (lookup-variable-value exp env))
4         ((quoted? exp) (text-of-quotation exp))
5         ((assignment? exp) (eval-assignment exp env))
6         ((definition? exp) (eval-definition exp env))
7         ((if? exp) (eval-if exp env))
8         ((lambda? exp)
9          (make-procedure (lambda-parameters exp)
10                          (lambda-body exp)
11                          env))
12         ((begin? exp) 
13          (eval-sequence (begin-actions exp) env))
14         ((cond? exp) (eval (cond->if exp) env))
15 	((let? exp) (eval (let->combination exp) env))
16         ((application? exp)
17          (apply (eval (operator exp) env)
18                 (list-of-values (operands exp) env)))
19         (else
20          (error "Unknown expression type -- EVAL" exp))))
21 
22 (define (apply procedure arguments)
23   (cond ((primitive-procedure? procedure)
24          (apply-primitive-procedure procedure arguments))
25         ((compound-procedure? procedure)
26          (eval-sequence
27            (procedure-body procedure)
28            (extend-environment
29              (procedure-parameters procedure)
30              arguments
31              (procedure-environment procedure))))
32         (else
33          (error
34           "Unknown procedure type -- APPLY" procedure))))
35 (define (list-of-values exps env)
36   (if (no-operands? exps)
37       '()
38       (cons (eval (first-operand exps) env)
39             (list-of-values (rest-operands exps) env))))
40 
41 (define (eval-if exp env)
42   (if (true? (eval (if-predicate exp) env))
43       (eval (if-consequent exp) env)
44       (eval (if-alternative exp) env)))
45 (define (eval-sequence exps env)
46   (cond ((last-exp? exps) (eval (first-exp exps) env))
47         (else (eval (first-exp exps) env)
48               (eval-sequence (rest-exps exps) env))))
49 (define (eval-assignment exp env)
50   (set-variable-value! (assignment-variable exp)
51                        (eval (assignment-value exp) env)
52                        env)
53   'ok)
54 (define (eval-definition exp env)
55   (define-variable! (definition-variable exp)
56                     (eval (definition-value exp) env)
57                     env)
58   'ok)
59 (define (self-evaluating? exp)
60   (cond ((number? exp) true)
61         ((string? exp) true)
62         (else false)))
63 (define (variable? exp) (symbol? exp))
64 (define (quoted? exp)
65   (tagged-list? exp 'quote))
66 
67 (define (text-of-quotation exp) (cadr exp))
68 (define (tagged-list? exp tag)
69   (if (pair? exp)
70       (eq? (car exp) tag)
71       false))
72 (define (assignment? exp)
73   (tagged-list? exp 'set!))
74 (define (assignment-variable exp) (cadr exp))
75 (define (assignment-value exp) (caddr exp))
76 (define (definition? exp)
77   (tagged-list? exp 'define))
78 (define (definition-variable exp)
79   (if (symbol? (cadr exp))
80       (cadr exp)
81       (caadr exp)))
82 (define (definition-value exp)
83   (if (symbol? (cadr exp))
84       (caddr exp)
85       (make-lambda (cdadr exp)   ; formal parameters
86                    (cddr exp)))) ; body
87 (define (lambda? exp) (tagged-list? exp 'lambda))
88 (define (lambda-parameters exp) (cadr exp))
89 (define (lambda-body exp) (cddr exp))
90 (define (make-lambda parameters body)
91   (cons 'lambda (cons parameters body)))
92 (define (if? exp) (tagged-list? exp 'if))
93 (define (if-predicate exp) (cadr exp))
94 (define (if-consequent exp) (caddr exp))
95 (define (if-alternative exp)
96   (if (not (null? (cdddr exp)))
97       (cadddr exp)
98       'false))
99 (define (make-if predicate consequent alternative)
100   (list 'if predicate consequent alternative))
101 (define (begin? exp) (tagged-list? exp 'begin))
102 (define (begin-actions exp) (cdr exp))
103 (define (last-exp? seq) (null? (cdr seq)))
104 (define (first-exp seq) (car seq))
105 (define (rest-exps seq) (cdr seq))
106 
107 (define (sequence->exp seq)
108   (cond ((null? seq) seq)
109         ((last-exp? seq) (first-exp seq))
110         (else (make-begin seq))))
111 (define (make-begin seq) (cons 'begin seq))
112 (define (application? exp) (pair? exp))
113 (define (operator exp) (car exp))
114 (define (operands exp) (cdr exp))
115 (define (no-operands? ops) (null? ops))
116 (define (first-operand ops) (car ops))
117 (define (rest-operands ops) (cdr ops))
118 (define (cond? exp) (tagged-list? exp 'cond))
119 (define (cond-clauses exp) (cdr exp))
120 (define (cond-else-clause? clause)
121   (eq? (cond-predicate clause) 'else))
122 (define (cond-predicate clause) (car clause))
123 (define (cond-actions clause) (cdr clause))
124 (define (cond->if exp)
125   (expand-clauses (cond-clauses exp)))
126 
127 (define (expand-clauses clauses)
128   (if (null? clauses)
129       'false                          ; no else clause
130       (let ((first (car clauses))
131             (rest (cdr clauses)))
132         (if (cond-else-clause? first)
133             (if (null? rest)
134                 (sequence->exp (cond-actions first))
135                 (error "ELSE clause isn't last -- COND->IF"
136                        clauses))
137             (make-if (cond-predicate first)
138                      (sequence->exp (cond-actions first))
139                      (expand-clauses rest))))))
140 (define (true? x)
141   (not (eq? x false)))
142 (define (false? x)
143   (eq? x false))
144 (define (make-procedure parameters body env)
145   (list 'procedure parameters body env))
146 (define (compound-procedure? p)
147   (tagged-list? p 'procedure))
148 (define (procedure-parameters p) (cadr p))
149 (define (procedure-body p) (caddr p))
150 (define (procedure-environment p) (cadddr p))
151 (define (enclosing-environment env) (cdr env))
152 (define (first-frame env) (car env))
153 (define the-empty-environment '())
154 (define (make-frame variables values)
155   (cons variables values))
156 (define (frame-variables frame) (car frame))
157 (define (frame-values frame) (cdr frame))
158 (define (add-binding-to-frame! var val frame)
159   (set-car! frame (cons var (car frame)))
160   (set-cdr! frame (cons val (cdr frame))))
161 (define (extend-environment vars vals base-env)
162   (if (= (length vars) (length vals))
163       (cons (make-frame vars vals) base-env)
164       (if (< (length vars) (length vals))
165           (error "Too many arguments supplied" vars vals)
166           (error "Too few arguments supplied" vars vals))))
167 (define (lookup-variable-value var env)
168   (define (env-loop env)
169     (define (scan vars vals)
170       (cond ((null? vars)
171              (env-loop (enclosing-environment env)))
172             ((eq? var (car vars))
173              (car vals))
174             (else (scan (cdr vars) (cdr vals)))))
175     (if (eq? env the-empty-environment)
176         (error "Unbound variable" var)
177         (let ((frame (first-frame env)))
178           (scan (frame-variables frame)
179                 (frame-values frame)))))
180   (env-loop env))
181 (define (set-variable-value! var val env)
182   (define (env-loop env)
183     (define (scan vars vals)
184       (cond ((null? vars)
185              (env-loop (enclosing-environment env)))
186             ((eq? var (car vars))
187              (set-car! vals val))
188             (else (scan (cdr vars) (cdr vals)))))
189     (if (eq? env the-empty-environment)
190         (error "Unbound variable -- SET!" var)
191         (let ((frame (first-frame env)))
192           (scan (frame-variables frame)
193                 (frame-values frame)))))
194   (env-loop env))
195 (define (define-variable! var val env)
196   (let ((frame (first-frame env)))
197     (define (scan vars vals)
198       (cond ((null? vars)
199              (add-binding-to-frame! var val frame))
200             ((eq? var (car vars))
201              (set-car! vals val))
202             (else (scan (cdr vars) (cdr vals)))))
203     (scan (frame-variables frame)
204           (frame-values frame))))
205 (define (primitive-procedure? proc)
206   (tagged-list? proc 'primitive))
207 
208 (define (primitive-implementation proc) (cadr proc))
209 (define primitive-procedures
210   (list (list 'car car)
211         (list 'cdr cdr)
212         (list 'cons cons)
213         (list 'null? null?)
214 	(list '* *)
215 	(list '/ /)
216 	(list '+ +)
217 	(list '- -)
218 	(list 'display display)))
219 (define (primitive-procedure-names)
220   (map car
221        primitive-procedures))
222 
223 (define (primitive-procedure-objects)
224   (map (lambda (proc) (list 'primitive (cadr proc)))
225        primitive-procedures))
226 (define (apply-primitive-procedure proc args)
227   (apply-in-underlying-scheme
228    (primitive-implementation proc) args))
229 (define input-prompt ";;; M-Eval input:")
230 (define output-prompt ";;; M-Eval value:")
231 (define (driver-loop)
232   (prompt-for-input input-prompt)
233   (let ((input (read)))
234     (let ((output (eval input the-global-environment)))
235       (announce-output output-prompt)
236       (user-print output)))
237   (driver-loop))
238 (define (prompt-for-input string)
239   (newline) (newline) (display string) (newline))
240 
241 (define (announce-output string)
242   (newline) (display string) (newline))
243 (define (user-print object)
244   (if (compound-procedure? object)
245       (display (list 'compound-procedure
246                      (procedure-parameters object)
247                      (procedure-body object)
248                      '<procedure-env>))
249       (display object)))
250 (define (setup-environment)
251   (let ((initial-env
252          (extend-environment (primitive-procedure-names)
253                              (primitive-procedure-objects)
254                              the-empty-environment)))
255     (define-variable! 'true true initial-env)
256     (define-variable! 'false false initial-env)
257     initial-env))
258 (define the-global-environment (setup-environment))
259 
260 ;; Exercise 4.1.  Notice that we cannot tell whether the metacircular evaluator evaluates operands from left to right or from right to left. Its evaluation order is inherited from the underlying Lisp: If the arguments to cons in list-of-values are evaluated from left to right, then list-of-values will evaluate operands from left to right; and if the arguments to cons are evaluated from right to left, then list-of-values will evaluate operands from right to left.
261 
262 ;; Write a version of list-of-values that evaluates operands from left to right regardless of the order of evaluation in the underlying Lisp. Also write a version of list-of-values that evaluates operands from right to left. 
263 
264 
265 (define (let? exp)
266   (tagged-list? exp 'let))
267 (define (let-vars exp)
268   (map car (cadr exp)))
269 (define (let-vals exp)
270   (map cadr (cadr exp)))
271 (define (let-body exp)
272   (cddr exp))
273 (define (let->combination exp)
274   (cons (make-lambda (let-vars exp) (let-body exp))
275 	(let-vals exp)))
276 
277 (define (test-case actual expected)
278   (newline)
279   (display "Actual:   ")
280   (display actual)
281   (newline)
282   (display "Expected: ")
283   (display expected)
284   (newline))
285 
286 (define (geval exp) ;; eval globally
287   (eval exp the-global-environment))
288 
289 ;; eval test suite
290 (test-case (geval 
291 	    '(let ((x 4) (y 7))
292 	       (+ x y (* x y))))
293 	   (+ 4 7 (* 4 7)))
294 (geval 
295  '(define old-value
296     (let ((x 0))
297       (lambda (y)
298 	(let ((z x))
299 	  (set! x y)
300 	  z)))))
301 
302 
303 (test-case (geval '(+ (old-value 4) (old-value 5)))
304 	   4)
305 (test-case (geval '(- (old-value 2) (old-value 8)))
306 	   3)
307