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