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