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