1,2c1,2
< ;;;;METACIRCULAR EVALUATOR THAT SEPARATES ANALYSIS FROM EXECUTION
< ;;;; FROM SECTION 4.1.7 OF STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
---
> ;;;;AMB EVALUATOR FROM SECTION 4.3 OF
> ;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
4c4,7
< ;;;;Matches code in ch4.scm
---
> ;;;;Matches code in ch4.scm.
> ;;;; To run the sample programs and exercises, code below also includes
> ;;;; -- enlarged primitive-procedures list
> ;;;; -- support for Let (as noted in footnote 56, p.428)
18c21
< ;;Note: It is loaded first so that the section 4.1.7 definition
---
> ;;Note: It is loaded first so that the section 4.2 definition
20c23
< (load "61a/lib/mceval.scm")
---
> (load "~/61a/lib/mceval.scm")
22d24
< ;;;SECTION 4.1.7
24,25d25
< (define (mc-eval exp env)
<   ((analyze exp) env))
26a27,33
> ;;;Code from SECTION 4.3.3, modified as needed to run it
> 
> (define (amb? exp) (tagged-list? exp 'amb))
> (define (amb-choices exp) (cdr exp))
> 
> ;; analyze from 4.1.6, with clause from 4.3.3 added
> ;; and also support for Let
37a45,46
>         ((let? exp) (analyze (let->combination exp))) ;**
>         ((amb? exp) (analyze-amb exp))                ;**
41a51,55
> (define (ambeval exp env succeed fail)
>   ((analyze exp) env succeed fail))
> 
> ;;;Simple expressions
> 
43c57,58
<   (lambda (env) exp))
---
>   (lambda (env succeed fail)
>     (succeed exp fail)))
47c62,63
<     (lambda (env) qval)))
---
>     (lambda (env succeed fail)
>       (succeed qval fail))))
50c66,68
<   (lambda (env) (lookup-variable-value exp env)))
---
>   (lambda (env succeed fail)
>     (succeed (lookup-variable-value exp env)
>              fail)))
52,57c70,75
< (define (analyze-assignment exp)
<   (let ((var (assignment-variable exp))
<         (vproc (analyze (assignment-value exp))))
<     (lambda (env)
<       (set-variable-value! var (vproc env) env)
<       'ok)))
---
> (define (analyze-lambda exp)
>   (let ((vars (lambda-parameters exp))
>         (bproc (analyze-sequence (lambda-body exp))))
>     (lambda (env succeed fail)
>       (succeed (make-procedure vars bproc env)
>                fail))))
59,64c77
< (define (analyze-definition exp)
<   (let ((var (definition-variable exp))
<         (vproc (analyze (definition-value exp))))
<     (lambda (env)
<       (define-variable! var (vproc env) env)
<       'ok)))
---
> ;;;Conditionals and sequences
70,73c83,92
<     (lambda (env)
<       (if (true? (pproc env))
<           (cproc env)
<           (aproc env)))))
---
>     (lambda (env succeed fail)
>       (pproc env
>              ;; success continuation for evaluating the predicate
>              ;; to obtain pred-value
>              (lambda (pred-value fail2)
>                (if (true? pred-value)
>                    (cproc env succeed fail2)
>                    (aproc env succeed fail2)))
>              ;; failure continuation for evaluating the predicate
>              fail))))
75,79d93
< (define (analyze-lambda exp)
<   (let ((vars (lambda-parameters exp))
<         (bproc (analyze-sequence (lambda-body exp))))
<     (lambda (env) (make-procedure vars bproc env))))
< 
81,82c95,102
<   (define (sequentially proc1 proc2)
<     (lambda (env) (proc1 env) (proc2 env)))
---
>   (define (sequentially a b)
>     (lambda (env succeed fail)
>       (a env
>          ;; success continuation for calling a
>          (lambda (a-value fail2)
>            (b env succeed fail2))
>          ;; failure continuation for calling a
>          fail)))
92a113,143
> ;;;Definitions and assignments
> 
> (define (analyze-definition exp)
>   (let ((var (definition-variable exp))
>         (vproc (analyze (definition-value exp))))
>     (lambda (env succeed fail)
>       (vproc env                        
>              (lambda (val fail2)
>                (define-variable! var val env)
>                (succeed 'ok fail2))
>              fail))))
> 
> (define (analyze-assignment exp)
>   (let ((var (assignment-variable exp))
>         (vproc (analyze (assignment-value exp))))
>     (lambda (env succeed fail)
>       (vproc env
>              (lambda (val fail2)        ; *1*
>                (let ((old-value
>                       (lookup-variable-value var env))) 
>                  (set-variable-value! var val env)
>                  (succeed 'ok
>                           (lambda ()    ; *2*
>                             (set-variable-value! var
>                                                  old-value
>                                                  env)
>                             (fail2)))))
>              fail))))
> 
> ;;;Procedure applications
> 
96,99c147,156
<     (lambda (env)
<       (execute-application (fproc env)
<                            (map (lambda (aproc) (aproc env))
<                                 aprocs)))))
---
>     (lambda (env succeed fail)
>       (fproc env
>              (lambda (proc fail2)
>                (get-args aprocs
>                          env
>                          (lambda (args fail3)
>                            (execute-application
>                             proc args succeed fail3))
>                          fail2))
>              fail))))
101c158,174
< (define (execute-application proc args)
---
> (define (get-args aprocs env succeed fail)
>   (if (null? aprocs)
>       (succeed '() fail)
>       ((car aprocs) env
>                     ;; success continuation for this aproc
>                     (lambda (arg fail2)
>                       (get-args (cdr aprocs)
>                                 env
>                                 ;; success continuation for recursive
>                                 ;; call to get-args
>                                 (lambda (args fail3)
>                                   (succeed (cons arg args)
>                                            fail3))
>                                 fail2))
>                     fail)))
> 
> (define (execute-application proc args succeed fail)
103c176,177
<          (apply-primitive-procedure proc args))
---
>          (succeed (apply-primitive-procedure proc args)
>                   fail))
108c182,184
<                               (procedure-environment proc))))
---
>                               (procedure-environment proc))
>           succeed
>           fail))
113a190,291
> ;;;amb expressions
> 
> (define (analyze-amb exp)
>   (let ((cprocs (map analyze (amb-choices exp))))
>     (lambda (env succeed fail)
>       (define (try-next choices)
>         (if (null? choices)
>             (fail)
>             ((car choices) env
>                            succeed
>                            (lambda ()
>                              (try-next (cdr choices))))))
>       (try-next cprocs))))
> 
> ;;;Driver loop
> 
> (define input-prompt ";;; Amb-Eval input:")
> (define output-prompt ";;; Amb-Eval value:")
> 
> (define (driver-loop)
>   (define (internal-loop try-again)
>     (prompt-for-input input-prompt)
>     (let ((input (read)))
>       (if (eq? input 'try-again)
>           (try-again)
>           (begin
>             (newline)
>             (display ";;; Starting a new problem ")
>             (ambeval input
>                      the-global-environment
>                      ;; ambeval success
>                      (lambda (val next-alternative)
>                        (announce-output output-prompt)
>                        (user-print val)
>                        (internal-loop next-alternative))
>                      ;; ambeval failure
>                      (lambda ()
>                        (announce-output
>                         ";;; There are no more values of")
>                        (user-print input)
>                        (driver-loop)))))))
>   (internal-loop
>    (lambda ()
>      (newline)
>      (display ";;; There is no current problem")
>      (driver-loop))))
> 
> 
> 
> ;;; Support for Let (as noted in footnote 56, p.428)
> 
> (define (let? exp) (tagged-list? exp 'let))
> (define (let-bindings exp) (cadr exp))
> (define (let-body exp) (cddr exp))
> 
> (define (let-var binding) (car binding))
> (define (let-val binding) (cadr binding))
> 
> (define (make-combination operator operands) (cons operator operands))
> 
> (define (let->combination exp)
>   ;;make-combination defined in earlier exercise
>   (let ((bindings (let-bindings exp)))
>     (make-combination (make-lambda (map let-var bindings)
>                                    (let-body exp))
>                       (map let-val bindings))))
>                      
> 
> 
> ;; A longer list of primitives -- suitable for running everything in 4.3
> ;; Overrides the list in ch4-mceval.scm
> ;; Has Not to support Require; various stuff for code in text (including
> ;;  support for Prime?); integer? and sqrt for exercise code;
> ;;  eq? for ex. solution
> 
> (define primitive-procedures
>   (list (list 'car car)
>         (list 'cdr cdr)
>         (list 'cons cons)
>         (list 'null? null?)
>         (list 'list list)
> 	(list 'append append)
>         (list 'memq memq)
>         (list 'member member)
>         (list 'not not)
>         (list '+ +)
>         (list '- -)
>         (list '* *)
>         (list '= =)
>         (list '> >)
>         (list '>= >=)
>         (list 'abs abs)
>         (list 'remainder remainder)
>         (list 'integer? integer?)
>         (list 'sqrt sqrt)
>         (list 'eq? eq?)
> 	(list 'equal? equal?)
> 	(list 'pair? pair?)
> ;;      more primitives
>         ))
> 
> 
116,117c294,300
< (define input-prompt ";;; A-Eval input:")
< (define output-prompt ";;; A-Eval value:")
---
> (define (mce)
>   (set! the-global-environment (setup-environment))
>   (ambeval '(define (require p) (if (not p) (amb)))
> 	   the-global-environment
> 	   (lambda (a b) #t)
> 	   (lambda () #t))
>   (driver-loop))