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 
42 	      (procedure-parameters-directives procedure)
43 	      arguments
44 	      env)
45              (procedure-environment procedure))))
46         (else
47          (error
48           "Unknown procedure type -- APPLY" procedure))))
49 
50 (define (thunk? obj)
51   (tagged-list? obj 'thunk))
52 (define (thunk-exp thunk)
53   (cadr thunk))
54 (define (thunk-env thunk)
55   (caddr thunk))
56 (define (evaluated-thunk? obj)
57   (tagged-list? obj 'evaluated-thunk))
58 (define (thunk-value evaluated-thunk)
59   (cadr evaluated-thunk))
60 (define (simple-thunk? obj)
61   (tagged-list? obj 'simple-thunk))
62 (define (simple-delay-it exp env)
63   `(simple-thunk ,exp ,env))
64 (define (delay-it exp env)
65   `(thunk ,exp ,env))
66 (define (actual-value exp env)
67   (force-it (eval exp env)))
68 (define (force-it obj)
69   (cond ((thunk? obj)
70 	 (let ((result (actual-value 
71 			(thunk-exp obj)
72 			(thunk-env obj))))
73 	   (set-car! obj 'evaluated-thunk)
74 	   (set-car! (cdr obj) result)
75 	   (set-cdr! (cdr obj) '())
76 	   result))
77 	((evaluated-thunk? obj)
78 	 (thunk-value obj))
79 	((simple-thunk? obj)
80 	 (actual-value (thunk-exp obj)
81 		       (thunk-env obj)))
82 	(else obj)))
83 
84 (define (list-of-arg-values exps env)
85   (if (no-operands? exps)
86       '()
87       (cons (actual-value (first-operand exps) env)
88             (list-of-arg-values (rest-operands exps) env))))
89 (define (list-of-delayed-args directives exps env)
90   (if (no-operands? exps)
91       '()
92       (let* ((directive (car directives))
93 	     (op (first-operand exps))
94 	     (arg (cond ((eq? directive 'strict)
95 			 (eval op env))
96 			((eq? directive 'lazy)
97 			 (simple-delay-it op env))
98 			((eq? directive 'lazy-memo)
99 			 (delay-it op env))
100 			(else 
101 			 (error "Unknown directive " directive)))))
102 	(cons arg
103 	      (list-of-delayed-args
104 	       (cdr directives)
105 	       (cdr exps)
106 	       env)))))
107 
108 
109 (define (tagged-list? exp tag)
110   (if (pair? exp)
111       (eq? (car exp) tag)
112       false))
113 
114 ;; self-evaluating/variable/quoted
115 (define (self-evaluating? exp)
116   (cond ((number? exp) true)
117         ((string? exp) true)
118         (else false)))
119 (define (variable? exp) (symbol? exp))
120 (define (quoted? exp)
121   (tagged-list? exp 'quote))
122 (define (text-of-quotation exp) (cadr exp))
123 
124 ;; assignment/definition
125 (define (assignment? exp)
126   (tagged-list? exp 'set!))
127 (define (assignment-variable exp) (cadr exp))
128 (define (assignment-value exp) (caddr exp))
129 (define (make-assignment var val)
130   (list 'set! var val))
131 (define (definition? exp)
132   (tagged-list? exp 'define))
133 (define (definition-variable exp)
134   (if (symbol? (cadr exp))
135       (cadr exp)
136       (caadr exp)))
137 (define (definition-value exp)
138   (if (symbol? (cadr exp))
139       (caddr exp)
140       (make-lambda (cdadr exp)   ; formal parameters
141                    (cddr exp)))) ; body
142 (define (eval-assignment exp env)
143   (set-variable-value! (assignment-variable exp)
144                        (eval (assignment-value exp) env)
145                        env)
146   'ok)
147 (define (eval-definition exp env)
148   (define-variable! (definition-variable exp)
149                     (eval (definition-value exp) env)
150                     env)
151   'ok)
152 (define (make-definition var val)
153   `(define ,var ,val))
154 
155 ;; make-unbound!
156 
157 ;; (define (unbound? exp)
158 ;;   (tagged-list? exp 'make-unbound!))
159 ;; (define (unbound-var exp)
160 ;;   (cadr exp))
161 ;; (define (eval-unbound exp env)
162 ;;   (remove-binding-from-frame! (unbound-var exp) (first-frame env)))
163 
164 
165 
166 ;; if/and/or
167 (define (if? exp) (tagged-list? exp 'if))
168 (define (if-predicate exp) (cadr exp))
169 (define (if-consequent exp) (caddr exp))
170 (define (if-alternative exp)
171   (if (not (null? (cdddr exp)))
172       (cadddr exp)
173       'false))
174 (define (make-if predicate consequent alternative)
175   (list 'if predicate consequent alternative))
176 (define (eval-if exp env)
177   (if (true? (actual-value (if-predicate exp) env))
178       (eval (if-consequent exp) env)
179       (eval (if-alternative exp) env)))
180 
181 (define (and? exp)
182   (tagged-list? exp 'and))
183 (define (and-clauses exp)
184   (cdr exp))
185 (define (or? exp)
186   (tagged-list? exp 'or))
187 (define (or-clauses exp)
188   (cdr exp))
189 (define (eval-and exp env)
190   (define (eval-clauses clauses)
191     (cond ((null? clauses) true)
192 	  ((null? (cdr clauses)) (eval (car clauses) env))
193 	  (else (and (eval (car clauses) env)
194 		     (eval-clauses (cdr clauses))))))
195   (eval-clauses (and-clauses exp)))
196 (define (eval-or exp env)
197   (define (eval-clauses clauses)
198     (if (null? clauses)
199 	false
200 	(or (eval (car clauses) env)
201 	    (eval-clauses (cdr clauses)))))
202   (eval-clauses (or-clauses exp)))
203 
204 
205 ;; lambda/let/let*/letrec
206 (define (lambda? exp) (tagged-list? exp 'lambda))
207 (define (lambda-parameters exp) (cadr exp))
208 (define (lambda-body exp) (cddr exp))
209 (define (make-lambda parameters body)
210   (cons 'lambda (cons parameters body)))
211 
212 (define (make-let vars vals body)
213   (cons 'let
214 	(cons (map list vars vals)
215 	      body)))
216 (define (let? exp)
217   (and (tagged-list? exp 'let)
218        (not (symbol? (cadr exp)))))
219 (define (let-vars exp)
220   (map car (cadr exp)))
221 (define (let-vals exp)
222   (map cadr (cadr exp)))
223 (define (let-body exp)
224   (cddr exp))
225 (define (let->combination exp)
226   (make-application (make-lambda (let-vars exp) (let-body exp))
227 		    (let-vals exp)))
228 (define (named-let? exp)
229   (and (tagged-list? exp 'let)
230        (symbol? (cadr exp))))
231 (define (named-let-name exp)
232   (cadr exp))
233 (define (named-let-vars exp)
234   (map car (caddr exp)))
235 (define (named-let-vals exp)
236   (map cadr (caddr exp)))
237 (define (named-let-body exp)
238   (cdddr exp))
239 (define (named-let->combination exp)
240   (sequence->exp
241    (list (make-definition (named-let-name exp)
242 			  (make-lambda (named-let-vars exp)
243 				       (named-let-body exp)))
244 	 (make-application (named-let-name exp)
245 			   (named-let-vals exp)))))
246 (define (make-named-let name vars vals body)
247   (cons 'let 
248 	(cons name
249 	      (cons (map list vars vals)
250 		    body))))
251 
252 (define (letrec? exp)
253   (tagged-list? exp 'letrec))
254 
255 (define (letrec-vars exp)
256   (map car (cadr exp)))
257 (define (letrec-vals exp)
258   (map cadr (cadr exp)))
259 (define (letrec-body exp)
260   (cddr exp))
261 (define (letrec->let exp)
262   (let* ((vars (letrec-vars exp))
263 	 (unassigneds (map (lambda (var) ''*unassigned*)
264 			   vars))
265 	 (vals (letrec-vals exp))
266 	 (assignments (map (lambda (var val)
267 			     (make-assignment var val))
268 			   vars
269 			   vals))
270 	 (body (letrec-body exp)))
271   (make-let vars 
272 	    unassigneds
273 	    (append assignments body))))
274 
275 
276 
277 
278 (define (let*? exp)
279   (tagged-list? exp 'let*))
280 (define let*-vars let-vars)
281 (define let*-vals let-vals)
282 (define let*-body let-body)
283 (define (let*->nested-lets exp)
284   (define (expand-lets vars vals)
285     (if (null? (cdr vars))
286 	(make-let (list (car vars)) 
287 		  (list (car vals))
288 		  (let*-body exp))
289 	(make-let (list (car vars))
290 		  (list (car vals))
291 		  (list (expand-lets (cdr vars) (cdr vals))))))
292   (let ((vars (let*-vars exp))
293 	(vals (let*-vals exp)))
294     (if (null? vars)
295 	(sequence->exp (let*-body exp))
296 	(expand-lets vars vals))))
297 
298 ;; do loop
299 (define (do? exp)
300   (tagged-list? exp 'do))
301 (define (do-vars exp)
302   (map car (cadr exp)))
303 (define (do-inits exp)
304   (map cadr (cadr exp)))
305 (define (do-steps exp)
306   (map (lambda (var-init-step)
307 	 (if (null? (cddr var-init-step))
308 	     (car var-init-step)
309 	     (caddr var-init-step)))
310        (cadr exp)))
311 (define (do-test exp)
312   (caaddr exp))
313 (define (do-expressions exp)
314   (if (null? (cdaddr exp))
315       (caddr exp)
316       (cdaddr exp)))
317 (define (do-commands exp)
318   (cdddr exp))
319 (define (do->combination exp)
320   (make-named-let
321    'do-iter
322    (do-vars exp)
323    (do-inits exp)
324    (list
325     (make-if
326      (do-test exp)
327      (sequence->exp (do-expressions exp))
328      (sequence->exp
329       (append (do-commands exp)
330 	      (list (make-application
331 		     'do-iter
332 		     (do-steps exp)))))))))
333 
334 
335 ;; begin/sequence
336 (define (begin? exp) (tagged-list? exp 'begin))
337 (define (begin-actions exp) (cdr exp))
338 (define (last-exp? seq) (null? (cdr seq)))
339 (define (first-exp seq) (car seq))
340 (define (rest-exps seq) (cdr seq))
341 (define (sequence->exp seq)
342   (cond ((null? seq) seq)
343         ((last-exp? seq) (first-exp seq))
344         (else (make-begin seq))))
345 (define (make-begin seq) (cons 'begin seq))
346 (define (eval-sequence exps env)
347   (cond ((last-exp? exps) (eval (first-exp exps) env))
348         (else (eval (first-exp exps) env)
349               (eval-sequence (rest-exps exps) env))))
350 
351 ;; application
352 (define (make-application op args)
353   (cons op args))
354 (define (application? exp) (pair? exp))
355 (define (operator exp) (car exp))
356 (define (operands exp) (cdr exp))
357 (define (no-operands? ops) (null? ops))
358 (define (first-operand ops) (car ops))
359 (define (rest-operands ops) (cdr ops))
360 
361 ;; cond
362 (define (cond? exp) (tagged-list? exp 'cond))
363 (define (cond-clauses exp) (cdr exp))
364 (define (cond-else-clause? clause)
365   (eq? (cond-predicate clause) 'else))
366 (define (cond-predicate clause) (car clause))
367 (define (cond-actions clause) (cdr clause))
368 (define (cond-extended-clause? clause)
369   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
370 (define (cond-extended-proc clause)
371   (caddr clause))
372 (define (cond->if exp)
373   (expand-clauses (cond-clauses exp)))
374 (define (expand-clauses clauses)
375   (if (null? clauses)
376       'false                          ; no else clause
377       (let ((first (car clauses))
378             (rest (cdr clauses)))
379         (if (cond-else-clause? first)
380             (if (null? rest)
381                 (sequence->exp (cond-actions first))
382                 (error "ELSE clause isn't last -- COND->IF"
383                        clauses))
384 	    (if (cond-extended-clause? first)
385 		(make-if (cond-predicate first)
386 			 (make-application
387 			  (cond-extended-proc first)
388 			  (list (cond-predicate first)))
389 			 (expand-clauses rest))
390 		(make-if (cond-predicate first)
391 			 (sequence->exp (cond-actions first))
392 			 (expand-clauses rest)))))))
393 (define (true? x)
394   (not (eq? x false)))
395 (define (false? x)
396   (eq? x false))
397 
398 ;; procedure
399 (define (make-procedure parameters body env)
400   (list 'procedure parameters body env))
401 ;; (define (scan-out-defines body)
402 ;;   (let* ((definitions (filter definition? body))
403 ;; 	 (vars (map definition-variable definitions))
404 ;; 	 (unassigneds (map (lambda (var) ''*unassigned*) 
405 ;; 			   vars))
406 ;; 	 (vals (map definition-value definitions))
407 ;; 	 (assignments 
408 ;; 	  (map (lambda (var val)
409 ;; 		 (make-assignment var val))
410 ;; 	       vars vals))
411 ;; 	 (exps (remove definition? body)))
412 ;;     (if (null? definitions)
413 ;; 	body
414 ;; 	(list
415 ;; 	 (make-let vars
416 ;; 		   unassigneds
417 ;; 		   (append assignments exps))))))
418 (define (compound-procedure? p)
419   (tagged-list? p 'procedure))
420 ;; (define (procedure-parameters p) (cadr p))
421 (define (procedure-parameters p) 
422   (map (lambda (param)
423 	 (if (symbol? param)
424 	     param
425 	     (car param)))
426        (cadr p)))
427 (define (procedure-parameters-directives p)
428   (map (lambda (param)
429 	 (if (symbol? param)
430 	     'strict
431 	     (cadr param)))
432        (cadr p)))
433 (define (procedure-body p) (caddr p))
434 (define (procedure-environment p) (cadddr p))
435 
436 ;; environment
437 (define (enclosing-environment env) (cdr env))
438 (define (first-frame env) (car env))
439 (define the-empty-environment '())
440 (define (make-frame variables values)
441   (cons variables values))
442 (define (frame-variables frame) (car frame))
443 (define (frame-values frame) (cdr frame))
444 (define (add-binding-to-frame! var val frame)
445   (set-car! frame (cons var (car frame)))
446   (set-cdr! frame (cons val (cdr frame))))
447 (define (extend-environment vars vals base-env)
448   (if (= (length vars) (length vals))
449       (cons (make-frame vars vals) base-env)
450       (if (< (length vars) (length vals))
451           (error "Too many arguments supplied" vars vals)
452           (error "Too few arguments supplied" vars vals))))
453 (define (lookup-variable-value var env)
454   (define (env-loop env)
455     (define (scan vars vals)
456       (cond ((null? vars)
457              (env-loop (enclosing-environment env)))
458             ((eq? var (car vars))
459 	     (let ((val (car vals)))
460 	       (if (eq? val '*unassigned*)
461 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
462 		   val)))
463             (else (scan (cdr vars) (cdr vals)))))
464     (if (eq? env the-empty-environment)
465         (error "Unbound variable" var)
466         (let ((frame (first-frame env)))
467           (scan (frame-variables frame)
468                 (frame-values frame)))))
469   (env-loop env))
470 (define (set-variable-value! var val env)
471   (define (env-loop env)
472     (define (scan vars vals)
473       (cond ((null? vars)
474              (env-loop (enclosing-environment env)))
475             ((eq? var (car vars))
476              (set-car! vals val))
477             (else (scan (cdr vars) (cdr vals)))))
478     (if (eq? env the-empty-environment)
479         (error "Unbound variable -- SET!" var)
480         (let ((frame (first-frame env)))
481           (scan (frame-variables frame)
482                 (frame-values frame)))))
483   (env-loop env))
484 (define (define-variable! var val env)
485   (let ((frame (first-frame env)))
486     (define (scan vars vals)
487       (cond ((null? vars)
488              (add-binding-to-frame! var val frame))
489             ((eq? var (car vars))
490              (set-car! vals val))
491             (else (scan (cdr vars) (cdr vals)))))
492     (scan (frame-variables frame)
493           (frame-values frame))))
494 
495 (define (remove-binding-from-frame! var frame)
496   (define (scan vars vals)
497     (cond ((null? (cdr vars))
498 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
499 	  ((eq? var (cadr vars))
500 	   (set-cdr! vars (cddr vars))
501 	   (set-cdr! vals (cddr vals)))
502 	  (else (scan (cdr vars) (cdr vals)))))
503   (let ((vars (frame-variables frame))
504 	(vals (frame-values frame)))
505     (if (eq? var (car vars))
506 	(begin (set-car! frame (cdr vars))
507 	       (set-cdr! frame (cdr vals)))
508 	(scan vars vals))))
509 
510 ;; primitives
511 (define (primitive-procedure? proc)
512   (tagged-list? proc 'primitive))
513 (define (primitive-implementation proc) (cadr proc))
514 (define primitive-procedures
515   (list (list 'car car)
516         (list 'cdr cdr)
517 	(list 'caar caar)
518 	(list 'cadr cadr)
519 	(list 'cddr cddr)
520         (list 'cons cons)
521         (list 'null? null?)
522 	(list '* *)
523 	(list '/ /)
524 	(list '+ +)
525 	(list '- -)
526 	(list '= =)
527 	(list '< <)
528 	(list '> >)
529 	(list '<= <=)
530 	(list '>= >=)
531 	(list 'remainder remainder)
532 	(list 'eq? eq?)
533 	(list 'equal? equal?)
534 	(list 'display display)))
535 (define (primitive-procedure-names)
536   (map car
537        primitive-procedures))
538 (define (primitive-procedure-objects)
539   (map (lambda (proc) (list 'primitive (cadr proc)))
540        primitive-procedures))
541 (define (apply-primitive-procedure proc args)
542   (apply-in-underlying-scheme
543    (primitive-implementation proc) args))
544 
545 ;; driver-loop
546 (define input-prompt ";;; M-Eval input:")
547 (define output-prompt ";;; M-Eval value:")
548 (define (driver-loop)
549   (prompt-for-input input-prompt)
550   (let ((input (read)))
551     (let ((output (actual-value input the-global-environment)))
552       (announce-output output-prompt)
553       (user-print output)))
554   (driver-loop))
555 (define (prompt-for-input string)
556   (newline) (newline) (display string) (newline))
557 
558 (define (announce-output string)
559   (newline) (display string) (newline))
560 (define (user-print object)
561   (if (compound-procedure? object)
562       (display (list 'compound-procedure
563                      (procedure-parameters object)
564                      (procedure-body object)
565                      '<procedure-env>))
566       (display object)))
567 (define (setup-environment)
568   (let ((initial-env
569          (extend-environment (primitive-procedure-names)
570                              (primitive-procedure-objects)
571                              the-empty-environment)))
572     (define-variable! 'true true initial-env)
573     (define-variable! 'false false initial-env)
574     initial-env))
575 (define the-global-environment (setup-environment))
576 
577 ;; auxiliary
578 (define (test-case actual expected)
579   (newline)
580   (display "Actual:   ")
581   (display actual)
582   (newline)
583   (display "Expected: ")
584   (display expected)
585   (newline))
586 (define (geval exp) ;; eval globally
587   (eval exp the-global-environment))
588 (define (test-eval exp expected)
589   (test-case (force-it (geval exp)) expected))
590 
591 ;; Exercise 4.31.  The approach taken in this section is somewhat unpleasant, because it makes a3n incompatible change to Scheme. It might be nicer to implement lazy evaluation as an upward-compatible extension, that is, so that ordinary Scheme programs will work as before. We can do this by extending the syntax of procedure declarations to let the user control whether or not arguments are to be delayed. While we're at it, we may as well also give the user the choice between delaying with and without memoization. For example, the definition
592 
593 ;; (define (f a (b lazy) c (d lazy-memo))
594 ;;   ...)
595 
596 ;; would define f to be a procedure of four arguments, where the first and third arguments are evaluated when the procedure is called, the second argument is delayed, and the fourth argument is both delayed and memoized. Thus, ordinary procedure definitions will produce the same behavior as ordinary Scheme, while adding the lazy-memo declaration to each parameter of every compound procedure will produce the behavior of the lazy evaluator defined in this section. Design and implement the changes required to produce such an extension to Scheme. You will have to implement new syntax procedures to handle the new syntax for define. You must also arrange for eval or apply to determine when arguments are to be delayed, and to force or delay arguments accordingly, and you must arrange for forcing to memoize or not, as appropriate. 
597 
598 
599 
600 ;; test-suite
601 
602 ;; procedure definitions
603 
604 (geval 
605  '(define (assoc key records)
606     (cond ((null? records) false)
607 	  ((equal? key (caar records)) (car records))
608 	  (else (assoc key (cdr records))))))
609 
610 (geval
611  '(define (map proc list)
612     (if (null? list)
613 	'()
614 	(cons (proc (car list))
615 	      (map proc (cdr list))))))
616 
617 (geval 
618  '(define (accumulate op initial sequence)
619     (if (null? sequence)
620 	initial
621 	(op (car sequence)
622 	    (accumulate op initial (cdr sequence))))))
623 
624 ;; all special forms
625 (test-eval '(begin 5 6) 6)
626 (test-eval '10 10)
627 (geval '(define x 3))
628 (test-eval 'x 3)
629 (test-eval '(set! x -25) 'ok)
630 (test-eval 'x -25)
631 (geval '(define z (lambda (x y) (+ x (* x y)))))
632 (test-eval '(z 3 4) 15)
633 (test-eval '(cond ((= x -2) 'x=-2)
634 		  ((= x -25) 'x=-25)
635 		  (else 'failed))
636 	   'x=-25)
637 (test-eval '(if true false true) false)
638 
639 (test-eval 
640  '(let ((x 4) (y 7))
641     (+ x y (* x y)))
642  (+ 4 7 (* 4 7)))
643 
644 
645 ;; and/or
646 (geval '(define x (+ 3 8)))
647 (test-eval '(and 0 true x) 11)
648 (test-eval '(and 0 true x false) false)
649 (test-eval '(and 0 true x (set! x -2) false) false)
650 (test-eval 'x -2)
651 (test-eval '(and 0 true x false (set! x -5)) false)
652 (test-eval 'x -2)
653 (test-eval '(or false (set! x 25)) 'ok)
654 (test-eval 'x 25)
655 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
656 (test-eval 'x 2)
657 (test-eval '(or false (set! x 25) true false) 'ok)
658 (test-eval 'x 25)
659 (test-eval '(or ((lambda (x) x) 5)) 5)
660 (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
661 
662 
663 ;; cond
664 
665 (test-eval 
666  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
667 	(else false))
668  2)
669 
670 (test-eval
671  '(cond ((= 3 4) 'not-true)
672 	((= (* 2 4) 3) 'also-false)
673 	((map (lambda (x)
674 		(* x (+ x 1)))
675 	      '(2 4 1 9))
676 	 =>
677 	 (lambda (x)
678 	   (accumulate + 0 x)))
679 	(else 'never-reach))
680  118)
681 ;; '(6 20 2 90)
682 
683 
684 ;; procedure definition and application
685 (geval
686  '(define (factorial n)
687     (if (= n 0)
688 	1
689 	(* n (factorial (- n 1))))))
690 (test-eval '(factorial 5) 120)
691 
692 ;; map
693 
694 (test-eval
695  '(map (lambda (x)
696 	 (* x (+ x 1)))
697        '(2 1 4 2 8 3))
698  '(6 2 20 6 72 12))
699 ;; accumulate
700 
701 (test-eval
702  '(accumulate + 0 '(1 2 3 4 5))
703  15)
704 
705 ;; make-let
706 (test-eval 
707  (make-let '(x y) '(3 5) '((+ x y)))
708  8)
709 (test-eval 
710  '(let ()
711     5)
712  5)
713 (test-eval
714  '(let ((x 3))
715     x)
716  3)
717 (test-eval
718  '(let ((x 3)
719 	(y 5))
720     (+ x y))
721  8)
722 (test-eval 
723  '(let ((x 3)
724 	(y 2))
725     (+ (let ((x (+ y 2))
726 	     (y x))
727 	 (* x y))
728        x y))
729  (+ (* 4 3) 3 2))
730 (test-eval
731  '(let ((x 6)
732 	(y (let ((x 2))
733 	     (+ x 3)))
734 	(z (let ((a (* 3 2)))
735 	     (+ a 3))))
736     (+ x y z))
737  (+ 6 5 9))
738     
739 
740 ;; let*
741 
742 (test-eval
743  '(let* ((x 3)
744 	 (y (+ x 2))
745 	 (z (+ x y 5)))
746     (* x z))
747  39)
748 
749 (test-eval
750  '(let* ()
751     5)
752  5)
753 (test-eval
754  '(let* ((x 3))
755     (let* ((y 5))
756       (+ x y)))
757  8)
758 
759 (test-eval 
760  '(let* ((x 3)
761 	 (y (+ x 1)))
762     (+ (let* ((x (+ y 2))
763 	      (y x))
764 	 (* x y))
765        x y))
766  (+ (* 6 6) 3 4))
767 (test-eval
768  '(let* ((x 6)
769 	 (y (let* ((x 2)
770 		   (a (let* ((x (* 3 x)))
771 			(+ x 2))))       
772 	      (+ x a)))                  
773 	 (z (+ x y)))                    
774     (+ x y z))
775  32)
776 
777 ;; named-let
778 
779 (test-eval
780  '(let eight ()
781     5
782     7
783     8)
784  8)
785 (test-eval
786  '(let loop ((count 0))
787     (if (= 100 count)
788 	count
789 	(loop (+ count 1))))
790  100)
791 (geval
792  '(define (prime? x)
793     (let prime-iter ((i 2))
794       (cond ((> (* i i) x) true)
795 	    ((= (remainder x i) 0) false)
796 	    (else (prime-iter (+ i 1)))))))
797 (test-eval
798  '(let primes ((x 2)
799 	       (n 20))
800     (cond ((= n 0) '())
801 	  ((prime? x) 
802 	   (cons x
803 		 (primes (+ x 1) (- n 1))))
804 	  (else (primes (+ x 1) n))))
805  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
806 
807 (geval
808  '(define (fib n)
809     (let fib-iter ((a 1)
810 		   (b 0)
811 		   (count n))
812       (if (= count 0)
813 	  b
814 	  (fib-iter (+ a b) a (- count 1))))))
815 (test-eval '(fib 19) 4181)
816 
817 ;; do-loop	  
818 (test-eval
819  '(let ((y 0))
820     (do ((x 0 (+ x 1)))
821 	((= x 5) y)
822       (set! y (+ y 1))))
823  5)
824 (test-eval
825  '(do ()
826       (true))
827  true)
828 (test-eval
829  '(do ()
830       (true 5))
831  5)
832 (test-eval
833  '(let ((y 0))
834     (do ()
835 	((= y 5) y)
836       (set! y (+ y 1))))
837  5)
838 
839 (test-eval
840  '(do ((y '(1 2 3 4)))
841       ((null? y))
842     (set! y (cdr y)))
843  true)
844 (test-eval
845  '(let ((y 0))
846     (do ((x 0 (+ x 1)))
847 	((= x 5) y)
848       (set! y (+ y 1))))
849  5)
850 (test-eval
851  '(let ((x '(1 3 5 7 9)))
852     (do ((x x (cdr x))
853 	 (sum 0 (+ sum (car x))))
854 	((null? x) sum)))
855  25)
856 (test-eval 
857  '(let ((z '()))
858     (do ((x '(1 2 3 4) (cdr x))
859 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
860 	((null? x) y x z)
861       (set! z (cons (car x) z))))
862  '(4 3 2 1))
863 
864 
865 
866 ;; make-unbound!
867 ;; broken now due to scan-out-defines
868 
869 ;; (test-eval
870 ;;  '(let ((x 3))
871 ;;     (let ((x 5))
872 ;;       (make-unbound! x)
873 ;;       (* x x)))
874 ;;  9)
875 
876 ;; (test-eval
877 ;;  '(let ((x 3))
878 ;;     (let ((x 5))
879 ;;       (define y x)
880 ;;       (make-unbound! x)
881 ;;       (* y x)))
882 ;;  15)
883 
884 ;; (test-eval
885 ;;  '(let ((y -1) (x 3))
886 ;;     (let ((y 0.5) (x 5))
887 ;;       (define a x)
888 ;;       (define b y)
889 ;;       (make-unbound! x)
890 ;;       (make-unbound! y)
891 ;;       (* a b x y)))
892 ;;  (* 5 3 -1 0.5))
893 
894 ;; (test-eval
895 ;;  '(let ((x 3) (y 4))
896 ;;     (let ((x 5))
897 ;;       (make-unbound! x)
898 ;;       (+ x 4)))
899 ;;  7)
900 
901 ;; (test-eval 
902 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
903 ;;     (make-unbound! b)
904 ;;     (+ a c d))
905 ;;  (+ 1 3 4))
906 
907 ;; (test-eval
908 ;;  '(let ((x 4) (y 5))
909 ;;     (let ((a 1) (b 2) (c 3))
910 ;;       (let ((x (+ a b)) (y (+ c a)))
911 ;; 	(make-unbound! x)
912 ;; 	(let ((a x) (b (+ x y)))
913 ;; 	  (define z b)
914 ;; 	  (make-unbound! b)
915 ;; 	  (* (+ a z)
916 ;; 	     (+ a b y))))))
917 ;;  (* (+ 4 8)
918 ;;     (+ 4 2 4)))
919  
920 ;; x 3 -- y 4
921 ;; x 4 -- y 4
922 ;; a 4 -- b 4
923 ;; a 4 -- b 2
924 
925 ;; scan-out-defines
926 
927 (geval
928  '(define (f x)
929     (define (even? n)
930       (if (= n 0)
931 	  true
932 	  (odd? (- n 1))))
933     (define (odd? n)
934       (if (= n 0)
935 	  false
936 	  (even? (- n 1))))
937     (even? x)))
938 (test-eval '(f 5) false)
939 (test-eval '(f 10) true)
940 
941 ;; (geval
942 ;;  '(let ((x 5))
943 ;;     (define y x)
944 ;;     (define x 3)
945 ;;     (+ x y)))
946 ;; signal an error because x is undefined if variables are scanned out
947 
948 ;; letrec
949 
950 (geval
951  '(define (f x)
952     (letrec ((even?
953 	      (lambda (n)
954 		(if (= n 0)
955 		    true
956 		    (odd? (- n 1)))))
957 	     (odd?
958 	      (lambda (n)
959 		(if (= n 0)
960 		    false
961 		    (even? (- n 1))))))
962       (even? x))))
963 (test-eval '(f 11) false)
964 (test-eval '(f 16) true)
965 
966 (test-eval 
967  '(letrec ((fact
968 	    (lambda (n)
969 	      (if (= n 1)
970 		  1
971 		  (* n (fact (- n 1)))))))
972     (fact 10))
973  3628800)
974 
975 
976 ;; delayed-evaluation
977 
978 (geval
979  '(define (try (a lazy-memo) (b lazy-memo))
980     (if (= a 0) 1 b)))
981 (test-eval '(try 0 (/ 1 0)) 1)
982 
983 (geval 
984  '(define (unless (condition lazy-memo) (usual-value lazy-memo) (exceptional-value lazy-memo))
985     (if condition exceptional-value usual-value)))
986 (test-eval
987  '(let ((a 4) (b 0))
988     (unless (= b 0)
989             (/ a b)
990 	    (begin (display "exception: returning 0")
991 		   0)))
992  0)
993 (test-eval
994   '(let ((a 4) (b 2))
995     (unless (= b 0)
996             (/ a b)
997 	    (begin (display "exception: returning 0")
998 		   0)))
999   2)
1000 
1001 (geval
1002  '(define (factorial (n lazy-memo))
1003     (unless (= n 1)
1004             (* n (factorial (- n 1)))
1005 	    1)))
1006 (test-eval
1007  '(factorial 8)
1008  40320)
1009 
1010 (geval '(define count 0))
1011 (geval '(define (id (x lazy-memo))
1012 	  (set! count (+ count 1))
1013 	  x))
1014 
1015 (geval '(define w (id (id 10))))
1016 (test-eval 'count 1)
1017 (test-eval 'w 10)
1018 (test-eval 'count 2)
1019 (test-eval
1020  '(let ((f (lambda (x) (+ x 1))))
1021     (f 1))
1022  2)
1023 (geval '(define count 0))
1024 (geval '(define (id (x lazy-memo))
1025 	  (set! count (+ count 1))
1026 	  x))
1027 (geval 
1028  '(define (square (x lazy-memo))
1029     (* x x)))
1030 (test-eval 
1031  '(square (id 10))
1032  100)
1033 (test-eval 'count 1)
1034 ;; would be 2 without memoization
1035 
1036 (geval 
1037  '(define (p1 (x lazy-memo))
1038     (set! x (cons x '(2)))
1039     x))
1040 (geval 
1041  '(define (p2 (x lazy-memo))
1042     (define (p e)
1043       e
1044       x)
1045     (p (set! x (cons x '(2))))))
1046 (test-eval '(p1 1) '(1 2))
1047 (test-eval '(p2 1) 1)
1048 
1049 (geval '(define count 0))
1050 
1051 (geval 
1052  '(define (id (x lazy-memo))
1053     (set! count (+ count 1))
1054     x))
1055 
1056 (geval 
1057  '(define (f a (b lazy) c (d lazy-memo))
1058     a
1059     b
1060     c
1061     d))
1062 (test-eval 
1063  '(f (id 1) (id 2) (id 3) (id 4))
1064  4)
1065 (test-eval 'count 3)
1066 (test-eval
1067  '(f 1 (id 2) 3 4)
1068  4)
1069 (test-eval 'count 3)
1070 (geval
1071  '(define (g (a lazy-memo))
1072     (+ a a)))
1073 (test-eval 
1074  '(g (id 2))
1075  4)
1076 (test-eval 'count 4)
1077 (geval
1078  '(define (h (a lazy))
1079     (+ a a)))
1080 (test-eval 
1081  '(h (id 2))
1082  4)
1083 (test-eval 'count 6)
1084 (test-eval
1085  '(g (id (id 2)))
1086  4)
1087 (test-eval 'count 8)
1088 
1089 (test-eval
1090  '(h (id (id 2)))
1091  4)
1092 (test-eval
1093  'count
1094  12)
1095 (geval
1096  '(define (i a)
1097     (+ a a)))
1098 (test-eval
1099  '(i (id 2))
1100  4)
1101 (test-eval
1102  'count
1103  13)
1104 (test-eval
1105  '(i (id (id 2)))
1106  4)
1107 (test-eval 'count 15)
1108 (geval 
1109  '(define (add-to-count (n lazy-memo))
1110     (if (= n 0)
1111 	0
1112 	(begin (set! count (+ count 1))
1113 	       (add-to-count (- n 1))))))
1114 (geval
1115  '(define (subtract-from-count (n lazy))
1116     (if (= n 0)
1117 	0
1118 	(begin (set! count (- count 1))
1119 	       (subtract-from-count (- n 1))))))
1120 (test-eval 
1121  '(add-to-count (id 5))
1122  0)
1123 (test-eval 'count 21)
1124 ;; n = (thunk (id 5))
1125 ;; count = 16
1126 ;; count = 17
1127 ;; (add-to-count (- n 1))
1128 ;; n = (thunk (- n 1))
1129 ;; n = 4
1130 ;; count = 18
1131 ;; n = 3
1132 ;; count = 19
1133 ;; n = 2
1134 ;; count = 20
1135 ;; n = 1
1136 ;; count = 21
1137 ;; n = 0
1138 (test-eval
1139  '(subtract-from-count (id 5))
1140  0)
1141 ;; n = (simple-thunk (id 5))
1142 ;; count = 22
1143 ;; (= 5 0)
1144 ;; count = 21
1145 ;; (subtract-from-count (- n 1))
1146 ;; n = (simple-thunk (- n 1))
1147 ;; n = (- n 1)
1148 ;; count = 22
1149 ;; n = 4
1150 ;; count = 21
1151 ;; (subtract-from-count (- n 1))
1152 ;; n = (simple-thunk (- n 1))
1153 ;; count = 22
1154 ;; n = 3
1155 ;; count = 21
1156 ;; (subtract-from-count (- n 1))
1157 ;; n = (simple-thunk (- n 1))
1158 ;; count = 22
1159 ;; n = 2
1160 ;; count = 21
1161 ;; ...
1162 ;; count = 22
1163 ;; n = 0
1164 (test-eval 'count 22)