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