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-args 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-args exps env)
80   (if (no-operands? exps)
81       '()
82       (cons (delay-it (first-operand exps) env)
83 	    (list-of-delayed-args (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 (let*? exp)
255   (tagged-list? exp 'let*))
256 (define let*-vars let-vars)
257 (define let*-vals let-vals)
258 (define let*-body let-body)
259 (define (let*->nested-lets exp)
260   (define (expand-lets vars vals)
261     (if (null? (cdr vars))
262 	(make-let (list (car vars)) 
263 		  (list (car vals))
264 		  (let*-body exp))
265 	(make-let (list (car vars))
266 		  (list (car vals))
267 		  (list (expand-lets (cdr vars) (cdr vals))))))
268   (let ((vars (let*-vars exp))
269 	(vals (let*-vals exp)))
270     (if (null? vars)
271 	(sequence->exp (let*-body exp))
272 	(expand-lets vars vals))))
273 
274 ;; do loop
275 (define (do? exp)
276   (tagged-list? exp 'do))
277 (define (do-vars exp)
278   (map car (cadr exp)))
279 (define (do-inits exp)
280   (map cadr (cadr exp)))
281 (define (do-steps exp)
282   (map (lambda (var-init-step)
283 	 (if (null? (cddr var-init-step))
284 	     (car var-init-step)
285 	     (caddr var-init-step)))
286        (cadr exp)))
287 (define (do-test exp)
288   (caaddr exp))
289 (define (do-expressions exp)
290   (if (null? (cdaddr exp))
291       (caddr exp)
292       (cdaddr exp)))
293 (define (do-commands exp)
294   (cdddr exp))
295 (define (do->combination exp)
296   (make-named-let
297    'do-iter
298    (do-vars exp)
299    (do-inits exp)
300    (list
301     (make-if
302      (do-test exp)
303      (sequence->exp (do-expressions exp))
304      (sequence->exp
305       (append (do-commands exp)
306 	      (list (make-application
307 		     'do-iter
308 		     (do-steps exp)))))))))
309 
310 
311 ;; begin/sequence
312 (define (begin? exp) (tagged-list? exp 'begin))
313 (define (begin-actions exp) (cdr exp))
314 (define (last-exp? seq) (null? (cdr seq)))
315 (define (first-exp seq) (car seq))
316 (define (rest-exps seq) (cdr seq))
317 (define (sequence->exp seq)
318   (cond ((null? seq) seq)
319         ((last-exp? seq) (first-exp seq))
320         (else (make-begin seq))))
321 (define (make-begin seq) (cons 'begin seq))
322 (define (eval-sequence exps env)
323   (cond ((last-exp? exps) (eval (first-exp exps) env))
324         (else (eval (first-exp exps) env)
325               (eval-sequence (rest-exps exps) env))))
326 
327 ;; application
328 (define (make-application op args)
329   (cons op args))
330 (define (application? exp) (pair? exp))
331 (define (operator exp) (car exp))
332 (define (operands exp) (cdr exp))
333 (define (no-operands? ops) (null? ops))
334 (define (first-operand ops) (car ops))
335 (define (rest-operands ops) (cdr ops))
336 
337 ;; cond
338 (define (cond? exp) (tagged-list? exp 'cond))
339 (define (cond-clauses exp) (cdr exp))
340 (define (cond-else-clause? clause)
341   (eq? (cond-predicate clause) 'else))
342 (define (cond-predicate clause) (car clause))
343 (define (cond-actions clause) (cdr clause))
344 (define (cond-extended-clause? clause)
345   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
346 (define (cond-extended-proc clause)
347   (caddr clause))
348 (define (cond->if exp)
349   (expand-clauses (cond-clauses exp)))
350 (define (expand-clauses clauses)
351   (if (null? clauses)
352       'false                          ; no else clause
353       (let ((first (car clauses))
354             (rest (cdr clauses)))
355         (if (cond-else-clause? first)
356             (if (null? rest)
357                 (sequence->exp (cond-actions first))
358                 (error "ELSE clause isn't last -- COND->IF"
359                        clauses))
360 	    (if (cond-extended-clause? first)
361 		(make-if (cond-predicate first)
362 			 (make-application
363 			  (cond-extended-proc first)
364 			  (list (cond-predicate first)))
365 			 (expand-clauses rest))
366 		(make-if (cond-predicate first)
367 			 (sequence->exp (cond-actions first))
368 			 (expand-clauses rest)))))))
369 (define (true? x)
370   (not (eq? x false)))
371 (define (false? x)
372   (eq? x false))
373 
374 ;; procedure
375 (define (make-procedure parameters body env)
376   (list 'procedure parameters body env))
377 ;; (define (scan-out-defines body)
378 ;;   (let* ((definitions (filter definition? body))
379 ;; 	 (vars (map definition-variable definitions))
380 ;; 	 (unassigneds (map (lambda (var) ''*unassigned*) 
381 ;; 			   vars))
382 ;; 	 (vals (map definition-value definitions))
383 ;; 	 (assignments 
384 ;; 	  (map (lambda (var val)
385 ;; 		 (make-assignment var val))
386 ;; 	       vars vals))
387 ;; 	 (exps (remove definition? body)))
388 ;;     (if (null? definitions)
389 ;; 	body
390 ;; 	(list
391 ;; 	 (make-let vars
392 ;; 		   unassigneds
393 ;; 		   (append assignments exps))))))
394 (define (compound-procedure? p)
395   (tagged-list? p 'procedure))
396 (define (procedure-parameters p) (cadr p))
397 (define (procedure-body p) (caddr p))
398 (define (procedure-environment p) (cadddr p))
399 
400 ;; environment
401 (define (enclosing-environment env) (cdr env))
402 (define (first-frame env) (car env))
403 (define the-empty-environment '())
404 (define (make-frame variables values)
405   (cons variables values))
406 (define (frame-variables frame) (car frame))
407 (define (frame-values frame) (cdr frame))
408 (define (add-binding-to-frame! var val frame)
409   (set-car! frame (cons var (car frame)))
410   (set-cdr! frame (cons val (cdr frame))))
411 (define (extend-environment vars vals base-env)
412   (if (= (length vars) (length vals))
413       (cons (make-frame vars vals) base-env)
414       (if (< (length vars) (length vals))
415           (error "Too many arguments supplied" vars vals)
416           (error "Too few arguments supplied" vars vals))))
417 (define (lookup-variable-value var env)
418   (define (env-loop env)
419     (define (scan vars vals)
420       (cond ((null? vars)
421              (env-loop (enclosing-environment env)))
422             ((eq? var (car vars))
423 	     (let ((val (car vals)))
424 	       (if (eq? val '*unassigned*)
425 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
426 		   val)))
427             (else (scan (cdr vars) (cdr vals)))))
428     (if (eq? env the-empty-environment)
429         (error "Unbound variable" var)
430         (let ((frame (first-frame env)))
431           (scan (frame-variables frame)
432                 (frame-values frame)))))
433   (env-loop env))
434 (define (set-variable-value! var val env)
435   (define (env-loop env)
436     (define (scan vars vals)
437       (cond ((null? vars)
438              (env-loop (enclosing-environment env)))
439             ((eq? var (car vars))
440              (set-car! vals val))
441             (else (scan (cdr vars) (cdr vals)))))
442     (if (eq? env the-empty-environment)
443         (error "Unbound variable -- SET!" var)
444         (let ((frame (first-frame env)))
445           (scan (frame-variables frame)
446                 (frame-values frame)))))
447   (env-loop env))
448 (define (define-variable! var val env)
449   (let ((frame (first-frame env)))
450     (define (scan vars vals)
451       (cond ((null? vars)
452              (add-binding-to-frame! var val frame))
453             ((eq? var (car vars))
454              (set-car! vals val))
455             (else (scan (cdr vars) (cdr vals)))))
456     (scan (frame-variables frame)
457           (frame-values frame))))
458 
459 (define (remove-binding-from-frame! var frame)
460   (define (scan vars vals)
461     (cond ((null? (cdr vars))
462 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
463 	  ((eq? var (cadr vars))
464 	   (set-cdr! vars (cddr vars))
465 	   (set-cdr! vals (cddr vals)))
466 	  (else (scan (cdr vars) (cdr vals)))))
467   (let ((vars (frame-variables frame))
468 	(vals (frame-values frame)))
469     (if (eq? var (car vars))
470 	(begin (set-car! frame (cdr vars))
471 	       (set-cdr! frame (cdr vals)))
472 	(scan vars vals))))
473 
474 ;; primitives
475 (define (primitive-procedure? proc)
476   (tagged-list? proc 'primitive))
477 (define (primitive-implementation proc) (cadr proc))
478 (define primitive-procedures
479   (list (list 'car car)
480         (list 'cdr cdr)
481 	(list 'caar caar)
482 	(list 'cadr cadr)
483 	(list 'cddr cddr)
484         (list 'cons cons)
485         (list 'null? null?)
486 	(list '* *)
487 	(list '/ /)
488 	(list '+ +)
489 	(list '- -)
490 	(list '= =)
491 	(list '< <)
492 	(list '> >)
493 	(list '<= <=)
494 	(list '>= >=)
495 	(list 'remainder remainder)
496 	(list 'eq? eq?)
497 	(list 'equal? equal?)
498 	(list 'display display)))
499 (define (primitive-procedure-names)
500   (map car
501        primitive-procedures))
502 (define (primitive-procedure-objects)
503   (map (lambda (proc) (list 'primitive (cadr proc)))
504        primitive-procedures))
505 (define (apply-primitive-procedure proc args)
506   (apply-in-underlying-scheme
507    (primitive-implementation proc) args))
508 
509 ;; driver-loop
510 (define input-prompt ";;; M-Eval input:")
511 (define output-prompt ";;; M-Eval value:")
512 (define (driver-loop)
513   (prompt-for-input input-prompt)
514   (let ((input (read)))
515     (let ((output (actual-value input the-global-environment)))
516       (announce-output output-prompt)
517       (user-print output)))
518   (driver-loop))
519 (define (prompt-for-input string)
520   (newline) (newline) (display string) (newline))
521 
522 (define (announce-output string)
523   (newline) (display string) (newline))
524 (define (user-print object)
525   (if (compound-procedure? object)
526       (display (list 'compound-procedure
527                      (procedure-parameters object)
528                      (procedure-body object)
529                      '<procedure-env>))
530       (display object)))
531 (define (setup-environment)
532   (let ((initial-env
533          (extend-environment (primitive-procedure-names)
534                              (primitive-procedure-objects)
535                              the-empty-environment)))
536     (define-variable! 'true true initial-env)
537     (define-variable! 'false false initial-env)
538     initial-env))
539 (define the-global-environment (setup-environment))
540 
541 ;; auxiliary
542 (define (test-case actual expected)
543   (newline)
544   (display "Actual:   ")
545   (display actual)
546   (newline)
547   (display "Expected: ")
548   (display expected)
549   (newline))
550 (define (geval exp) ;; eval globally
551   (eval exp the-global-environment))
552 (define (test-eval exp expected)
553   (test-case (force-it (geval exp)) expected))
554 
555 
556 ;; cons/car/cdr
557 
558 (geval 
559  '(define (cons x y)
560     (lambda (m) (m x y))))
561 (geval
562  '(define (car z)
563     (z (lambda (p q) p))))
564 (geval
565  '(define (cdr z)
566     (z (lambda (p q) q))))
567 (geval
568  '(define (list-ref items n)
569     (if (= n 0)
570 	(car items)
571 	(list-ref (cdr items) (- n 1)))))
572 (geval
573  '(define (map proc items)
574     (if (null? items)
575 	'()
576 	(cons (proc (car items))
577 	      (map proc (cdr items))))))
578 (geval
579  '(define (scale-list items factor)
580     (map (lambda (x) (* x factor))
581 	 items)))
582 (geval
583  '(define (add-lists list1 list2)
584     (cond ((null? list1) list2)
585 	  ((null? list2) list1)
586 	  (else (cons (+ (car list1) (car list2))
587 		      (add-lists (cdr list1) (cdr list2)))))))
588 (geval 
589  '(define ones (cons 1 ones)))
590 (geval
591  '(define integers (cons 1 (add-lists ones integers))))
592 (test-eval 
593  '(list-ref integers 17)
594  18)
595 
596 (geval
597  '(define (integral integrand initial-value dt)
598     (define int
599       (cons initial-value
600 	    (add-lists (scale-list integrand dt)
601 		       int)))
602     int))
603 (geval
604  '(define (solve f y0 dt)
605     (define y (integral dy y0 dt))
606     (define dy (map f y))
607     y))
608 (test-eval 
609  '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
610  2.716924)
611 ;; test-suite
612 
613 ;; procedure definitions
614 
615 (geval 
616  '(define (assoc key records)
617     (cond ((null? records) false)
618 	  ((equal? key (caar records)) (car records))
619 	  (else (assoc key (cdr records))))))
620 
621 (geval
622  '(define (map proc list)
623     (if (null? list)
624 	'()
625 	(cons (proc (car list))
626 	      (map proc (cdr list))))))
627 
628 (geval 
629  '(define (accumulate op initial sequence)
630     (if (null? sequence)
631 	initial
632 	(op (car sequence)
633 	    (accumulate op initial (cdr sequence))))))
634 
635 ;; all special forms
636 (test-eval '(begin 5 6) 6)
637 (test-eval '10 10)
638 (geval '(define x 3))
639 (test-eval 'x 3)
640 (test-eval '(set! x -25) 'ok)
641 (test-eval 'x -25)
642 (geval '(define z (lambda (x y) (+ x (* x y)))))
643 (test-eval '(z 3 4) 15)
644 (test-eval '(cond ((= x -2) 'x=-2)
645 		  ((= x -25) 'x=-25)
646 		  (else 'failed))
647 	   'x=-25)
648 (test-eval '(if true false true) false)
649 
650 (test-eval 
651  '(let ((x 4) (y 7))
652     (+ x y (* x y)))
653  (+ 4 7 (* 4 7)))
654 
655 
656 ;; and/or
657 (geval '(define x (+ 3 8)))
658 (test-eval '(and 0 true x) 11)
659 (test-eval '(and 0 true x false) false)
660 (test-eval '(and 0 true x (set! x -2) false) false)
661 (test-eval 'x -2)
662 (test-eval '(and 0 true x false (set! x -5)) false)
663 (test-eval 'x -2)
664 (test-eval '(or false (set! x 25)) 'ok)
665 (test-eval 'x 25)
666 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
667 (test-eval 'x 2)
668 (test-eval '(or false (set! x 25) true false) 'ok)
669 (test-eval 'x 25)
670 (test-eval '(or ((lambda (x) x) 5)) 5)
671 (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
672 
673 
674 ;; cond
675 
676 (test-eval 
677  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
678 	(else false))
679  2)
680 
681 (test-eval
682  '(cond ((= 3 4) 'not-true)
683 	((= (* 2 4) 3) 'also-false)
684 	((map (lambda (x)
685 		(* x (+ x 1)))
686 	      '(2 4 1 9))
687 	 =>
688 	 (lambda (x)
689 	   (accumulate + 0 x)))
690 	(else 'never-reach))
691  118)
692 ;; '(6 20 2 90)
693 
694 
695 ;; procedure definition and application
696 (geval
697  '(define (factorial n)
698     (if (= n 0)
699 	1
700 	(* n (factorial (- n 1))))))
701 (test-eval '(factorial 5) 120)
702 
703 ;; map
704 
705 (test-eval
706  '(map (lambda (x)
707 	 (* x (+ x 1)))
708        '(2 1 4 2 8 3))
709  '(6 2 20 6 72 12))
710 ;; accumulate
711 
712 (test-eval
713  '(accumulate + 0 '(1 2 3 4 5))
714  15)
715 
716 ;; make-let
717 (test-eval 
718  (make-let '(x y) '(3 5) '((+ x y)))
719  8)
720 (test-eval 
721  '(let ()
722     5)
723  5)
724 (test-eval
725  '(let ((x 3))
726     x)
727  3)
728 (test-eval
729  '(let ((x 3)
730 	(y 5))
731     (+ x y))
732  8)
733 (test-eval 
734  '(let ((x 3)
735 	(y 2))
736     (+ (let ((x (+ y 2))
737 	     (y x))
738 	 (* x y))
739        x y))
740  (+ (* 4 3) 3 2))
741 (test-eval
742  '(let ((x 6)
743 	(y (let ((x 2))
744 	     (+ x 3)))
745 	(z (let ((a (* 3 2)))
746 	     (+ a 3))))
747     (+ x y z))
748  (+ 6 5 9))
749     
750 
751 ;; let*
752 
753 (test-eval
754  '(let* ((x 3)
755 	 (y (+ x 2))
756 	 (z (+ x y 5)))
757     (* x z))
758  39)
759 
760 (test-eval
761  '(let* ()
762     5)
763  5)
764 (test-eval
765  '(let* ((x 3))
766     (let* ((y 5))
767       (+ x y)))
768  8)
769 
770 (test-eval 
771  '(let* ((x 3)
772 	 (y (+ x 1)))
773     (+ (let* ((x (+ y 2))
774 	      (y x))
775 	 (* x y))
776        x y))
777  (+ (* 6 6) 3 4))
778 (test-eval
779  '(let* ((x 6)
780 	 (y (let* ((x 2)
781 		   (a (let* ((x (* 3 x)))
782 			(+ x 2))))       
783 	      (+ x a)))                  
784 	 (z (+ x y)))                    
785     (+ x y z))
786  32)
787 
788 ;; named-let
789 
790 (test-eval
791  '(let eight ()
792     5
793     7
794     8)
795  8)
796 (test-eval
797  '(let loop ((count 0))
798     (if (= 100 count)
799 	count
800 	(loop (+ count 1))))
801  100)
802 (geval
803  '(define (prime? x)
804     (let prime-iter ((i 2))
805       (cond ((> (* i i) x) true)
806 	    ((= (remainder x i) 0) false)
807 	    (else (prime-iter (+ i 1)))))))
808 (test-eval
809  '(let primes ((x 2)
810 	       (n 20))
811     (cond ((= n 0) '())
812 	  ((prime? x) 
813 	   (cons x
814 		 (primes (+ x 1) (- n 1))))
815 	  (else (primes (+ x 1) n))))
816  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
817 
818 (geval
819  '(define (fib n)
820     (let fib-iter ((a 1)
821 		   (b 0)
822 		   (count n))
823       (if (= count 0)
824 	  b
825 	  (fib-iter (+ a b) a (- count 1))))))
826 (test-eval '(fib 19) 4181)
827 
828 ;; do-loop	  
829 (test-eval
830  '(let ((y 0))
831     (do ((x 0 (+ x 1)))
832 	((= x 5) y)
833       (set! y (+ y 1))))
834  5)
835 (test-eval
836  '(do ()
837       (true))
838  true)
839 (test-eval
840  '(do ()
841       (true 5))
842  5)
843 (test-eval
844  '(let ((y 0))
845     (do ()
846 	((= y 5) y)
847       (set! y (+ y 1))))
848  5)
849 
850 (test-eval
851  '(do ((y '(1 2 3 4)))
852       ((null? y))
853     (set! y (cdr y)))
854  true)
855 (test-eval
856  '(let ((y 0))
857     (do ((x 0 (+ x 1)))
858 	((= x 5) y)
859       (set! y (+ y 1))))
860  5)
861 (test-eval
862  '(let ((x '(1 3 5 7 9)))
863     (do ((x x (cdr x))
864 	 (sum 0 (+ sum (car x))))
865 	((null? x) sum)))
866  25)
867 (test-eval 
868  '(let ((z '()))
869     (do ((x '(1 2 3 4) (cdr x))
870 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
871 	((null? x) y x z)
872       (set! z (cons (car x) z))))
873  '(4 3 2 1))
874 
875 
876 
877 ;; make-unbound!
878 ;; broken now due to scan-out-defines
879 
880 ;; (test-eval
881 ;;  '(let ((x 3))
882 ;;     (let ((x 5))
883 ;;       (make-unbound! x)
884 ;;       (* x x)))
885 ;;  9)
886 
887 ;; (test-eval
888 ;;  '(let ((x 3))
889 ;;     (let ((x 5))
890 ;;       (define y x)
891 ;;       (make-unbound! x)
892 ;;       (* y x)))
893 ;;  15)
894 
895 ;; (test-eval
896 ;;  '(let ((y -1) (x 3))
897 ;;     (let ((y 0.5) (x 5))
898 ;;       (define a x)
899 ;;       (define b y)
900 ;;       (make-unbound! x)
901 ;;       (make-unbound! y)
902 ;;       (* a b x y)))
903 ;;  (* 5 3 -1 0.5))
904 
905 ;; (test-eval
906 ;;  '(let ((x 3) (y 4))
907 ;;     (let ((x 5))
908 ;;       (make-unbound! x)
909 ;;       (+ x 4)))
910 ;;  7)
911 
912 ;; (test-eval 
913 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
914 ;;     (make-unbound! b)
915 ;;     (+ a c d))
916 ;;  (+ 1 3 4))
917 
918 ;; (test-eval
919 ;;  '(let ((x 4) (y 5))
920 ;;     (let ((a 1) (b 2) (c 3))
921 ;;       (let ((x (+ a b)) (y (+ c a)))
922 ;; 	(make-unbound! x)
923 ;; 	(let ((a x) (b (+ x y)))
924 ;; 	  (define z b)
925 ;; 	  (make-unbound! b)
926 ;; 	  (* (+ a z)
927 ;; 	     (+ a b y))))))
928 ;;  (* (+ 4 8)
929 ;;     (+ 4 2 4)))
930  
931 ;; x 3 -- y 4
932 ;; x 4 -- y 4
933 ;; a 4 -- b 4
934 ;; a 4 -- b 2
935 
936 ;; scan-out-defines
937 
938 (geval
939  '(define (f x)
940     (define (even? n)
941       (if (= n 0)
942 	  true
943 	  (odd? (- n 1))))
944     (define (odd? n)
945       (if (= n 0)
946 	  false
947 	  (even? (- n 1))))
948     (even? x)))
949 (test-eval '(f 5) false)
950 (test-eval '(f 10) true)
951 
952 ;; (geval
953 ;;  '(let ((x 5))
954 ;;     (define y x)
955 ;;     (define x 3)
956 ;;     (+ x y)))
957 ;; signal an error because x is undefined if variables are scanned out
958 
959 ;; letrec
960 
961 (geval
962  '(define (f x)
963     (letrec ((even?
964 	      (lambda (n)
965 		(if (= n 0)
966 		    true
967 		    (odd? (- n 1)))))
968 	     (odd?
969 	      (lambda (n)
970 		(if (= n 0)
971 		    false
972 		    (even? (- n 1))))))
973       (even? x))))
974 (test-eval '(f 11) false)
975 (test-eval '(f 16) true)
976 
977 (test-eval 
978  '(letrec ((fact
979 	    (lambda (n)
980 	      (if (= n 1)
981 		  1
982 		  (* n (fact (- n 1)))))))
983     (fact 10))
984  3628800)
985 
986 
987 ;; delayed-evaluation
988 
989 (geval
990  '(define (try a b)
991     (if (= a 0) 1 b)))
992 (test-eval '(try 0 (/ 1 0)) 1)
993 
994 (geval 
995  '(define (unless condition usual-value exceptional-value)
996     (if condition exceptional-value usual-value)))
997 (test-eval
998  '(let ((a 4) (b 0))
999     (unless (= b 0)
1000             (/ a b)
1001 	    (begin (display "exception: returning 0")
1002 		   0)))
1003  0)
1004 (test-eval
1005   '(let ((a 4) (b 2))
1006     (unless (= b 0)
1007             (/ a b)
1008 	    (begin (display "exception: returning 0")
1009 		   0)))
1010   2)
1011 
1012 (geval
1013  '(define (factorial n)
1014     (unless (= n 1)
1015             (* n (factorial (- n 1)))
1016 	    1)))
1017 (test-eval
1018  '(factorial 8)
1019  40320)
1020 
1021 (geval '(define count 0))
1022 (geval '(define (id x)
1023 	  (set! count (+ count 1))
1024 	  x))
1025 
1026 (geval '(define w (id (id 10))))
1027 (test-eval 'count 1)
1028 (test-eval 'w 10)
1029 (test-eval 'count 2)
1030 (test-eval
1031  '(let ((f (lambda (x) (+ x 1))))
1032     (f 1))
1033  2)
1034 (geval '(define count 0))
1035 (geval '(define (id x)
1036 	  (set! count (+ count 1))
1037 	  x))
1038 (geval 
1039  '(define (square x)
1040     (* x x)))
1041 (test-eval 
1042  '(square (id 10))
1043  100)
1044 (test-eval 'count 1)
1045 ;; would be 2 without memoization