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 	((and? exp) (eval-and exp env))
9 	((or? exp) (eval-or exp env))
10         ((lambda? exp)
11          (make-procedure (lambda-parameters exp)
12                          (lambda-body exp)
13                          env))
14         ((begin? exp) 
15          (eval-sequence (begin-actions exp) env))
16         ((cond? exp) (eval (cond->if exp) env))
17 	((let? exp) (eval (let->combination exp) env))
18 	((let*? exp) (eval (let*->nested-lets exp) env))
19         ((application? exp)
20          (apply (eval (operator exp) env)
21                 (list-of-values (operands exp) env)))
22         (else
23          (error "Unknown expression type -- EVAL" exp))))
24 (define (apply procedure arguments)
25   (cond ((primitive-procedure? procedure)
26          (apply-primitive-procedure procedure arguments))
27         ((compound-procedure? procedure)
28          (eval-sequence
29            (procedure-body procedure)
30            (extend-environment
31              (procedure-parameters procedure)
32              arguments
33              (procedure-environment procedure))))
34         (else
35          (error
36           "Unknown procedure type -- APPLY" procedure))))
37 (define (list-of-values exps env)
38   (if (no-operands? exps)
39       '()
40       (cons (eval (first-operand exps) env)
41             (list-of-values (rest-operands exps) env))))
42 
43 (define (tagged-list? exp tag)
44   (if (pair? exp)
45       (eq? (car exp) tag)
46       false))
47 
48 ;; self-evaluating/variable/quoted
49 (define (self-evaluating? exp)
50   (cond ((number? exp) true)
51         ((string? exp) true)
52         (else false)))
53 (define (variable? exp) (symbol? exp))
54 (define (quoted? exp)
55   (tagged-list? exp 'quote))
56 (define (text-of-quotation exp) (cadr exp))
57 
58 ;; assignment/definition
59 (define (assignment? exp)
60   (tagged-list? exp 'set!))
61 (define (assignment-variable exp) (cadr exp))
62 (define (assignment-value exp) (caddr exp))
63 (define (definition? exp)
64   (tagged-list? exp 'define))
65 (define (definition-variable exp)
66   (if (symbol? (cadr exp))
67       (cadr exp)
68       (caadr exp)))
69 (define (definition-value exp)
70   (if (symbol? (cadr exp))
71       (caddr exp)
72       (make-lambda (cdadr exp)   ; formal parameters
73                    (cddr exp)))) ; body
74 (define (eval-assignment exp env)
75   (set-variable-value! (assignment-variable exp)
76                        (eval (assignment-value exp) env)
77                        env)
78   'ok)
79 (define (eval-definition exp env)
80   (define-variable! (definition-variable exp)
81                     (eval (definition-value exp) env)
82                     env)
83   'ok)
84 
85 
86 ;; if/and/or
87 (define (if? exp) (tagged-list? exp 'if))
88 (define (if-predicate exp) (cadr exp))
89 (define (if-consequent exp) (caddr exp))
90 (define (if-alternative exp)
91   (if (not (null? (cdddr exp)))
92       (cadddr exp)
93       'false))
94 (define (make-if predicate consequent alternative)
95   (list 'if predicate consequent alternative))
96 (define (eval-if exp env)
97   (if (true? (eval (if-predicate exp) env))
98       (eval (if-consequent exp) env)
99       (eval (if-alternative exp) env)))
100 
101 (define (and? exp)
102   (tagged-list? exp 'and))
103 (define (and-clauses exp)
104   (cdr exp))
105 (define (or? exp)
106   (tagged-list? exp 'or))
107 (define (or-clauses exp)
108   (cdr exp))
109 (define (eval-and exp env)
110   (define (eval-clauses clauses)
111     (cond ((null? clauses) true)
112 	  ((null? (cdr clauses)) (eval (car clauses) env))
113 	  (else (and (eval (car clauses) env)
114 		     (eval-clauses (cdr clauses))))))
115   (eval-clauses (and-clauses exp)))
116 (define (eval-or exp env)
117   (define (eval-clauses clauses)
118     (if (null? clauses)
119 	false
120 	(or (eval (car clauses) env)
121 	    (eval-clauses (cdr clauses)))))
122   (eval-clauses (or-clauses exp)))
123 
124 
125 ;; lambda
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 
132 (define (make-let vars vals body)
133   (cons 'let
134 	(cons (map (lambda (var val)
135 		     (list var val))
136 		   vars vals)
137 	      body)))
138 (define (let? exp)
139   (tagged-list? exp 'let))
140 (define (let-vars exp)
141   (map car (cadr exp)))
142 (define (let-vals exp)
143   (map cadr (cadr exp)))
144 (define (let-body exp)
145   (cddr exp))
146 (define (let->combination exp)
147   (make-application (make-lambda (let-vars exp) (let-body exp))
148 		    (let-vals exp)))
149 (define (make-application op args)
150   (cons op args))
151 
152 
153 
154 ;; begin/sequence
155 (define (begin? exp) (tagged-list? exp 'begin))
156 (define (begin-actions exp) (cdr exp))
157 (define (last-exp? seq) (null? (cdr seq)))
158 (define (first-exp seq) (car seq))
159 (define (rest-exps seq) (cdr seq))
160 (define (sequence->exp seq)
161   (cond ((null? seq) seq)
162         ((last-exp? seq) (first-exp seq))
163         (else (make-begin seq))))
164 (define (make-begin seq) (cons 'begin seq))
165 (define (eval-sequence exps env)
166   (cond ((last-exp? exps) (eval (first-exp exps) env))
167         (else (eval (first-exp exps) env)
168               (eval-sequence (rest-exps exps) env))))
169 
170 ;; application
171 (define (application? exp) (pair? exp))
172 (define (operator exp) (car exp))
173 (define (operands exp) (cdr exp))
174 (define (no-operands? ops) (null? ops))
175 (define (first-operand ops) (car ops))
176 (define (rest-operands ops) (cdr ops))
177 
178 ;; cond
179 (define (cond? exp) (tagged-list? exp 'cond))
180 (define (cond-clauses exp) (cdr exp))
181 (define (cond-else-clause? clause)
182   (eq? (cond-predicate clause) 'else))
183 (define (cond-predicate clause) (car clause))
184 (define (cond-actions clause) (cdr clause))
185 (define (cond-extended-clause? clause)
186   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
187 (define (cond-extended-proc clause)
188   (caddr clause))
189 (define (cond->if exp)
190   (expand-clauses (cond-clauses exp)))
191 (define (expand-clauses clauses)
192   (if (null? clauses)
193       'false                          ; no else clause
194       (let ((first (car clauses))
195             (rest (cdr clauses)))
196         (if (cond-else-clause? first)
197             (if (null? rest)
198                 (sequence->exp (cond-actions first))
199                 (error "ELSE clause isn't last -- COND->IF"
200                        clauses))
201 	    (if (cond-extended-clause? first)
202 		(make-if (cond-predicate first)
203 			 (make-application
204 			  (cond-extended-proc first)
205 			  (list (cond-predicate first)))
206 			 (expand-clauses rest))
207 		(make-if (cond-predicate first)
208 			 (sequence->exp (cond-actions first))
209 			 (expand-clauses rest)))))))
210 (define (true? x)
211   (not (eq? x false)))
212 (define (false? x)
213   (eq? x false))
214 
215 ;; procedure
216 (define (make-procedure parameters body env)
217   (list 'procedure parameters body env))
218 (define (compound-procedure? p)
219   (tagged-list? p 'procedure))
220 (define (procedure-parameters p) (cadr p))
221 (define (procedure-body p) (caddr p))
222 (define (procedure-environment p) (cadddr p))
223 
224 ;; environment
225 (define (enclosing-environment env) (cdr env))
226 (define (first-frame env) (car env))
227 (define the-empty-environment '())
228 (define (make-frame variables values)
229   (cons variables values))
230 (define (frame-variables frame) (car frame))
231 (define (frame-values frame) (cdr frame))
232 (define (add-binding-to-frame! var val frame)
233   (set-car! frame (cons var (car frame)))
234   (set-cdr! frame (cons val (cdr frame))))
235 (define (extend-environment vars vals base-env)
236   (if (= (length vars) (length vals))
237       (cons (make-frame vars vals) base-env)
238       (if (< (length vars) (length vals))
239           (error "Too many arguments supplied" vars vals)
240           (error "Too few arguments supplied" vars vals))))
241 (define (lookup-variable-value var env)
242   (define (env-loop env)
243     (define (scan vars vals)
244       (cond ((null? vars)
245              (env-loop (enclosing-environment env)))
246             ((eq? var (car vars))
247              (car vals))
248             (else (scan (cdr vars) (cdr vals)))))
249     (if (eq? env the-empty-environment)
250         (error "Unbound variable" var)
251         (let ((frame (first-frame env)))
252           (scan (frame-variables frame)
253                 (frame-values frame)))))
254   (env-loop env))
255 (define (set-variable-value! var val env)
256   (define (env-loop env)
257     (define (scan vars vals)
258       (cond ((null? vars)
259              (env-loop (enclosing-environment env)))
260             ((eq? var (car vars))
261              (set-car! vals val))
262             (else (scan (cdr vars) (cdr vals)))))
263     (if (eq? env the-empty-environment)
264         (error "Unbound variable -- SET!" var)
265         (let ((frame (first-frame env)))
266           (scan (frame-variables frame)
267                 (frame-values frame)))))
268   (env-loop env))
269 (define (define-variable! var val env)
270   (let ((frame (first-frame env)))
271     (define (scan vars vals)
272       (cond ((null? vars)
273              (add-binding-to-frame! var val frame))
274             ((eq? var (car vars))
275              (set-car! vals val))
276             (else (scan (cdr vars) (cdr vals)))))
277     (scan (frame-variables frame)
278           (frame-values frame))))
279 (define (primitive-procedure? proc)
280   (tagged-list? proc 'primitive))
281 
282 (define (primitive-implementation proc) (cadr proc))
283 (define primitive-procedures
284   (list (list 'car car)
285         (list 'cdr cdr)
286 	(list 'caar caar)
287 	(list 'cadr cadr)
288 	(list 'cddr cddr)
289         (list 'cons cons)
290         (list 'null? null?)
291 	(list '* *)
292 	(list '/ /)
293 	(list '+ +)
294 	(list '- -)
295 	(list '= =)
296 	(list 'eq? eq?)
297 	(list 'equal? equal?)
298 	(list 'display display)))
299 (define (primitive-procedure-names)
300   (map car
301        primitive-procedures))
302 
303 (define (primitive-procedure-objects)
304   (map (lambda (proc) (list 'primitive (cadr proc)))
305        primitive-procedures))
306 (define (apply-primitive-procedure proc args)
307   (apply-in-underlying-scheme
308    (primitive-implementation proc) args))
309 
310 ;; driver-loop
311 (define input-prompt ";;; M-Eval input:")
312 (define output-prompt ";;; M-Eval value:")
313 (define (driver-loop)
314   (prompt-for-input input-prompt)
315   (let ((input (read)))
316     (let ((output (eval input the-global-environment)))
317       (announce-output output-prompt)
318       (user-print output)))
319   (driver-loop))
320 (define (prompt-for-input string)
321   (newline) (newline) (display string) (newline))
322 
323 (define (announce-output string)
324   (newline) (display string) (newline))
325 (define (user-print object)
326   (if (compound-procedure? object)
327       (display (list 'compound-procedure
328                      (procedure-parameters object)
329                      (procedure-body object)
330                      '<procedure-env>))
331       (display object)))
332 (define (setup-environment)
333   (let ((initial-env
334          (extend-environment (primitive-procedure-names)
335                              (primitive-procedure-objects)
336                              the-empty-environment)))
337     (define-variable! 'true true initial-env)
338     (define-variable! 'false false initial-env)
339     initial-env))
340 (define the-global-environment (setup-environment))
341 
342 
343 (define (test-case actual expected)
344   (newline)
345   (display "Actual:   ")
346   (display actual)
347   (newline)
348   (display "Expected: ")
349   (display expected)
350   (newline))
351 
352 (define (geval exp) ;; eval globally
353   (eval exp the-global-environment))
354 
355 (define (test-eval exp expected)
356   (test-case (geval exp) expected))
357 
358  ;; Exercise 4.7.  Let* is similar to let, except that the bindings of the let variables are performed sequentially from left to right, and each binding is made in an environment in which all of the preceding bindings are visible. For example
359 
360 (let* ((x 3)
361        (y (+ x 2))
362        (z (+ x y 5)))
363   (* x z))
364 
365 ;; returns 39. Explain how a let* expression can be rewritten as a set of nested let expressions, and write a procedure let*->nested-lets that performs this transformation. If we have already implemented let (exercise 4.6) and we want to extend the evaluator to handle let*, is it sufficient to add a clause to eval whose action is
366 
367 ;; (eval (let*->nested-lets exp) env)
368 
369 ;; or must we explicitly expand let* in terms of non-derived expressions? 
370 
371 (define (let*? exp)
372   (tagged-list? exp 'let*))
373 (define let*-vars let-vars)
374 (define let*-vals let-vals)
375 (define let*-body let-body)
376 (define (let*->nested-lets exp)
377   (define (expand-lets vars vals)
378     (if (null? (cdr vars))
379 	(make-let (list (car vars)) 
380 		  (list (car vals))
381 		  (let*-body exp))
382 	(make-let (list (car vars))
383 		  (list (car vals))
384 		  (list (expand-lets (cdr vars) (cdr vals))))))
385   (let ((vars (let*-vars exp))
386 	(vals (let*-vals exp)))
387     (if (null? vars)
388 	(sequence->exp (let*-body exp))
389 	(expand-lets vars vals))))
390 
391 ;; test-suite
392 
393 ;; procedure definitions
394 
395 (geval 
396  '(define (assoc key records)
397     (cond ((null? records) false)
398 	  ((equal? key (caar records)) (car records))
399 	  (else (assoc key (cdr records))))))
400 
401 (geval
402  '(define (map proc list)
403     (if (null? list)
404 	'()
405 	(cons (proc (car list))
406 	      (map proc (cdr list))))))
407 
408 (geval 
409  '(define (accumulate op initial sequence)
410     (if (null? sequence)
411 	initial
412 	(op (car sequence)
413 	    (accumulate op initial (cdr sequence))))))
414 
415 ;; all special forms
416 (test-eval '(begin 5 6) 6)
417 (test-eval '10 10)
418 (geval '(define x 3))
419 (test-eval 'x 3)
420 (test-eval '(set! x -25) 'ok)
421 (test-eval 'x -25)
422 (geval '(define z (lambda (x y) (+ x (* x y)))))
423 (test-eval '(z 3 4) 15)
424 (test-eval '(cond ((= x -2) 'x=-2)
425 		  ((= x -25) 'x=-25)
426 		  (else 'failed))
427 	   'x=-25)
428 (test-eval '(if true false true) false)
429 (test-eval 
430  '(let ((x 4) (y 7))
431     (+ x y (* x y)))
432  (+ 4 7 (* 4 7)))
433 
434 
435 ;; and/or
436 (geval '(define x (+ 3 8)))
437 (test-eval '(and 0 true x) 11)
438 (test-eval '(and 0 true x false) false)
439 (test-eval '(and 0 true x (set! x -2) false) false)
440 (test-eval 'x -2)
441 (test-eval '(and 0 true x false (set! x -5)) false)
442 (test-eval 'x -2)
443 (test-eval '(or false (set! x 25)) 'ok)
444 (test-eval 'x 25)
445 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
446 (test-eval 'x 2)
447 (test-eval '(or false (set! x 25) true false) 'ok)
448 (test-eval 'x 25)
449 (test-eval '(or ((lambda (x) x) 5)) 5)
450 (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
451 
452 
453 ;; cond
454 
455 (test-eval 
456  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
457 	(else false))
458  2)
459 
460 (test-eval
461  '(cond ((= 3 4) 'not-true)
462 	((= (* 2 4) 3) 'also-false)
463 	((map (lambda (x)
464 		(* x (+ x 1)))
465 	      '(2 4 1 9))
466 	 =>
467 	 (lambda (x)
468 	   (accumulate + 0 x)))
469 	(else 'never-reach))
470  118)
471 ;; '(6 20 2 90)
472 
473 
474 ;; procedure definition and application
475 (geval
476  '(define (factorial n)
477     (if (= n 0)
478 	1
479 	(* n (factorial (- n 1))))))
480 (test-eval '(factorial 5) 120)
481 
482 ;; map
483 
484 (test-eval
485  '(map (lambda (x)
486 	 (* x (+ x 1)))
487        '(2 1 4 2 8 3))
488  '(6 2 20 6 72 12))
489 ;; accumulate
490 
491 (test-eval
492  '(accumulate + 0 '(1 2 3 4 5))
493  15)
494 
495 ;; make-let
496 (test-eval 
497  (make-let '(x y) '(3 5) '((+ x y)))
498  8)
499 (test-eval 
500  '(let ()
501     5)
502  5)
503 (test-eval
504  '(let ((x 3))
505     x)
506  3)
507 (test-eval
508  '(let ((x 3)
509 	(y 5))
510     (+ x y))
511  8)
512 (test-eval 
513  '(let ((x 3)
514 	(y 2))
515     (+ (let ((x (+ y 2))
516 	     (y x))
517 	 (* x y))
518        x y))
519  (+ (* 4 3) 3 2))
520 (test-eval
521  '(let ((x 6)
522 	(y (let ((x 2))
523 	     (+ x 3)))
524 	(z (let ((a (* 3 2)))
525 	     (+ a 3))))
526     (+ x y z))
527  (+ 6 5 9))
528     
529 
530 ;; let*
531 
532 (test-eval
533  '(let* ((x 3)
534 	 (y (+ x 2))
535 	 (z (+ x y 5)))
536     (* x z))
537  39)
538 
539 (test-eval
540  '(let* ()
541     5)
542  5)
543 (test-eval
544  '(let* ((x 3))
545     (let* ((y 5))
546       (+ x y)))
547  8)
548 
549 (test-eval 
550  '(let* ((x 3)
551 	 (y (+ x 1)))
552     (+ (let* ((x (+ y 2))
553 	      (y x))
554 	 (* x y))
555        x y))
556  (+ (* 6 6) 3 4))
557 (test-eval
558  '(let* ((x 6)
559 	 (y (let* ((x 2)
560 		   (a (let* ((x (* 3 x)))
561 			(+ x 2))))       
562 	      (+ x a)))                  
563 	 (z (+ x y)))                    
564     (+ x y z))
565  32)
566 
567 ;; x = 6
568 ;; a = 8
569 ;; y = 10
570 ;; z = 16
571 ;; 32