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