1 (define (ambeval exp env succeed fail)
2   ((analyze exp) env succeed fail))
3 (define (analyze exp)
4   (cond ((self-evaluating? exp) 
5          (analyze-self-evaluating exp))
6         ((quoted? exp) (analyze-quoted exp))
7         ((variable? exp) (analyze-variable exp))
8         ((assignment? exp) (analyze-assignment exp))
9         ((definition? exp) (analyze-definition exp))
10         ((if? exp) (analyze-if exp))
11 	((and? exp) (analyze (and->if exp)))
12 	((or? exp) (analyze (or->if exp)))
13 	((not? exp) (analyze (not->if exp)))
14         ((lambda? exp) (analyze-lambda exp))
15 	((let? exp) (analyze (let->combination exp)))
16 	((let*? exp) (analyze (let*->nested-lets exp)))
17 	((named-let? exp) (analyze (named-let->combination exp)))
18 	((letrec? exp) (analyze (letrec->let exp)))
19 	((do? exp) (analyze (do->combination exp)))
20         ((begin? exp) (analyze-sequence (begin-actions exp)))
21         ((cond? exp) (analyze (cond->if exp)))
22 	((amb? exp) (analyze-amb exp))
23         ((application? exp) (analyze-application exp))
24         (else
25          (error "Unknown expression type -- ANALYZE" exp))))
26 
27 
28 ;; analyzing procedures
29 (define (analyze-self-evaluating exp)
30   (lambda (env succeed fail)
31     (succeed exp fail)))
32 (define (analyze-quoted exp)
33   (let ((qval (text-of-quotation exp)))
34     (lambda (env succeed fail)
35       (succeed qval fail))))
36 (define (analyze-variable exp)
37   (lambda (env succeed fail)
38     (succeed (lookup-variable-value exp env)
39              fail)))
40 (define (analyze-lambda exp)
41   (let ((vars (lambda-parameters exp))
42 ;;        (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
43 	(bproc (analyze-sequence (lambda-body exp))))
44     (lambda (env succeed fail)
45       (succeed (make-procedure vars bproc env)
46                fail))))
47 (define (analyze-if exp)
48   (let ((pproc (analyze (if-predicate exp)))
49         (cproc (analyze (if-consequent exp)))
50         (aproc (analyze (if-alternative exp))))
51     (lambda (env succeed fail)
52       (pproc env
53              ;; success continuation for evaluating the predicate
54              ;; to obtain pred-value
55              (lambda (pred-value fail2)
56                (if (true? pred-value)
57                    (cproc env succeed fail2)
58                    (aproc env succeed fail2)))
59              ;; failure continuation for evaluating the predicate
60              fail))))
61 (define (analyze-sequence exps)
62   (define (sequentially a b)
63     (lambda (env succeed fail)
64       (a env
65          ;; success continuation for calling a
66          (lambda (a-value fail2)
67            (b env succeed fail2))
68          ;; failure continuation for calling a
69          fail)))
70   (define (loop first-proc rest-procs)
71     (if (null? rest-procs)
72         first-proc
73         (loop (sequentially first-proc (car rest-procs))
74               (cdr rest-procs))))
75   (let ((procs (map analyze exps)))
76     (if (null? procs)
77         (error "Empty sequence -- ANALYZE"))
78     (loop (car procs) (cdr procs))))
79 (define (analyze-definition exp)
80   (let ((var (definition-variable exp))
81         (vproc (analyze (definition-value exp))))
82     (lambda (env succeed fail)
83       (vproc env                        
84              (lambda (val fail2)
85                (define-variable! var val env)
86                (succeed 'ok fail2))
87              fail))))
88 (define (analyze-assignment exp)
89   (let ((var (assignment-variable exp))
90         (vproc (analyze (assignment-value exp))))
91     (lambda (env succeed fail)
92       (vproc env
93              (lambda (val fail2)        ; *1*
94                (let ((old-value
95                       (lookup-variable-value var env))) 
96                  (set-variable-value! var val env)
97                  (succeed 'ok
98                           (lambda ()    ; *2*
99                             (set-variable-value! var
100                                                  old-value
101                                                  env)
102                             (fail2)))))
103              fail))))
104 
105 (define (analyze-application exp)
106   (let ((fproc (analyze (operator exp)))
107         (aprocs (map analyze (operands exp))))
108     (lambda (env succeed fail)
109       (fproc env
110              (lambda (proc fail2)
111                (get-args aprocs
112                          env
113                          (lambda (args fail3)
114                            (execute-application
115                             proc args succeed fail3))
116                          fail2))
117              fail))))
118 (define (get-args aprocs env succeed fail)
119   (if (null? aprocs)
120       (succeed '() fail)
121       ((car aprocs) env
122                     ;; success continuation for this aproc
123                     (lambda (arg fail2)
124                       (get-args (cdr aprocs)
125                                 env
126                                 ;; success continuation for recursive
127                                 ;; call to get-args
128                                 (lambda (args fail3)
129                                   (succeed (cons arg args)
130                                            fail3))
131                                 fail2))
132                     fail)))
133 
134 (define (analyze-amb exp)
135   (let ((cprocs (map analyze (amb-choices exp))))
136     (lambda (env succeed fail)
137       (define (try-next choices)
138         (if (null? choices)
139             (fail)
140             ((car choices) env
141                            succeed
142                            (lambda ()
143                              (try-next (cdr choices))))))
144       (try-next cprocs))))
145 
146 
147 
148 
149 
150 
151 (define (tagged-list? exp tag)
152   (if (pair? exp)
153       (eq? (car exp) tag)
154       false))
155 
156 ;; amb
157 (define (amb? exp) (tagged-list? exp 'amb))
158 (define (amb-choices exp) (cdr exp))
159 
160 ;; self-evaluating/variable/quoted
161 (define (self-evaluating? exp)
162   (cond ((number? exp) true)
163         ((string? exp) true)
164         (else false)))
165 (define (variable? exp) (symbol? exp))
166 (define (quoted? exp)
167   (tagged-list? exp 'quote))
168 (define (text-of-quotation exp) (cadr exp))
169 
170 ;; assignment/definition
171 (define (assignment? exp)
172   (tagged-list? exp 'set!))
173 (define (assignment-variable exp) (cadr exp))
174 (define (assignment-value exp) (caddr exp))
175 (define (make-assignment var val)
176   (list 'set! var val))
177 (define (definition? exp)
178   (tagged-list? exp 'define))
179 (define (definition-variable exp)
180   (if (symbol? (cadr exp))
181       (cadr exp)
182       (caadr exp)))
183 (define (definition-value exp)
184   (if (symbol? (cadr exp))
185       (caddr exp)
186       (make-lambda (cdadr exp)   ; formal parameters
187                    (cddr exp)))) ; body
188 (define (make-definition var val)
189   `(define ,var ,val))
190 
191 ;; if/and/or/not
192 (define (if? exp) (tagged-list? exp 'if))
193 (define (if-predicate exp) (cadr exp))
194 (define (if-consequent exp) (caddr exp))
195 (define (if-alternative exp)
196   (if (not (null? (cdddr exp)))
197       (cadddr exp)
198       'false))
199 (define (make-if predicate consequent alternative)
200   (list 'if predicate consequent alternative))
201 
202 (define (and? exp)
203   (tagged-list? exp 'and))
204 (define (and-clauses exp)
205   (cdr exp))
206 (define (or? exp)
207   (tagged-list? exp 'or))
208 (define (or-clauses exp)
209   (cdr exp))
210 (define (and->if exp)
211   (define (expand-clauses clauses)
212     (cond ((null? clauses) 'true)
213 	  ((null? (cdr clauses)) (car clauses))
214 	  (else (make-if (car clauses)
215 			 (expand-clauses (cdr clauses))
216 			 'false))))
217   (expand-clauses (and-clauses exp)))
218 (define (or->if exp)
219   (define (expand-clauses clauses)
220     (if (null? clauses)
221 	'false
222         (make-if (car clauses)
223 		 (car clauses)
224 		 (expand-clauses (cdr clauses)))))
225   (expand-clauses (or-clauses exp)))
226 (define (not? exp)
227   (tagged-list? exp 'not))
228 (define (not->if exp)
229   `(if ,(cadr exp) false true))
230 
231 ;; lambda/let/let*/letrec
232 (define (lambda? exp) (tagged-list? exp 'lambda))
233 (define (lambda-parameters exp) (cadr exp))
234 (define (lambda-body exp) (cddr exp))
235 (define (make-lambda parameters body)
236   (cons 'lambda (cons parameters body)))
237 
238 (define (make-let vars vals body)
239   (cons 'let
240 	(cons (map list vars vals)
241 	      body)))
242 (define (let? exp)
243   (and (tagged-list? exp 'let)
244        (not (symbol? (cadr exp)))))
245 (define (let-vars exp)
246   (map car (cadr exp)))
247 (define (let-vals exp)
248   (map cadr (cadr exp)))
249 (define (let-body exp)
250   (cddr exp))
251 (define (let->combination exp)
252   (make-application (make-lambda (let-vars exp) (let-body exp))
253 		    (let-vals exp)))
254 (define (named-let? exp)
255   (and (tagged-list? exp 'let)
256        (symbol? (cadr exp))))
257 (define (named-let-name exp)
258   (cadr exp))
259 (define (named-let-vars exp)
260   (map car (caddr exp)))
261 (define (named-let-vals exp)
262   (map cadr (caddr exp)))
263 (define (named-let-body exp)
264   (cdddr exp))
265 (define (named-let->combination exp)
266   (sequence->exp
267    (list (make-definition (named-let-name exp)
268 			  (make-lambda (named-let-vars exp)
269 				       (named-let-body exp)))
270 	 (make-application (named-let-name exp)
271 			   (named-let-vals exp)))))
272 (define (make-named-let name vars vals body)
273   (cons 'let 
274 	(cons name
275 	      (cons (map list vars vals)
276 		    body))))
277 
278 (define (letrec? exp)
279   (tagged-list? exp 'letrec))
280 
281 (define (letrec-vars exp)
282   (map car (cadr exp)))
283 (define (letrec-vals exp)
284   (map cadr (cadr exp)))
285 (define (letrec-body exp)
286   (cddr exp))
287 (define (letrec->let exp)
288   (let* ((vars (letrec-vars exp))
289 	 (unassigneds (map (lambda (var) ''*unassigned*)
290 			   vars))
291 	 (vals (letrec-vals exp))
292 	 (assignments (map (lambda (var val)
293 			     (make-assignment var val))
294 			   vars
295 			   vals))
296 	 (body (letrec-body exp)))
297   (make-let vars 
298 	    unassigneds
299 	    (append assignments body))))
300 
301 (define (make-application op args)
302   (cons op args))
303 
304 (define (let*? exp)
305   (tagged-list? exp 'let*))
306 (define let*-vars let-vars)
307 (define let*-vals let-vals)
308 (define let*-body let-body)
309 (define (let*->nested-lets exp)
310   (define (expand-lets vars vals)
311     (if (null? (cdr vars))
312 	(make-let (list (car vars)) 
313 		  (list (car vals))
314 		  (let*-body exp))
315 	(make-let (list (car vars))
316 		  (list (car vals))
317 		  (list (expand-lets (cdr vars) (cdr vals))))))
318   (let ((vars (let*-vars exp))
319 	(vals (let*-vals exp)))
320     (if (null? vars)
321 	(sequence->exp (let*-body exp))
322 	(expand-lets vars vals))))
323 
324 ;; do loop
325 (define (do? exp)
326   (tagged-list? exp 'do))
327 (define (do-vars exp)
328   (map car (cadr exp)))
329 (define (do-inits exp)
330   (map cadr (cadr exp)))
331 (define (do-steps exp)
332   (map (lambda (var-init-step)
333 	 (if (null? (cddr var-init-step))
334 	     (car var-init-step)
335 	     (caddr var-init-step)))
336        (cadr exp)))
337 (define (do-test exp)
338   (caaddr exp))
339 (define (do-expressions exp)
340   (if (null? (cdaddr exp))
341       (caddr exp)
342       (cdaddr exp)))
343 (define (do-commands exp)
344   (cdddr exp))
345 (define (do->combination exp)
346   (make-named-let
347    'do-iter
348    (do-vars exp)
349    (do-inits exp)
350    (list
351     (make-if
352      (do-test exp)
353      (sequence->exp (do-expressions exp))
354      (sequence->exp
355       (append (do-commands exp)
356 	      (list (make-application
357 		     'do-iter
358 		     (do-steps exp)))))))))
359 
360 
361 ;; begin/sequence
362 (define (begin? exp) (tagged-list? exp 'begin))
363 (define (begin-actions exp) (cdr exp))
364 (define (last-exp? seq) (null? (cdr seq)))
365 (define (first-exp seq) (car seq))
366 (define (rest-exps seq) (cdr seq))
367 (define (sequence->exp seq)
368   (cond ((null? seq) seq)
369         ((last-exp? seq) (first-exp seq))
370         (else (make-begin seq))))
371 (define (make-begin seq) (cons 'begin seq))
372 
373 ;; application
374 (define (application? exp) (pair? exp))
375 (define (operator exp) (car exp))
376 (define (operands exp) (cdr exp))
377 (define (no-operands? ops) (null? ops))
378 (define (first-operand ops) (car ops))
379 (define (rest-operands ops) (cdr ops))
380 
381 ;; cond
382 (define (cond? exp) (tagged-list? exp 'cond))
383 (define (cond-clauses exp) (cdr exp))
384 (define (cond-else-clause? clause)
385   (eq? (cond-predicate clause) 'else))
386 (define (cond-predicate clause) (car clause))
387 (define (cond-actions clause) (cdr clause))
388 (define (cond-extended-clause? clause)
389   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
390 (define (cond-extended-proc clause)
391   (caddr clause))
392 (define (cond->if exp)
393   (expand-clauses (cond-clauses exp)))
394 (define (expand-clauses clauses)
395   (if (null? clauses)
396       'false                          ; no else clause
397       (let ((first (car clauses))
398             (rest (cdr clauses)))
399         (if (cond-else-clause? first)
400             (if (null? rest)
401                 (sequence->exp (cond-actions first))
402                 (error "ELSE clause isn't last -- COND->IF"
403                        clauses))
404 	    (if (cond-extended-clause? first)
405 		(make-if (cond-predicate first)
406 			 (make-application
407 			  (cond-extended-proc first)
408 			  (list (cond-predicate first)))
409 			 (expand-clauses rest))
410 		(make-if (cond-predicate first)
411 			 (sequence->exp (cond-actions first))
412 			 (expand-clauses rest)))))))
413 (define (true? x)
414   (not (eq? x false)))
415 (define (false? x)
416   (eq? x false))
417 
418 ;; procedure
419 (define (make-procedure parameters body env)
420   (list 'procedure parameters body env))
421 (define (scan-out-defines body)
422   (let* ((definitions (filter definition? body))
423 	 (vars (map definition-variable definitions))
424 	 (unassigneds (map (lambda (var) ''*unassigned*) 
425 			   vars))
426 	 (vals (map definition-value definitions))
427 	 (assignments 
428 	  (map (lambda (var val)
429 		 (make-assignment var val))
430 	       vars vals))
431 	 (exps (remove definition? body)))
432     (if (null? definitions)
433 	body
434 	(list
435 	 (make-let vars
436 		   unassigneds
437 		   (append assignments exps))))))
438 (define (compound-procedure? p)
439   (tagged-list? p 'procedure))
440 (define (procedure-parameters p) (cadr p))
441 (define (procedure-body p) (caddr p))
442 (define (procedure-environment p) (cadddr p))
443 
444 ;; environment
445 (define (enclosing-environment env) (cdr env))
446 (define (first-frame env) (car env))
447 (define the-empty-environment '())
448 (define (make-frame variables values)
449   (cons variables values))
450 (define (frame-variables frame) (car frame))
451 (define (frame-values frame) (cdr frame))
452 (define (add-binding-to-frame! var val frame)
453   (set-car! frame (cons var (car frame)))
454   (set-cdr! frame (cons val (cdr frame))))
455 (define (extend-environment vars vals base-env)
456   (if (= (length vars) (length vals))
457       (cons (make-frame vars vals) base-env)
458       (if (< (length vars) (length vals))
459           (error "Too many arguments supplied" vars vals)
460           (error "Too few arguments supplied" vars vals))))
461 (define (lookup-variable-value var env)
462   (define (env-loop env)
463     (define (scan vars vals)
464       (cond ((null? vars)
465              (env-loop (enclosing-environment env)))
466             ((eq? var (car vars))
467 	     (let ((val (car vals)))
468 	       (if (eq? val '*unassigned*)
469 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
470 		   val)))
471             (else (scan (cdr vars) (cdr vals)))))
472     (if (eq? env the-empty-environment)
473         (error "Unbound variable" var)
474         (let ((frame (first-frame env)))
475           (scan (frame-variables frame)
476                 (frame-values frame)))))
477   (env-loop env))
478 (define (set-variable-value! var val env)
479   (define (env-loop env)
480     (define (scan vars vals)
481       (cond ((null? vars)
482              (env-loop (enclosing-environment env)))
483             ((eq? var (car vars))
484              (set-car! vals val))
485             (else (scan (cdr vars) (cdr vals)))))
486     (if (eq? env the-empty-environment)
487         (error "Unbound variable -- SET!" var)
488         (let ((frame (first-frame env)))
489           (scan (frame-variables frame)
490                 (frame-values frame)))))
491   (env-loop env))
492 (define (define-variable! var val env)
493   (let ((frame (first-frame env)))
494     (define (scan vars vals)
495       (cond ((null? vars)
496              (add-binding-to-frame! var val frame))
497             ((eq? var (car vars))
498              (set-car! vals val))
499             (else (scan (cdr vars) (cdr vals)))))
500     (scan (frame-variables frame)
501           (frame-values frame))))
502 
503 ;; (define (remove-binding-from-frame! var frame)
504 ;;   (define (scan vars vals)
505 ;;     (cond ((null? (cdr vars))
506 ;; 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
507 ;; 	  ((eq? var (cadr vars))
508 ;; 	   (set-cdr! vars (cddr vars))
509 ;; 	   (set-cdr! vals (cddr vals)))
510 ;; 	  (else (scan (cdr vars) (cdr vals)))))
511 ;;   (let ((vars (frame-variables frame))
512 ;; 	(vals (frame-values frame)))
513 ;;     (if (eq? var (car vars))
514 ;; 	(begin (set-car! frame (cdr vars))
515 ;; 	       (set-cdr! frame (cdr vals)))
516 ;; 	(scan vars vals))))
517 
518 ;; primitives
519 (define (primitive-procedure? proc)
520   (tagged-list? proc 'primitive))
521 (define (primitive-implementation proc) (cadr proc))
522 (define primitive-procedures
523   (list (list 'car car)
524         (list 'cdr cdr)
525 	(list 'caar caar)
526 	(list 'cadr cadr)
527 	(list 'cddr cddr)
528         (list 'cons cons)
529 	(list 'list list)
530         (list 'null? null?)
531 	(list '* *)
532 	(list '/ /)
533 	(list '+ +)
534 	(list '- -)
535 	(list '= =)
536 	(list '< <)
537 	(list '> >)
538 	(list '<= <=)
539 	(list '>= >=)
540 	(list 'remainder remainder)
541 	(list 'eq? eq?)
542 	(list 'equal? equal?)
543 	(list 'display display)))
544 (define (primitive-procedure-names)
545   (map car
546        primitive-procedures))
547 (define (primitive-procedure-objects)
548   (map (lambda (proc) (list 'primitive (cadr proc)))
549        primitive-procedures))
550 (define (apply-primitive-procedure proc args)
551   (apply
552    (primitive-implementation proc) args))
553 
554 ;; execute application
555 
556 (define (execute-application proc args succeed fail)
557   (cond ((primitive-procedure? proc)
558          (succeed (apply-primitive-procedure proc args)
559                   fail))
560         ((compound-procedure? proc)
561          ((procedure-body proc)
562           (extend-environment (procedure-parameters proc)
563                               args
564                               (procedure-environment proc))
565           succeed
566           fail))
567         (else
568          (error
569           "Unknown procedure type -- EXECUTE-APPLICATION"
570           proc))))
571 
572 
573 ;; driver-loop
574 (define (prompt-for-input string)
575   (newline) (newline) (display string) (newline))
576 (define (announce-output string)
577   (newline) (display string) (newline))
578 (define (user-print object)
579   (if (compound-procedure? object)
580       (display (list 'compound-procedure
581                      (procedure-parameters object)
582                      (procedure-body object)
583                      '<procedure-env>))
584       (display object)))
585 (define (setup-environment)
586   (let ((initial-env
587          (extend-environment (primitive-procedure-names)
588                              (primitive-procedure-objects)
589                              the-empty-environment)))
590     (define-variable! 'true true initial-env)
591     (define-variable! 'false false initial-env)
592     initial-env))
593 (define the-global-environment (setup-environment))
594 
595 (define input-prompt ";;; Amb-Eval input:")
596 (define output-prompt ";;; Amb-Eval value:")
597 (define (driver-loop)
598   (define (internal-loop try-again)
599     (prompt-for-input input-prompt)
600     (let ((input (read)))
601       (if (eq? input 'try-again)
602           (try-again)
603           (begin
604             (newline)
605             (display ";;; Starting a new problem ")
606             (ambeval input
607                      the-global-environment
608                      ;; ambeval success
609                      (lambda (val next-alternative)
610                        (announce-output output-prompt)
611                        (user-print val)
612                        (internal-loop next-alternative))
613                      ;; ambeval failure
614                      (lambda ()
615                        (announce-output
616                         ";;; There are no more values of")
617                        (user-print input)
618                        (driver-loop)))))))
619   (internal-loop
620    (lambda ()
621      (newline)
622      (display ";;; There is no current problem")
623      (driver-loop))))
624 
625 
626 ;; auxiliary
627 (define (test-case actual expected)
628   (newline)
629   (display "Actual:   ")
630   (display actual)
631   (newline)
632   (display "Expected: ")
633   (display expected)
634   (newline))
635 (define try-again
636   (lambda ()
637     "No current problem"))
638 (define (geval exp) ;; eval globally
639   (if (eq? exp 'try-again)
640       (try-again)
641       (ambeval exp 
642 	       the-global-environment
643 	       (lambda (val next-alternative)
644 		 (set! try-again next-alternative)
645 		 val)
646 	       (lambda ()
647 		 (set! try-again
648 		       (lambda ()
649 			 "No current problem"))
650 		 "No alternatives"))))
651 (define (test-eval exp expected)
652   (test-case (geval exp) expected))
653 
654 
655 ;; test-suite
656 
657 ;; procedure definitions
658 
659 (geval 
660  '(define (assoc key records)
661     (cond ((null? records) false)
662 	  ((equal? key (caar records)) (car records))
663 	  (else (assoc key (cdr records))))))
664 
665 (geval
666  '(define (map proc list)
667     (if (null? list)
668 	'()
669 	(cons (proc (car list))
670 	      (map proc (cdr list))))))
671 
672 (geval 
673  '(define (accumulate op initial sequence)
674     (if (null? sequence)
675 	initial
676 	(op (car sequence)
677 	    (accumulate op initial (cdr sequence))))))
678 
679 ;; ;; all special forms
680 (test-eval '(begin 5 6) 6)
681 (test-eval '10 10)
682 (geval '(define x 3))
683 (test-eval 'x 3)
684 (test-eval '(set! x -25) 'ok)
685 (test-eval 'x -25)
686 (geval '(define z (lambda (x y) (+ x (* x y)))))
687 (test-eval '(z 3 4) 15)
688 (test-eval '(cond ((= x -2) 'x=-2)
689 		  ((= x -25) 'x=-25)
690 		  (else 'failed))
691 	   'x=-25)
692 (test-eval '(if true false true) false)
693 
694 (test-eval 
695  '(let ((x 4) (y 7))
696     (+ x y (* x y)))
697  (+ 4 7 (* 4 7)))
698 
699 
700 ;; and/or
701 (geval '(define x (+ 3 8)))
702 (test-eval '(and 0 true x) 11)
703 (test-eval '(and 0 true x false) false)
704 (test-eval '(and 0 true x (set! x -2) false) false)
705 (test-eval 'x -2)
706 (test-eval '(and 0 true x false (set! x -5)) false)
707 (test-eval 'x -2)
708 (test-eval '(or false (set! x 25)) 'ok)
709 (test-eval 'x 25)
710 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
711 (test-eval 'x 2)
712 (test-eval '(or false (set! x 25) true false) 'ok)
713 (test-eval 'x 25)
714 (test-eval '(or ((lambda (x) x) 5)) 5)
715 (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
716 (newline)
717 (display "Failure expected")
718 (newline)
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)
1031 
1032 ;; amb
1033 (test-eval '(amb 1 2 3) 1)
1034 (test-eval 'try-again 2)
1035 (test-eval 'try-again 3)
1036 (test-eval 'try-again "No alternatives")
1037 (test-eval 'try-again "No current problem")
1038 (test-eval 'try-again "No current problem")
1039 (test-eval '(amb (amb 1 2) (amb 'a 'b))
1040 	   1)
1041 (test-eval 'try-again 2)
1042 (test-eval 'try-again 'a)
1043 (test-eval 'try-again 'b)
1044 (test-eval 'try-again "No alternatives")
1045 (geval '(define (require p) (if (not p) (amb))))
1046 (test-eval '(require false) "No alternatives")
1047 (test-eval '(require true) false)
1048 
1049 	   
1050 ;; Exercise 4.35.  Write a procedure an-integer-between that returns an integer between two given bounds. This can be used to implement a procedure that finds Pythagorean triples, i.e., triples of integers (i,j,k) between the given bounds such that i < j and i2 + j2 = k2, as follows:
1051 
1052 (geval
1053  '(define (an-integer-between low high)
1054     (require (<= low high))
1055     (amb low (an-integer-between (+ low 1) high))))
1056 
1057 (geval 
1058  '(define (a-pythagorean-triple-between low high)
1059     (let ((i (an-integer-between low high)))
1060       (let ((j (an-integer-between i high)))
1061 	(let ((k (an-integer-between j high)))
1062 	  (require (= (+ (* i i) (* j j)) (* k k)))
1063 	  (list i j k))))))
1064 
1065 (test-eval
1066  '(a-pythagorean-triple-between 1 20)
1067  '(3 4 5))
1068 (test-eval 'try-again '(5 12 13))
1069 (test-eval 'try-again '(6 8 10))
1070 (test-eval 'try-again '(8 15 17))
1071 (test-eval 'try-again '(9 12 15))