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         ((lambda? exp) (analyze-lambda exp))
14 	((let? exp) (analyze (let->combination exp)))
15 	((let*? exp) (analyze (let*->nested-lets exp)))
16 	((named-let? exp) (analyze (named-let->combination exp)))
17 	((letrec? exp) (analyze (letrec->let exp)))
18 	((do? exp) (analyze (do->combination exp)))
19         ((begin? exp) (analyze-sequence (begin-actions exp)))
20         ((cond? exp) (analyze (cond->if exp)))
21 	((amb? exp) (analyze-amb exp))
22 	((ramb? exp) (analyze-ramb 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
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 
227 ;; lambda/let/let*/letrec
228 (define (lambda? exp) (tagged-list? exp 'lambda))
229 (define (lambda-parameters exp) (cadr exp))
230 (define (lambda-body exp) (cddr exp))
231 (define (make-lambda parameters body)
232   (cons 'lambda (cons parameters body)))
233 
234 (define (make-let vars vals body)
235   (cons 'let
236 	(cons (map list vars vals)
237 	      body)))
238 (define (let? exp)
239   (and (tagged-list? exp 'let)
240        (not (symbol? (cadr exp)))))
241 (define (let-vars exp)
242   (map car (cadr exp)))
243 (define (let-vals exp)
244   (map cadr (cadr exp)))
245 (define (let-body exp)
246   (cddr exp))
247 (define (let->combination exp)
248   (make-application (make-lambda (let-vars exp) (let-body exp))
249 		    (let-vals exp)))
250 (define (named-let? exp)
251   (and (tagged-list? exp 'let)
252        (symbol? (cadr exp))))
253 (define (named-let-name exp)
254   (cadr exp))
255 (define (named-let-vars exp)
256   (map car (caddr exp)))
257 (define (named-let-vals exp)
258   (map cadr (caddr exp)))
259 (define (named-let-body exp)
260   (cdddr exp))
261 (define (named-let->combination exp)
262   (sequence->exp
263    (list (make-definition (named-let-name exp)
264 			  (make-lambda (named-let-vars exp)
265 				       (named-let-body exp)))
266 	 (make-application (named-let-name exp)
267 			   (named-let-vals exp)))))
268 (define (make-named-let name vars vals body)
269   (cons 'let 
270 	(cons name
271 	      (cons (map list vars vals)
272 		    body))))
273 
274 (define (letrec? exp)
275   (tagged-list? exp 'letrec))
276 
277 (define (letrec-vars exp)
278   (map car (cadr exp)))
279 (define (letrec-vals exp)
280   (map cadr (cadr exp)))
281 (define (letrec-body exp)
282   (cddr exp))
283 (define (letrec->let exp)
284   (let* ((vars (letrec-vars exp))
285 	 (unassigneds (map (lambda (var) ''*unassigned*)
286 			   vars))
287 	 (vals (letrec-vals exp))
288 	 (assignments (map (lambda (var val)
289 			     (make-assignment var val))
290 			   vars
291 			   vals))
292 	 (body (letrec-body exp)))
293   (make-let vars 
294 	    unassigneds
295 	    (append assignments body))))
296 
297 (define (make-application op args)
298   (cons op args))
299 
300 (define (let*? exp)
301   (tagged-list? exp 'let*))
302 (define let*-vars let-vars)
303 (define let*-vals let-vals)
304 (define let*-body let-body)
305 (define (let*->nested-lets exp)
306   (define (expand-lets vars vals)
307     (if (null? (cdr vars))
308 	(make-let (list (car vars)) 
309 		  (list (car vals))
310 		  (let*-body exp))
311 	(make-let (list (car vars))
312 		  (list (car vals))
313 		  (list (expand-lets (cdr vars) (cdr vals))))))
314   (let ((vars (let*-vars exp))
315 	(vals (let*-vals exp)))
316     (if (null? vars)
317 	(sequence->exp (let*-body exp))
318 	(expand-lets vars vals))))
319 
320 ;; do loop
321 (define (do? exp)
322   (tagged-list? exp 'do))
323 (define (do-vars exp)
324   (map car (cadr exp)))
325 (define (do-inits exp)
326   (map cadr (cadr exp)))
327 (define (do-steps exp)
328   (map (lambda (var-init-step)
329 	 (if (null? (cddr var-init-step))
330 	     (car var-init-step)
331 	     (caddr var-init-step)))
332        (cadr exp)))
333 (define (do-test exp)
334   (caaddr exp))
335 (define (do-expressions exp)
336   (if (null? (cdaddr exp))
337       (caddr exp)
338       (cdaddr exp)))
339 (define (do-commands exp)
340   (cdddr exp))
341 (define (do->combination exp)
342   (make-named-let
343    'do-iter
344    (do-vars exp)
345    (do-inits exp)
346    (list
347     (make-if
348      (do-test exp)
349      (sequence->exp (do-expressions exp))
350      (sequence->exp
351       (append (do-commands exp)
352 	      (list (make-application
353 		     'do-iter
354 		     (do-steps exp)))))))))
355 
356 
357 ;; begin/sequence
358 (define (begin? exp) (tagged-list? exp 'begin))
359 (define (begin-actions exp) (cdr exp))
360 (define (last-exp? seq) (null? (cdr seq)))
361 (define (first-exp seq) (car seq))
362 (define (rest-exps seq) (cdr seq))
363 (define (sequence->exp seq)
364   (cond ((null? seq) seq)
365         ((last-exp? seq) (first-exp seq))
366         (else (make-begin seq))))
367 (define (make-begin seq) (cons 'begin seq))
368 
369 ;; application
370 (define (application? exp) (pair? exp))
371 (define (operator exp) (car exp))
372 (define (operands exp) (cdr exp))
373 (define (no-operands? ops) (null? ops))
374 (define (first-operand ops) (car ops))
375 (define (rest-operands ops) (cdr ops))
376 
377 ;; cond
378 (define (cond? exp) (tagged-list? exp 'cond))
379 (define (cond-clauses exp) (cdr exp))
380 (define (cond-else-clause? clause)
381   (eq? (cond-predicate clause) 'else))
382 (define (cond-predicate clause) (car clause))
383 (define (cond-actions clause) (cdr clause))
384 (define (cond-extended-clause? clause)
385   (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
386 (define (cond-extended-proc clause)
387   (caddr clause))
388 (define (cond->if exp)
389   (expand-clauses (cond-clauses exp)))
390 (define (expand-clauses clauses)
391   (if (null? clauses)
392       'false                          ; no else clause
393       (let ((first (car clauses))
394             (rest (cdr clauses)))
395         (if (cond-else-clause? first)
396             (if (null? rest)
397                 (sequence->exp (cond-actions first))
398                 (error "ELSE clause isn't last -- COND->IF"
399                        clauses))
400 	    (if (cond-extended-clause? first)
401 		(make-if (cond-predicate first)
402 			 (make-application
403 			  (cond-extended-proc first)
404 			  (list (cond-predicate first)))
405 			 (expand-clauses rest))
406 		(make-if (cond-predicate first)
407 			 (sequence->exp (cond-actions first))
408 			 (expand-clauses rest)))))))
409 (define (true? x)
410   (not (eq? x false)))
411 (define (false? x)
412   (eq? x false))
413 
414 ;; procedure
415 (define (make-procedure parameters body env)
416   (list 'procedure parameters body env))
417 (define (scan-out-defines body)
418   (let* ((definitions (filter definition? body))
419 	 (vars (map definition-variable definitions))
420 	 (unassigneds (map (lambda (var) ''*unassigned*) 
421 			   vars))
422 	 (vals (map definition-value definitions))
423 	 (assignments 
424 	  (map (lambda (var val)
425 		 (make-assignment var val))
426 	       vars vals))
427 	 (exps (remove definition? body)))
428     (if (null? definitions)
429 	body
430 	(list
431 	 (make-let vars
432 		   unassigneds
433 		   (append assignments exps))))))
434 (define (compound-procedure? p)
435   (tagged-list? p 'procedure))
436 (define (procedure-parameters p) (cadr p))
437 (define (procedure-body p) (caddr p))
438 (define (procedure-environment p) (cadddr p))
439 
440 ;; environment
441 (define (enclosing-environment env) (cdr env))
442 (define (first-frame env) (car env))
443 (define the-empty-environment '())
444 (define (make-frame variables values)
445   (cons variables values))
446 (define (frame-variables frame) (car frame))
447 (define (frame-values frame) (cdr frame))
448 (define (add-binding-to-frame! var val frame)
449   (set-car! frame (cons var (car frame)))
450   (set-cdr! frame (cons val (cdr frame))))
451 (define (extend-environment vars vals base-env)
452   (if (= (length vars) (length vals))
453       (cons (make-frame vars vals) base-env)
454       (if (< (length vars) (length vals))
455           (error "Too many arguments supplied" vars vals)
456           (error "Too few arguments supplied" vars vals))))
457 (define (lookup-variable-value var env)
458   (define (env-loop env)
459     (define (scan vars vals)
460       (cond ((null? vars)
461              (env-loop (enclosing-environment env)))
462             ((eq? var (car vars))
463 	     (let ((val (car vals)))
464 	       (if (eq? val '*unassigned*)
465 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
466 		   val)))
467             (else (scan (cdr vars) (cdr vals)))))
468     (if (eq? env the-empty-environment)
469         (error "Unbound variable" var)
470         (let ((frame (first-frame env)))
471           (scan (frame-variables frame)
472                 (frame-values frame)))))
473   (env-loop env))
474 (define (set-variable-value! var val env)
475   (define (env-loop env)
476     (define (scan vars vals)
477       (cond ((null? vars)
478              (env-loop (enclosing-environment env)))
479             ((eq? var (car vars))
480              (set-car! vals val))
481             (else (scan (cdr vars) (cdr vals)))))
482     (if (eq? env the-empty-environment)
483         (error "Unbound variable -- SET!" var)
484         (let ((frame (first-frame env)))
485           (scan (frame-variables frame)
486                 (frame-values frame)))))
487   (env-loop env))
488 (define (define-variable! var val env)
489   (let ((frame (first-frame env)))
490     (define (scan vars vals)
491       (cond ((null? vars)
492              (add-binding-to-frame! var val frame))
493             ((eq? var (car vars))
494              (set-car! vals val))
495             (else (scan (cdr vars) (cdr vals)))))
496     (scan (frame-variables frame)
497           (frame-values frame))))
498 
499 ;; (define (remove-binding-from-frame! var frame)
500 ;;   (define (scan vars vals)
501 ;;     (cond ((null? (cdr vars))
502 ;; 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
503 ;; 	  ((eq? var (cadr vars))
504 ;; 	   (set-cdr! vars (cddr vars))
505 ;; 	   (set-cdr! vals (cddr vals)))
506 ;; 	  (else (scan (cdr vars) (cdr vals)))))
507 ;;   (let ((vars (frame-variables frame))
508 ;; 	(vals (frame-values frame)))
509 ;;     (if (eq? var (car vars))
510 ;; 	(begin (set-car! frame (cdr vars))
511 ;; 	       (set-cdr! frame (cdr vals)))
512 ;; 	(scan vars vals))))
513 
514 ;; primitives
515 (define (primitive-procedure? proc)
516   (tagged-list? proc 'primitive))
517 (define (primitive-implementation proc) (cadr proc))
518 (define primitive-procedures
519   (list (list 'car car)
520         (list 'cdr cdr)
521 	(list 'caar caar)
522 	(list 'cadr cadr)
523 	(list 'cddr cddr)
524         (list 'cons cons)
525         (list 'null? null?)
526 	(list '* *)
527 	(list '/ /)
528 	(list '+ +)
529 	(list '- -)
530 	(list '= =)
531 	(list '< <)
532 	(list '> >)
533 	(list '<= <=)
534 	(list '>= >=)
535 	(list 'remainder remainder)
536 	(list 'eq? eq?)
537 	(list 'equal? equal?)
538 	(list 'display display)))
539 (define (primitive-procedure-names)
540   (map car
541        primitive-procedures))
542 (define (primitive-procedure-objects)
543   (map (lambda (proc) (list 'primitive (cadr proc)))
544        primitive-procedures))
545 (define (apply-primitive-procedure proc args)
546   (apply
547    (primitive-implementation proc) args))
548 
549 ;; execute application
550 
551 (define (execute-application proc args succeed fail)
552   (cond ((primitive-procedure? proc)
553          (succeed (apply-primitive-procedure proc args)
554                   fail))
555         ((compound-procedure? proc)
556          ((procedure-body proc)
557           (extend-environment (procedure-parameters proc)
558                               args
559                               (procedure-environment proc))
560           succeed
561           fail))
562         (else
563          (error
564           "Unknown procedure type -- EXECUTE-APPLICATION"
565           proc))))
566 
567 
568 ;; driver-loop
569 (define (prompt-for-input string)
570   (newline) (newline) (display string) (newline))
571 (define (announce-output string)
572   (newline) (display string) (newline))
573 (define (user-print object)
574   (if (compound-procedure? object)
575       (display (list 'compound-procedure
576                      (procedure-parameters object)
577                      (procedure-body object)
578                      '<procedure-env>))
579       (display object)))
580 (define (setup-environment)
581   (let ((initial-env
582          (extend-environment (primitive-procedure-names)
583                              (primitive-procedure-objects)
584                              the-empty-environment)))
585     (define-variable! 'true true initial-env)
586     (define-variable! 'false false initial-env)
587     initial-env))
588 (define the-global-environment (setup-environment))
589 
590 (define input-prompt ";;; Amb-Eval input:")
591 (define output-prompt ";;; Amb-Eval value:")
592 (define (driver-loop)
593   (define (internal-loop try-again)
594     (prompt-for-input input-prompt)
595     (let ((input (read)))
596       (if (eq? input 'try-again)
597           (try-again)
598           (begin
599             (newline)
600             (display ";;; Starting a new problem ")
601             (ambeval input
602                      the-global-environment
603                      ;; ambeval success
604                      (lambda (val next-alternative)
605                        (announce-output output-prompt)
606                        (user-print val)
607                        (internal-loop next-alternative))
608                      ;; ambeval failure
609                      (lambda ()
610                        (announce-output
611                         ";;; There are no more values of")
612                        (user-print input)
613                        (driver-loop)))))))
614   (internal-loop
615    (lambda ()
616      (newline)
617      (display ";;; There is no current problem")
618      (driver-loop))))
619 
620 
621 ;; auxiliary
622 (define (test-case actual expected)
623   (newline)
624   (display "Actual:   ")
625   (display actual)
626   (newline)
627   (display "Expected: ")
628   (display expected)
629   (newline))
630 (define try-again
631   (lambda ()
632     "No current problem"))
633 (define (geval exp) ;; eval globally
634   (if (eq? exp 'try-again)
635       (try-again)
636       (ambeval exp 
637 	       the-global-environment
638 	       (lambda (val next-alternative)
639 		 (set! try-again next-alternative)
640 		 val)
641 	       (lambda ()
642 		 (set! try-again
643 		       (lambda ()
644 			 "No current problem"))
645 		 "No alternatives"))))
646 (define (test-eval exp expected)
647   (test-case (geval exp) expected))
648 
649 
650 ;; test-suite
651 
652 ;; procedure definitions
653 
654 (geval 
655  '(define (assoc key records)
656     (cond ((null? records) false)
657 	  ((equal? key (caar records)) (car records))
658 	  (else (assoc key (cdr records))))))
659 
660 (geval
661  '(define (map proc list)
662     (if (null? list)
663 	'()
664 	(cons (proc (car list))
665 	      (map proc (cdr list))))))
666 
667 (geval 
668  '(define (accumulate op initial sequence)
669     (if (null? sequence)
670 	initial
671 	(op (car sequence)
672 	    (accumulate op initial (cdr sequence))))))
673 
674 ;; ;; all special forms
675 (test-eval '(begin 5 6) 6)
676 (test-eval '10 10)
677 (geval '(define x 3))
678 (test-eval 'x 3)
679 (test-eval '(set! x -25) 'ok)
680 (test-eval 'x -25)
681 (geval '(define z (lambda (x y) (+ x (* x y)))))
682 (test-eval '(z 3 4) 15)
683 (test-eval '(cond ((= x -2) 'x=-2)
684 		  ((= x -25) 'x=-25)
685 		  (else 'failed))
686 	   'x=-25)
687 (test-eval '(if true false true) false)
688 
689 (test-eval 
690  '(let ((x 4) (y 7))
691     (+ x y (* x y)))
692  (+ 4 7 (* 4 7)))
693 
694 
695 ;; and/or
696 (geval '(define x (+ 3 8)))
697 (test-eval '(and 0 true x) 11)
698 (test-eval '(and 0 true x false) false)
699 (test-eval '(and 0 true x (set! x -2) false) false)
700 (test-eval 'x -2)
701 (test-eval '(and 0 true x false (set! x -5)) false)
702 (test-eval 'x -2)
703 (test-eval '(or false (set! x 25)) 'ok)
704 (test-eval 'x 25)
705 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
706 (test-eval 'x 2)
707 (test-eval '(or false (set! x 25) true false) 'ok)
708 (test-eval 'x 25)
709 (test-eval '(or ((lambda (x) x) 5)) 5)
710 (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
711 (newline)
712 (display "Failure expected")
713 (newline)
714 
715 ;; cond
716 
717 (test-eval 
718  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
719 	(else false))
720  2)
721 
722 (test-eval
723  '(cond ((= 3 4) 'not-true)
724 	((= (* 2 4) 3) 'also-false)
725 	((map (lambda (x)
726 		(* x (+ x 1)))
727 	      '(2 4 1 9))
728 	 =>
729 	 (lambda (x)
730 	   (accumulate + 0 x)))
731 	(else 'never-reach))
732  118)
733 ;; '(6 20 2 90)
734 
735 
736 ;; procedure definition and application
737 (geval
738  '(define (factorial n)
739     (if (= n 0)
740 	1
741 	(* n (factorial (- n 1))))))
742 (test-eval '(factorial 5) 120)
743 
744 ;; map
745 
746 (test-eval
747  '(map (lambda (x)
748 	 (* x (+ x 1)))
749        '(2 1 4 2 8 3))
750  '(6 2 20 6 72 12))
751 ;; accumulate
752 
753 (test-eval
754  '(accumulate + 0 '(1 2 3 4 5))
755  15)
756 
757 ;; make-let
758 (test-eval 
759  (make-let '(x y) '(3 5) '((+ x y)))
760  8)
761 (test-eval 
762  '(let ()
763     5)
764  5)
765 (test-eval
766  '(let ((x 3))
767     x)
768  3)
769 (test-eval
770  '(let ((x 3)
771 	(y 5))
772     (+ x y))
773  8)
774 (test-eval 
775  '(let ((x 3)
776 	(y 2))
777     (+ (let ((x (+ y 2))
778 	     (y x))
779 	 (* x y))
780        x y))
781  (+ (* 4 3) 3 2))
782 (test-eval
783  '(let ((x 6)
784 	(y (let ((x 2))
785 	     (+ x 3)))
786 	(z (let ((a (* 3 2)))
787 	     (+ a 3))))
788     (+ x y z))
789  (+ 6 5 9))
790     
791 
792 ;; let*
793 
794 (test-eval
795  '(let* ((x 3)
796 	 (y (+ x 2))
797 	 (z (+ x y 5)))
798     (* x z))
799  39)
800 
801 (test-eval
802  '(let* ()
803     5)
804  5)
805 (test-eval
806  '(let* ((x 3))
807     (let* ((y 5))
808       (+ x y)))
809  8)
810 
811 (test-eval 
812  '(let* ((x 3)
813 	 (y (+ x 1)))
814     (+ (let* ((x (+ y 2))
815 	      (y x))
816 	 (* x y))
817        x y))
818  (+ (* 6 6) 3 4))
819 (test-eval
820  '(let* ((x 6)
821 	 (y (let* ((x 2)
822 		   (a (let* ((x (* 3 x)))
823 			(+ x 2))))       
824 	      (+ x a)))                  
825 	 (z (+ x y)))                    
826     (+ x y z))
827  32)
828 
829 ;; named-let
830 
831 (test-eval
832  '(let eight ()
833     5
834     7
835     8)
836  8)
837 (test-eval
838  '(let loop ((count 0))
839     (if (= 100 count)
840 	count
841 	(loop (+ count 1))))
842  100)
843 (geval
844  '(define (prime? x)
845     (let prime-iter ((i 2))
846       (cond ((> (* i i) x) true)
847 	    ((= (remainder x i) 0) false)
848 	    (else (prime-iter (+ i 1)))))))
849 (test-eval
850  '(let primes ((x 2)
851 	       (n 20))
852     (cond ((= n 0) '())
853 	  ((prime? x) 
854 	   (cons x
855 		 (primes (+ x 1) (- n 1))))
856 	  (else (primes (+ x 1) n))))
857  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
858 
859 (geval
860  '(define (fib n)
861     (let fib-iter ((a 1)
862 		   (b 0)
863 		   (count n))
864       (if (= count 0)
865 	  b
866 	  (fib-iter (+ a b) a (- count 1))))))
867 (test-eval '(fib 19) 4181)
868 
869 ;; do-loop	  
870 (test-eval
871  '(let ((y 0))
872     (do ((x 0 (+ x 1)))
873 	((= x 5) y)
874       (set! y (+ y 1))))
875  5)
876 (test-eval
877  '(do ()
878       (true))
879  true)
880 (test-eval
881  '(do ()
882       (true 5))
883  5)
884 (test-eval
885  '(let ((y 0))
886     (do ()
887 	((= y 5) y)
888       (set! y (+ y 1))))
889  5)
890 
891 (test-eval
892  '(do ((y '(1 2 3 4)))
893       ((null? y))
894     (set! y (cdr y)))
895  true)
896 (test-eval
897  '(let ((y 0))
898     (do ((x 0 (+ x 1)))
899 	((= x 5) y)
900       (set! y (+ y 1))))
901  5)
902 (test-eval
903  '(let ((x '(1 3 5 7 9)))
904     (do ((x x (cdr x))
905 	 (sum 0 (+ sum (car x))))
906 	((null? x) sum)))
907  25)
908 (test-eval 
909  '(let ((z '()))
910     (do ((x '(1 2 3 4) (cdr x))
911 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
912 	((null? x) y x z)
913       (set! z (cons (car x) z))))
914  '(4 3 2 1))
915 
916 
917 
918 ;; make-unbound!
919 ;; broken now due to scan-out-defines
920 
921 ;; (test-eval
922 ;;  '(let ((x 3))
923 ;;     (let ((x 5))
924 ;;       (make-unbound! x)
925 ;;       (* x x)))
926 ;;  9)
927 
928 ;; (test-eval
929 ;;  '(let ((x 3))
930 ;;     (let ((x 5))
931 ;;       (define y x)
932 ;;       (make-unbound! x)
933 ;;       (* y x)))
934 ;;  15)
935 
936 ;; (test-eval
937 ;;  '(let ((y -1) (x 3))
938 ;;     (let ((y 0.5) (x 5))
939 ;;       (define a x)
940 ;;       (define b y)
941 ;;       (make-unbound! x)
942 ;;       (make-unbound! y)
943 ;;       (* a b x y)))
944 ;;  (* 5 3 -1 0.5))
945 
946 ;; (test-eval
947 ;;  '(let ((x 3) (y 4))
948 ;;     (let ((x 5))
949 ;;       (make-unbound! x)
950 ;;       (+ x 4)))
951 ;;  7)
952 
953 ;; (test-eval 
954 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
955 ;;     (make-unbound! b)
956 ;;     (+ a c d))
957 ;;  (+ 1 3 4))
958 
959 ;; (test-eval
960 ;;  '(let ((x 4) (y 5))
961 ;;     (let ((a 1) (b 2) (c 3))
962 ;;       (let ((x (+ a b)) (y (+ c a)))
963 ;; 	(make-unbound! x)
964 ;; 	(let ((a x) (b (+ x y)))
965 ;; 	  (define z b)
966 ;; 	  (make-unbound! b)
967 ;; 	  (* (+ a z)
968 ;; 	     (+ a b y))))))
969 ;;  (* (+ 4 8)
970 ;;     (+ 4 2 4)))
971  
972 ;; x 3 -- y 4
973 ;; x 4 -- y 4
974 ;; a 4 -- b 4
975 ;; a 4 -- b 2
976 
977 ;; scan-out-defines
978 
979 (geval
980  '(define (f x)
981     (define (even? n)
982       (if (= n 0)
983 	  true
984 	  (odd? (- n 1))))
985     (define (odd? n)
986       (if (= n 0)
987 	  false
988 	  (even? (- n 1))))
989     (even? x)))
990 (test-eval '(f 5) false)
991 (test-eval '(f 10) true)
992 
993 ;; ;; (geval
994 ;; ;;  '(let ((x 5))
995 ;; ;;     (define y x)
996 ;; ;;     (define x 3)
997 ;; ;;     (+ x y)))
998 ;; ;; signal an error because x is undefined if variables are scanned out
999 
1000 ;; ;; letrec
1001 
1002 ;; (geval
1003 ;;  '(define (f x)
1004 ;;     (letrec ((even?
1005 ;; 	      (lambda (n)
1006 ;; 		(if (= n 0)
1007 ;; 		    true
1008 ;; 		    (odd? (- n 1)))))
1009 ;; 	     (odd?
1010 ;; 	      (lambda (n)
1011 ;; 		(if (= n 0)
1012 ;; 		    false
1013 ;; 		    (even? (- n 1))))))
1014 ;;       (even? x))))
1015 ;; (test-eval '(f 11) false)
1016 ;; (test-eval '(f 16) true)
1017 
1018 ;; (test-eval 
1019 ;;  '(letrec ((fact
1020 ;; 	    (lambda (n)
1021 ;; 	      (if (= n 1)
1022 ;; 		  1
1023 ;; 		  (* n (fact (- n 1)))))))
1024 ;;     (fact 10))
1025 ;;  3628800)
1026 
1027 ;; amb
1028 (test-eval '(amb 1 2 3) 1)
1029 (test-eval 'try-again 2)
1030 (test-eval 'try-again 3)
1031 (test-eval 'try-again "No alternatives")
1032 (test-eval 'try-again "No current problem")
1033 (test-eval 'try-again "No current problem")
1034 (test-eval '(amb (amb 1 2) (amb 'a 'b))
1035 	   1)
1036 (test-eval 'try-again 2)
1037 (test-eval 'try-again 'a)
1038 (test-eval 'try-again 'b)
1039 (test-eval 'try-again "No alternatives")
1040 
1041 	  
1042 	   
1043 ;; Exercise 4.50.  Implement a new special form ramb that is like amb except that it searches alternatives in a random order, rather than from left to right. Show how this can help with Alyssa's problem in exercise 4.49. 
1044 
1045 (ramb <exp1> <exp2> ... <expN>)
1046 (define (ramb? exp)
1047   (tagged-list? exp 'ramb))
1048 (define (ramb-choices exp)
1049   (cdr exp))
1050