blob: cc98c12398daed541a3f16bb9a74400576d4c66e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
;;;; Analyzing interpreter with AMB.
;;; Execution procedures take environment
;;; and two continuations: SUCCEED and FAIL
(define *amb-count* 0)
(define (show-amb-count)
(display "Number of alts considered: ")
(display *amb-count*)
(newline)
(set! *amb-count* 0))
(define (ambeval exp env succeed fail)
((analyze exp) env succeed fail))
(define analyze
(make-generic-operator 1
(lambda (exp)
(cond ((application? exp) (analyze-application exp))
(else (error "Unknown expression type" exp))))))
(define (analyze-self-evaluating exp)
(lambda (env succeed fail)
(succeed exp fail)))
(defhandler analyze analyze-self-evaluating self-evaluating?)
(define (analyze-quoted exp)
(let ((qval (text-of-quotation exp)))
(lambda (env succeed fail)
(succeed qval fail))))
(defhandler analyze analyze-quoted quoted?)
(define (analyze-variable exp)
(lambda (env succeed fail)
(succeed (lookup-variable-value exp env) fail)))
(defhandler analyze analyze-variable variable?)
(define (analyze-lambda exp)
(let ((vars (lambda-parameters exp))
(bproc (analyze (lambda-body exp))))
(lambda (env succeed fail)
(succeed (make-compound-procedure vars bproc env)
fail))))
(defhandler analyze analyze-lambda lambda?)
(define (analyze-if exp)
(let ((pproc (analyze (if-predicate exp)))
(cproc (analyze (if-consequent exp)))
(aproc (analyze (if-alternative exp))))
(lambda (env succeed fail)
(pproc env
(lambda (pred-value pred-fail)
(if (true? pred-value)
(cproc env succeed pred-fail)
(aproc env succeed pred-fail)))
fail))))
(defhandler analyze analyze-if if?)
(define (analyze-sequence exps)
(define (sequentially proc1 proc2)
(lambda (env succeed fail)
(proc1 env
(lambda (proc1-value proc1-fail)
(proc2 env succeed proc1-fail))
fail)))
(define (loop first-proc rest-procs)
(if (null? rest-procs)
first-proc
(loop (sequentially first-proc (car rest-procs))
(cdr rest-procs))))
(if (null? exps) (error "Empty sequence"))
(let ((procs (map analyze exps)))
(loop (car procs) (cdr procs))))
(defhandler analyze
(lambda (exp)
(analyze-sequence (begin-actions exp)))
begin?)
(define (analyze-application exp)
(let ((fproc (analyze (operator exp)))
(aprocs (map analyze (operands exp))))
(lambda (env succeed fail)
(fproc env
(lambda (proc proc-fail)
(get-args aprocs env
(lambda (args args-fail)
(execute-application proc
args
succeed
args-fail))
proc-fail))
fail))))
(define (get-args aprocs env succeed fail)
(cond ((null? aprocs) (succeed '() fail))
((null? (cdr aprocs))
((car aprocs) env
(lambda (arg fail)
(succeed (list arg) fail))
fail))
(else
((car aprocs) env
(lambda (arg fail)
(get-args (cdr aprocs) env
(lambda (args fail)
(succeed (cons arg args)
fail))
fail))
fail))))
(define execute-application
(make-generic-operator 4
(lambda (proc args succeed fail)
(error "Unknown procedure type" proc))))
(defhandler execute-application
(lambda (proc args succeed fail)
(succeed (apply-primitive-procedure proc args) fail))
strict-primitive-procedure?)
(defhandler execute-application
(lambda (proc args succeed fail)
((procedure-body proc)
(extend-environment (procedure-parameters proc)
args
(procedure-environment proc))
succeed
fail))
compound-procedure?)
;;; There are two useful kinds of assignments in AMB
;;; interpreters. Undoable assignments and permanent
;;; assignments. The default is the undoable assignment.
(define (analyze-undoable-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (new-val val-fail)
(let ((old-val (lookup-variable-value var env)))
(set-variable-value! var new-val env)
(succeed 'OK
(lambda ()
(set-variable-value! var old-val env)
(val-fail)))))
fail))))
(defhandler analyze
analyze-undoable-assignment
assignment?)
(define (analyze-permanent-assignment exp)
(let ((var (assignment-variable exp))
(vproc (analyze (assignment-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (new-val val-fail)
(set-variable-value! var new-val env)
(succeed 'OK fail))
fail))))
(defhandler analyze
analyze-permanent-assignment
permanent-assignment?)
(define (analyze-definition exp)
(let ((var (definition-variable exp))
(vproc (analyze (definition-value exp))))
(lambda (env succeed fail)
(vproc env
(lambda (new-val val-fail)
(define-variable! var new-val env)
(succeed var val-fail))
fail))))
(defhandler analyze analyze-definition definition?)
;;; AMB, itself!
(define (analyze-amb exp)
(let ((aprocs (map analyze (amb-alternatives exp))))
(lambda (env succeed fail)
(let loop ((alts aprocs))
(if (null? alts)
(fail)
(begin
(set! *amb-count* (+ 1 *amb-count*))
((car alts) env
succeed
(lambda ()
(loop (cdr alts))))))))))
(defhandler analyze analyze-amb amb?)
;;; Macros (definitions are in syntax.scm)
(defhandler analyze
(lambda (exp)
(analyze (cond->if exp)))
cond?)
(defhandler analyze
(lambda (exp)
(analyze (let->combination exp)))
let?)
|
