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