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