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