1 665c255d 2023-08-04 jrmu (define (make-machine register-names ops controller-text)
2 665c255d 2023-08-04 jrmu (let ((machine (make-new-machine)))
3 665c255d 2023-08-04 jrmu (for-each (lambda (register-name)
4 665c255d 2023-08-04 jrmu ((machine 'allocate-register) register-name))
5 665c255d 2023-08-04 jrmu register-names)
6 665c255d 2023-08-04 jrmu ((machine 'install-operations) ops)
7 665c255d 2023-08-04 jrmu ((machine 'install-instruction-sequence)
8 665c255d 2023-08-04 jrmu (assemble controller-text machine))
10 665c255d 2023-08-04 jrmu (define (make-register name)
11 665c255d 2023-08-04 jrmu (let ((contents '*unassigned*))
12 665c255d 2023-08-04 jrmu (define (dispatch message)
13 665c255d 2023-08-04 jrmu (cond ((eq? message 'get) contents)
14 665c255d 2023-08-04 jrmu ((eq? message 'set)
15 665c255d 2023-08-04 jrmu (lambda (value) (set! contents value)))
17 665c255d 2023-08-04 jrmu (error "Unknown request -- REGISTER" message))))
19 665c255d 2023-08-04 jrmu (define (get-contents register)
20 665c255d 2023-08-04 jrmu (register 'get))
21 665c255d 2023-08-04 jrmu (define (set-contents! register value)
22 665c255d 2023-08-04 jrmu ((register 'set) value))
23 665c255d 2023-08-04 jrmu (define (make-stack)
24 665c255d 2023-08-04 jrmu (let ((s '())
25 665c255d 2023-08-04 jrmu (number-pushes 0)
26 665c255d 2023-08-04 jrmu (max-depth 0)
27 665c255d 2023-08-04 jrmu (current-depth 0))
28 665c255d 2023-08-04 jrmu (define (push x)
29 665c255d 2023-08-04 jrmu (set! s (cons x s))
30 665c255d 2023-08-04 jrmu (set! number-pushes (+ 1 number-pushes))
31 665c255d 2023-08-04 jrmu (set! current-depth (+ 1 current-depth))
32 665c255d 2023-08-04 jrmu (set! max-depth (max current-depth max-depth)))
33 665c255d 2023-08-04 jrmu (define (pop)
34 665c255d 2023-08-04 jrmu (if (null? s)
35 665c255d 2023-08-04 jrmu (error "Empty stack -- POP")
36 665c255d 2023-08-04 jrmu (let ((top (car s)))
37 665c255d 2023-08-04 jrmu (set! s (cdr s))
38 665c255d 2023-08-04 jrmu (set! current-depth (- current-depth 1))
40 665c255d 2023-08-04 jrmu (define (initialize)
41 665c255d 2023-08-04 jrmu (set! s '())
42 665c255d 2023-08-04 jrmu (set! number-pushes 0)
43 665c255d 2023-08-04 jrmu (set! max-depth 0)
44 665c255d 2023-08-04 jrmu (set! current-depth 0)
46 665c255d 2023-08-04 jrmu (define (print-statistics)
48 665c255d 2023-08-04 jrmu (display (list 'total-pushes '= number-pushes
49 665c255d 2023-08-04 jrmu 'maximum-depth '= max-depth)))
50 665c255d 2023-08-04 jrmu (define (dispatch message)
51 665c255d 2023-08-04 jrmu (cond ((eq? message 'push) push)
52 665c255d 2023-08-04 jrmu ((eq? message 'pop) (pop))
53 665c255d 2023-08-04 jrmu ((eq? message 'initialize) (initialize))
54 665c255d 2023-08-04 jrmu ((eq? message 'print-statistics)
55 665c255d 2023-08-04 jrmu (print-statistics))
57 665c255d 2023-08-04 jrmu (error "Unknown request -- STACK" message))))
59 665c255d 2023-08-04 jrmu (define (pop stack)
60 665c255d 2023-08-04 jrmu (stack 'pop))
61 665c255d 2023-08-04 jrmu (define (push stack value)
62 665c255d 2023-08-04 jrmu ((stack 'push) value))
63 665c255d 2023-08-04 jrmu (define (make-new-machine)
64 665c255d 2023-08-04 jrmu (let ((pc (make-register 'pc))
65 665c255d 2023-08-04 jrmu (flag (make-register 'flag))
66 665c255d 2023-08-04 jrmu (stack (make-stack))
67 665c255d 2023-08-04 jrmu (the-instruction-sequence '()))
68 665c255d 2023-08-04 jrmu (let ((the-ops
69 665c255d 2023-08-04 jrmu (list (list 'initialize-stack
70 665c255d 2023-08-04 jrmu (lambda () (stack 'initialize)))
71 665c255d 2023-08-04 jrmu (list 'print-stack-statistics
72 665c255d 2023-08-04 jrmu (lambda () (stack 'print-statistics)))))
73 665c255d 2023-08-04 jrmu (register-table
74 665c255d 2023-08-04 jrmu (list (list 'pc pc) (list 'flag flag))))
75 665c255d 2023-08-04 jrmu (define (allocate-register name)
76 665c255d 2023-08-04 jrmu (if (assoc name register-table)
77 665c255d 2023-08-04 jrmu (error "Multiply defined register: " name)
78 665c255d 2023-08-04 jrmu (set! register-table
79 665c255d 2023-08-04 jrmu (cons (list name (make-register name))
80 665c255d 2023-08-04 jrmu register-table)))
81 665c255d 2023-08-04 jrmu 'register-allocated)
82 665c255d 2023-08-04 jrmu (define (lookup-register name)
83 665c255d 2023-08-04 jrmu (let ((val (assoc name register-table)))
86 665c255d 2023-08-04 jrmu (error "Unknown register:" name))))
87 665c255d 2023-08-04 jrmu (define (execute)
88 665c255d 2023-08-04 jrmu (let ((insts (get-contents pc)))
89 665c255d 2023-08-04 jrmu (if (null? insts)
92 665c255d 2023-08-04 jrmu ((instruction-execution-proc (car insts)))
93 665c255d 2023-08-04 jrmu (execute)))))
94 665c255d 2023-08-04 jrmu (define (dispatch message)
95 665c255d 2023-08-04 jrmu (cond ((eq? message 'start)
96 665c255d 2023-08-04 jrmu (set-contents! pc the-instruction-sequence)
98 665c255d 2023-08-04 jrmu ((eq? message 'install-instruction-sequence)
99 665c255d 2023-08-04 jrmu (lambda (seq) (set! the-instruction-sequence seq)))
100 665c255d 2023-08-04 jrmu ((eq? message 'allocate-register) allocate-register)
101 665c255d 2023-08-04 jrmu ((eq? message 'get-register) lookup-register)
102 665c255d 2023-08-04 jrmu ((eq? message 'install-operations)
103 665c255d 2023-08-04 jrmu (lambda (ops) (set! the-ops (append the-ops ops))))
104 665c255d 2023-08-04 jrmu ((eq? message 'stack) stack)
105 665c255d 2023-08-04 jrmu ((eq? message 'operations) the-ops)
106 665c255d 2023-08-04 jrmu (else (error "Unknown request -- MACHINE" message))))
107 665c255d 2023-08-04 jrmu dispatch)))
108 665c255d 2023-08-04 jrmu (define (start machine)
109 665c255d 2023-08-04 jrmu (machine 'start))
110 665c255d 2023-08-04 jrmu (define (get-register-contents machine register-name)
111 665c255d 2023-08-04 jrmu (get-contents (get-register machine register-name)))
112 665c255d 2023-08-04 jrmu (define (set-register-contents! machine register-name value)
113 665c255d 2023-08-04 jrmu (set-contents! (get-register machine register-name) value)
115 665c255d 2023-08-04 jrmu (define (get-register machine reg-name)
116 665c255d 2023-08-04 jrmu ((machine 'get-register) reg-name))
117 665c255d 2023-08-04 jrmu (define (assemble controller-text machine)
118 665c255d 2023-08-04 jrmu (extract-labels controller-text
119 665c255d 2023-08-04 jrmu (lambda (insts labels)
120 665c255d 2023-08-04 jrmu (update-insts! insts labels machine)
122 665c255d 2023-08-04 jrmu (define (extract-labels text receive)
123 665c255d 2023-08-04 jrmu (if (null? text)
124 665c255d 2023-08-04 jrmu (receive '() '())
125 665c255d 2023-08-04 jrmu (extract-labels (cdr text)
126 665c255d 2023-08-04 jrmu (lambda (insts labels)
127 665c255d 2023-08-04 jrmu (let ((next-inst (car text)))
128 665c255d 2023-08-04 jrmu (if (symbol? next-inst)
129 665c255d 2023-08-04 jrmu (if (label-defined? labels next-inst)
130 665c255d 2023-08-04 jrmu (error "Duplicate label -- ASSEMBLE"
134 665c255d 2023-08-04 jrmu (cons (make-label-entry next-inst
138 665c255d 2023-08-04 jrmu (cons (make-instruction next-inst)
140 665c255d 2023-08-04 jrmu labels)))))))
141 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
142 665c255d 2023-08-04 jrmu (let ((pc (get-register machine 'pc))
143 665c255d 2023-08-04 jrmu (flag (get-register machine 'flag))
144 665c255d 2023-08-04 jrmu (stack (machine 'stack))
145 665c255d 2023-08-04 jrmu (ops (machine 'operations)))
147 665c255d 2023-08-04 jrmu (lambda (inst)
148 665c255d 2023-08-04 jrmu (set-instruction-execution-proc!
150 665c255d 2023-08-04 jrmu (make-execution-procedure
151 665c255d 2023-08-04 jrmu (instruction-text inst) labels machine
152 665c255d 2023-08-04 jrmu pc flag stack ops)))
154 665c255d 2023-08-04 jrmu (define (make-instruction text)
155 665c255d 2023-08-04 jrmu (cons text '()))
156 665c255d 2023-08-04 jrmu (define (instruction-text inst)
157 665c255d 2023-08-04 jrmu (car inst))
158 665c255d 2023-08-04 jrmu (define (instruction-execution-proc inst)
159 665c255d 2023-08-04 jrmu (cdr inst))
160 665c255d 2023-08-04 jrmu (define (set-instruction-execution-proc! inst proc)
161 665c255d 2023-08-04 jrmu (set-cdr! inst proc))
162 665c255d 2023-08-04 jrmu (define (make-label-entry label-name insts)
163 665c255d 2023-08-04 jrmu (cons label-name insts))
164 665c255d 2023-08-04 jrmu (define (label-defined? labels label-name)
165 665c255d 2023-08-04 jrmu (not (false? (assoc label-name labels))))
166 665c255d 2023-08-04 jrmu (define (lookup-label labels label-name)
167 665c255d 2023-08-04 jrmu (let ((val (assoc label-name labels)))
170 665c255d 2023-08-04 jrmu (error "Undefined label -- ASSEMBLE" label-name))))
171 665c255d 2023-08-04 jrmu (define (make-execution-procedure inst labels machine
172 665c255d 2023-08-04 jrmu pc flag stack ops)
173 665c255d 2023-08-04 jrmu (cond ((eq? (car inst) 'assign)
174 665c255d 2023-08-04 jrmu (make-assign inst machine labels ops pc))
175 665c255d 2023-08-04 jrmu ((eq? (car inst) 'test)
176 665c255d 2023-08-04 jrmu (make-test inst machine labels ops flag pc))
177 665c255d 2023-08-04 jrmu ((eq? (car inst) 'branch)
178 665c255d 2023-08-04 jrmu (make-branch inst machine labels flag pc))
179 665c255d 2023-08-04 jrmu ((eq? (car inst) 'goto)
180 665c255d 2023-08-04 jrmu (make-goto inst machine labels pc))
181 665c255d 2023-08-04 jrmu ((eq? (car inst) 'save)
182 665c255d 2023-08-04 jrmu (make-save inst machine stack pc))
183 665c255d 2023-08-04 jrmu ((eq? (car inst) 'restore)
184 665c255d 2023-08-04 jrmu (make-restore inst machine stack pc))
185 665c255d 2023-08-04 jrmu ((eq? (car inst) 'perform)
186 665c255d 2023-08-04 jrmu (make-perform inst machine labels ops pc))
187 665c255d 2023-08-04 jrmu (else (error "Unknown instruction type -- ASSEMBLE"
189 665c255d 2023-08-04 jrmu (define (make-assign inst machine labels operations pc)
190 665c255d 2023-08-04 jrmu (let ((target
191 665c255d 2023-08-04 jrmu (get-register machine (assign-reg-name inst)))
192 665c255d 2023-08-04 jrmu (value-exp (assign-value-exp inst)))
193 665c255d 2023-08-04 jrmu (let ((value-proc
194 665c255d 2023-08-04 jrmu (if (operation-exp? value-exp)
195 665c255d 2023-08-04 jrmu (make-operation-exp
196 665c255d 2023-08-04 jrmu value-exp machine labels operations)
197 665c255d 2023-08-04 jrmu (make-primitive-exp
198 665c255d 2023-08-04 jrmu (car value-exp) machine labels))))
199 665c255d 2023-08-04 jrmu (lambda () ; execution procedure for assign
200 665c255d 2023-08-04 jrmu (set-contents! target (value-proc))
201 665c255d 2023-08-04 jrmu (advance-pc pc)))))
202 665c255d 2023-08-04 jrmu (define (assign-reg-name assign-instruction)
203 665c255d 2023-08-04 jrmu (cadr assign-instruction))
204 665c255d 2023-08-04 jrmu (define (assign-value-exp assign-instruction)
205 665c255d 2023-08-04 jrmu (cddr assign-instruction))
206 665c255d 2023-08-04 jrmu (define (advance-pc pc)
207 665c255d 2023-08-04 jrmu (set-contents! pc (cdr (get-contents pc))))
208 665c255d 2023-08-04 jrmu (define (make-test inst machine labels operations flag pc)
209 665c255d 2023-08-04 jrmu (let ((condition (test-condition inst)))
210 665c255d 2023-08-04 jrmu (if (operation-exp? condition)
211 665c255d 2023-08-04 jrmu (let ((condition-proc
212 665c255d 2023-08-04 jrmu (make-operation-exp
213 665c255d 2023-08-04 jrmu condition machine labels operations)))
215 665c255d 2023-08-04 jrmu (set-contents! flag (condition-proc))
216 665c255d 2023-08-04 jrmu (advance-pc pc)))
217 665c255d 2023-08-04 jrmu (error "Bad TEST instruction -- ASSEMBLE" inst))))
218 665c255d 2023-08-04 jrmu (define (test-condition test-instruction)
219 665c255d 2023-08-04 jrmu (cdr test-instruction))
220 665c255d 2023-08-04 jrmu (define (make-branch inst machine labels flag pc)
221 665c255d 2023-08-04 jrmu (let ((dest (branch-dest inst)))
222 665c255d 2023-08-04 jrmu (if (label-exp? dest)
223 665c255d 2023-08-04 jrmu (let ((insts
224 665c255d 2023-08-04 jrmu (lookup-label labels (label-exp-label dest))))
226 665c255d 2023-08-04 jrmu (if (get-contents flag)
227 665c255d 2023-08-04 jrmu (set-contents! pc insts)
228 665c255d 2023-08-04 jrmu (advance-pc pc))))
229 665c255d 2023-08-04 jrmu (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
230 665c255d 2023-08-04 jrmu (define (branch-dest branch-instruction)
231 665c255d 2023-08-04 jrmu (cadr branch-instruction))
232 665c255d 2023-08-04 jrmu (define (make-goto inst machine labels pc)
233 665c255d 2023-08-04 jrmu (let ((dest (goto-dest inst)))
234 665c255d 2023-08-04 jrmu (cond ((label-exp? dest)
235 665c255d 2023-08-04 jrmu (let ((insts
236 665c255d 2023-08-04 jrmu (lookup-label labels
237 665c255d 2023-08-04 jrmu (label-exp-label dest))))
238 665c255d 2023-08-04 jrmu (lambda () (set-contents! pc insts))))
239 665c255d 2023-08-04 jrmu ((register-exp? dest)
241 665c255d 2023-08-04 jrmu (get-register machine
242 665c255d 2023-08-04 jrmu (register-exp-reg dest))))
244 665c255d 2023-08-04 jrmu (set-contents! pc (get-contents reg)))))
245 665c255d 2023-08-04 jrmu (else (error "Bad GOTO instruction -- ASSEMBLE"
247 665c255d 2023-08-04 jrmu (define (goto-dest goto-instruction)
248 665c255d 2023-08-04 jrmu (cadr goto-instruction))
249 665c255d 2023-08-04 jrmu (define (make-stack-pair reg-name contents)
250 665c255d 2023-08-04 jrmu (cons reg-name contents))
251 665c255d 2023-08-04 jrmu (define (stack-pair-reg-name pair)
252 665c255d 2023-08-04 jrmu (car pair))
253 665c255d 2023-08-04 jrmu (define (stack-pair-val pair)
254 665c255d 2023-08-04 jrmu (cdr pair))
255 665c255d 2023-08-04 jrmu (define (make-save inst machine stack pc)
256 665c255d 2023-08-04 jrmu (let* ((reg-name (stack-inst-reg-name inst))
257 665c255d 2023-08-04 jrmu (reg (get-register machine reg-name)))
259 665c255d 2023-08-04 jrmu (push stack (make-stack-pair reg-name (get-contents reg)))
260 665c255d 2023-08-04 jrmu (advance-pc pc))))
261 665c255d 2023-08-04 jrmu (define (make-restore inst machine stack pc)
262 665c255d 2023-08-04 jrmu (let* ((reg-name (stack-inst-reg-name inst))
263 665c255d 2023-08-04 jrmu (reg (get-register machine reg-name)))
265 665c255d 2023-08-04 jrmu (let* ((stack-pair (pop stack))
266 665c255d 2023-08-04 jrmu (stack-reg-name (stack-pair-reg-name stack-pair))
267 665c255d 2023-08-04 jrmu (stack-val (stack-pair-val stack-pair)))
268 665c255d 2023-08-04 jrmu (if (eq? stack-reg-name reg-name)
269 665c255d 2023-08-04 jrmu (begin (set-contents! reg stack-val)
270 665c255d 2023-08-04 jrmu (advance-pc pc))
271 665c255d 2023-08-04 jrmu (error "Stack/register mismatch -- Save/Restore: "
272 665c255d 2023-08-04 jrmu stack-reg-name reg-name))))))
273 665c255d 2023-08-04 jrmu (define (stack-inst-reg-name stack-instruction)
274 665c255d 2023-08-04 jrmu (cadr stack-instruction))
275 665c255d 2023-08-04 jrmu (define (make-perform inst machine labels operations pc)
276 665c255d 2023-08-04 jrmu (let ((action (perform-action inst)))
277 665c255d 2023-08-04 jrmu (if (operation-exp? action)
278 665c255d 2023-08-04 jrmu (let ((action-proc
279 665c255d 2023-08-04 jrmu (make-operation-exp
280 665c255d 2023-08-04 jrmu action machine labels operations)))
282 665c255d 2023-08-04 jrmu (action-proc)
283 665c255d 2023-08-04 jrmu (advance-pc pc)))
284 665c255d 2023-08-04 jrmu (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
285 665c255d 2023-08-04 jrmu (define (perform-action inst) (cdr inst))
286 665c255d 2023-08-04 jrmu (define (make-primitive-exp exp machine labels)
287 665c255d 2023-08-04 jrmu (cond ((constant-exp? exp)
288 665c255d 2023-08-04 jrmu (let ((c (constant-exp-value exp)))
289 665c255d 2023-08-04 jrmu (lambda () c)))
290 665c255d 2023-08-04 jrmu ((label-exp? exp)
291 665c255d 2023-08-04 jrmu (let ((insts
292 665c255d 2023-08-04 jrmu (lookup-label labels
293 665c255d 2023-08-04 jrmu (label-exp-label exp))))
294 665c255d 2023-08-04 jrmu (lambda () insts)))
295 665c255d 2023-08-04 jrmu ((register-exp? exp)
296 665c255d 2023-08-04 jrmu (let ((r (get-register machine
297 665c255d 2023-08-04 jrmu (register-exp-reg exp))))
298 665c255d 2023-08-04 jrmu (lambda () (get-contents r))))
300 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ASSEMBLE" exp))))
301 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
302 665c255d 2023-08-04 jrmu (and (pair? exp) (eq? (car exp) tag)))
303 665c255d 2023-08-04 jrmu (define (register-exp? exp) (tagged-list? exp 'reg))
304 665c255d 2023-08-04 jrmu (define (register-exp-reg exp) (cadr exp))
305 665c255d 2023-08-04 jrmu (define (constant-exp? exp) (tagged-list? exp 'const))
306 665c255d 2023-08-04 jrmu (define (constant-exp-value exp) (cadr exp))
307 665c255d 2023-08-04 jrmu (define (label-exp? exp) (tagged-list? exp 'label))
308 665c255d 2023-08-04 jrmu (define (label-exp-label exp) (cadr exp))
309 665c255d 2023-08-04 jrmu (define (make-operation-exp exp machine labels operations)
310 665c255d 2023-08-04 jrmu (let ((op (lookup-prim (operation-exp-op exp) operations))
312 665c255d 2023-08-04 jrmu (map (lambda (e)
313 665c255d 2023-08-04 jrmu ;; (if (label-exp? e)
314 665c255d 2023-08-04 jrmu ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
316 665c255d 2023-08-04 jrmu (make-primitive-exp e machine labels))
317 665c255d 2023-08-04 jrmu (operation-exp-operands exp))))
319 665c255d 2023-08-04 jrmu (apply op (map (lambda (p) (p)) aprocs)))))
320 665c255d 2023-08-04 jrmu (define (operation-exp? exp)
321 665c255d 2023-08-04 jrmu (and (pair? exp) (tagged-list? (car exp) 'op)))
322 665c255d 2023-08-04 jrmu (define (operation-exp-op operation-exp)
323 665c255d 2023-08-04 jrmu (cadr (car operation-exp)))
324 665c255d 2023-08-04 jrmu (define (operation-exp-operands operation-exp)
325 665c255d 2023-08-04 jrmu (cdr operation-exp))
326 665c255d 2023-08-04 jrmu (define (lookup-prim symbol operations)
327 665c255d 2023-08-04 jrmu (let ((val (assoc symbol operations)))
330 665c255d 2023-08-04 jrmu (error "Unknown operation -- ASSEMBLE" symbol))))
332 665c255d 2023-08-04 jrmu ;; test suite
334 665c255d 2023-08-04 jrmu (define (test-case actual expected)
336 665c255d 2023-08-04 jrmu (display "Actual: ")
337 665c255d 2023-08-04 jrmu (display actual)
339 665c255d 2023-08-04 jrmu (display "Expected: ")
340 665c255d 2023-08-04 jrmu (display expected)
343 665c255d 2023-08-04 jrmu (define gcd-machine
344 665c255d 2023-08-04 jrmu (make-machine
346 665c255d 2023-08-04 jrmu (list (list 'rem remainder) (list '= =))
348 665c255d 2023-08-04 jrmu (test (op =) (reg b) (const 0))
349 665c255d 2023-08-04 jrmu (branch (label gcd-done))
350 665c255d 2023-08-04 jrmu (assign t (op rem) (reg a) (reg b))
351 665c255d 2023-08-04 jrmu (assign a (reg b))
352 665c255d 2023-08-04 jrmu (assign b (reg t))
353 665c255d 2023-08-04 jrmu (goto (label test-b))
354 665c255d 2023-08-04 jrmu gcd-done)))
355 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'a 206)
356 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'b 40)
357 665c255d 2023-08-04 jrmu (start gcd-machine)
358 665c255d 2023-08-04 jrmu (test-case (get-register-contents gcd-machine 'a) 2)
360 665c255d 2023-08-04 jrmu (define fib-machine
361 665c255d 2023-08-04 jrmu (make-machine
362 665c255d 2023-08-04 jrmu '(n val continue)
363 665c255d 2023-08-04 jrmu `((< ,<) (- ,-) (+ ,+))
364 665c255d 2023-08-04 jrmu '(controller
365 665c255d 2023-08-04 jrmu (assign continue (label fib-done))
367 665c255d 2023-08-04 jrmu (test (op <) (reg n) (const 2))
368 665c255d 2023-08-04 jrmu (branch (label immediate-answer))
369 665c255d 2023-08-04 jrmu (save continue)
370 665c255d 2023-08-04 jrmu (assign continue (label afterfib-n-1))
372 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
373 665c255d 2023-08-04 jrmu (goto (label fib-loop))
374 665c255d 2023-08-04 jrmu afterfib-n-1
375 665c255d 2023-08-04 jrmu (restore n)
376 665c255d 2023-08-04 jrmu (restore continue)
377 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 2))
378 665c255d 2023-08-04 jrmu (save continue)
379 665c255d 2023-08-04 jrmu (assign continue (label afterfib-n-2))
381 665c255d 2023-08-04 jrmu (goto (label fib-loop))
382 665c255d 2023-08-04 jrmu afterfib-n-2
383 665c255d 2023-08-04 jrmu (assign n (reg val))
384 665c255d 2023-08-04 jrmu (restore val)
385 665c255d 2023-08-04 jrmu (restore continue)
386 665c255d 2023-08-04 jrmu (assign val
387 665c255d 2023-08-04 jrmu (op +) (reg val) (reg n))
388 665c255d 2023-08-04 jrmu (goto (reg continue))
389 665c255d 2023-08-04 jrmu immediate-answer
390 665c255d 2023-08-04 jrmu (assign val (reg n))
391 665c255d 2023-08-04 jrmu (goto (reg continue))
392 665c255d 2023-08-04 jrmu fib-done)))
393 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'val 0)
394 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'n 15)
395 665c255d 2023-08-04 jrmu (start fib-machine)
396 665c255d 2023-08-04 jrmu (test-case (get-register-contents fib-machine 'val) 610)
398 665c255d 2023-08-04 jrmu (define fact-iter
399 665c255d 2023-08-04 jrmu (make-machine
400 665c255d 2023-08-04 jrmu '(product counter n)
401 665c255d 2023-08-04 jrmu `((> ,>) (* ,*) (+ ,+))
402 665c255d 2023-08-04 jrmu '((assign product (const 1))
403 665c255d 2023-08-04 jrmu (assign counter (const 1))
405 665c255d 2023-08-04 jrmu (test (op >) (reg counter) (reg n))
406 665c255d 2023-08-04 jrmu (branch (label fact-end))
407 665c255d 2023-08-04 jrmu (assign product (op *) (reg counter) (reg product))
408 665c255d 2023-08-04 jrmu (assign counter (op +) (reg counter) (const 1))
409 665c255d 2023-08-04 jrmu (goto (label fact-loop))
410 665c255d 2023-08-04 jrmu fact-end)))
411 665c255d 2023-08-04 jrmu (set-register-contents! fact-iter 'n 10)
412 665c255d 2023-08-04 jrmu (start fact-iter)
413 665c255d 2023-08-04 jrmu (test-case (get-register-contents fact-iter 'product) 3628800)
415 665c255d 2023-08-04 jrmu (define (sqrt x)
416 665c255d 2023-08-04 jrmu (define (good-enough? guess)
417 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
418 665c255d 2023-08-04 jrmu (define (improve guess)
419 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
420 665c255d 2023-08-04 jrmu (define (sqrt-iter guess)
421 665c255d 2023-08-04 jrmu (if (good-enough? guess)
423 665c255d 2023-08-04 jrmu (sqrt-iter (improve guess))))
424 665c255d 2023-08-04 jrmu (sqrt-iter 1.0))
426 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
427 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
428 665c255d 2023-08-04 jrmu (define (improve guess x)
429 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
430 665c255d 2023-08-04 jrmu (define (average x y)
431 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
432 665c255d 2023-08-04 jrmu (define sqrt-iter-ops
433 665c255d 2023-08-04 jrmu (make-machine
435 665c255d 2023-08-04 jrmu `((good-enough? ,good-enough?)
436 665c255d 2023-08-04 jrmu (improve ,improve)
438 665c255d 2023-08-04 jrmu (square ,square)
439 665c255d 2023-08-04 jrmu (average ,average)
443 665c255d 2023-08-04 jrmu '((assign guess (const 1.0))
445 665c255d 2023-08-04 jrmu (test (op good-enough?) (reg guess) (reg x))
446 665c255d 2023-08-04 jrmu (branch (label sqrt-done))
447 665c255d 2023-08-04 jrmu (assign guess (op improve) (reg guess) (reg x))
448 665c255d 2023-08-04 jrmu (goto (label sqrt-iter))
449 665c255d 2023-08-04 jrmu sqrt-done)))
451 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 27)
452 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
453 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
454 665c255d 2023-08-04 jrmu 5.19615242)
456 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
457 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
458 665c255d 2023-08-04 jrmu (define (improve guess x)
459 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
460 665c255d 2023-08-04 jrmu (define (average x y)
461 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
462 665c255d 2023-08-04 jrmu (define sqrt-iter
463 665c255d 2023-08-04 jrmu (make-machine
464 665c255d 2023-08-04 jrmu '(guess x temp)
465 665c255d 2023-08-04 jrmu `((abs ,abs)
466 665c255d 2023-08-04 jrmu (square ,square)
467 665c255d 2023-08-04 jrmu (average ,average)
471 665c255d 2023-08-04 jrmu '((assign guess (const 1.0))
473 665c255d 2023-08-04 jrmu ;; (test (op good-enough?) (reg guess) (reg x))
474 665c255d 2023-08-04 jrmu (assign temp (op square) (reg guess))
475 665c255d 2023-08-04 jrmu (assign temp (op -) (reg temp) (reg x))
476 665c255d 2023-08-04 jrmu (assign temp (op abs) (reg temp))
477 665c255d 2023-08-04 jrmu (test (op <) (reg temp) (const 0.001))
478 665c255d 2023-08-04 jrmu (branch (label sqrt-done))
479 665c255d 2023-08-04 jrmu ;; (assign guess (op improve) (reg guess) (reg x))
480 665c255d 2023-08-04 jrmu (assign temp (op /) (reg x) (reg guess))
481 665c255d 2023-08-04 jrmu (assign guess (op average) (reg guess) (reg temp))
482 665c255d 2023-08-04 jrmu (goto (label sqrt-iter))
483 665c255d 2023-08-04 jrmu sqrt-done)))
484 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 91)
485 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
486 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
487 665c255d 2023-08-04 jrmu 9.53939201)
489 665c255d 2023-08-04 jrmu (define (expt b n)
490 665c255d 2023-08-04 jrmu (if (= n 0)
492 665c255d 2023-08-04 jrmu (* b (expt b (- n 1)))))
494 665c255d 2023-08-04 jrmu (define expt-rec
495 665c255d 2023-08-04 jrmu (make-machine
496 665c255d 2023-08-04 jrmu '(b n product continue)
500 665c255d 2023-08-04 jrmu '((assign continue (label expt-done))
502 665c255d 2023-08-04 jrmu (test (op =) (reg n) (const 0))
503 665c255d 2023-08-04 jrmu (branch (label base-case))
504 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
505 665c255d 2023-08-04 jrmu (save continue)
506 665c255d 2023-08-04 jrmu (assign continue (label after-b-n-1))
507 665c255d 2023-08-04 jrmu (goto (label expt-rec))
508 665c255d 2023-08-04 jrmu after-b-n-1
509 665c255d 2023-08-04 jrmu (restore continue)
510 665c255d 2023-08-04 jrmu (assign product (op *) (reg b) (reg product))
511 665c255d 2023-08-04 jrmu (goto (reg continue))
513 665c255d 2023-08-04 jrmu (assign product (const 1))
514 665c255d 2023-08-04 jrmu (goto (reg continue))
515 665c255d 2023-08-04 jrmu expt-done)))
517 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'b 3.2)
518 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'n 6)
519 665c255d 2023-08-04 jrmu (start expt-rec)
520 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-rec 'product)
521 665c255d 2023-08-04 jrmu 1073.74182)
523 665c255d 2023-08-04 jrmu (define (expt b n)
524 665c255d 2023-08-04 jrmu (define (expt-iter counter product)
525 665c255d 2023-08-04 jrmu (if (= counter 0)
527 665c255d 2023-08-04 jrmu (expt-iter (- counter 1) (* b product))))
528 665c255d 2023-08-04 jrmu (expt-iter n 1))
530 665c255d 2023-08-04 jrmu (define expt-iter
531 665c255d 2023-08-04 jrmu (make-machine
532 665c255d 2023-08-04 jrmu '(b n counter product)
536 665c255d 2023-08-04 jrmu '((assign counter (reg n))
537 665c255d 2023-08-04 jrmu (assign product (const 1))
539 665c255d 2023-08-04 jrmu (test (op =) (reg counter) (const 0))
540 665c255d 2023-08-04 jrmu (branch (label expt-iter-done))
541 665c255d 2023-08-04 jrmu (assign counter (op -) (reg counter) (const 1))
542 665c255d 2023-08-04 jrmu (assign product (op *) (reg b) (reg product))
543 665c255d 2023-08-04 jrmu (goto (label expt-iter))
544 665c255d 2023-08-04 jrmu expt-iter-done)))
545 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'b 1.6)
546 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'n 17)
547 665c255d 2023-08-04 jrmu (start expt-iter)
548 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-iter 'product)
549 665c255d 2023-08-04 jrmu 2951.47905)
551 665c255d 2023-08-04 jrmu ;; (define amb-machine
552 665c255d 2023-08-04 jrmu ;; (make-machine
556 665c255d 2023-08-04 jrmu ;; (goto (label here))
558 665c255d 2023-08-04 jrmu ;; (assign a (const 3))
559 665c255d 2023-08-04 jrmu ;; (goto (label there))
561 665c255d 2023-08-04 jrmu ;; (assign a (const 4))
562 665c255d 2023-08-04 jrmu ;; (goto (label there))
563 665c255d 2023-08-04 jrmu ;; there)))
565 665c255d 2023-08-04 jrmu ;; (start amb-machine)
566 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents amb-machine 'a)
568 665c255d 2023-08-04 jrmu ;; this now raises an error
570 665c255d 2023-08-04 jrmu (define fact-rec
571 665c255d 2023-08-04 jrmu (make-machine
572 665c255d 2023-08-04 jrmu '(n val continue)
573 665c255d 2023-08-04 jrmu `((= ,=) (- ,-) (* ,*))
574 665c255d 2023-08-04 jrmu '((assign continue (label fact-done)) ; set up final return address
576 665c255d 2023-08-04 jrmu (test (op =) (reg n) (const 1))
577 665c255d 2023-08-04 jrmu (branch (label base-case))
578 665c255d 2023-08-04 jrmu ;; Set up for the recursive call by saving n and continue.
579 665c255d 2023-08-04 jrmu ;; Set up continue so that the computation will continue
580 665c255d 2023-08-04 jrmu ;; at after-fact when the subroutine returns.
581 665c255d 2023-08-04 jrmu (save continue)
583 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
584 665c255d 2023-08-04 jrmu (assign continue (label after-fact))
585 665c255d 2023-08-04 jrmu (goto (label fact-loop))
587 665c255d 2023-08-04 jrmu (restore n)
588 665c255d 2023-08-04 jrmu (restore continue)
589 665c255d 2023-08-04 jrmu (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
590 665c255d 2023-08-04 jrmu (goto (reg continue)) ; return to caller
592 665c255d 2023-08-04 jrmu (assign val (const 1)) ; base case: 1! = 1
593 665c255d 2023-08-04 jrmu (goto (reg continue)) ; return to caller
595 665c255d 2023-08-04 jrmu (perform (op print-stack-statistics)))))
597 665c255d 2023-08-04 jrmu (define count-leaves-rec
598 665c255d 2023-08-04 jrmu (make-machine
599 665c255d 2023-08-04 jrmu '(tree val continue)
600 665c255d 2023-08-04 jrmu `((pair? ,pair?)
601 665c255d 2023-08-04 jrmu (null? ,null?)
605 665c255d 2023-08-04 jrmu '((assign continue (label count-leaves-done))
606 665c255d 2023-08-04 jrmu count-leaves
607 665c255d 2023-08-04 jrmu (test (op null?) (reg tree))
608 665c255d 2023-08-04 jrmu (branch (label null-tree))
609 665c255d 2023-08-04 jrmu (test (op pair?) (reg tree))
610 665c255d 2023-08-04 jrmu (branch (label pair-tree))
611 665c255d 2023-08-04 jrmu (assign val (const 1))
612 665c255d 2023-08-04 jrmu (goto (reg continue))
614 665c255d 2023-08-04 jrmu (save continue)
615 665c255d 2023-08-04 jrmu (save tree)
616 665c255d 2023-08-04 jrmu (assign tree (op car) (reg tree))
617 665c255d 2023-08-04 jrmu (assign continue (label left-tree-done))
618 665c255d 2023-08-04 jrmu (goto (label count-leaves))
619 665c255d 2023-08-04 jrmu left-tree-done
620 665c255d 2023-08-04 jrmu (restore tree)
621 665c255d 2023-08-04 jrmu (assign tree (op cdr) (reg tree))
622 665c255d 2023-08-04 jrmu (assign continue (label right-tree-done))
624 665c255d 2023-08-04 jrmu (goto (label count-leaves))
625 665c255d 2023-08-04 jrmu right-tree-done
626 665c255d 2023-08-04 jrmu (assign tree (reg val))
627 665c255d 2023-08-04 jrmu (restore val)
628 665c255d 2023-08-04 jrmu (assign val (op +) (reg tree) (reg val))
629 665c255d 2023-08-04 jrmu (restore continue)
630 665c255d 2023-08-04 jrmu (goto (reg continue))
632 665c255d 2023-08-04 jrmu (assign val (const 0))
633 665c255d 2023-08-04 jrmu (goto (reg continue))
634 665c255d 2023-08-04 jrmu count-leaves-done)))
636 665c255d 2023-08-04 jrmu (set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
637 665c255d 2023-08-04 jrmu (start count-leaves-rec)
638 665c255d 2023-08-04 jrmu (test-case (get-register-contents count-leaves-rec 'val)
641 665c255d 2023-08-04 jrmu (define count-leaves-iter
642 665c255d 2023-08-04 jrmu (make-machine
643 665c255d 2023-08-04 jrmu '(tree n val continue)
644 665c255d 2023-08-04 jrmu `((null? ,null?)
645 665c255d 2023-08-04 jrmu (pair? ,pair?)
649 665c255d 2023-08-04 jrmu '((assign n (const 0))
650 665c255d 2023-08-04 jrmu (assign continue (label count-iter-done))
652 665c255d 2023-08-04 jrmu (test (op null?) (reg tree))
653 665c255d 2023-08-04 jrmu (branch (label null-tree))
654 665c255d 2023-08-04 jrmu (test (op pair?) (reg tree))
655 665c255d 2023-08-04 jrmu (branch (label pair-tree))
656 665c255d 2023-08-04 jrmu (assign val (op +) (reg n) (const 1))
657 665c255d 2023-08-04 jrmu (goto (reg continue))
659 665c255d 2023-08-04 jrmu (assign val (reg n))
660 665c255d 2023-08-04 jrmu (goto (reg continue))
662 665c255d 2023-08-04 jrmu (save continue)
663 665c255d 2023-08-04 jrmu (save tree)
664 665c255d 2023-08-04 jrmu (assign continue (label left-tree-done))
665 665c255d 2023-08-04 jrmu (assign tree (op car) (reg tree))
666 665c255d 2023-08-04 jrmu (goto (label count-iter))
667 665c255d 2023-08-04 jrmu left-tree-done
668 665c255d 2023-08-04 jrmu (assign n (reg val))
669 665c255d 2023-08-04 jrmu (restore tree)
670 665c255d 2023-08-04 jrmu (assign tree (op cdr) (reg tree))
671 665c255d 2023-08-04 jrmu (restore continue)
672 665c255d 2023-08-04 jrmu (goto (label count-iter))
673 665c255d 2023-08-04 jrmu count-iter-done)))
675 665c255d 2023-08-04 jrmu (set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
676 665c255d 2023-08-04 jrmu (start count-leaves-iter)
677 665c255d 2023-08-04 jrmu (test-case (get-register-contents count-leaves-iter 'val)
679 665c255d 2023-08-04 jrmu (set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
680 665c255d 2023-08-04 jrmu (start count-leaves-iter)
681 665c255d 2023-08-04 jrmu (test-case (get-register-contents count-leaves-iter 'val)
684 665c255d 2023-08-04 jrmu (define (append x y)
685 665c255d 2023-08-04 jrmu (if (null? x)
687 665c255d 2023-08-04 jrmu (cons (car x) (append (cdr x) y))))
689 665c255d 2023-08-04 jrmu (define append-machine
690 665c255d 2023-08-04 jrmu (make-machine
691 665c255d 2023-08-04 jrmu '(x y carx val continue)
692 665c255d 2023-08-04 jrmu `((cons ,cons)
695 665c255d 2023-08-04 jrmu (null? ,null?))
696 665c255d 2023-08-04 jrmu '((assign continue (label append-done))
698 665c255d 2023-08-04 jrmu (test (op null?) (reg x))
699 665c255d 2023-08-04 jrmu (branch (label null-x))
700 665c255d 2023-08-04 jrmu (assign carx (op car) (reg x))
701 665c255d 2023-08-04 jrmu (save carx)
702 665c255d 2023-08-04 jrmu (assign x (op cdr) (reg x))
703 665c255d 2023-08-04 jrmu (save continue)
704 665c255d 2023-08-04 jrmu (assign continue (label after-null-x))
705 665c255d 2023-08-04 jrmu (goto (label append))
707 665c255d 2023-08-04 jrmu (assign val (reg y))
708 665c255d 2023-08-04 jrmu (goto (reg continue))
709 665c255d 2023-08-04 jrmu after-null-x
710 665c255d 2023-08-04 jrmu (restore continue)
711 665c255d 2023-08-04 jrmu (restore carx)
712 665c255d 2023-08-04 jrmu (assign val (op cons) (reg carx) (reg val))
713 665c255d 2023-08-04 jrmu (goto (reg continue))
714 665c255d 2023-08-04 jrmu append-done)))
715 665c255d 2023-08-04 jrmu (set-register-contents! append-machine 'x '(a (b c) ((d) e)))
716 665c255d 2023-08-04 jrmu (set-register-contents! append-machine 'y '(((f g) (h)) i))
717 665c255d 2023-08-04 jrmu (start append-machine)
718 665c255d 2023-08-04 jrmu (test-case (get-register-contents append-machine 'val)
719 665c255d 2023-08-04 jrmu '(a (b c) ((d) e) ((f g) (h)) i))
721 665c255d 2023-08-04 jrmu (define append!-machine
722 665c255d 2023-08-04 jrmu (make-machine
723 665c255d 2023-08-04 jrmu '(x y cdrx)
724 665c255d 2023-08-04 jrmu `((set-cdr! ,set-cdr!)
726 665c255d 2023-08-04 jrmu (null? ,null?))
728 665c255d 2023-08-04 jrmu (assign cdrx (op cdr) (reg x))
730 665c255d 2023-08-04 jrmu (test (op null?) (reg cdrx))
731 665c255d 2023-08-04 jrmu (branch (label set-cdr!))
732 665c255d 2023-08-04 jrmu (assign x (reg cdrx))
733 665c255d 2023-08-04 jrmu (assign cdrx (op cdr) (reg x))
734 665c255d 2023-08-04 jrmu (goto (label last-pair))
736 665c255d 2023-08-04 jrmu (perform (op set-cdr!) (reg x) (reg y))
737 665c255d 2023-08-04 jrmu (restore x)
738 665c255d 2023-08-04 jrmu append!-done)))
739 665c255d 2023-08-04 jrmu (define (append! x y)
740 665c255d 2023-08-04 jrmu (set-cdr! (last-pair x) y)
743 665c255d 2023-08-04 jrmu (define (last-pair x)
744 665c255d 2023-08-04 jrmu (if (null? (cdr x))
746 665c255d 2023-08-04 jrmu (last-pair (cdr x))))
748 665c255d 2023-08-04 jrmu (set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
749 665c255d 2023-08-04 jrmu (set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
750 665c255d 2023-08-04 jrmu (start append!-machine)
751 665c255d 2023-08-04 jrmu (test-case (get-register-contents append!-machine 'x)
752 665c255d 2023-08-04 jrmu '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
754 665c255d 2023-08-04 jrmu ;; procedures from metacircular evaluator
758 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
759 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
760 665c255d 2023-08-04 jrmu (define (announce-output string)
761 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
762 665c255d 2023-08-04 jrmu (define (user-print object)
763 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
764 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
765 665c255d 2023-08-04 jrmu (procedure-parameters object)
766 665c255d 2023-08-04 jrmu (procedure-body object)
767 665c255d 2023-08-04 jrmu '<procedure-env>))
768 665c255d 2023-08-04 jrmu (display object)))
770 665c255d 2023-08-04 jrmu ;; self-evaluating/variables/quoted
772 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
773 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
774 665c255d 2023-08-04 jrmu ((string? exp) true)
775 665c255d 2023-08-04 jrmu (else false)))
776 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
777 665c255d 2023-08-04 jrmu (define (quoted? exp)
778 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
779 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
780 665c255d 2023-08-04 jrmu (define (assignment? exp)
781 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
783 665c255d 2023-08-04 jrmu ;; assignments/definitions
785 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
786 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
787 665c255d 2023-08-04 jrmu (define (definition? exp)
788 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
789 665c255d 2023-08-04 jrmu (define (definition-variable exp)
790 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
792 665c255d 2023-08-04 jrmu (caadr exp)))
793 665c255d 2023-08-04 jrmu (define (definition-value exp)
794 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
795 665c255d 2023-08-04 jrmu (caddr exp)
796 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
797 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
801 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
802 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
803 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
804 665c255d 2023-08-04 jrmu (define (if-alternative exp)
805 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
806 665c255d 2023-08-04 jrmu (cadddr exp)
808 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
809 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
812 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
813 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
814 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
815 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
816 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
817 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
818 665c255d 2023-08-04 jrmu (define (cond->if exp)
819 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
820 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
821 665c255d 2023-08-04 jrmu (if (null? clauses)
822 665c255d 2023-08-04 jrmu 'false ; no else clause
823 665c255d 2023-08-04 jrmu (let ((first (car clauses))
824 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
825 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
826 665c255d 2023-08-04 jrmu (if (null? rest)
827 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
828 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
830 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
831 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
832 665c255d 2023-08-04 jrmu (expand-clauses rest))))))
837 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
838 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
839 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
840 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
841 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
842 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
843 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
845 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
846 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
850 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
852 665c255d 2023-08-04 jrmu (cons (map list vars vals)
854 665c255d 2023-08-04 jrmu (define (let? exp)
855 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
856 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
857 665c255d 2023-08-04 jrmu (define (let-vars exp)
858 665c255d 2023-08-04 jrmu (map car (cadr exp)))
859 665c255d 2023-08-04 jrmu (define (let-vals exp)
860 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
861 665c255d 2023-08-04 jrmu (define (let-body exp)
862 665c255d 2023-08-04 jrmu (cddr exp))
863 665c255d 2023-08-04 jrmu (define (let->combination exp)
864 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
865 665c255d 2023-08-04 jrmu (let-vals exp)))
866 665c255d 2023-08-04 jrmu (define (make-application op args)
867 665c255d 2023-08-04 jrmu (cons op args))
871 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
872 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
873 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
874 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
875 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
876 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
877 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
878 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
879 665c255d 2023-08-04 jrmu (else (make-begin seq))))
880 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
882 665c255d 2023-08-04 jrmu ;; applications
884 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
885 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
886 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
887 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
888 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
889 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
890 665c255d 2023-08-04 jrmu (define (empty-arglist) '())
891 665c255d 2023-08-04 jrmu (define (adjoin-arg arg arglist)
892 665c255d 2023-08-04 jrmu (append arglist (list arg)))
893 665c255d 2023-08-04 jrmu (define (last-operand? ops)
894 665c255d 2023-08-04 jrmu (null? (cdr ops)))
896 665c255d 2023-08-04 jrmu ;; true/false
898 665c255d 2023-08-04 jrmu (define (true? x)
899 665c255d 2023-08-04 jrmu (not (eq? x false)))
900 665c255d 2023-08-04 jrmu (define (false? x)
901 665c255d 2023-08-04 jrmu (eq? x false))
903 665c255d 2023-08-04 jrmu ;; compound procedures
905 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
906 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
907 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
908 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
909 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
911 665c255d 2023-08-04 jrmu ;; environment procedures/data structures
913 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
914 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
915 665c255d 2023-08-04 jrmu (define the-empty-environment '())
916 665c255d 2023-08-04 jrmu (define (make-frame variables values)
917 665c255d 2023-08-04 jrmu (cons variables values))
918 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
919 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
920 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
921 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
922 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
923 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
924 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
925 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
926 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
927 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
928 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
929 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
930 665c255d 2023-08-04 jrmu (define (env-loop env)
931 665c255d 2023-08-04 jrmu (define (scan vars vals)
932 665c255d 2023-08-04 jrmu (cond ((null? vars)
933 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
934 665c255d 2023-08-04 jrmu ((eq? var (car vars))
935 665c255d 2023-08-04 jrmu (let ((val (car vals)))
936 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
937 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
939 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
940 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
941 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
942 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
943 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
944 665c255d 2023-08-04 jrmu (frame-values frame)))))
945 665c255d 2023-08-04 jrmu (env-loop env))
946 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
947 665c255d 2023-08-04 jrmu (define (env-loop env)
948 665c255d 2023-08-04 jrmu (define (scan vars vals)
949 665c255d 2023-08-04 jrmu (cond ((null? vars)
950 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
951 665c255d 2023-08-04 jrmu ((eq? var (car vars))
952 665c255d 2023-08-04 jrmu (set-car! vals val))
953 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
954 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
955 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
956 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
957 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
958 665c255d 2023-08-04 jrmu (frame-values frame)))))
959 665c255d 2023-08-04 jrmu (env-loop env))
960 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
961 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
962 665c255d 2023-08-04 jrmu (define (scan vars vals)
963 665c255d 2023-08-04 jrmu (cond ((null? vars)
964 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
965 665c255d 2023-08-04 jrmu ((eq? var (car vars))
966 665c255d 2023-08-04 jrmu (set-car! vals val))
967 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
968 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
969 665c255d 2023-08-04 jrmu (frame-values frame))))
970 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
971 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
972 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
973 665c255d 2023-08-04 jrmu (define primitive-procedures
974 665c255d 2023-08-04 jrmu (list (list 'car car)
975 665c255d 2023-08-04 jrmu (list 'cdr cdr)
976 665c255d 2023-08-04 jrmu (list 'caar caar)
977 665c255d 2023-08-04 jrmu (list 'cadr cadr)
978 665c255d 2023-08-04 jrmu (list 'cddr cddr)
979 665c255d 2023-08-04 jrmu (list 'cons cons)
980 665c255d 2023-08-04 jrmu (list 'null? null?)
981 665c255d 2023-08-04 jrmu (list '* *)
982 665c255d 2023-08-04 jrmu (list '/ /)
983 665c255d 2023-08-04 jrmu (list '+ +)
984 665c255d 2023-08-04 jrmu (list '- -)
985 665c255d 2023-08-04 jrmu (list '= =)
986 665c255d 2023-08-04 jrmu (list '< <)
987 665c255d 2023-08-04 jrmu (list '> >)
988 665c255d 2023-08-04 jrmu (list '<= <=)
989 665c255d 2023-08-04 jrmu (list '>= >=)
990 665c255d 2023-08-04 jrmu (list 'remainder remainder)
991 665c255d 2023-08-04 jrmu (list 'eq? eq?)
992 665c255d 2023-08-04 jrmu (list 'equal? equal?)
993 665c255d 2023-08-04 jrmu (list 'display display)))
994 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
996 665c255d 2023-08-04 jrmu primitive-procedures))
997 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
998 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
999 665c255d 2023-08-04 jrmu primitive-procedures))
1000 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
1001 665c255d 2023-08-04 jrmu (apply (primitive-implementation proc) args))
1002 665c255d 2023-08-04 jrmu (define (setup-environment)
1003 665c255d 2023-08-04 jrmu (let ((initial-env
1004 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
1005 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
1006 665c255d 2023-08-04 jrmu the-empty-environment)))
1007 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
1008 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
1009 665c255d 2023-08-04 jrmu initial-env))
1010 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
1011 665c255d 2023-08-04 jrmu (define (get-global-environment)
1012 665c255d 2023-08-04 jrmu the-global-environment)
1014 665c255d 2023-08-04 jrmu ;; Explicit Control Evaluator Machine
1016 665c255d 2023-08-04 jrmu (define eceval-operations
1017 665c255d 2023-08-04 jrmu `((prompt-for-input ,prompt-for-input)
1018 665c255d 2023-08-04 jrmu (read ,read)
1019 665c255d 2023-08-04 jrmu (get-global-environment ,get-global-environment)
1020 665c255d 2023-08-04 jrmu (announce-output ,announce-output)
1021 665c255d 2023-08-04 jrmu (user-print ,user-print)
1022 665c255d 2023-08-04 jrmu (self-evaluating? ,self-evaluating?)
1023 665c255d 2023-08-04 jrmu (variable? ,variable?)
1024 665c255d 2023-08-04 jrmu (quoted? ,quoted?)
1025 665c255d 2023-08-04 jrmu (assignment? ,assignment?)
1026 665c255d 2023-08-04 jrmu (definition? ,definition?)
1027 665c255d 2023-08-04 jrmu (if? ,if?)
1028 665c255d 2023-08-04 jrmu (cond? ,cond?)
1029 665c255d 2023-08-04 jrmu (cond->if ,cond->if)
1030 665c255d 2023-08-04 jrmu (lambda? ,lambda?)
1031 665c255d 2023-08-04 jrmu (begin? ,begin?)
1032 665c255d 2023-08-04 jrmu (application? ,application?)
1033 665c255d 2023-08-04 jrmu (lookup-variable-value ,lookup-variable-value)
1034 665c255d 2023-08-04 jrmu (text-of-quotation ,text-of-quotation)
1035 665c255d 2023-08-04 jrmu (lambda-parameters ,lambda-parameters)
1036 665c255d 2023-08-04 jrmu (lambda-body ,lambda-body)
1037 665c255d 2023-08-04 jrmu (make-procedure ,make-procedure)
1038 665c255d 2023-08-04 jrmu (let->combination ,let->combination)
1039 665c255d 2023-08-04 jrmu (let? ,let?)
1040 665c255d 2023-08-04 jrmu (operands ,operands)
1041 665c255d 2023-08-04 jrmu (operator ,operator)
1042 665c255d 2023-08-04 jrmu (empty-arglist ,empty-arglist)
1043 665c255d 2023-08-04 jrmu (no-operands? ,no-operands?)
1044 665c255d 2023-08-04 jrmu (first-operand ,first-operand)
1045 665c255d 2023-08-04 jrmu (rest-operands ,rest-operands)
1046 665c255d 2023-08-04 jrmu (last-operand? ,last-operand?)
1047 665c255d 2023-08-04 jrmu (adjoin-arg ,adjoin-arg)
1048 665c255d 2023-08-04 jrmu (procedure-parameters ,procedure-parameters)
1049 665c255d 2023-08-04 jrmu (procedure-environment ,procedure-environment)
1050 665c255d 2023-08-04 jrmu (extend-environment ,extend-environment)
1051 665c255d 2023-08-04 jrmu (procedure-body ,procedure-body)
1052 665c255d 2023-08-04 jrmu (begin-actions ,begin-actions)
1053 665c255d 2023-08-04 jrmu (first-exp ,first-exp)
1054 665c255d 2023-08-04 jrmu (last-exp? ,last-exp?)
1055 665c255d 2023-08-04 jrmu (rest-exps ,rest-exps)
1056 665c255d 2023-08-04 jrmu (true? ,true?)
1057 665c255d 2023-08-04 jrmu (if-predicate ,if-predicate)
1058 665c255d 2023-08-04 jrmu (if-alternative ,if-alternative)
1059 665c255d 2023-08-04 jrmu (if-consequent ,if-consequent)
1060 665c255d 2023-08-04 jrmu (assignment-variable ,assignment-variable)
1061 665c255d 2023-08-04 jrmu (assignment-value ,assignment-value)
1062 665c255d 2023-08-04 jrmu (set-variable-value! ,set-variable-value!)
1063 665c255d 2023-08-04 jrmu (definition-variable ,definition-variable)
1064 665c255d 2023-08-04 jrmu (definition-value ,definition-value)
1065 665c255d 2023-08-04 jrmu (define-variable! ,define-variable!)
1066 665c255d 2023-08-04 jrmu (primitive-procedure? ,primitive-procedure?)
1067 665c255d 2023-08-04 jrmu (apply-primitive-procedure ,apply-primitive-procedure)
1068 665c255d 2023-08-04 jrmu (compound-procedure? ,compound-procedure?)
1069 665c255d 2023-08-04 jrmu (user-print ,user-print)
1070 665c255d 2023-08-04 jrmu (null? ,null?)))
1072 665c255d 2023-08-04 jrmu (define eceval
1073 665c255d 2023-08-04 jrmu (make-machine
1074 665c255d 2023-08-04 jrmu '(exp env val proc argl continue unev code)
1075 665c255d 2023-08-04 jrmu eceval-operations
1078 665c255d 2023-08-04 jrmu (test (op null?) (reg code))
1079 665c255d 2023-08-04 jrmu (branch (label eval-done))
1080 665c255d 2023-08-04 jrmu (perform (op initialize-stack))
1081 665c255d 2023-08-04 jrmu (assign env (op get-global-environment))
1082 665c255d 2023-08-04 jrmu (assign exp (op first-exp) (reg code))
1083 665c255d 2023-08-04 jrmu (assign code (op rest-exps) (reg code))
1084 665c255d 2023-08-04 jrmu (assign continue (label eval-loop))
1085 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1087 665c255d 2023-08-04 jrmu read-eval-print-loop
1088 665c255d 2023-08-04 jrmu (perform (op initialize-stack))
1090 665c255d 2023-08-04 jrmu (op prompt-for-input) (const ";;; EC-Eval input:"))
1091 665c255d 2023-08-04 jrmu (assign exp (op read))
1092 665c255d 2023-08-04 jrmu (assign env (op get-global-environment))
1093 665c255d 2023-08-04 jrmu (assign continue (label print-result))
1094 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1095 665c255d 2023-08-04 jrmu print-result
1096 665c255d 2023-08-04 jrmu (perform (op print-stack-statistics)); added instruction
1098 665c255d 2023-08-04 jrmu (op announce-output) (const ";;; EC-Eval value:"))
1099 665c255d 2023-08-04 jrmu (perform (op user-print) (reg val))
1100 665c255d 2023-08-04 jrmu (goto (label read-eval-print-loop))
1102 665c255d 2023-08-04 jrmu eval-dispatch
1103 665c255d 2023-08-04 jrmu (test (op self-evaluating?) (reg exp))
1104 665c255d 2023-08-04 jrmu (branch (label ev-self-eval))
1105 665c255d 2023-08-04 jrmu (test (op variable?) (reg exp))
1106 665c255d 2023-08-04 jrmu (branch (label ev-variable))
1107 665c255d 2023-08-04 jrmu (test (op quoted?) (reg exp))
1108 665c255d 2023-08-04 jrmu (branch (label ev-quoted))
1109 665c255d 2023-08-04 jrmu (test (op assignment?) (reg exp))
1110 665c255d 2023-08-04 jrmu (branch (label ev-assignment))
1111 665c255d 2023-08-04 jrmu (test (op definition?) (reg exp))
1112 665c255d 2023-08-04 jrmu (branch (label ev-definition))
1113 665c255d 2023-08-04 jrmu (test (op if?) (reg exp))
1114 665c255d 2023-08-04 jrmu (branch (label ev-if))
1115 665c255d 2023-08-04 jrmu (test (op cond?) (reg exp))
1116 665c255d 2023-08-04 jrmu (branch (label ev-cond))
1117 665c255d 2023-08-04 jrmu (test (op lambda?) (reg exp))
1118 665c255d 2023-08-04 jrmu (branch (label ev-lambda))
1119 665c255d 2023-08-04 jrmu (test (op let?) (reg exp))
1120 665c255d 2023-08-04 jrmu (branch (label ev-let))
1121 665c255d 2023-08-04 jrmu (test (op begin?) (reg exp))
1122 665c255d 2023-08-04 jrmu (branch (label ev-begin))
1123 665c255d 2023-08-04 jrmu (test (op application?) (reg exp))
1124 665c255d 2023-08-04 jrmu (branch (label ev-application))
1125 665c255d 2023-08-04 jrmu (goto (label unknown-expression-type))
1126 665c255d 2023-08-04 jrmu ev-self-eval
1127 665c255d 2023-08-04 jrmu (assign val (reg exp))
1128 665c255d 2023-08-04 jrmu (goto (reg continue))
1129 665c255d 2023-08-04 jrmu ev-variable
1130 665c255d 2023-08-04 jrmu (assign val (op lookup-variable-value) (reg exp) (reg env))
1131 665c255d 2023-08-04 jrmu (goto (reg continue))
1133 665c255d 2023-08-04 jrmu (assign val (op text-of-quotation) (reg exp))
1134 665c255d 2023-08-04 jrmu (goto (reg continue))
1136 665c255d 2023-08-04 jrmu (assign unev (op lambda-parameters) (reg exp))
1137 665c255d 2023-08-04 jrmu (assign exp (op lambda-body) (reg exp))
1138 665c255d 2023-08-04 jrmu (assign val (op make-procedure)
1139 665c255d 2023-08-04 jrmu (reg unev) (reg exp) (reg env))
1140 665c255d 2023-08-04 jrmu (goto (reg continue))
1142 665c255d 2023-08-04 jrmu (assign exp (op let->combination) (reg exp))
1143 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1144 665c255d 2023-08-04 jrmu ev-application
1145 665c255d 2023-08-04 jrmu (save continue)
1146 665c255d 2023-08-04 jrmu (save env)
1147 665c255d 2023-08-04 jrmu (assign unev (op operands) (reg exp))
1148 665c255d 2023-08-04 jrmu (save unev)
1149 665c255d 2023-08-04 jrmu (assign exp (op operator) (reg exp))
1150 665c255d 2023-08-04 jrmu (assign continue (label ev-appl-did-operator))
1151 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1152 665c255d 2023-08-04 jrmu ev-appl-did-operator
1153 665c255d 2023-08-04 jrmu (restore unev) ; the operands
1154 665c255d 2023-08-04 jrmu (restore env)
1155 665c255d 2023-08-04 jrmu (assign argl (op empty-arglist))
1156 665c255d 2023-08-04 jrmu (assign proc (reg val)) ; the operator
1157 665c255d 2023-08-04 jrmu (test (op no-operands?) (reg unev))
1158 665c255d 2023-08-04 jrmu (branch (label apply-dispatch))
1159 665c255d 2023-08-04 jrmu (save proc)
1160 665c255d 2023-08-04 jrmu ev-appl-operand-loop
1161 665c255d 2023-08-04 jrmu (save argl)
1162 665c255d 2023-08-04 jrmu (assign exp (op first-operand) (reg unev))
1163 665c255d 2023-08-04 jrmu (test (op last-operand?) (reg unev))
1164 665c255d 2023-08-04 jrmu (branch (label ev-appl-last-arg))
1165 665c255d 2023-08-04 jrmu (save env)
1166 665c255d 2023-08-04 jrmu (save unev)
1167 665c255d 2023-08-04 jrmu (assign continue (label ev-appl-accumulate-arg))
1168 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1169 665c255d 2023-08-04 jrmu ev-appl-accumulate-arg
1170 665c255d 2023-08-04 jrmu (restore unev)
1171 665c255d 2023-08-04 jrmu (restore env)
1172 665c255d 2023-08-04 jrmu (restore argl)
1173 665c255d 2023-08-04 jrmu (assign argl (op adjoin-arg) (reg val) (reg argl))
1174 665c255d 2023-08-04 jrmu (assign unev (op rest-operands) (reg unev))
1175 665c255d 2023-08-04 jrmu (goto (label ev-appl-operand-loop))
1176 665c255d 2023-08-04 jrmu ev-appl-last-arg
1177 665c255d 2023-08-04 jrmu (assign continue (label ev-appl-accum-last-arg))
1178 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1179 665c255d 2023-08-04 jrmu ev-appl-accum-last-arg
1180 665c255d 2023-08-04 jrmu (restore argl)
1181 665c255d 2023-08-04 jrmu (assign argl (op adjoin-arg) (reg val) (reg argl))
1182 665c255d 2023-08-04 jrmu (restore proc)
1183 665c255d 2023-08-04 jrmu (goto (label apply-dispatch))
1184 665c255d 2023-08-04 jrmu apply-dispatch
1185 665c255d 2023-08-04 jrmu (test (op primitive-procedure?) (reg proc))
1186 665c255d 2023-08-04 jrmu (branch (label primitive-apply))
1187 665c255d 2023-08-04 jrmu (test (op compound-procedure?) (reg proc))
1188 665c255d 2023-08-04 jrmu (branch (label compound-apply))
1189 665c255d 2023-08-04 jrmu (goto (label unknown-procedure-type))
1190 665c255d 2023-08-04 jrmu primitive-apply
1191 665c255d 2023-08-04 jrmu (assign val (op apply-primitive-procedure)
1192 665c255d 2023-08-04 jrmu (reg proc)
1193 665c255d 2023-08-04 jrmu (reg argl))
1194 665c255d 2023-08-04 jrmu (restore continue)
1195 665c255d 2023-08-04 jrmu (goto (reg continue))
1196 665c255d 2023-08-04 jrmu compound-apply
1197 665c255d 2023-08-04 jrmu (assign unev (op procedure-parameters) (reg proc))
1198 665c255d 2023-08-04 jrmu (assign env (op procedure-environment) (reg proc))
1199 665c255d 2023-08-04 jrmu (assign env (op extend-environment)
1200 665c255d 2023-08-04 jrmu (reg unev) (reg argl) (reg env))
1201 665c255d 2023-08-04 jrmu (assign unev (op procedure-body) (reg proc))
1202 665c255d 2023-08-04 jrmu (goto (label ev-sequence))
1204 665c255d 2023-08-04 jrmu (assign unev (op begin-actions) (reg exp))
1205 665c255d 2023-08-04 jrmu (save continue)
1206 665c255d 2023-08-04 jrmu (goto (label ev-sequence))
1207 665c255d 2023-08-04 jrmu ev-sequence
1208 665c255d 2023-08-04 jrmu (assign exp (op first-exp) (reg unev))
1209 665c255d 2023-08-04 jrmu (test (op last-exp?) (reg unev))
1210 665c255d 2023-08-04 jrmu (branch (label ev-sequence-last-exp))
1211 665c255d 2023-08-04 jrmu (save unev)
1212 665c255d 2023-08-04 jrmu (save env)
1213 665c255d 2023-08-04 jrmu (assign continue (label ev-sequence-continue))
1214 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1215 665c255d 2023-08-04 jrmu ev-sequence-continue
1216 665c255d 2023-08-04 jrmu (restore env)
1217 665c255d 2023-08-04 jrmu (restore unev)
1218 665c255d 2023-08-04 jrmu (assign unev (op rest-exps) (reg unev))
1219 665c255d 2023-08-04 jrmu (goto (label ev-sequence))
1220 665c255d 2023-08-04 jrmu ev-sequence-last-exp
1221 665c255d 2023-08-04 jrmu (restore continue)
1222 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1224 665c255d 2023-08-04 jrmu (save exp) ; save expression for later
1225 665c255d 2023-08-04 jrmu (save env)
1226 665c255d 2023-08-04 jrmu (save continue)
1227 665c255d 2023-08-04 jrmu (assign continue (label ev-if-decide))
1228 665c255d 2023-08-04 jrmu (assign exp (op if-predicate) (reg exp))
1229 665c255d 2023-08-04 jrmu (goto (label eval-dispatch)) ; evaluate the predicate
1230 665c255d 2023-08-04 jrmu ev-if-decide
1231 665c255d 2023-08-04 jrmu (restore continue)
1232 665c255d 2023-08-04 jrmu (restore env)
1233 665c255d 2023-08-04 jrmu (restore exp)
1234 665c255d 2023-08-04 jrmu (test (op true?) (reg val))
1235 665c255d 2023-08-04 jrmu (branch (label ev-if-consequent))
1237 665c255d 2023-08-04 jrmu ev-if-alternative
1238 665c255d 2023-08-04 jrmu (assign exp (op if-alternative) (reg exp))
1239 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1240 665c255d 2023-08-04 jrmu ev-if-consequent
1241 665c255d 2023-08-04 jrmu (assign exp (op if-consequent) (reg exp))
1242 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1245 665c255d 2023-08-04 jrmu (assign exp (op cond->if) (reg exp))
1246 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1248 665c255d 2023-08-04 jrmu ev-assignment
1249 665c255d 2023-08-04 jrmu (assign unev (op assignment-variable) (reg exp))
1250 665c255d 2023-08-04 jrmu (save unev) ; save variable for later
1251 665c255d 2023-08-04 jrmu (assign exp (op assignment-value) (reg exp))
1252 665c255d 2023-08-04 jrmu (save env)
1253 665c255d 2023-08-04 jrmu (save continue)
1254 665c255d 2023-08-04 jrmu (assign continue (label ev-assignment-1))
1255 665c255d 2023-08-04 jrmu (goto (label eval-dispatch)) ; evaluate the assignment value
1256 665c255d 2023-08-04 jrmu ev-assignment-1
1257 665c255d 2023-08-04 jrmu (restore continue)
1258 665c255d 2023-08-04 jrmu (restore env)
1259 665c255d 2023-08-04 jrmu (restore unev)
1261 665c255d 2023-08-04 jrmu (op set-variable-value!) (reg unev) (reg val) (reg env))
1262 665c255d 2023-08-04 jrmu (assign val (const ok))
1263 665c255d 2023-08-04 jrmu (goto (reg continue))
1264 665c255d 2023-08-04 jrmu ev-definition
1265 665c255d 2023-08-04 jrmu (assign unev (op definition-variable) (reg exp))
1266 665c255d 2023-08-04 jrmu (save unev) ; save variable for later
1267 665c255d 2023-08-04 jrmu (assign exp (op definition-value) (reg exp))
1268 665c255d 2023-08-04 jrmu (save env)
1269 665c255d 2023-08-04 jrmu (save continue)
1270 665c255d 2023-08-04 jrmu (assign continue (label ev-definition-1))
1271 665c255d 2023-08-04 jrmu (goto (label eval-dispatch)) ; evaluate the definition value
1272 665c255d 2023-08-04 jrmu ev-definition-1
1273 665c255d 2023-08-04 jrmu (restore continue)
1274 665c255d 2023-08-04 jrmu (restore env)
1275 665c255d 2023-08-04 jrmu (restore unev)
1277 665c255d 2023-08-04 jrmu (op define-variable!) (reg unev) (reg val) (reg env))
1278 665c255d 2023-08-04 jrmu (assign val (const ok))
1279 665c255d 2023-08-04 jrmu (goto (reg continue))
1281 665c255d 2023-08-04 jrmu unknown-expression-type
1282 665c255d 2023-08-04 jrmu (assign val (const unknown-expression-type-error))
1283 665c255d 2023-08-04 jrmu (goto (label signal-error))
1284 665c255d 2023-08-04 jrmu unknown-procedure-type
1285 665c255d 2023-08-04 jrmu (restore continue) ; clean up stack (from apply-dispatch)
1286 665c255d 2023-08-04 jrmu (assign val (const unknown-procedure-type-error))
1287 665c255d 2023-08-04 jrmu (goto (label signal-error))
1288 665c255d 2023-08-04 jrmu signal-error
1289 665c255d 2023-08-04 jrmu (perform (op user-print) (reg val))
1290 665c255d 2023-08-04 jrmu (goto (label read-eval-print-loop))
1292 665c255d 2023-08-04 jrmu eval-done)))
1294 665c255d 2023-08-04 jrmu ;; test suite
1296 665c255d 2023-08-04 jrmu ;; (set-register-contents!
1299 665c255d 2023-08-04 jrmu ;; '((define (factorial n)
1300 665c255d 2023-08-04 jrmu ;; (if (= n 1)
1302 665c255d 2023-08-04 jrmu ;; (* n (factorial (- n 1)))))
1303 665c255d 2023-08-04 jrmu ;; (factorial 8)))
1304 665c255d 2023-08-04 jrmu ;; (start eceval)
1305 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents eceval 'val)
1309 665c255d 2023-08-04 jrmu ;; (set-register-contents!
1312 665c255d 2023-08-04 jrmu ;; '((define (cons x y)
1313 665c255d 2023-08-04 jrmu ;; (lambda (m) (m x y)))
1314 665c255d 2023-08-04 jrmu ;; (define (car z)
1315 665c255d 2023-08-04 jrmu ;; (z (lambda (p q) p)))
1316 665c255d 2023-08-04 jrmu ;; (define (cdr z)
1317 665c255d 2023-08-04 jrmu ;; (z (lambda (p q) q)))
1318 665c255d 2023-08-04 jrmu ;; (define pair (cons 3 2))
1319 665c255d 2023-08-04 jrmu ;; (+ (car pair) (cdr pair))))
1320 665c255d 2023-08-04 jrmu ;; (start eceval)
1321 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents eceval 'val)
1324 665c255d 2023-08-04 jrmu (define (test-interpret code expected)
1325 665c255d 2023-08-04 jrmu (set-register-contents! eceval 'code code)
1326 665c255d 2023-08-04 jrmu (start eceval)
1327 665c255d 2023-08-04 jrmu (test-case (get-register-contents eceval 'val) expected))
1329 665c255d 2023-08-04 jrmu (test-interpret
1330 665c255d 2023-08-04 jrmu '((define (factorial n)
1331 665c255d 2023-08-04 jrmu (if (= n 1)
1333 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))))
1334 665c255d 2023-08-04 jrmu (factorial 8))
1336 665c255d 2023-08-04 jrmu (test-interpret
1337 665c255d 2023-08-04 jrmu '((define (cons x y)
1338 665c255d 2023-08-04 jrmu (lambda (m) (m x y)))
1339 665c255d 2023-08-04 jrmu (define (car z)
1340 665c255d 2023-08-04 jrmu (z (lambda (p q) p)))
1341 665c255d 2023-08-04 jrmu (define (cdr z)
1342 665c255d 2023-08-04 jrmu (z (lambda (p q) q)))
1343 665c255d 2023-08-04 jrmu (define pair (cons 3 2))
1344 665c255d 2023-08-04 jrmu (+ (car pair) (cdr pair)))
1348 665c255d 2023-08-04 jrmu ;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28
1350 665c255d 2023-08-04 jrmu (test-interpret
1351 665c255d 2023-08-04 jrmu '((define x -25)
1352 665c255d 2023-08-04 jrmu (cond ((= x -2) 'x=-2)
1353 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
1354 665c255d 2023-08-04 jrmu (else 'failed)))
1356 665c255d 2023-08-04 jrmu (test-interpret
1357 665c255d 2023-08-04 jrmu '((cond ((= 2 4) 3)
1358 665c255d 2023-08-04 jrmu ((= 2 (factorial 3)) true)
1359 665c255d 2023-08-04 jrmu (((lambda (result) result) true) 5)))
1362 665c255d 2023-08-04 jrmu (test-interpret
1363 665c255d 2023-08-04 jrmu '((let ((x 4) (y 7))
1364 665c255d 2023-08-04 jrmu (+ x y (* x y))))
1365 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
1366 665c255d 2023-08-04 jrmu (test-interpret
1367 665c255d 2023-08-04 jrmu '((let ((x 3)
1371 665c255d 2023-08-04 jrmu (test-interpret
1372 665c255d 2023-08-04 jrmu '((let ((x 3)
1374 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
1378 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
1379 665c255d 2023-08-04 jrmu (test-interpret
1380 665c255d 2023-08-04 jrmu '((let ((x 6)
1381 665c255d 2023-08-04 jrmu (y (let ((x 2))
1383 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
1384 665c255d 2023-08-04 jrmu (+ a 3))))
1385 665c255d 2023-08-04 jrmu (+ x y z)))
1386 665c255d 2023-08-04 jrmu (+ 6 5 9))
