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