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