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