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 env))
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 
589 
590 ;; Exercise 4.33.  Ben Bitdiddle tests the lazy list implementation given above by evaluating the expression
591 
592 (define (text-of-quotation exp env) 
593   (define (make-tree tree)
594     (if (pair? tree)
595 	(eval 
596 	 (make-cons (make-tree (car tree)) 
597 		    (make-tree (cdr tree)))
598 	 env)
599 	tree))
600   (let ((qval (cadr exp)))
601     (make-tree qval)))
602 
603 (define (make-cons x y)
604   `(cons ,x ,y))
605 
606 
607 ;; (car '(a b c))
608 
609 ;; (car (quote (a b c)))
610 
611 
612 ;; z = (thunk (quote (a b c)))
613 
614 ;; if we have a quoted list, we need to transform it into the proper cons
615 
616 ;; z = (cons a (cons b (cons c ())))
617 
618 ;; (car '((a b) c))
619 ;; (car (quote ((a b) c)))
620 
621 ;; z = (thunk (quote ((a b) c)))
622 ;; z = (cons (cons a (cons b ())) 
623 ;;  	     (cons c ()))
624 
625 ;; To his surprise, this produces an error. After some thought, he realizes that the ``lists'' obtained by reading in quoted expressions are different from the lists manipulated by the new definitions of cons, car, and cdr. Modify the evaluator's treatment of quoted expressions so that quoted lists typed at the driver loop will produce true lazy lists. 
626 
627 ;; (quote (a))
628 
629 (test-eval
630  '(car '(a))
631  'a)
632 (test-eval
633  '(cdr '(a))
634  '())
635 (test-eval
636  '(car (cdr '(a b)))
637  'a)
638 (test-eval
639  '(car (car '((a b) c)))
640  'a)
641 (test-eval
642  '(car (cdr (car (cdr '((a c) (b d))))))
643  'd)
644 
645 ;; test-suite
646 
647 ;; procedure definitions
648 
649 (geval 
650  '(define (assoc key records)
651     (cond ((null? records) false)
652 	  ((equal? key (caar records)) (car records))
653 	  (else (assoc key (cdr records))))))
654 
655 (geval
656  '(define (map proc list)
657     (if (null? list)
658 	'()
659 	(cons (proc (car list))
660 	      (map proc (cdr list))))))
661 
662 (geval 
663  '(define (accumulate op initial sequence)
664     (if (null? sequence)
665 	initial
666 	(op (car sequence)
667 	    (accumulate op initial (cdr sequence))))))
668 
669 ;; all special forms
670 (test-eval '(begin 5 6) 6)
671 (test-eval '10 10)
672 (geval '(define x 3))
673 (test-eval 'x 3)
674 (test-eval '(set! x -25) 'ok)
675 (test-eval 'x -25)
676 (geval '(define z (lambda (x y) (+ x (* x y)))))
677 (test-eval '(z 3 4) 15)
678 (test-eval '(cond ((= x -2) 'x=-2)
679 		  ((= x -25) 'x=-25)
680 		  (else 'failed))
681 	   'x=-25)
682 (test-eval '(if true false true) false)
683 
684 (test-eval 
685  '(let ((x 4) (y 7))
686     (+ x y (* x y)))
687  (+ 4 7 (* 4 7)))
688 
689 
690 ;; and/or
691 (geval '(define x (+ 3 8)))
692 (test-eval '(and 0 true x) 11)
693 (test-eval '(and 0 true x false) false)
694 (test-eval '(and 0 true x (set! x -2) false) false)
695 (test-eval 'x -2)
696 (test-eval '(and 0 true x false (set! x -5)) false)
697 (test-eval 'x -2)
698 (test-eval '(or false (set! x 25)) 'ok)
699 (test-eval 'x 25)
700 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
701 (test-eval 'x 2)
702 (test-eval '(or false (set! x 25) true false) 'ok)
703 (test-eval 'x 25)
704 (test-eval '(or ((lambda (x) x) 5)) 5)
705 (test-eval '(or (begin (set! x (+ x 1)) x)) 26)
706 
707 
708 ;; cond
709 
710 (test-eval 
711  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
712 	(else false))
713  2)
714 
715 (test-eval
716  '(cond ((= 3 4) 'not-true)
717 	((= (* 2 4) 3) 'also-false)
718 	((map (lambda (x)
719 		(* x (+ x 1)))
720 	      '(2 4 1 9))
721 	 =>
722 	 (lambda (x)
723 	   (accumulate + 0 x)))
724 	(else 'never-reach))
725  118)
726 ;; '(6 20 2 90)
727 
728 
729 ;; procedure definition and application
730 (geval
731  '(define (factorial n)
732     (if (= n 0)
733 	1
734 	(* n (factorial (- n 1))))))
735 (test-eval '(factorial 5) 120)
736 
737 ;; map
738 
739 (test-eval
740  '(map (lambda (x)
741 	 (* x (+ x 1)))
742        '(2 1 4 2 8 3))
743  '(6 2 20 6 72 12))
744 ;; accumulate
745 
746 (test-eval
747  '(accumulate + 0 '(1 2 3 4 5))
748  15)
749 
750 ;; make-let
751 (test-eval 
752  (make-let '(x y) '(3 5) '((+ x y)))
753  8)
754 (test-eval 
755  '(let ()
756     5)
757  5)
758 (test-eval
759  '(let ((x 3))
760     x)
761  3)
762 (test-eval
763  '(let ((x 3)
764 	(y 5))
765     (+ x y))
766  8)
767 (test-eval 
768  '(let ((x 3)
769 	(y 2))
770     (+ (let ((x (+ y 2))
771 	     (y x))
772 	 (* x y))
773        x y))
774  (+ (* 4 3) 3 2))
775 (test-eval
776  '(let ((x 6)
777 	(y (let ((x 2))
778 	     (+ x 3)))
779 	(z (let ((a (* 3 2)))
780 	     (+ a 3))))
781     (+ x y z))
782  (+ 6 5 9))
783     
784 
785 ;; let*
786 
787 (test-eval
788  '(let* ((x 3)
789 	 (y (+ x 2))
790 	 (z (+ x y 5)))
791     (* x z))
792  39)
793 
794 (test-eval
795  '(let* ()
796     5)
797  5)
798 (test-eval
799  '(let* ((x 3))
800     (let* ((y 5))
801       (+ x y)))
802  8)
803 
804 (test-eval 
805  '(let* ((x 3)
806 	 (y (+ x 1)))
807     (+ (let* ((x (+ y 2))
808 	      (y x))
809 	 (* x y))
810        x y))
811  (+ (* 6 6) 3 4))
812 (test-eval
813  '(let* ((x 6)
814 	 (y (let* ((x 2)
815 		   (a (let* ((x (* 3 x)))
816 			(+ x 2))))       
817 	      (+ x a)))                  
818 	 (z (+ x y)))                    
819     (+ x y z))
820  32)
821 
822 ;; named-let
823 
824 (test-eval
825  '(let eight ()
826     5
827     7
828     8)
829  8)
830 (test-eval
831  '(let loop ((count 0))
832     (if (= 100 count)
833 	count
834 	(loop (+ count 1))))
835  100)
836 (geval
837  '(define (prime? x)
838     (let prime-iter ((i 2))
839       (cond ((> (* i i) x) true)
840 	    ((= (remainder x i) 0) false)
841 	    (else (prime-iter (+ i 1)))))))
842 (test-eval
843  '(let primes ((x 2)
844 	       (n 20))
845     (cond ((= n 0) '())
846 	  ((prime? x) 
847 	   (cons x
848 		 (primes (+ x 1) (- n 1))))
849 	  (else (primes (+ x 1) n))))
850  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
851 
852 (geval
853  '(define (fib n)
854     (let fib-iter ((a 1)
855 		   (b 0)
856 		   (count n))
857       (if (= count 0)
858 	  b
859 	  (fib-iter (+ a b) a (- count 1))))))
860 (test-eval '(fib 19) 4181)
861 
862 ;; do-loop	  
863 (test-eval
864  '(let ((y 0))
865     (do ((x 0 (+ x 1)))
866 	((= x 5) y)
867       (set! y (+ y 1))))
868  5)
869 (test-eval
870  '(do ()
871       (true))
872  true)
873 (test-eval
874  '(do ()
875       (true 5))
876  5)
877 (test-eval
878  '(let ((y 0))
879     (do ()
880 	((= y 5) y)
881       (set! y (+ y 1))))
882  5)
883 
884 (test-eval
885  '(do ((y '(1 2 3 4)))
886       ((null? y))
887     (set! y (cdr y)))
888  true)
889 (test-eval
890  '(let ((y 0))
891     (do ((x 0 (+ x 1)))
892 	((= x 5) y)
893       (set! y (+ y 1))))
894  5)
895 (test-eval
896  '(let ((x '(1 3 5 7 9)))
897     (do ((x x (cdr x))
898 	 (sum 0 (+ sum (car x))))
899 	((null? x) sum)))
900  25)
901 (test-eval 
902  '(let ((z '()))
903     (do ((x '(1 2 3 4) (cdr x))
904 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
905 	((null? x) y x z)
906       (set! z (cons (car x) z))))
907  '(4 3 2 1))
908 
909 
910 
911 ;; make-unbound!
912 ;; broken now due to scan-out-defines
913 
914 ;; (test-eval
915 ;;  '(let ((x 3))
916 ;;     (let ((x 5))
917 ;;       (make-unbound! x)
918 ;;       (* x x)))
919 ;;  9)
920 
921 ;; (test-eval
922 ;;  '(let ((x 3))
923 ;;     (let ((x 5))
924 ;;       (define y x)
925 ;;       (make-unbound! x)
926 ;;       (* y x)))
927 ;;  15)
928 
929 ;; (test-eval
930 ;;  '(let ((y -1) (x 3))
931 ;;     (let ((y 0.5) (x 5))
932 ;;       (define a x)
933 ;;       (define b y)
934 ;;       (make-unbound! x)
935 ;;       (make-unbound! y)
936 ;;       (* a b x y)))
937 ;;  (* 5 3 -1 0.5))
938 
939 ;; (test-eval
940 ;;  '(let ((x 3) (y 4))
941 ;;     (let ((x 5))
942 ;;       (make-unbound! x)
943 ;;       (+ x 4)))
944 ;;  7)
945 
946 ;; (test-eval 
947 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
948 ;;     (make-unbound! b)
949 ;;     (+ a c d))
950 ;;  (+ 1 3 4))
951 
952 ;; (test-eval
953 ;;  '(let ((x 4) (y 5))
954 ;;     (let ((a 1) (b 2) (c 3))
955 ;;       (let ((x (+ a b)) (y (+ c a)))
956 ;; 	(make-unbound! x)
957 ;; 	(let ((a x) (b (+ x y)))
958 ;; 	  (define z b)
959 ;; 	  (make-unbound! b)
960 ;; 	  (* (+ a z)
961 ;; 	     (+ a b y))))))
962 ;;  (* (+ 4 8)
963 ;;     (+ 4 2 4)))
964  
965 ;; x 3 -- y 4
966 ;; x 4 -- y 4
967 ;; a 4 -- b 4
968 ;; a 4 -- b 2
969 
970 ;; scan-out-defines
971 
972 (geval
973  '(define (f x)
974     (define (even? n)
975       (if (= n 0)
976 	  true
977 	  (odd? (- n 1))))
978     (define (odd? n)
979       (if (= n 0)
980 	  false
981 	  (even? (- n 1))))
982     (even? x)))
983 (test-eval '(f 5) false)
984 (test-eval '(f 10) true)
985 
986 ;; (geval
987 ;;  '(let ((x 5))
988 ;;     (define y x)
989 ;;     (define x 3)
990 ;;     (+ x y)))
991 ;; signal an error because x is undefined if variables are scanned out
992 
993 ;; letrec
994 
995 (geval
996  '(define (f x)
997     (letrec ((even?
998 	      (lambda (n)
999 		(if (= n 0)
1000 		    true
1001 		    (odd? (- n 1)))))
1002 	     (odd?
1003 	      (lambda (n)
1004 		(if (= n 0)
1005 		    false
1006 		    (even? (- n 1))))))
1007       (even? x))))
1008 (test-eval '(f 11) false)
1009 (test-eval '(f 16) true)
1010 
1011 (test-eval 
1012  '(letrec ((fact
1013 	    (lambda (n)
1014 	      (if (= n 1)
1015 		  1
1016 		  (* n (fact (- n 1)))))))
1017     (fact 10))
1018  3628800)
1019 
1020 
1021 ;; delayed-evaluation
1022 
1023 (geval
1024  '(define (try a b)
1025     (if (= a 0) 1 b)))
1026 (test-eval '(try 0 (/ 1 0)) 1)
1027 
1028 (geval 
1029  '(define (unless condition usual-value exceptional-value)
1030     (if condition exceptional-value usual-value)))
1031 (test-eval
1032  '(let ((a 4) (b 0))
1033     (unless (= b 0)
1034             (/ a b)
1035 	    (begin (display "exception: returning 0")
1036 		   0)))
1037  0)
1038 (test-eval
1039   '(let ((a 4) (b 2))
1040     (unless (= b 0)
1041             (/ a b)
1042 	    (begin (display "exception: returning 0")
1043 		   0)))
1044   2)
1045 
1046 (geval
1047  '(define (factorial n)
1048     (unless (= n 1)
1049             (* n (factorial (- n 1)))
1050 	    1)))
1051 (test-eval
1052  '(factorial 8)
1053  40320)
1054 
1055 (geval '(define count 0))
1056 (geval '(define (id x)
1057 	  (set! count (+ count 1))
1058 	  x))
1059 
1060 (geval '(define w (id (id 10))))
1061 (test-eval 'count 1)
1062 (test-eval 'w 10)
1063 (test-eval 'count 2)
1064 (test-eval
1065  '(let ((f (lambda (x) (+ x 1))))
1066     (f 1))
1067  2)
1068 (geval '(define count 0))
1069 (geval '(define (id x)
1070 	  (set! count (+ count 1))
1071 	  x))
1072 (geval 
1073  '(define (square x)
1074     (* x x)))
1075 (test-eval 
1076  '(square (id 10))
1077  100)
1078 (test-eval 'count 1)
1079 ;; would be 2 without memoization
1080 
1081 
1082 ;; streams
1083 
1084 (geval 
1085  '(define ones (cons 1 ones)))
1086 (geval
1087  '(define integers (cons 1 (add-lists ones integers))))
1088 (test-eval 
1089  '(list-ref integers 17)
1090  18)
1091 
1092 (geval
1093  '(define (integral integrand initial-value dt)
1094     (define int
1095       (cons initial-value
1096 	    (add-lists (scale-list integrand dt)
1097 		       int)))
1098     int))
1099 (geval
1100  '(define (solve f y0 dt)
1101     (define y (integral dy y0 dt))
1102     (define dy (map f y))
1103     y))
1104 (test-eval 
1105  '(list-ref (solve (lambda (x) x) 1 0.001) 1000)
1106  2.716924)