1 ;; (define apply-in-underlying-scheme apply)
2 
3 (define (eval exp env)
4   (cond ((self-evaluating? exp) exp)
5         ((variable? exp) (lookup-variable-value exp env))
6         ((quoted? exp) (text-of-quotation exp))
7         ((assignment? exp) (eval-assignment exp env))
8         ((definition? exp) (eval-definition exp env))
9 ;;	((unbound? exp) (eval-unbound exp env))
10         ((if? exp) (eval-if exp env))
11 	((and? exp) (eval-and exp env))
12 	((or? exp) (eval-or exp env))
13         ((lambda? exp)
14          (make-procedure (lambda-parameters exp)
15                          (lambda-body exp)
16                          env))
17         ((begin? exp) 
18          (eval-sequence (begin-actions exp) env))
19         ((cond? exp) (eval (cond->if exp) env))
20 	((let? exp) (eval (let->combination exp) env))
21 	((let*? exp) (eval (let*->nested-lets exp) env))
22 	((named-let? exp) (eval (named-let->combination exp) env))
23 	((letrec? exp) (eval (letrec->let exp) env))
24 	((do? exp) (eval (do->combination exp) env))
25         ((application? exp)
26          (apply (eval (operator exp) env)
27                 (list-of-values (operands exp) env)))
28         (else
29          (error "Unknown expression type -- EVAL" exp))))
30 (define (apply procedure arguments)
31   (cond ((primitive-procedure? procedure)
32          (apply-primitive-procedure procedure arguments))
33         ((compound-procedure? procedure)
34          (eval-sequence
35            (procedure-body procedure)
36            (extend-environment
37              (procedure-parameters procedure)
38              arguments
39              (procedure-environment procedure))))
40         (else
41          (error
42           "Unknown procedure type -- APPLY" procedure))))
43 
44 (define (list-of-values exps env)
45   (if (no-operands? exps)
46       '()
47       (cons (eval (first-operand exps) env)
48             (list-of-values (rest-operands exps) env))))
49 
50 (define (tagged-list? exp tag)
51   (if (pair? exp)
52       (eq? (car exp) tag)
53       false))
54 
55 ;; self-evaluating/variable/quoted
56 (define (self-evaluating? exp)
57   (cond ((number? exp) true)
58         ((string? exp) true)
59         (else false)))
60 (define (variable? exp) (symbol? exp))
61 (define (quoted? exp)
62   (tagged-list? exp 'quote))
63 (define (text-of-quotation exp) (cadr exp))
64 
65 ;; assignment/definition
66 (define (assignment? exp)
67   (tagged-list? exp 'set!))
68 (define (assignment-variable exp) (cadr exp))
69 (define (assignment-value exp) (caddr exp))
70 (define (make-assignment var val)
71   (list 'set! var val))
72 (define (definition? exp)
73   (tagged-list? exp 'define))
74 (define (definition-variable exp)
75   (if (symbol? (cadr exp))
76       (cadr exp)
77       (caadr exp)))
78 (define (definition-value exp)
79   (if (symbol? (cadr exp))
80       (caddr exp)
81       (make-lambda (cdadr exp)   ; formal parameters
82                    (cddr exp)))) ; body
83 (define (eval-assignment exp env)
84   (set-variable-value! (assignment-variable exp)
85                        (eval (assignment-value exp) env)
86                        env)
87   'ok)
88 (define (eval-definition exp env)
89   (define-variable! (definition-variable exp)
90                     (eval (definition-value exp) env)
91                     env)
92   'ok)
93 (define (make-definition var val)
94   `(define ,var ,val))
95 
96 ;; make-unbound!
97 
98 ;; (define (unbound? exp)
99 ;;   (tagged-list? exp 'make-unbound!))
100 ;; (define (unbound-var exp)
101 ;;   (cadr exp))
102 ;; (define (eval-unbound exp env)
103 ;;   (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
104 
105 
106 
107 ;; if/and/or
108 (define (if? exp) (tagged-list? exp 'if))
109 (define (if-predicate exp) (cadr exp))
110 (define (if-consequent exp) (caddr exp))
111 (define (if-alternative exp)
112   (if (not (null? (cdddr exp)))
113       (cadddr exp)
114       'false))
115 (define (make-if predicate consequent alternative)
116   (list 'if predicate consequent alternative))
117 (define (eval-if exp env)
118   (if (true? (eval (if-predicate exp) env))
119       (eval (if-consequent exp) env)
120       (eval (if-alternative exp) env)))
121 
122 (define (and? exp)
123   (tagged-list? exp 'and))
124 (define (and-clauses exp)
125   (cdr exp))
126 (define (or? exp)
127   (tagged-list? exp 'or))
128 (define (or-clauses exp)
129   (cdr exp))
130 (define (eval-and exp env)
131   (define (eval-clauses clauses)
132     (cond ((null? clauses) true)
133 	  ((null? (cdr clauses)) (eval (car clauses) env))
134 	  (else (and (eval (car clauses) env)
135 		     (eval-clauses (cdr clauses))))))
136   (eval-clauses (and-clauses exp)))
137 (define (eval-or exp env)
138   (define (eval-clauses clauses)
139     (if (null? clauses)
140 	false
141 	(or (eval (car clauses) env)
142 	    (eval-clauses (cdr clauses)))))
143   (eval-clauses (or-clauses exp)))
144 
145 
146 ;; lambda/let/let*
147 (define (lambda? exp) (tagged-list? exp 'lambda))
148 (define (lambda-parameters exp) (cadr exp))
149 (define (lambda-body exp) (cddr exp))
150 (define (make-lambda parameters body)
151   (cons 'lambda (cons parameters body)))
152 
153 (define (make-let vars vals body)
154   (cons 'let
155 	(cons (map list vars vals)
156 	      body)))
157 (define (let? exp)
158   (and (tagged-list? exp 'let)
159        (not (symbol? (cadr exp)))))
160 (define (let-vars exp)
161   (map car (cadr exp)))
162 (define (let-vals exp)
163   (map cadr (cadr exp)))
164 (define (let-body exp)
165   (cddr exp))
166 (define (let->combination exp)
167   (make-application (make-lambda (let-vars exp) (let-body exp))
168 		    (let-vals exp)))
169 (define (named-let? exp)
170   (and (tagged-list? exp 'let)
171        (symbol? (cadr exp))))
172 (define (named-let-name exp)
173   (cadr exp))
174 (define (named-let-vars exp)
175   (map car (caddr exp)))
176 (define (named-let-vals exp)
177   (map cadr (caddr exp)))
178 (define (named-let-body exp)
179   (cdddr exp))
180 (define (named-let->combination exp)
181   (sequence->exp
182    (list (make-definition (named-let-name exp)
183 			  (make-lambda (named-let-vars exp)
184 				       (named-let-body exp)))
185 	 (make-application (named-let-name exp)
186 			   (named-let-vals exp)))))
187 (define (make-named-let name vars vals body)
188   (cons 'let 
189 	(cons name
190 	      (cons (map list vars vals)
191 		    body))))
192 
193 (define (make-application op args)
194   (cons op args))
195 
196 (define (let*? exp)
197   (tagged-list? exp 'let*))
198 (define let*-vars let-vars)
199 (define let*-vals let-vals)
200 (define let*-body let-body)
201 (define (let*->nested-lets exp)
202   (define (expand-lets vars vals)
203     (if (null? (cdr vars))
204 	(make-let (list (car vars)) 
205 		  (list (car vals))
206 		  (let*-body exp))
207 	(make-let (list (car vars))
208 		  (list (car vals))
209 		  (list (expand-lets (cdr vars) (cdr vals))))))
210   (let ((vars (let*-vars exp))
211 	(vals (let*-vals exp)))
212     (if (null? vars)
213 	(sequence->exp (let*-body exp))
214 	(expand-lets vars vals))))
215 
216 ;; do loop
217 (define (do? exp)
218   (tagged-list? exp 'do))
219 (define (do-vars exp)
220   (map car (cadr exp)))
221 (define (do-inits exp)
222   (map cadr (cadr exp)))
223 (define (do-steps exp)
224   (map (lambda (var-init-step)
225 	 (if (null? (cddr var-init-step))
226 	     (car var-init-step)
227 	     (caddr var-init-step)))
228        (cadr exp)))
229 (define (do-test exp)
230   (caaddr exp))
231 (define (do-expressions exp)
232   (if (null? (cdaddr exp))
233       (caddr exp)
234       (cdaddr exp)))
235 (define (do-commands exp)
236   (cdddr exp))
237 (define (do->combination exp)
238   (make-named-let
239    'do-iter
240    (do-vars exp)
241    (do-inits exp)
242    (list
243     (make-if
244      (do-test exp)
245      (sequence->exp (do-expressions exp))
246      (sequence->exp
247       (append (do-commands exp)
248 	      (list (make-application
249 		     'do-iter
250 		     (do-steps exp)))))))))
251 
252 
253 ;; begin/sequence
254 (define (begin? exp) (tagged-list? exp 'begin))
255 (define (begin-actions exp) (cdr exp))
256 (define (last-exp? seq) (null? (cdr seq)))
257 (define (first-exp seq) (car seq))
258 (define (rest-exps seq) (cdr seq))
259 (define (sequence->exp seq)
260   (cond ((null? seq) seq)
261         ((last-exp? seq) (first-exp seq))
262         (else (make-begin seq))))
263 (define (make-begin seq) (cons 'begin seq))
264 (define (eval-sequence exps env)
265   (cond ((last-exp? exps) (eval (first-exp exps) env))
266         (else (eval (first-exp exps) env)
267               (eval-sequence (rest-exps exps) env))))
268 
269 ;; application
270 (define (application? exp) (pair? exp))
271 (define (operator exp) (car exp))
272 (define (operands exp) (cdr exp))
273 (define (no-operands? ops) (null? ops))
274 (define (first-operand ops) (car ops))
275 (define (rest-operands ops) (cdr ops))
276 
277 ;; cond
278 (define (cond? exp) (tagged-list? exp 'cond))
279 (define (cond-clauses exp) (cdr exp))
280 (define (cond-else-clause? clause)
281   (eq? (cond-predicate clause) 'else))
282 (define (cond-predicate clause) (car clause))
283 (define (cond-actions clause) (cdr clause))
284 (define (cond-extended-clause? clause)
285   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
286 (define (cond-extended-proc clause)
287   (caddr clause))
288 (define (cond->if exp)
289   (expand-clauses (cond-clauses exp)))
290 (define (expand-clauses clauses)
291   (if (null? clauses)
292       'false                          ; no else clause
293       (let ((first (car clauses))
294             (rest (cdr clauses)))
295         (if (cond-else-clause? first)
296             (if (null? rest)
297                 (sequence->exp (cond-actions first))
298                 (error "ELSE clause isn't last -- COND->IF"
299                        clauses))
300 	    (if (cond-extended-clause? first)
301 		(make-if (cond-predicate first)
302 			 (make-application
303 			  (cond-extended-proc first)
304 			  (list (cond-predicate first)))
305 			 (expand-clauses rest))
306 		(make-if (cond-predicate first)
307 			 (sequence->exp (cond-actions first))
308 			 (expand-clauses rest)))))))
309 (define (true? x)
310   (not (eq? x false)))
311 (define (false? x)
312   (eq? x false))
313 
314 ;; procedure
315 (define (make-procedure parameters body env)
316   (list 'procedure parameters (scan-out-defines body) env))
317 (define (scan-out-defines body)
318   (let* ((definitions (filter definition? body))
319 	 (vars (map definition-variable definitions))
320 	 (unassigneds (map (lambda (var) ''*unassigned*) 
321 			   vars))
322 	 (vals (map definition-value definitions))
323 	 (assignments 
324 	  (map (lambda (var val)
325 		 (make-assignment var val))
326 	       vars vals))
327 	 (exps (remove definition? body)))
328     (if (null? definitions)
329 	body
330 	(list
331 	 (make-let vars
332 		   unassigneds
333 		   (append assignments exps))))))
334 (define (compound-procedure? p)
335   (tagged-list? p 'procedure))
336 (define (procedure-parameters p) (cadr p))
337 (define (procedure-body p) (caddr p))
338 (define (procedure-environment p) (cadddr p))
339 
340 ;; environment
341 (define (enclosing-environment env) (cdr env))
342 (define (first-frame env) (car env))
343 (define the-empty-environment '())
344 (define (make-frame variables values)
345   (cons variables values))
346 (define (frame-variables frame) (car frame))
347 (define (frame-values frame) (cdr frame))
348 (define (add-binding-to-frame! var val frame)
349   (set-car! frame (cons var (car frame)))
350   (set-cdr! frame (cons val (cdr frame))))
351 (define (extend-environment vars vals base-env)
352   (if (= (length vars) (length vals))
353       (cons (make-frame vars vals) base-env)
354       (if (< (length vars) (length vals))
355           (error "Too many arguments supplied" vars vals)
356           (error "Too few arguments supplied" vars vals))))
357 (define (lookup-variable-value var env)
358   (define (env-loop env)
359     (define (scan vars vals)
360       (cond ((null? vars)
361              (env-loop (enclosing-environment env)))
362             ((eq? var (car vars))
363 	     (let ((val (car vals)))
364 	       (if (eq? val '*unassigned*)
365 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
366 		   val)))
367             (else (scan (cdr vars) (cdr vals)))))
368     (if (eq? env the-empty-environment)
369         (error "Unbound variable" var)
370         (let ((frame (first-frame env)))
371           (scan (frame-variables frame)
372                 (frame-values frame)))))
373   (env-loop env))
374 (define (set-variable-value! var val env)
375   (define (env-loop env)
376     (define (scan vars vals)
377       (cond ((null? vars)
378              (env-loop (enclosing-environment env)))
379             ((eq? var (car vars))
380              (set-car! vals val))
381             (else (scan (cdr vars) (cdr vals)))))
382     (if (eq? env the-empty-environment)
383         (error "Unbound variable -- SET!" var)
384         (let ((frame (first-frame env)))
385           (scan (frame-variables frame)
386                 (frame-values frame)))))
387   (env-loop env))
388 (define (define-variable! var val env)
389   (let ((frame (first-frame env)))
390     (define (scan vars vals)
391       (cond ((null? vars)
392              (add-binding-to-frame! var val frame))
393             ((eq? var (car vars))
394              (set-car! vals val))
395             (else (scan (cdr vars) (cdr vals)))))
396     (scan (frame-variables frame)
397           (frame-values frame))))
398 
399 (define (remove-binding-from-frame! var frame)
400   (define (scan vars vals)
401     (cond ((null? (cdr vars))
402 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
403 	  ((eq? var (cadr vars))
404 	   (set-cdr! vars (cddr vars))
405 	   (set-cdr! vals (cddr vals)))
406 	  (else (scan (cdr vars) (cdr vals)))))
407   (let ((vars (frame-variables frame))
408 	(vals (frame-values frame)))
409     (if (eq? var (car vars))
410 	(begin (set-car! frame (cdr vars))
411 	       (set-cdr! frame (cdr vals)))
412 	(scan vars vals))))
413 
414 ;; primitives
415 (define (primitive-procedure? proc)
416   (tagged-list? proc 'primitive))
417 (define (primitive-implementation proc) (cadr proc))
418 (define primitive-procedures
419   (list (list 'car car)
420         (list 'cdr cdr)
421 	(list 'caar caar)
422 	(list 'cadr cadr)
423 	(list 'cddr cddr)
424         (list 'cons cons)
425         (list 'null? null?)
426 	(list '* *)
427 	(list '/ /)
428 	(list '+ +)
429 	(list '- -)
430 	(list '= =)
431 	(list '< <)
432 	(list '> >)
433 	(list '<= <=)
434 	(list '>= >=)
435 	(list 'remainder remainder)
436 	(list 'eq? eq?)
437 	(list 'equal? equal?)
438 	(list 'display display)))
439 (define (primitive-procedure-names)
440   (map car
441        primitive-procedures))
442 (define (primitive-procedure-objects)
443   (map (lambda (proc) (list 'primitive (cadr proc)))
444        primitive-procedures))
445 (define (apply-primitive-procedure proc args)
446   (apply-in-underlying-scheme
447    (primitive-implementation proc) args))
448 
449 ;; driver-loop
450 (define input-prompt ";;; M-Eval input:")
451 (define output-prompt ";;; M-Eval value:")
452 (define (driver-loop)
453   (prompt-for-input input-prompt)
454   (let ((input (read)))
455     (let ((output (eval input the-global-environment)))
456       (announce-output output-prompt)
457       (user-print output)))
458   (driver-loop))
459 (define (prompt-for-input string)
460   (newline) (newline) (display string) (newline))
461 
462 (define (announce-output string)
463   (newline) (display string) (newline))
464 (define (user-print object)
465   (if (compound-procedure? object)
466       (display (list 'compound-procedure
467                      (procedure-parameters object)
468                      (procedure-body object)
469                      '<procedure-env>))
470       (display object)))
471 (define (setup-environment)
472   (let ((initial-env
473          (extend-environment (primitive-procedure-names)
474                              (primitive-procedure-objects)
475                              the-empty-environment)))
476     (define-variable! 'true true initial-env)
477     (define-variable! 'false false initial-env)
478     initial-env))
479 (define the-global-environment (setup-environment))
480 
481 ;; auxiliary
482 (define (test-case actual expected)
483   (newline)
484   (display "Actual:   ")
485   (display actual)
486   (newline)
487   (display "Expected: ")
488   (display expected)
489   (newline))
490 (define (geval exp) ;; eval globally
491   (eval exp the-global-environment))
492 (define (test-eval exp expected)
493   (test-case (geval exp) expected))
494 
495 
496 
497 ;; Exercise 4.20.  Because internal definitions look sequential but are actually simultaneous, some people prefer to avoid them entirely, and use the special form letrec instead. Letrec looks like let, so it is not surprising that the variables it binds are bound simultaneously and have the same scope as each other. The sample procedure f above can be written without internal definitions, but with exactly the same meaning, as
498 
499 ;; (define (f x)
500 ;;   (letrec ((even?
501 ;;             (lambda (n)
502 ;;               (if (= n 0)
503 ;;                   true
504 ;;                   (odd? (- n 1)))))
505 ;;            (odd?
506 ;;             (lambda (n)
507 ;;               (if (= n 0)
508 ;;                   false
509 ;;                   (even? (- n 1))))))
510 ;;     <rest of body of f>))
511 
512 ;; Letrec expressions, which have the form
513 
514 ;; (letrec ((<var1> <exp1>) ... (<varn> <expn>))
515 ;;   <body>)
516 
517 ;; are a variation on let in which the expressions <expk> that provide the initial values for the variables <vark> are evaluated in an environment that includes all the letrec bindings. This permits recursion in the bindings, such as the mutual recursion of even? and odd? in the example above, or the evaluation of 10 factorial with
518 
519 ;; (letrec ((fact
520 ;;           (lambda (n)
521 ;;             (if (= n 1)
522 ;;                 1
523 ;;                 (* n (fact (- n 1)))))))
524 ;;   (fact 10))
525 
526 
527 ;; a. Implement letrec as a derived expression, by transforming a letrec expression into a let expression as shown in the text above or in exercise 4.18. That is, the letrec variables should be created with a let and then be assigned their values with set!.
528 
529 ;; the two definitions above can be transformed to the following
530 
531 ;; (let ((fact '*unassigned*))
532 ;;   (set! fact (lambda (n)
533 ;; 	       (if (= n 1)
534 ;; 		   1
535 ;; 		   (* n (fact (- n 1))))))
536 ;;   (fact 10))
537 
538 ;; (define (f x)
539 ;;   (let ((even? '*unassigned*)
540 ;; 	(odd? '*unassigned*))
541 ;;     (set! even? (lambda (n)
542 ;; 		  (if (= n 0)
543 ;; 		      true
544 ;; 		      (odd? (- n 1)))))
545 ;;     (set! odd? (lambda (n)
546 ;; 		 (if (= n 0)
547 ;; 		     false
548 ;; 		     (even? (- n 1)))))
549 ;;     <rest of body of f>))
550 
551 (define (letrec? exp)
552   (tagged-list? exp 'letrec))
553 
554 (define (letrec-vars exp)
555   (map car (cadr exp)))
556 (define (letrec-vals exp)
557   (map cadr (cadr exp)))
558 (define (letrec-body exp)
559   (cddr exp))
560 (define (letrec->let exp)
561   (let* ((vars (letrec-vars exp))
562 	 (unassigneds (map (lambda (var) ''*unassigned*)
563 			   vars))
564 	 (vals (letrec-vals exp))
565 	 (assignments (map (lambda (var val)
566 			     (make-assignment var val))
567 			   vars
568 			   vals))
569 	 (body (letrec-body exp)))
570   (make-let vars 
571 	    unassigneds
572 	    (append assignments body))))
573 
574 
575 
576 
577 ;; b. Louis Reasoner is confused by all this fuss about internal definitions. The way he sees it, if you don't like to use define inside a procedure, you can just use let. Illustrate what is loose about his reasoning by drawing an environment diagram that shows the environment in which the <rest of body of f> is evaluated during evaluation of the expression (f 5), with f defined as in this exercise. Draw an environment diagram for the same evaluation, but with let in place of letrec in the definition of f. 
578 
579 
580 
581 
582 
583 
584 
585 ;; test-suite
586 
587 ;; procedure definitions
588 
589 (geval 
590  '(define (assoc key records)
591     (cond ((null? records) false)
592 	  ((equal? key (caar records)) (car records))
593 	  (else (assoc key (cdr records))))))
594 
595 (geval
596  '(define (map proc list)
597     (if (null? list)
598 	'()
599 	(cons (proc (car list))
600 	      (map proc (cdr list))))))
601 
602 (geval 
603  '(define (accumulate op initial sequence)
604     (if (null? sequence)
605 	initial
606 	(op (car sequence)
607 	    (accumulate op initial (cdr sequence))))))
608 
609 ;; all special forms
610 (test-eval '(begin 5 6) 6)
611 (test-eval '10 10)
612 (geval '(define x 3))
613 (test-eval 'x 3)
614 (test-eval '(set! x -25) 'ok)
615 (test-eval 'x -25)
616 (geval '(define z (lambda (x y) (+ x (* x y)))))
617 (test-eval '(z 3 4) 15)
618 (test-eval '(cond ((= x -2) 'x=-2)
619 		  ((= x -25) 'x=-25)
620 		  (else 'failed))
621 	   'x=-25)
622 (test-eval '(if true false true) false)
623 (test-eval 
624  '(let ((x 4) (y 7))
625     (+ x y (* x y)))
626  (+ 4 7 (* 4 7)))
627 
628 
629 ;; and/or
630 (geval '(define x (+ 3 8)))
631 (test-eval '(and 0 true x) 11)
632 (test-eval '(and 0 true x false) false)
633 (test-eval '(and 0 true x (set! x -2) false) false)
634 (test-eval 'x -2)
635 (test-eval '(and 0 true x false (set! x -5)) false)
636 (test-eval 'x -2)
637 (test-eval '(or false (set! x 25)) 'ok)
638 (test-eval 'x 25)
639 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
640 (test-eval 'x 2)
641 (test-eval '(or false (set! x 25) true false) 'ok)
642 (test-eval 'x 25)
643 (test-eval '(or ((lambda (x) x) 5)) 5)
644 (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
645 
646 
647 ;; cond
648 
649 (test-eval 
650  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
651 	(else false))
652  2)
653 
654 (test-eval
655  '(cond ((= 3 4) 'not-true)
656 	((= (* 2 4) 3) 'also-false)
657 	((map (lambda (x)
658 		(* x (+ x 1)))
659 	      '(2 4 1 9))
660 	 =>
661 	 (lambda (x)
662 	   (accumulate + 0 x)))
663 	(else 'never-reach))
664  118)
665 ;; '(6 20 2 90)
666 
667 
668 ;; procedure definition and application
669 (geval
670  '(define (factorial n)
671     (if (= n 0)
672 	1
673 	(* n (factorial (- n 1))))))
674 (test-eval '(factorial 5) 120)
675 
676 ;; map
677 
678 (test-eval
679  '(map (lambda (x)
680 	 (* x (+ x 1)))
681        '(2 1 4 2 8 3))
682  '(6 2 20 6 72 12))
683 ;; accumulate
684 
685 (test-eval
686  '(accumulate + 0 '(1 2 3 4 5))
687  15)
688 
689 ;; make-let
690 (test-eval 
691  (make-let '(x y) '(3 5) '((+ x y)))
692  8)
693 (test-eval 
694  '(let ()
695     5)
696  5)
697 (test-eval
698  '(let ((x 3))
699     x)
700  3)
701 (test-eval
702  '(let ((x 3)
703 	(y 5))
704     (+ x y))
705  8)
706 (test-eval 
707  '(let ((x 3)
708 	(y 2))
709     (+ (let ((x (+ y 2))
710 	     (y x))
711 	 (* x y))
712        x y))
713  (+ (* 4 3) 3 2))
714 (test-eval
715  '(let ((x 6)
716 	(y (let ((x 2))
717 	     (+ x 3)))
718 	(z (let ((a (* 3 2)))
719 	     (+ a 3))))
720     (+ x y z))
721  (+ 6 5 9))
722     
723 
724 ;; let*
725 
726 (test-eval
727  '(let* ((x 3)
728 	 (y (+ x 2))
729 	 (z (+ x y 5)))
730     (* x z))
731  39)
732 
733 (test-eval
734  '(let* ()
735     5)
736  5)
737 (test-eval
738  '(let* ((x 3))
739     (let* ((y 5))
740       (+ x y)))
741  8)
742 
743 (test-eval 
744  '(let* ((x 3)
745 	 (y (+ x 1)))
746     (+ (let* ((x (+ y 2))
747 	      (y x))
748 	 (* x y))
749        x y))
750  (+ (* 6 6) 3 4))
751 (test-eval
752  '(let* ((x 6)
753 	 (y (let* ((x 2)
754 		   (a (let* ((x (* 3 x)))
755 			(+ x 2))))       
756 	      (+ x a)))                  
757 	 (z (+ x y)))                    
758     (+ x y z))
759  32)
760 
761 ;; named-let
762 
763 (test-eval
764  '(let eight ()
765     5
766     7
767     8)
768  8)
769 (test-eval
770  '(let loop ((count 0))
771     (if (= 100 count)
772 	count
773 	(loop (+ count 1))))
774  100)
775 (geval
776  '(define (prime? x)
777     (let prime-iter ((i 2))
778       (cond ((> (* i i) x) true)
779 	    ((= (remainder x i) 0) false)
780 	    (else (prime-iter (+ i 1)))))))
781 (test-eval
782  '(let primes ((x 2)
783 	       (n 20))
784     (cond ((= n 0) '())
785 	  ((prime? x) 
786 	   (cons x
787 		 (primes (+ x 1) (- n 1))))
788 	  (else (primes (+ x 1) n))))
789  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
790 
791 (geval
792  '(define (fib n)
793     (let fib-iter ((a 1)
794 		   (b 0)
795 		   (count n))
796       (if (= count 0)
797 	  b
798 	  (fib-iter (+ a b) a (- count 1))))))
799 (test-eval '(fib 19) 4181)
800 
801 ;; do-loop	  
802 (test-eval
803  '(let ((y 0))
804     (do ((x 0 (+ x 1)))
805 	((= x 5) y)
806       (set! y (+ y 1))))
807  5)
808 (test-eval
809  '(do ()
810       (true))
811  true)
812 (test-eval
813  '(do ()
814       (true 5))
815  5)
816 (test-eval
817  '(let ((y 0))
818     (do ()
819 	((= y 5) y)
820       (set! y (+ y 1))))
821  5)
822 
823 (test-eval
824  '(do ((y '(1 2 3 4)))
825       ((null? y))
826     (set! y (cdr y)))
827  true)
828 (test-eval
829  '(let ((y 0))
830     (do ((x 0 (+ x 1)))
831 	((= x 5) y)
832       (set! y (+ y 1))))
833  5)
834 (test-eval
835  '(let ((x '(1 3 5 7 9)))
836     (do ((x x (cdr x))
837 	 (sum 0 (+ sum (car x))))
838 	((null? x) sum)))
839  25)
840 (test-eval 
841  '(let ((z '()))
842     (do ((x '(1 2 3 4) (cdr x))
843 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
844 	((null? x) y x z)
845       (set! z (cons (car x) z))))
846  '(4 3 2 1))
847 
848 
849 
850 ;; make-unbound!
851 ;; broken now due to scan-out-defines
852 
853 ;; (test-eval
854 ;;  '(let ((x 3))
855 ;;     (let ((x 5))
856 ;;       (make-unbound! x)
857 ;;       (* x x)))
858 ;;  9)
859 
860 ;; (test-eval
861 ;;  '(let ((x 3))
862 ;;     (let ((x 5))
863 ;;       (define y x)
864 ;;       (make-unbound! x)
865 ;;       (* y x)))
866 ;;  15)
867 
868 ;; (test-eval
869 ;;  '(let ((y -1) (x 3))
870 ;;     (let ((y 0.5) (x 5))
871 ;;       (define a x)
872 ;;       (define b y)
873 ;;       (make-unbound! x)
874 ;;       (make-unbound! y)
875 ;;       (* a b x y)))
876 ;;  (* 5 3 -1 0.5))
877 
878 ;; (test-eval
879 ;;  '(let ((x 3) (y 4))
880 ;;     (let ((x 5))
881 ;;       (make-unbound! x)
882 ;;       (+ x 4)))
883 ;;  7)
884 
885 ;; (test-eval 
886 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
887 ;;     (make-unbound! b)
888 ;;     (+ a c d))
889 ;;  (+ 1 3 4))
890 
891 ;; (test-eval
892 ;;  '(let ((x 4) (y 5))
893 ;;     (let ((a 1) (b 2) (c 3))
894 ;;       (let ((x (+ a b)) (y (+ c a)))
895 ;; 	(make-unbound! x)
896 ;; 	(let ((a x) (b (+ x y)))
897 ;; 	  (define z b)
898 ;; 	  (make-unbound! b)
899 ;; 	  (* (+ a z)
900 ;; 	     (+ a b y))))))
901 ;;  (* (+ 4 8)
902 ;;     (+ 4 2 4)))
903  
904 ;; x 3 -- y 4
905 ;; x 4 -- y 4
906 ;; a 4 -- b 4
907 ;; a 4 -- b 2
908 
909 ;; scan-out-defines
910 
911 (geval
912  '(define (f x)
913     (define (even? n)
914       (if (= n 0)
915 	  true
916 	  (odd? (- n 1))))
917     (define (odd? n)
918       (if (= n 0)
919 	  false
920 	  (even? (- n 1))))
921     (even? x)))
922 (test-eval '(f 5) false)
923 (test-eval '(f 10) true)
924 
925 ;; (geval
926 ;;  '(let ((x 5))
927 ;;     (define y x)
928 ;;     (define x 3)
929 ;;     (+ x y)))
930 ;; signal an error because x is undefined if variables are scanned out
931 
932 ;; letrec
933 
934 (geval
935  '(define (f x)
936     (letrec ((even?
937 	      (lambda (n)
938 		(if (= n 0)
939 		    true
940 		    (odd? (- n 1)))))
941 	     (odd?
942 	      (lambda (n)
943 		(if (= n 0)
944 		    false
945 		    (even? (- n 1))))))
946       (even? x))))
947 (test-eval '(f 11) false)
948 (test-eval '(f 16) true)
949 
950 (test-eval 
951  '(letrec ((fact
952 	    (lambda (n)
953 	      (if (= n 1)
954 		  1
955 		  (* n (fact (- n 1)))))))
956     (fact 10))
957  3628800)