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