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