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 (stack-statistics)
51 665c255d 2023-08-04 jrmu (list 'total-pushes '= number-pushes
52 665c255d 2023-08-04 jrmu 'maximum-depth '= max-depth))
53 665c255d 2023-08-04 jrmu (define (dispatch message)
54 665c255d 2023-08-04 jrmu (cond ((eq? message 'push) push)
55 665c255d 2023-08-04 jrmu ((eq? message 'pop) (pop))
56 665c255d 2023-08-04 jrmu ((eq? message 'initialize) (initialize))
57 665c255d 2023-08-04 jrmu ((eq? message 'print-statistics)
58 665c255d 2023-08-04 jrmu (print-statistics))
59 665c255d 2023-08-04 jrmu ((eq? message 'stack-statistics)
60 665c255d 2023-08-04 jrmu (stack-statistics))
62 665c255d 2023-08-04 jrmu (error "Unknown request -- STACK" message))))
64 665c255d 2023-08-04 jrmu (define (pop stack)
65 665c255d 2023-08-04 jrmu (stack 'pop))
66 665c255d 2023-08-04 jrmu (define (push stack value)
67 665c255d 2023-08-04 jrmu ((stack 'push) value))
68 665c255d 2023-08-04 jrmu (define (make-new-machine)
69 665c255d 2023-08-04 jrmu (let ((pc (make-register 'pc))
70 665c255d 2023-08-04 jrmu (flag (make-register 'flag))
71 665c255d 2023-08-04 jrmu (stack (make-stack))
72 665c255d 2023-08-04 jrmu (the-instruction-sequence '()))
73 665c255d 2023-08-04 jrmu (let ((the-ops
74 665c255d 2023-08-04 jrmu (list (list 'initialize-stack
75 665c255d 2023-08-04 jrmu (lambda () (stack 'initialize)))
76 665c255d 2023-08-04 jrmu (list 'print-stack-statistics
77 665c255d 2023-08-04 jrmu (lambda () (stack 'print-statistics)))
78 665c255d 2023-08-04 jrmu (list 'stack-statistics
79 665c255d 2023-08-04 jrmu (lambda () (stack 'stack-statistics)))))
80 665c255d 2023-08-04 jrmu (register-table
81 665c255d 2023-08-04 jrmu (list (list 'pc pc) (list 'flag flag))))
82 665c255d 2023-08-04 jrmu (define (allocate-register name)
83 665c255d 2023-08-04 jrmu (if (assoc name register-table)
84 665c255d 2023-08-04 jrmu (error "Multiply defined register: " name)
85 665c255d 2023-08-04 jrmu (set! register-table
86 665c255d 2023-08-04 jrmu (cons (list name (make-register name))
87 665c255d 2023-08-04 jrmu register-table)))
88 665c255d 2023-08-04 jrmu 'register-allocated)
89 665c255d 2023-08-04 jrmu (define (lookup-register name)
90 665c255d 2023-08-04 jrmu (let ((val (assoc name register-table)))
93 665c255d 2023-08-04 jrmu (error "Unknown register:" name))))
94 665c255d 2023-08-04 jrmu (define (execute)
95 665c255d 2023-08-04 jrmu (let ((insts (get-contents pc)))
96 665c255d 2023-08-04 jrmu (if (null? insts)
99 665c255d 2023-08-04 jrmu ((instruction-execution-proc (car insts)))
100 665c255d 2023-08-04 jrmu (execute)))))
101 665c255d 2023-08-04 jrmu (define (dispatch message)
102 665c255d 2023-08-04 jrmu (cond ((eq? message 'start)
103 665c255d 2023-08-04 jrmu (set-contents! pc the-instruction-sequence)
105 665c255d 2023-08-04 jrmu ((eq? message 'install-instruction-sequence)
106 665c255d 2023-08-04 jrmu (lambda (seq) (set! the-instruction-sequence seq)))
107 665c255d 2023-08-04 jrmu ((eq? message 'allocate-register) allocate-register)
108 665c255d 2023-08-04 jrmu ((eq? message 'get-register) lookup-register)
109 665c255d 2023-08-04 jrmu ((eq? message 'install-operations)
110 665c255d 2023-08-04 jrmu (lambda (ops) (set! the-ops (append the-ops ops))))
111 665c255d 2023-08-04 jrmu ((eq? message 'stack) stack)
112 665c255d 2023-08-04 jrmu ((eq? message 'operations) the-ops)
113 665c255d 2023-08-04 jrmu (else (error "Unknown request -- MACHINE" message))))
114 665c255d 2023-08-04 jrmu dispatch)))
115 665c255d 2023-08-04 jrmu (define (start machine)
116 665c255d 2023-08-04 jrmu (machine 'start))
117 665c255d 2023-08-04 jrmu (define (get-register-contents machine register-name)
118 665c255d 2023-08-04 jrmu (get-contents (get-register machine register-name)))
119 665c255d 2023-08-04 jrmu (define (set-register-contents! machine register-name value)
120 665c255d 2023-08-04 jrmu (set-contents! (get-register machine register-name) value)
122 665c255d 2023-08-04 jrmu (define (get-register machine reg-name)
123 665c255d 2023-08-04 jrmu ((machine 'get-register) reg-name))
124 665c255d 2023-08-04 jrmu (define (assemble controller-text machine)
125 665c255d 2023-08-04 jrmu (extract-labels controller-text
126 665c255d 2023-08-04 jrmu (lambda (insts labels)
127 665c255d 2023-08-04 jrmu (update-insts! insts labels machine)
129 665c255d 2023-08-04 jrmu (define (extract-labels text receive)
130 665c255d 2023-08-04 jrmu (if (null? text)
131 665c255d 2023-08-04 jrmu (receive '() '())
132 665c255d 2023-08-04 jrmu (extract-labels (cdr text)
133 665c255d 2023-08-04 jrmu (lambda (insts labels)
134 665c255d 2023-08-04 jrmu (let ((next-inst (car text)))
135 665c255d 2023-08-04 jrmu (if (symbol? next-inst)
136 665c255d 2023-08-04 jrmu (if (label-defined? labels next-inst)
137 665c255d 2023-08-04 jrmu (error "Duplicate label -- ASSEMBLE"
141 665c255d 2023-08-04 jrmu (cons (make-label-entry next-inst
145 665c255d 2023-08-04 jrmu (cons (make-instruction next-inst)
147 665c255d 2023-08-04 jrmu labels)))))))
148 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
149 665c255d 2023-08-04 jrmu (let ((pc (get-register machine 'pc))
150 665c255d 2023-08-04 jrmu (flag (get-register machine 'flag))
151 665c255d 2023-08-04 jrmu (stack (machine 'stack))
152 665c255d 2023-08-04 jrmu (ops (machine 'operations)))
154 665c255d 2023-08-04 jrmu (lambda (inst)
155 665c255d 2023-08-04 jrmu (set-instruction-execution-proc!
157 665c255d 2023-08-04 jrmu (make-execution-procedure
158 665c255d 2023-08-04 jrmu (instruction-text inst) labels machine
159 665c255d 2023-08-04 jrmu pc flag stack ops)))
161 665c255d 2023-08-04 jrmu (define (make-instruction text)
162 665c255d 2023-08-04 jrmu (cons text '()))
163 665c255d 2023-08-04 jrmu (define (instruction-text inst)
164 665c255d 2023-08-04 jrmu (car inst))
165 665c255d 2023-08-04 jrmu (define (instruction-execution-proc inst)
166 665c255d 2023-08-04 jrmu (cdr inst))
167 665c255d 2023-08-04 jrmu (define (set-instruction-execution-proc! inst proc)
168 665c255d 2023-08-04 jrmu (set-cdr! inst proc))
169 665c255d 2023-08-04 jrmu (define (make-label-entry label-name insts)
170 665c255d 2023-08-04 jrmu (cons label-name insts))
171 665c255d 2023-08-04 jrmu (define (label-defined? labels label-name)
172 665c255d 2023-08-04 jrmu (not (false? (assoc label-name labels))))
173 665c255d 2023-08-04 jrmu (define (lookup-label labels label-name)
174 665c255d 2023-08-04 jrmu (let ((val (assoc label-name labels)))
177 665c255d 2023-08-04 jrmu (error "Undefined label -- ASSEMBLE" label-name))))
178 665c255d 2023-08-04 jrmu (define (make-execution-procedure inst labels machine
179 665c255d 2023-08-04 jrmu pc flag stack ops)
180 665c255d 2023-08-04 jrmu (cond ((eq? (car inst) 'assign)
181 665c255d 2023-08-04 jrmu (make-assign inst machine labels ops pc))
182 665c255d 2023-08-04 jrmu ((eq? (car inst) 'test)
183 665c255d 2023-08-04 jrmu (make-test inst machine labels ops flag pc))
184 665c255d 2023-08-04 jrmu ((eq? (car inst) 'branch)
185 665c255d 2023-08-04 jrmu (make-branch inst machine labels flag pc))
186 665c255d 2023-08-04 jrmu ((eq? (car inst) 'goto)
187 665c255d 2023-08-04 jrmu (make-goto inst machine labels pc))
188 665c255d 2023-08-04 jrmu ((eq? (car inst) 'save)
189 665c255d 2023-08-04 jrmu (make-save inst machine stack pc))
190 665c255d 2023-08-04 jrmu ((eq? (car inst) 'restore)
191 665c255d 2023-08-04 jrmu (make-restore inst machine stack pc))
192 665c255d 2023-08-04 jrmu ((eq? (car inst) 'perform)
193 665c255d 2023-08-04 jrmu (make-perform inst machine labels ops pc))
194 665c255d 2023-08-04 jrmu (else (error "Unknown instruction type -- ASSEMBLE"
196 665c255d 2023-08-04 jrmu (define (make-assign inst machine labels operations pc)
197 665c255d 2023-08-04 jrmu (let ((target
198 665c255d 2023-08-04 jrmu (get-register machine (assign-reg-name inst)))
199 665c255d 2023-08-04 jrmu (value-exp (assign-value-exp inst)))
200 665c255d 2023-08-04 jrmu (let ((value-proc
201 665c255d 2023-08-04 jrmu (if (operation-exp? value-exp)
202 665c255d 2023-08-04 jrmu (make-operation-exp
203 665c255d 2023-08-04 jrmu value-exp machine labels operations)
204 665c255d 2023-08-04 jrmu (make-primitive-exp
205 665c255d 2023-08-04 jrmu (car value-exp) machine labels))))
206 665c255d 2023-08-04 jrmu (lambda () ; execution procedure for assign
207 665c255d 2023-08-04 jrmu (set-contents! target (value-proc))
208 665c255d 2023-08-04 jrmu (advance-pc pc)))))
209 665c255d 2023-08-04 jrmu (define (assign-reg-name assign-instruction)
210 665c255d 2023-08-04 jrmu (cadr assign-instruction))
211 665c255d 2023-08-04 jrmu (define (assign-value-exp assign-instruction)
212 665c255d 2023-08-04 jrmu (cddr assign-instruction))
213 665c255d 2023-08-04 jrmu (define (advance-pc pc)
214 665c255d 2023-08-04 jrmu (set-contents! pc (cdr (get-contents pc))))
215 665c255d 2023-08-04 jrmu (define (make-test inst machine labels operations flag pc)
216 665c255d 2023-08-04 jrmu (let ((condition (test-condition inst)))
217 665c255d 2023-08-04 jrmu (if (operation-exp? condition)
218 665c255d 2023-08-04 jrmu (let ((condition-proc
219 665c255d 2023-08-04 jrmu (make-operation-exp
220 665c255d 2023-08-04 jrmu condition machine labels operations)))
222 665c255d 2023-08-04 jrmu (set-contents! flag (condition-proc))
223 665c255d 2023-08-04 jrmu (advance-pc pc)))
224 665c255d 2023-08-04 jrmu (error "Bad TEST instruction -- ASSEMBLE" inst))))
225 665c255d 2023-08-04 jrmu (define (test-condition test-instruction)
226 665c255d 2023-08-04 jrmu (cdr test-instruction))
227 665c255d 2023-08-04 jrmu (define (make-branch inst machine labels flag pc)
228 665c255d 2023-08-04 jrmu (let ((dest (branch-dest inst)))
229 665c255d 2023-08-04 jrmu (if (label-exp? dest)
230 665c255d 2023-08-04 jrmu (let ((insts
231 665c255d 2023-08-04 jrmu (lookup-label labels (label-exp-label dest))))
233 665c255d 2023-08-04 jrmu (if (get-contents flag)
234 665c255d 2023-08-04 jrmu (set-contents! pc insts)
235 665c255d 2023-08-04 jrmu (advance-pc pc))))
236 665c255d 2023-08-04 jrmu (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
237 665c255d 2023-08-04 jrmu (define (branch-dest branch-instruction)
238 665c255d 2023-08-04 jrmu (cadr branch-instruction))
239 665c255d 2023-08-04 jrmu (define (make-goto inst machine labels pc)
240 665c255d 2023-08-04 jrmu (let ((dest (goto-dest inst)))
241 665c255d 2023-08-04 jrmu (cond ((label-exp? dest)
242 665c255d 2023-08-04 jrmu (let ((insts
243 665c255d 2023-08-04 jrmu (lookup-label labels
244 665c255d 2023-08-04 jrmu (label-exp-label dest))))
245 665c255d 2023-08-04 jrmu (lambda () (set-contents! pc insts))))
246 665c255d 2023-08-04 jrmu ((register-exp? dest)
248 665c255d 2023-08-04 jrmu (get-register machine
249 665c255d 2023-08-04 jrmu (register-exp-reg dest))))
251 665c255d 2023-08-04 jrmu (set-contents! pc (get-contents reg)))))
252 665c255d 2023-08-04 jrmu (else (error "Bad GOTO instruction -- ASSEMBLE"
254 665c255d 2023-08-04 jrmu (define (goto-dest goto-instruction)
255 665c255d 2023-08-04 jrmu (cadr goto-instruction))
256 665c255d 2023-08-04 jrmu (define (make-stack-pair reg-name contents)
257 665c255d 2023-08-04 jrmu (cons reg-name contents))
258 665c255d 2023-08-04 jrmu (define (stack-pair-reg-name pair)
259 665c255d 2023-08-04 jrmu (car pair))
260 665c255d 2023-08-04 jrmu (define (stack-pair-val pair)
261 665c255d 2023-08-04 jrmu (cdr pair))
262 665c255d 2023-08-04 jrmu (define (make-save inst machine stack pc)
263 665c255d 2023-08-04 jrmu (let* ((reg-name (stack-inst-reg-name inst))
264 665c255d 2023-08-04 jrmu (reg (get-register machine reg-name)))
266 665c255d 2023-08-04 jrmu (push stack (make-stack-pair reg-name (get-contents reg)))
267 665c255d 2023-08-04 jrmu (advance-pc pc))))
268 665c255d 2023-08-04 jrmu (define (make-restore inst machine stack pc)
269 665c255d 2023-08-04 jrmu (let* ((reg-name (stack-inst-reg-name inst))
270 665c255d 2023-08-04 jrmu (reg (get-register machine reg-name)))
272 665c255d 2023-08-04 jrmu (let* ((stack-pair (pop stack))
273 665c255d 2023-08-04 jrmu (stack-reg-name (stack-pair-reg-name stack-pair))
274 665c255d 2023-08-04 jrmu (stack-val (stack-pair-val stack-pair)))
275 665c255d 2023-08-04 jrmu (if (eq? stack-reg-name reg-name)
276 665c255d 2023-08-04 jrmu (begin (set-contents! reg stack-val)
277 665c255d 2023-08-04 jrmu (advance-pc pc))
278 665c255d 2023-08-04 jrmu (error "Stack/register mismatch -- Save/Restore: "
279 665c255d 2023-08-04 jrmu stack-reg-name reg-name))))))
280 665c255d 2023-08-04 jrmu (define (stack-inst-reg-name stack-instruction)
281 665c255d 2023-08-04 jrmu (cadr stack-instruction))
282 665c255d 2023-08-04 jrmu (define (make-perform inst machine labels operations pc)
283 665c255d 2023-08-04 jrmu (let ((action (perform-action inst)))
284 665c255d 2023-08-04 jrmu (if (operation-exp? action)
285 665c255d 2023-08-04 jrmu (let ((action-proc
286 665c255d 2023-08-04 jrmu (make-operation-exp
287 665c255d 2023-08-04 jrmu action machine labels operations)))
289 665c255d 2023-08-04 jrmu (action-proc)
290 665c255d 2023-08-04 jrmu (advance-pc pc)))
291 665c255d 2023-08-04 jrmu (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
292 665c255d 2023-08-04 jrmu (define (perform-action inst) (cdr inst))
293 665c255d 2023-08-04 jrmu (define (make-primitive-exp exp machine labels)
294 665c255d 2023-08-04 jrmu (cond ((constant-exp? exp)
295 665c255d 2023-08-04 jrmu (let ((c (constant-exp-value exp)))
296 665c255d 2023-08-04 jrmu (lambda () c)))
297 665c255d 2023-08-04 jrmu ((label-exp? exp)
298 665c255d 2023-08-04 jrmu (let ((insts
299 665c255d 2023-08-04 jrmu (lookup-label labels
300 665c255d 2023-08-04 jrmu (label-exp-label exp))))
301 665c255d 2023-08-04 jrmu (lambda () insts)))
302 665c255d 2023-08-04 jrmu ((register-exp? exp)
303 665c255d 2023-08-04 jrmu (let ((r (get-register machine
304 665c255d 2023-08-04 jrmu (register-exp-reg exp))))
305 665c255d 2023-08-04 jrmu (lambda () (get-contents r))))
307 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ASSEMBLE" exp))))
308 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
309 665c255d 2023-08-04 jrmu (and (pair? exp) (eq? (car exp) tag)))
310 665c255d 2023-08-04 jrmu (define (register-exp? exp) (tagged-list? exp 'reg))
311 665c255d 2023-08-04 jrmu (define (register-exp-reg exp) (cadr exp))
312 665c255d 2023-08-04 jrmu (define (constant-exp? exp) (tagged-list? exp 'const))
313 665c255d 2023-08-04 jrmu (define (constant-exp-value exp) (cadr exp))
314 665c255d 2023-08-04 jrmu (define (label-exp? exp) (tagged-list? exp 'label))
315 665c255d 2023-08-04 jrmu (define (label-exp-label exp) (cadr exp))
316 665c255d 2023-08-04 jrmu (define (make-operation-exp exp machine labels operations)
317 665c255d 2023-08-04 jrmu (let ((op (lookup-prim (operation-exp-op exp) operations))
319 665c255d 2023-08-04 jrmu (map (lambda (e)
320 665c255d 2023-08-04 jrmu ;; (if (label-exp? e)
321 665c255d 2023-08-04 jrmu ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
323 665c255d 2023-08-04 jrmu (make-primitive-exp e machine labels))
324 665c255d 2023-08-04 jrmu (operation-exp-operands exp))))
326 665c255d 2023-08-04 jrmu (apply op (map (lambda (p) (p)) aprocs)))))
327 665c255d 2023-08-04 jrmu (define (operation-exp? exp)
328 665c255d 2023-08-04 jrmu (and (pair? exp) (tagged-list? (car exp) 'op)))
329 665c255d 2023-08-04 jrmu (define (operation-exp-op operation-exp)
330 665c255d 2023-08-04 jrmu (cadr (car operation-exp)))
331 665c255d 2023-08-04 jrmu (define (operation-exp-operands operation-exp)
332 665c255d 2023-08-04 jrmu (cdr operation-exp))
333 665c255d 2023-08-04 jrmu (define (lookup-prim symbol operations)
334 665c255d 2023-08-04 jrmu (let ((val (assoc symbol operations)))
337 665c255d 2023-08-04 jrmu (error "Unknown operation -- ASSEMBLE" symbol))))
339 665c255d 2023-08-04 jrmu ;; test suite
341 665c255d 2023-08-04 jrmu (define (test-case actual expected)
343 665c255d 2023-08-04 jrmu (display "Actual: ")
344 665c255d 2023-08-04 jrmu (display actual)
346 665c255d 2023-08-04 jrmu (display "Expected: ")
347 665c255d 2023-08-04 jrmu (display expected)
350 665c255d 2023-08-04 jrmu (define gcd-machine
351 665c255d 2023-08-04 jrmu (make-machine
353 665c255d 2023-08-04 jrmu (list (list 'rem remainder) (list '= =))
355 665c255d 2023-08-04 jrmu (test (op =) (reg b) (const 0))
356 665c255d 2023-08-04 jrmu (branch (label gcd-done))
357 665c255d 2023-08-04 jrmu (assign t (op rem) (reg a) (reg b))
358 665c255d 2023-08-04 jrmu (assign a (reg b))
359 665c255d 2023-08-04 jrmu (assign b (reg t))
360 665c255d 2023-08-04 jrmu (goto (label test-b))
361 665c255d 2023-08-04 jrmu gcd-done)))
362 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'a 206)
363 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'b 40)
364 665c255d 2023-08-04 jrmu (start gcd-machine)
365 665c255d 2023-08-04 jrmu (test-case (get-register-contents gcd-machine 'a) 2)
367 665c255d 2023-08-04 jrmu (define fib-machine
368 665c255d 2023-08-04 jrmu (make-machine
369 665c255d 2023-08-04 jrmu '(n val continue)
370 665c255d 2023-08-04 jrmu `((< ,<) (- ,-) (+ ,+))
371 665c255d 2023-08-04 jrmu '(controller
372 665c255d 2023-08-04 jrmu (assign continue (label fib-done))
374 665c255d 2023-08-04 jrmu (test (op <) (reg n) (const 2))
375 665c255d 2023-08-04 jrmu (branch (label immediate-answer))
376 665c255d 2023-08-04 jrmu (save continue)
377 665c255d 2023-08-04 jrmu (assign continue (label afterfib-n-1))
379 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
380 665c255d 2023-08-04 jrmu (goto (label fib-loop))
381 665c255d 2023-08-04 jrmu afterfib-n-1
382 665c255d 2023-08-04 jrmu (restore n)
383 665c255d 2023-08-04 jrmu (restore continue)
384 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 2))
385 665c255d 2023-08-04 jrmu (save continue)
386 665c255d 2023-08-04 jrmu (assign continue (label afterfib-n-2))
388 665c255d 2023-08-04 jrmu (goto (label fib-loop))
389 665c255d 2023-08-04 jrmu afterfib-n-2
390 665c255d 2023-08-04 jrmu (assign n (reg val))
391 665c255d 2023-08-04 jrmu (restore val)
392 665c255d 2023-08-04 jrmu (restore continue)
393 665c255d 2023-08-04 jrmu (assign val
394 665c255d 2023-08-04 jrmu (op +) (reg val) (reg n))
395 665c255d 2023-08-04 jrmu (goto (reg continue))
396 665c255d 2023-08-04 jrmu immediate-answer
397 665c255d 2023-08-04 jrmu (assign val (reg n))
398 665c255d 2023-08-04 jrmu (goto (reg continue))
399 665c255d 2023-08-04 jrmu fib-done)))
400 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'val 0)
401 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'n 15)
402 665c255d 2023-08-04 jrmu (start fib-machine)
403 665c255d 2023-08-04 jrmu (test-case (get-register-contents fib-machine 'val) 610)
405 665c255d 2023-08-04 jrmu (define fact-iter
406 665c255d 2023-08-04 jrmu (make-machine
407 665c255d 2023-08-04 jrmu '(product counter n)
408 665c255d 2023-08-04 jrmu `((> ,>) (* ,*) (+ ,+))
409 665c255d 2023-08-04 jrmu '((assign product (const 1))
410 665c255d 2023-08-04 jrmu (assign counter (const 1))
412 665c255d 2023-08-04 jrmu (test (op >) (reg counter) (reg n))
413 665c255d 2023-08-04 jrmu (branch (label fact-end))
414 665c255d 2023-08-04 jrmu (assign product (op *) (reg counter) (reg product))
415 665c255d 2023-08-04 jrmu (assign counter (op +) (reg counter) (const 1))
416 665c255d 2023-08-04 jrmu (goto (label fact-loop))
417 665c255d 2023-08-04 jrmu fact-end)))
418 665c255d 2023-08-04 jrmu (set-register-contents! fact-iter 'n 10)
419 665c255d 2023-08-04 jrmu (start fact-iter)
420 665c255d 2023-08-04 jrmu (test-case (get-register-contents fact-iter 'product) 3628800)
422 665c255d 2023-08-04 jrmu (define (sqrt x)
423 665c255d 2023-08-04 jrmu (define (good-enough? guess)
424 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
425 665c255d 2023-08-04 jrmu (define (improve guess)
426 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
427 665c255d 2023-08-04 jrmu (define (sqrt-iter guess)
428 665c255d 2023-08-04 jrmu (if (good-enough? guess)
430 665c255d 2023-08-04 jrmu (sqrt-iter (improve guess))))
431 665c255d 2023-08-04 jrmu (sqrt-iter 1.0))
433 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
434 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
435 665c255d 2023-08-04 jrmu (define (improve guess x)
436 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
437 665c255d 2023-08-04 jrmu (define (average x y)
438 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
439 665c255d 2023-08-04 jrmu (define sqrt-iter-ops
440 665c255d 2023-08-04 jrmu (make-machine
442 665c255d 2023-08-04 jrmu `((good-enough? ,good-enough?)
443 665c255d 2023-08-04 jrmu (improve ,improve)
445 665c255d 2023-08-04 jrmu (square ,square)
446 665c255d 2023-08-04 jrmu (average ,average)
450 665c255d 2023-08-04 jrmu '((assign guess (const 1.0))
452 665c255d 2023-08-04 jrmu (test (op good-enough?) (reg guess) (reg x))
453 665c255d 2023-08-04 jrmu (branch (label sqrt-done))
454 665c255d 2023-08-04 jrmu (assign guess (op improve) (reg guess) (reg x))
455 665c255d 2023-08-04 jrmu (goto (label sqrt-iter))
456 665c255d 2023-08-04 jrmu sqrt-done)))
458 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 27)
459 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
460 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
461 665c255d 2023-08-04 jrmu 5.19615242)
463 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
464 665c255d 2023-08-04 jrmu (< (abs (- (square guess) x)) 0.001))
465 665c255d 2023-08-04 jrmu (define (improve guess x)
466 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
467 665c255d 2023-08-04 jrmu (define (average x y)
468 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
469 665c255d 2023-08-04 jrmu (define sqrt-iter
470 665c255d 2023-08-04 jrmu (make-machine
471 665c255d 2023-08-04 jrmu '(guess x temp)
472 665c255d 2023-08-04 jrmu `((abs ,abs)
473 665c255d 2023-08-04 jrmu (square ,square)
474 665c255d 2023-08-04 jrmu (average ,average)
478 665c255d 2023-08-04 jrmu '((assign guess (const 1.0))
480 665c255d 2023-08-04 jrmu ;; (test (op good-enough?) (reg guess) (reg x))
481 665c255d 2023-08-04 jrmu (assign temp (op square) (reg guess))
482 665c255d 2023-08-04 jrmu (assign temp (op -) (reg temp) (reg x))
483 665c255d 2023-08-04 jrmu (assign temp (op abs) (reg temp))
484 665c255d 2023-08-04 jrmu (test (op <) (reg temp) (const 0.001))
485 665c255d 2023-08-04 jrmu (branch (label sqrt-done))
486 665c255d 2023-08-04 jrmu ;; (assign guess (op improve) (reg guess) (reg x))
487 665c255d 2023-08-04 jrmu (assign temp (op /) (reg x) (reg guess))
488 665c255d 2023-08-04 jrmu (assign guess (op average) (reg guess) (reg temp))
489 665c255d 2023-08-04 jrmu (goto (label sqrt-iter))
490 665c255d 2023-08-04 jrmu sqrt-done)))
491 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 91)
492 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
493 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
494 665c255d 2023-08-04 jrmu 9.53939201)
496 665c255d 2023-08-04 jrmu (define (expt b n)
497 665c255d 2023-08-04 jrmu (if (= n 0)
499 665c255d 2023-08-04 jrmu (* b (expt b (- n 1)))))
501 665c255d 2023-08-04 jrmu (define expt-rec
502 665c255d 2023-08-04 jrmu (make-machine
503 665c255d 2023-08-04 jrmu '(b n product continue)
507 665c255d 2023-08-04 jrmu '((assign continue (label expt-done))
509 665c255d 2023-08-04 jrmu (test (op =) (reg n) (const 0))
510 665c255d 2023-08-04 jrmu (branch (label base-case))
511 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
512 665c255d 2023-08-04 jrmu (save continue)
513 665c255d 2023-08-04 jrmu (assign continue (label after-b-n-1))
514 665c255d 2023-08-04 jrmu (goto (label expt-rec))
515 665c255d 2023-08-04 jrmu after-b-n-1
516 665c255d 2023-08-04 jrmu (restore continue)
517 665c255d 2023-08-04 jrmu (assign product (op *) (reg b) (reg product))
518 665c255d 2023-08-04 jrmu (goto (reg continue))
520 665c255d 2023-08-04 jrmu (assign product (const 1))
521 665c255d 2023-08-04 jrmu (goto (reg continue))
522 665c255d 2023-08-04 jrmu expt-done)))
524 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'b 3.2)
525 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'n 6)
526 665c255d 2023-08-04 jrmu (start expt-rec)
527 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-rec 'product)
528 665c255d 2023-08-04 jrmu 1073.74182)
530 665c255d 2023-08-04 jrmu (define (expt b n)
531 665c255d 2023-08-04 jrmu (define (expt-iter counter product)
532 665c255d 2023-08-04 jrmu (if (= counter 0)
534 665c255d 2023-08-04 jrmu (expt-iter (- counter 1) (* b product))))
535 665c255d 2023-08-04 jrmu (expt-iter n 1))
537 665c255d 2023-08-04 jrmu (define expt-iter
538 665c255d 2023-08-04 jrmu (make-machine
539 665c255d 2023-08-04 jrmu '(b n counter product)
543 665c255d 2023-08-04 jrmu '((assign counter (reg n))
544 665c255d 2023-08-04 jrmu (assign product (const 1))
546 665c255d 2023-08-04 jrmu (test (op =) (reg counter) (const 0))
547 665c255d 2023-08-04 jrmu (branch (label expt-iter-done))
548 665c255d 2023-08-04 jrmu (assign counter (op -) (reg counter) (const 1))
549 665c255d 2023-08-04 jrmu (assign product (op *) (reg b) (reg product))
550 665c255d 2023-08-04 jrmu (goto (label expt-iter))
551 665c255d 2023-08-04 jrmu expt-iter-done)))
552 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'b 1.6)
553 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'n 17)
554 665c255d 2023-08-04 jrmu (start expt-iter)
555 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-iter 'product)
556 665c255d 2023-08-04 jrmu 2951.47905)
558 665c255d 2023-08-04 jrmu ;; (define amb-machine
559 665c255d 2023-08-04 jrmu ;; (make-machine
563 665c255d 2023-08-04 jrmu ;; (goto (label here))
565 665c255d 2023-08-04 jrmu ;; (assign a (const 3))
566 665c255d 2023-08-04 jrmu ;; (goto (label there))
568 665c255d 2023-08-04 jrmu ;; (assign a (const 4))
569 665c255d 2023-08-04 jrmu ;; (goto (label there))
570 665c255d 2023-08-04 jrmu ;; there)))
572 665c255d 2023-08-04 jrmu ;; (start amb-machine)
573 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents amb-machine 'a)
575 665c255d 2023-08-04 jrmu ;; this now raises an error
577 665c255d 2023-08-04 jrmu (define fact-rec
578 665c255d 2023-08-04 jrmu (make-machine
579 665c255d 2023-08-04 jrmu '(n val continue)
580 665c255d 2023-08-04 jrmu `((= ,=) (- ,-) (* ,*))
581 665c255d 2023-08-04 jrmu '((assign continue (label fact-done)) ; set up final return address
583 665c255d 2023-08-04 jrmu (test (op =) (reg n) (const 1))
584 665c255d 2023-08-04 jrmu (branch (label base-case))
585 665c255d 2023-08-04 jrmu ;; Set up for the recursive call by saving n and continue.
586 665c255d 2023-08-04 jrmu ;; Set up continue so that the computation will continue
587 665c255d 2023-08-04 jrmu ;; at after-fact when the subroutine returns.
588 665c255d 2023-08-04 jrmu (save continue)
590 665c255d 2023-08-04 jrmu (assign n (op -) (reg n) (const 1))
591 665c255d 2023-08-04 jrmu (assign continue (label after-fact))
592 665c255d 2023-08-04 jrmu (goto (label fact-loop))
594 665c255d 2023-08-04 jrmu (restore n)
595 665c255d 2023-08-04 jrmu (restore continue)
596 665c255d 2023-08-04 jrmu (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
597 665c255d 2023-08-04 jrmu (goto (reg continue)) ; return to caller
599 665c255d 2023-08-04 jrmu (assign val (const 1)) ; base case: 1! = 1
600 665c255d 2023-08-04 jrmu (goto (reg continue)) ; return to caller
602 665c255d 2023-08-04 jrmu (perform (op print-stack-statistics)))))
604 665c255d 2023-08-04 jrmu (define count-leaves-rec
605 665c255d 2023-08-04 jrmu (make-machine
606 665c255d 2023-08-04 jrmu '(tree val continue)
607 665c255d 2023-08-04 jrmu `((pair? ,pair?)
608 665c255d 2023-08-04 jrmu (null? ,null?)
612 665c255d 2023-08-04 jrmu '((assign continue (label count-leaves-done))
613 665c255d 2023-08-04 jrmu count-leaves
614 665c255d 2023-08-04 jrmu (test (op null?) (reg tree))
615 665c255d 2023-08-04 jrmu (branch (label null-tree))
616 665c255d 2023-08-04 jrmu (test (op pair?) (reg tree))
617 665c255d 2023-08-04 jrmu (branch (label pair-tree))
618 665c255d 2023-08-04 jrmu (assign val (const 1))
619 665c255d 2023-08-04 jrmu (goto (reg continue))
621 665c255d 2023-08-04 jrmu (save continue)
622 665c255d 2023-08-04 jrmu (save tree)
623 665c255d 2023-08-04 jrmu (assign tree (op car) (reg tree))
624 665c255d 2023-08-04 jrmu (assign continue (label left-tree-done))
625 665c255d 2023-08-04 jrmu (goto (label count-leaves))
626 665c255d 2023-08-04 jrmu left-tree-done
627 665c255d 2023-08-04 jrmu (restore tree)
628 665c255d 2023-08-04 jrmu (assign tree (op cdr) (reg tree))
629 665c255d 2023-08-04 jrmu (assign continue (label right-tree-done))
631 665c255d 2023-08-04 jrmu (goto (label count-leaves))
632 665c255d 2023-08-04 jrmu right-tree-done
633 665c255d 2023-08-04 jrmu (assign tree (reg val))
634 665c255d 2023-08-04 jrmu (restore val)
635 665c255d 2023-08-04 jrmu (assign val (op +) (reg tree) (reg val))
636 665c255d 2023-08-04 jrmu (restore continue)
637 665c255d 2023-08-04 jrmu (goto (reg continue))
639 665c255d 2023-08-04 jrmu (assign val (const 0))
640 665c255d 2023-08-04 jrmu (goto (reg continue))
641 665c255d 2023-08-04 jrmu count-leaves-done)))
643 665c255d 2023-08-04 jrmu (set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
644 665c255d 2023-08-04 jrmu (start count-leaves-rec)
645 665c255d 2023-08-04 jrmu (test-case (get-register-contents count-leaves-rec 'val)
648 665c255d 2023-08-04 jrmu (define count-leaves-iter
649 665c255d 2023-08-04 jrmu (make-machine
650 665c255d 2023-08-04 jrmu '(tree n val continue)
651 665c255d 2023-08-04 jrmu `((null? ,null?)
652 665c255d 2023-08-04 jrmu (pair? ,pair?)
656 665c255d 2023-08-04 jrmu '((assign n (const 0))
657 665c255d 2023-08-04 jrmu (assign continue (label count-iter-done))
659 665c255d 2023-08-04 jrmu (test (op null?) (reg tree))
660 665c255d 2023-08-04 jrmu (branch (label null-tree))
661 665c255d 2023-08-04 jrmu (test (op pair?) (reg tree))
662 665c255d 2023-08-04 jrmu (branch (label pair-tree))
663 665c255d 2023-08-04 jrmu (assign val (op +) (reg n) (const 1))
664 665c255d 2023-08-04 jrmu (goto (reg continue))
666 665c255d 2023-08-04 jrmu (assign val (reg n))
667 665c255d 2023-08-04 jrmu (goto (reg continue))
669 665c255d 2023-08-04 jrmu (save continue)
670 665c255d 2023-08-04 jrmu (save tree)
671 665c255d 2023-08-04 jrmu (assign continue (label left-tree-done))
672 665c255d 2023-08-04 jrmu (assign tree (op car) (reg tree))
673 665c255d 2023-08-04 jrmu (goto (label count-iter))
674 665c255d 2023-08-04 jrmu left-tree-done
675 665c255d 2023-08-04 jrmu (assign n (reg val))
676 665c255d 2023-08-04 jrmu (restore tree)
677 665c255d 2023-08-04 jrmu (assign tree (op cdr) (reg tree))
678 665c255d 2023-08-04 jrmu (restore continue)
679 665c255d 2023-08-04 jrmu (goto (label count-iter))
680 665c255d 2023-08-04 jrmu count-iter-done)))
682 665c255d 2023-08-04 jrmu (set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
683 665c255d 2023-08-04 jrmu (start count-leaves-iter)
684 665c255d 2023-08-04 jrmu (test-case (get-register-contents count-leaves-iter 'val)
686 665c255d 2023-08-04 jrmu (set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
687 665c255d 2023-08-04 jrmu (start count-leaves-iter)
688 665c255d 2023-08-04 jrmu (test-case (get-register-contents count-leaves-iter 'val)
691 665c255d 2023-08-04 jrmu (define (append x y)
692 665c255d 2023-08-04 jrmu (if (null? x)
694 665c255d 2023-08-04 jrmu (cons (car x) (append (cdr x) y))))
696 665c255d 2023-08-04 jrmu (define append-machine
697 665c255d 2023-08-04 jrmu (make-machine
698 665c255d 2023-08-04 jrmu '(x y carx val continue)
699 665c255d 2023-08-04 jrmu `((cons ,cons)
702 665c255d 2023-08-04 jrmu (null? ,null?))
703 665c255d 2023-08-04 jrmu '((assign continue (label append-done))
705 665c255d 2023-08-04 jrmu (test (op null?) (reg x))
706 665c255d 2023-08-04 jrmu (branch (label null-x))
707 665c255d 2023-08-04 jrmu (assign carx (op car) (reg x))
708 665c255d 2023-08-04 jrmu (save carx)
709 665c255d 2023-08-04 jrmu (assign x (op cdr) (reg x))
710 665c255d 2023-08-04 jrmu (save continue)
711 665c255d 2023-08-04 jrmu (assign continue (label after-null-x))
712 665c255d 2023-08-04 jrmu (goto (label append))
714 665c255d 2023-08-04 jrmu (assign val (reg y))
715 665c255d 2023-08-04 jrmu (goto (reg continue))
716 665c255d 2023-08-04 jrmu after-null-x
717 665c255d 2023-08-04 jrmu (restore continue)
718 665c255d 2023-08-04 jrmu (restore carx)
719 665c255d 2023-08-04 jrmu (assign val (op cons) (reg carx) (reg val))
720 665c255d 2023-08-04 jrmu (goto (reg continue))
721 665c255d 2023-08-04 jrmu append-done)))
722 665c255d 2023-08-04 jrmu (set-register-contents! append-machine 'x '(a (b c) ((d) e)))
723 665c255d 2023-08-04 jrmu (set-register-contents! append-machine 'y '(((f g) (h)) i))
724 665c255d 2023-08-04 jrmu (start append-machine)
725 665c255d 2023-08-04 jrmu (test-case (get-register-contents append-machine 'val)
726 665c255d 2023-08-04 jrmu '(a (b c) ((d) e) ((f g) (h)) i))
728 665c255d 2023-08-04 jrmu (define append!-machine
729 665c255d 2023-08-04 jrmu (make-machine
730 665c255d 2023-08-04 jrmu '(x y cdrx)
731 665c255d 2023-08-04 jrmu `((set-cdr! ,set-cdr!)
733 665c255d 2023-08-04 jrmu (null? ,null?))
735 665c255d 2023-08-04 jrmu (assign cdrx (op cdr) (reg x))
737 665c255d 2023-08-04 jrmu (test (op null?) (reg cdrx))
738 665c255d 2023-08-04 jrmu (branch (label set-cdr!))
739 665c255d 2023-08-04 jrmu (assign x (reg cdrx))
740 665c255d 2023-08-04 jrmu (assign cdrx (op cdr) (reg x))
741 665c255d 2023-08-04 jrmu (goto (label last-pair))
743 665c255d 2023-08-04 jrmu (perform (op set-cdr!) (reg x) (reg y))
744 665c255d 2023-08-04 jrmu (restore x)
745 665c255d 2023-08-04 jrmu append!-done)))
746 665c255d 2023-08-04 jrmu (define (append! x y)
747 665c255d 2023-08-04 jrmu (set-cdr! (last-pair x) y)
750 665c255d 2023-08-04 jrmu (define (last-pair x)
751 665c255d 2023-08-04 jrmu (if (null? (cdr x))
753 665c255d 2023-08-04 jrmu (last-pair (cdr x))))
755 665c255d 2023-08-04 jrmu (set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
756 665c255d 2023-08-04 jrmu (set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
757 665c255d 2023-08-04 jrmu (start append!-machine)
758 665c255d 2023-08-04 jrmu (test-case (get-register-contents append!-machine 'x)
759 665c255d 2023-08-04 jrmu '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
761 665c255d 2023-08-04 jrmu ;; procedures from metacircular evaluator
765 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
766 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
767 665c255d 2023-08-04 jrmu (define (announce-output string)
768 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
769 665c255d 2023-08-04 jrmu (define (user-print object)
770 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
771 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
772 665c255d 2023-08-04 jrmu (procedure-parameters object)
773 665c255d 2023-08-04 jrmu (procedure-body object)
774 665c255d 2023-08-04 jrmu '<procedure-env>))
775 665c255d 2023-08-04 jrmu (display object)))
777 665c255d 2023-08-04 jrmu ;; self-evaluating/variables/quoted
779 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
780 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
781 665c255d 2023-08-04 jrmu ((string? exp) true)
782 665c255d 2023-08-04 jrmu (else false)))
783 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
784 665c255d 2023-08-04 jrmu (define (quoted? exp)
785 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
786 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
787 665c255d 2023-08-04 jrmu (define (assignment? exp)
788 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
790 665c255d 2023-08-04 jrmu ;; assignments/definitions
792 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
793 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
794 665c255d 2023-08-04 jrmu (define (definition? exp)
795 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
796 665c255d 2023-08-04 jrmu (define (definition-variable exp)
797 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
799 665c255d 2023-08-04 jrmu (caadr exp)))
800 665c255d 2023-08-04 jrmu (define (definition-value exp)
801 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
802 665c255d 2023-08-04 jrmu (caddr exp)
803 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
804 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
808 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
809 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
810 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
811 665c255d 2023-08-04 jrmu (define (if-alternative exp)
812 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
813 665c255d 2023-08-04 jrmu (cadddr exp)
815 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
816 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
819 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
820 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
821 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
822 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
823 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
824 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
825 665c255d 2023-08-04 jrmu (define (cond->if exp)
826 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
827 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
828 665c255d 2023-08-04 jrmu (if (null? clauses)
829 665c255d 2023-08-04 jrmu 'false ; no else clause
830 665c255d 2023-08-04 jrmu (let ((first (car clauses))
831 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
832 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
833 665c255d 2023-08-04 jrmu (if (null? rest)
834 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
835 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
837 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
838 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
839 665c255d 2023-08-04 jrmu (expand-clauses rest))))))
844 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
845 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
846 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
847 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
848 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
849 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
850 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
852 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
853 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
857 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
859 665c255d 2023-08-04 jrmu (cons (map list vars vals)
861 665c255d 2023-08-04 jrmu (define (let? exp)
862 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
863 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
864 665c255d 2023-08-04 jrmu (define (let-vars exp)
865 665c255d 2023-08-04 jrmu (map car (cadr exp)))
866 665c255d 2023-08-04 jrmu (define (let-vals exp)
867 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
868 665c255d 2023-08-04 jrmu (define (let-body exp)
869 665c255d 2023-08-04 jrmu (cddr exp))
870 665c255d 2023-08-04 jrmu (define (let->combination exp)
871 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
872 665c255d 2023-08-04 jrmu (let-vals exp)))
873 665c255d 2023-08-04 jrmu (define (make-application op args)
874 665c255d 2023-08-04 jrmu (cons op args))
878 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
879 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
880 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
881 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
882 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
883 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
884 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
885 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
886 665c255d 2023-08-04 jrmu (else (make-begin seq))))
887 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
889 665c255d 2023-08-04 jrmu ;; applications
891 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
892 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
893 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
894 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
895 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
896 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
897 665c255d 2023-08-04 jrmu (define (empty-arglist) '())
898 665c255d 2023-08-04 jrmu (define (adjoin-arg arg arglist)
899 665c255d 2023-08-04 jrmu (append arglist (list arg)))
900 665c255d 2023-08-04 jrmu (define (last-operand? ops)
901 665c255d 2023-08-04 jrmu (null? (cdr ops)))
903 665c255d 2023-08-04 jrmu ;; true/false
905 665c255d 2023-08-04 jrmu (define (true? x)
906 665c255d 2023-08-04 jrmu (not (eq? x false)))
907 665c255d 2023-08-04 jrmu (define (false? x)
908 665c255d 2023-08-04 jrmu (eq? x false))
910 665c255d 2023-08-04 jrmu ;; compound procedures
912 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
913 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
914 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
915 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
916 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
918 665c255d 2023-08-04 jrmu ;; environment procedures/data structures
920 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
921 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
922 665c255d 2023-08-04 jrmu (define the-empty-environment '())
923 665c255d 2023-08-04 jrmu (define (make-frame variables values)
924 665c255d 2023-08-04 jrmu (cons variables values))
925 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
926 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
927 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
928 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
929 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
930 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
931 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
932 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
933 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
934 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
935 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
936 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
937 665c255d 2023-08-04 jrmu (define (env-loop env)
938 665c255d 2023-08-04 jrmu (define (scan vars vals)
939 665c255d 2023-08-04 jrmu (cond ((null? vars)
940 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
941 665c255d 2023-08-04 jrmu ((eq? var (car vars))
942 665c255d 2023-08-04 jrmu (let ((val (car vals)))
943 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
944 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
946 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
947 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
948 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
949 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
950 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
951 665c255d 2023-08-04 jrmu (frame-values frame)))))
952 665c255d 2023-08-04 jrmu (env-loop env))
953 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
954 665c255d 2023-08-04 jrmu (define (env-loop env)
955 665c255d 2023-08-04 jrmu (define (scan vars vals)
956 665c255d 2023-08-04 jrmu (cond ((null? vars)
957 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
958 665c255d 2023-08-04 jrmu ((eq? var (car vars))
959 665c255d 2023-08-04 jrmu (set-car! vals val))
960 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
961 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
962 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
963 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
964 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
965 665c255d 2023-08-04 jrmu (frame-values frame)))))
966 665c255d 2023-08-04 jrmu (env-loop env))
967 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
968 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
969 665c255d 2023-08-04 jrmu (define (scan vars vals)
970 665c255d 2023-08-04 jrmu (cond ((null? vars)
971 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
972 665c255d 2023-08-04 jrmu ((eq? var (car vars))
973 665c255d 2023-08-04 jrmu (set-car! vals val))
974 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
975 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
976 665c255d 2023-08-04 jrmu (frame-values frame))))
977 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
978 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
979 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
980 665c255d 2023-08-04 jrmu (define primitive-procedures
981 665c255d 2023-08-04 jrmu (list (list 'car car)
982 665c255d 2023-08-04 jrmu (list 'cdr cdr)
983 665c255d 2023-08-04 jrmu (list 'caar caar)
984 665c255d 2023-08-04 jrmu (list 'cadr cadr)
985 665c255d 2023-08-04 jrmu (list 'cddr cddr)
986 665c255d 2023-08-04 jrmu (list 'cons cons)
987 665c255d 2023-08-04 jrmu (list 'null? null?)
988 665c255d 2023-08-04 jrmu (list '* *)
989 665c255d 2023-08-04 jrmu (list '/ /)
990 665c255d 2023-08-04 jrmu (list '+ +)
991 665c255d 2023-08-04 jrmu (list '- -)
992 665c255d 2023-08-04 jrmu (list '= =)
993 665c255d 2023-08-04 jrmu (list '< <)
994 665c255d 2023-08-04 jrmu (list '> >)
995 665c255d 2023-08-04 jrmu (list '<= <=)
996 665c255d 2023-08-04 jrmu (list '>= >=)
997 665c255d 2023-08-04 jrmu (list 'remainder remainder)
998 665c255d 2023-08-04 jrmu (list 'eq? eq?)
999 665c255d 2023-08-04 jrmu (list 'equal? equal?)
1000 665c255d 2023-08-04 jrmu (list 'display display)))
1001 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
1003 665c255d 2023-08-04 jrmu primitive-procedures))
1004 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
1005 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
1006 665c255d 2023-08-04 jrmu primitive-procedures))
1007 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
1008 665c255d 2023-08-04 jrmu (apply (primitive-implementation proc) args))
1009 665c255d 2023-08-04 jrmu (define (setup-environment)
1010 665c255d 2023-08-04 jrmu (let ((initial-env
1011 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
1012 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
1013 665c255d 2023-08-04 jrmu the-empty-environment)))
1014 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
1015 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
1016 665c255d 2023-08-04 jrmu initial-env))
1017 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
1018 665c255d 2023-08-04 jrmu (define (get-global-environment)
1019 665c255d 2023-08-04 jrmu the-global-environment)
1021 665c255d 2023-08-04 jrmu ;; Explicit Control Evaluator Machine
1023 665c255d 2023-08-04 jrmu (define eceval-operations
1024 665c255d 2023-08-04 jrmu `((prompt-for-input ,prompt-for-input)
1025 665c255d 2023-08-04 jrmu (read ,read)
1026 665c255d 2023-08-04 jrmu (get-global-environment ,get-global-environment)
1027 665c255d 2023-08-04 jrmu (announce-output ,announce-output)
1028 665c255d 2023-08-04 jrmu (user-print ,user-print)
1029 665c255d 2023-08-04 jrmu (self-evaluating? ,self-evaluating?)
1030 665c255d 2023-08-04 jrmu (variable? ,variable?)
1031 665c255d 2023-08-04 jrmu (quoted? ,quoted?)
1032 665c255d 2023-08-04 jrmu (assignment? ,assignment?)
1033 665c255d 2023-08-04 jrmu (definition? ,definition?)
1034 665c255d 2023-08-04 jrmu (if? ,if?)
1035 665c255d 2023-08-04 jrmu (cond? ,cond?)
1036 665c255d 2023-08-04 jrmu (cond->if ,cond->if)
1037 665c255d 2023-08-04 jrmu (lambda? ,lambda?)
1038 665c255d 2023-08-04 jrmu (begin? ,begin?)
1039 665c255d 2023-08-04 jrmu (application? ,application?)
1040 665c255d 2023-08-04 jrmu (lookup-variable-value ,lookup-variable-value)
1041 665c255d 2023-08-04 jrmu (text-of-quotation ,text-of-quotation)
1042 665c255d 2023-08-04 jrmu (lambda-parameters ,lambda-parameters)
1043 665c255d 2023-08-04 jrmu (lambda-body ,lambda-body)
1044 665c255d 2023-08-04 jrmu (make-procedure ,make-procedure)
1045 665c255d 2023-08-04 jrmu (let->combination ,let->combination)
1046 665c255d 2023-08-04 jrmu (let? ,let?)
1047 665c255d 2023-08-04 jrmu (operands ,operands)
1048 665c255d 2023-08-04 jrmu (operator ,operator)
1049 665c255d 2023-08-04 jrmu (empty-arglist ,empty-arglist)
1050 665c255d 2023-08-04 jrmu (no-operands? ,no-operands?)
1051 665c255d 2023-08-04 jrmu (first-operand ,first-operand)
1052 665c255d 2023-08-04 jrmu (rest-operands ,rest-operands)
1053 665c255d 2023-08-04 jrmu (last-operand? ,last-operand?)
1054 665c255d 2023-08-04 jrmu (adjoin-arg ,adjoin-arg)
1055 665c255d 2023-08-04 jrmu (procedure-parameters ,procedure-parameters)
1056 665c255d 2023-08-04 jrmu (procedure-environment ,procedure-environment)
1057 665c255d 2023-08-04 jrmu (extend-environment ,extend-environment)
1058 665c255d 2023-08-04 jrmu (procedure-body ,procedure-body)
1059 665c255d 2023-08-04 jrmu (begin-actions ,begin-actions)
1060 665c255d 2023-08-04 jrmu (first-exp ,first-exp)
1061 665c255d 2023-08-04 jrmu (last-exp? ,last-exp?)
1062 665c255d 2023-08-04 jrmu (rest-exps ,rest-exps)
1063 665c255d 2023-08-04 jrmu (true? ,true?)
1064 665c255d 2023-08-04 jrmu (if-predicate ,if-predicate)
1065 665c255d 2023-08-04 jrmu (if-alternative ,if-alternative)
1066 665c255d 2023-08-04 jrmu (if-consequent ,if-consequent)
1067 665c255d 2023-08-04 jrmu (assignment-variable ,assignment-variable)
1068 665c255d 2023-08-04 jrmu (assignment-value ,assignment-value)
1069 665c255d 2023-08-04 jrmu (set-variable-value! ,set-variable-value!)
1070 665c255d 2023-08-04 jrmu (definition-variable ,definition-variable)
1071 665c255d 2023-08-04 jrmu (definition-value ,definition-value)
1072 665c255d 2023-08-04 jrmu (define-variable! ,define-variable!)
1073 665c255d 2023-08-04 jrmu (primitive-procedure? ,primitive-procedure?)
1074 665c255d 2023-08-04 jrmu (apply-primitive-procedure ,apply-primitive-procedure)
1075 665c255d 2023-08-04 jrmu (compound-procedure? ,compound-procedure?)
1076 665c255d 2023-08-04 jrmu (user-print ,user-print)
1077 665c255d 2023-08-04 jrmu (null? ,null?)))
1079 665c255d 2023-08-04 jrmu (define eceval
1080 665c255d 2023-08-04 jrmu (make-machine
1081 665c255d 2023-08-04 jrmu '(exp env val proc argl continue unev code)
1082 665c255d 2023-08-04 jrmu eceval-operations
1085 665c255d 2023-08-04 jrmu (test (op null?) (reg code))
1086 665c255d 2023-08-04 jrmu (branch (label eval-done))
1087 665c255d 2023-08-04 jrmu (perform (op initialize-stack))
1088 665c255d 2023-08-04 jrmu (assign env (op get-global-environment))
1089 665c255d 2023-08-04 jrmu (assign exp (op first-exp) (reg code))
1090 665c255d 2023-08-04 jrmu (assign code (op rest-exps) (reg code))
1091 665c255d 2023-08-04 jrmu (assign continue (label eval-continue))
1092 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1094 665c255d 2023-08-04 jrmu eval-continue
1095 665c255d 2023-08-04 jrmu (assign unev (op stack-statistics))
1096 665c255d 2023-08-04 jrmu (goto (label eval-loop))
1098 665c255d 2023-08-04 jrmu read-eval-print-loop
1099 665c255d 2023-08-04 jrmu (perform (op initialize-stack))
1101 665c255d 2023-08-04 jrmu (op prompt-for-input) (const ";;; EC-Eval input:"))
1102 665c255d 2023-08-04 jrmu (assign exp (op read))
1103 665c255d 2023-08-04 jrmu (assign env (op get-global-environment))
1104 665c255d 2023-08-04 jrmu (assign continue (label print-result))
1105 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1106 665c255d 2023-08-04 jrmu print-result
1107 665c255d 2023-08-04 jrmu (perform (op print-stack-statistics)); added instruction
1109 665c255d 2023-08-04 jrmu (op announce-output) (const ";;; EC-Eval value:"))
1110 665c255d 2023-08-04 jrmu (perform (op user-print) (reg val))
1111 665c255d 2023-08-04 jrmu (goto (label read-eval-print-loop))
1113 665c255d 2023-08-04 jrmu eval-dispatch
1114 665c255d 2023-08-04 jrmu (test (op self-evaluating?) (reg exp))
1115 665c255d 2023-08-04 jrmu (branch (label ev-self-eval))
1116 665c255d 2023-08-04 jrmu (test (op variable?) (reg exp))
1117 665c255d 2023-08-04 jrmu (branch (label ev-variable))
1118 665c255d 2023-08-04 jrmu (test (op quoted?) (reg exp))
1119 665c255d 2023-08-04 jrmu (branch (label ev-quoted))
1120 665c255d 2023-08-04 jrmu (test (op assignment?) (reg exp))
1121 665c255d 2023-08-04 jrmu (branch (label ev-assignment))
1122 665c255d 2023-08-04 jrmu (test (op definition?) (reg exp))
1123 665c255d 2023-08-04 jrmu (branch (label ev-definition))
1124 665c255d 2023-08-04 jrmu (test (op if?) (reg exp))
1125 665c255d 2023-08-04 jrmu (branch (label ev-if))
1126 665c255d 2023-08-04 jrmu (test (op cond?) (reg exp))
1127 665c255d 2023-08-04 jrmu (branch (label ev-cond))
1128 665c255d 2023-08-04 jrmu (test (op lambda?) (reg exp))
1129 665c255d 2023-08-04 jrmu (branch (label ev-lambda))
1130 665c255d 2023-08-04 jrmu (test (op let?) (reg exp))
1131 665c255d 2023-08-04 jrmu (branch (label ev-let))
1132 665c255d 2023-08-04 jrmu (test (op begin?) (reg exp))
1133 665c255d 2023-08-04 jrmu (branch (label ev-begin))
1134 665c255d 2023-08-04 jrmu (test (op application?) (reg exp))
1135 665c255d 2023-08-04 jrmu (branch (label ev-application))
1136 665c255d 2023-08-04 jrmu (goto (label unknown-expression-type))
1137 665c255d 2023-08-04 jrmu ev-self-eval
1138 665c255d 2023-08-04 jrmu (assign val (reg exp))
1139 665c255d 2023-08-04 jrmu (goto (reg continue))
1140 665c255d 2023-08-04 jrmu ev-variable
1141 665c255d 2023-08-04 jrmu (assign val (op lookup-variable-value) (reg exp) (reg env))
1142 665c255d 2023-08-04 jrmu (goto (reg continue))
1144 665c255d 2023-08-04 jrmu (assign val (op text-of-quotation) (reg exp))
1145 665c255d 2023-08-04 jrmu (goto (reg continue))
1147 665c255d 2023-08-04 jrmu (assign unev (op lambda-parameters) (reg exp))
1148 665c255d 2023-08-04 jrmu (assign exp (op lambda-body) (reg exp))
1149 665c255d 2023-08-04 jrmu (assign val (op make-procedure)
1150 665c255d 2023-08-04 jrmu (reg unev) (reg exp) (reg env))
1151 665c255d 2023-08-04 jrmu (goto (reg continue))
1153 665c255d 2023-08-04 jrmu (assign exp (op let->combination) (reg exp))
1154 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1155 665c255d 2023-08-04 jrmu ev-application
1156 665c255d 2023-08-04 jrmu (save continue)
1157 665c255d 2023-08-04 jrmu (save env)
1158 665c255d 2023-08-04 jrmu (assign unev (op operands) (reg exp))
1159 665c255d 2023-08-04 jrmu (save unev)
1160 665c255d 2023-08-04 jrmu (assign exp (op operator) (reg exp))
1161 665c255d 2023-08-04 jrmu (assign continue (label ev-appl-did-operator))
1162 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1163 665c255d 2023-08-04 jrmu ev-appl-did-operator
1164 665c255d 2023-08-04 jrmu (restore unev) ; the operands
1165 665c255d 2023-08-04 jrmu (restore env)
1166 665c255d 2023-08-04 jrmu (assign argl (op empty-arglist))
1167 665c255d 2023-08-04 jrmu (assign proc (reg val)) ; the operator
1168 665c255d 2023-08-04 jrmu (test (op no-operands?) (reg unev))
1169 665c255d 2023-08-04 jrmu (branch (label apply-dispatch))
1170 665c255d 2023-08-04 jrmu (save proc)
1171 665c255d 2023-08-04 jrmu ev-appl-operand-loop
1172 665c255d 2023-08-04 jrmu (save argl)
1173 665c255d 2023-08-04 jrmu (assign exp (op first-operand) (reg unev))
1174 665c255d 2023-08-04 jrmu (test (op last-operand?) (reg unev))
1175 665c255d 2023-08-04 jrmu (branch (label ev-appl-last-arg))
1176 665c255d 2023-08-04 jrmu (save env)
1177 665c255d 2023-08-04 jrmu (save unev)
1178 665c255d 2023-08-04 jrmu (assign continue (label ev-appl-accumulate-arg))
1179 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1180 665c255d 2023-08-04 jrmu ev-appl-accumulate-arg
1181 665c255d 2023-08-04 jrmu (restore unev)
1182 665c255d 2023-08-04 jrmu (restore env)
1183 665c255d 2023-08-04 jrmu (restore argl)
1184 665c255d 2023-08-04 jrmu (assign argl (op adjoin-arg) (reg val) (reg argl))
1185 665c255d 2023-08-04 jrmu (assign unev (op rest-operands) (reg unev))
1186 665c255d 2023-08-04 jrmu (goto (label ev-appl-operand-loop))
1187 665c255d 2023-08-04 jrmu ev-appl-last-arg
1188 665c255d 2023-08-04 jrmu (assign continue (label ev-appl-accum-last-arg))
1189 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1190 665c255d 2023-08-04 jrmu ev-appl-accum-last-arg
1191 665c255d 2023-08-04 jrmu (restore argl)
1192 665c255d 2023-08-04 jrmu (assign argl (op adjoin-arg) (reg val) (reg argl))
1193 665c255d 2023-08-04 jrmu (restore proc)
1194 665c255d 2023-08-04 jrmu (goto (label apply-dispatch))
1195 665c255d 2023-08-04 jrmu apply-dispatch
1196 665c255d 2023-08-04 jrmu (test (op primitive-procedure?) (reg proc))
1197 665c255d 2023-08-04 jrmu (branch (label primitive-apply))
1198 665c255d 2023-08-04 jrmu (test (op compound-procedure?) (reg proc))
1199 665c255d 2023-08-04 jrmu (branch (label compound-apply))
1200 665c255d 2023-08-04 jrmu (goto (label unknown-procedure-type))
1201 665c255d 2023-08-04 jrmu primitive-apply
1202 665c255d 2023-08-04 jrmu (assign val (op apply-primitive-procedure)
1203 665c255d 2023-08-04 jrmu (reg proc)
1204 665c255d 2023-08-04 jrmu (reg argl))
1205 665c255d 2023-08-04 jrmu (restore continue)
1206 665c255d 2023-08-04 jrmu (goto (reg continue))
1207 665c255d 2023-08-04 jrmu compound-apply
1208 665c255d 2023-08-04 jrmu (assign unev (op procedure-parameters) (reg proc))
1209 665c255d 2023-08-04 jrmu (assign env (op procedure-environment) (reg proc))
1210 665c255d 2023-08-04 jrmu (assign env (op extend-environment)
1211 665c255d 2023-08-04 jrmu (reg unev) (reg argl) (reg env))
1212 665c255d 2023-08-04 jrmu (assign unev (op procedure-body) (reg proc))
1213 665c255d 2023-08-04 jrmu (goto (label ev-sequence))
1215 665c255d 2023-08-04 jrmu (assign unev (op begin-actions) (reg exp))
1216 665c255d 2023-08-04 jrmu (save continue)
1217 665c255d 2023-08-04 jrmu (goto (label ev-sequence))
1218 665c255d 2023-08-04 jrmu ev-sequence
1219 665c255d 2023-08-04 jrmu (assign exp (op first-exp) (reg unev))
1220 665c255d 2023-08-04 jrmu (test (op last-exp?) (reg unev))
1221 665c255d 2023-08-04 jrmu (branch (label ev-sequence-last-exp))
1222 665c255d 2023-08-04 jrmu (save unev)
1223 665c255d 2023-08-04 jrmu (save env)
1224 665c255d 2023-08-04 jrmu (assign continue (label ev-sequence-continue))
1225 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1226 665c255d 2023-08-04 jrmu ev-sequence-continue
1227 665c255d 2023-08-04 jrmu (restore env)
1228 665c255d 2023-08-04 jrmu (restore unev)
1229 665c255d 2023-08-04 jrmu (assign unev (op rest-exps) (reg unev))
1230 665c255d 2023-08-04 jrmu (goto (label ev-sequence))
1231 665c255d 2023-08-04 jrmu ev-sequence-last-exp
1232 665c255d 2023-08-04 jrmu (restore continue)
1233 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1235 665c255d 2023-08-04 jrmu (save exp) ; save expression for later
1236 665c255d 2023-08-04 jrmu (save env)
1237 665c255d 2023-08-04 jrmu (save continue)
1238 665c255d 2023-08-04 jrmu (assign continue (label ev-if-decide))
1239 665c255d 2023-08-04 jrmu (assign exp (op if-predicate) (reg exp))
1240 665c255d 2023-08-04 jrmu (goto (label eval-dispatch)) ; evaluate the predicate
1241 665c255d 2023-08-04 jrmu ev-if-decide
1242 665c255d 2023-08-04 jrmu (restore continue)
1243 665c255d 2023-08-04 jrmu (restore env)
1244 665c255d 2023-08-04 jrmu (restore exp)
1245 665c255d 2023-08-04 jrmu (test (op true?) (reg val))
1246 665c255d 2023-08-04 jrmu (branch (label ev-if-consequent))
1248 665c255d 2023-08-04 jrmu ev-if-alternative
1249 665c255d 2023-08-04 jrmu (assign exp (op if-alternative) (reg exp))
1250 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1251 665c255d 2023-08-04 jrmu ev-if-consequent
1252 665c255d 2023-08-04 jrmu (assign exp (op if-consequent) (reg exp))
1253 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1256 665c255d 2023-08-04 jrmu (assign exp (op cond->if) (reg exp))
1257 665c255d 2023-08-04 jrmu (goto (label eval-dispatch))
1259 665c255d 2023-08-04 jrmu ev-assignment
1260 665c255d 2023-08-04 jrmu (assign unev (op assignment-variable) (reg exp))
1261 665c255d 2023-08-04 jrmu (save unev) ; save variable for later
1262 665c255d 2023-08-04 jrmu (assign exp (op assignment-value) (reg exp))
1263 665c255d 2023-08-04 jrmu (save env)
1264 665c255d 2023-08-04 jrmu (save continue)
1265 665c255d 2023-08-04 jrmu (assign continue (label ev-assignment-1))
1266 665c255d 2023-08-04 jrmu (goto (label eval-dispatch)) ; evaluate the assignment value
1267 665c255d 2023-08-04 jrmu ev-assignment-1
1268 665c255d 2023-08-04 jrmu (restore continue)
1269 665c255d 2023-08-04 jrmu (restore env)
1270 665c255d 2023-08-04 jrmu (restore unev)
1272 665c255d 2023-08-04 jrmu (op set-variable-value!) (reg unev) (reg val) (reg env))
1273 665c255d 2023-08-04 jrmu (assign val (const ok))
1274 665c255d 2023-08-04 jrmu (goto (reg continue))
1275 665c255d 2023-08-04 jrmu ev-definition
1276 665c255d 2023-08-04 jrmu (assign unev (op definition-variable) (reg exp))
1277 665c255d 2023-08-04 jrmu (save unev) ; save variable for later
1278 665c255d 2023-08-04 jrmu (assign exp (op definition-value) (reg exp))
1279 665c255d 2023-08-04 jrmu (save env)
1280 665c255d 2023-08-04 jrmu (save continue)
1281 665c255d 2023-08-04 jrmu (assign continue (label ev-definition-1))
1282 665c255d 2023-08-04 jrmu (goto (label eval-dispatch)) ; evaluate the definition value
1283 665c255d 2023-08-04 jrmu ev-definition-1
1284 665c255d 2023-08-04 jrmu (restore continue)
1285 665c255d 2023-08-04 jrmu (restore env)
1286 665c255d 2023-08-04 jrmu (restore unev)
1288 665c255d 2023-08-04 jrmu (op define-variable!) (reg unev) (reg val) (reg env))
1289 665c255d 2023-08-04 jrmu (assign val (const ok))
1290 665c255d 2023-08-04 jrmu (goto (reg continue))
1292 665c255d 2023-08-04 jrmu unknown-expression-type
1293 665c255d 2023-08-04 jrmu (assign val (const unknown-expression-type-error))
1294 665c255d 2023-08-04 jrmu (goto (label signal-error))
1295 665c255d 2023-08-04 jrmu unknown-procedure-type
1296 665c255d 2023-08-04 jrmu (restore continue) ; clean up stack (from apply-dispatch)
1297 665c255d 2023-08-04 jrmu (assign val (const unknown-procedure-type-error))
1298 665c255d 2023-08-04 jrmu (goto (label signal-error))
1299 665c255d 2023-08-04 jrmu signal-error
1300 665c255d 2023-08-04 jrmu (perform (op user-print) (reg val))
1301 665c255d 2023-08-04 jrmu (goto (label read-eval-print-loop))
1303 665c255d 2023-08-04 jrmu eval-done)))
1305 665c255d 2023-08-04 jrmu ;; test suite
1307 665c255d 2023-08-04 jrmu ;; (set-register-contents!
1310 665c255d 2023-08-04 jrmu ;; '((define (factorial n)
1311 665c255d 2023-08-04 jrmu ;; (if (= n 1)
1313 665c255d 2023-08-04 jrmu ;; (* n (factorial (- n 1)))))
1314 665c255d 2023-08-04 jrmu ;; (factorial 8)))
1315 665c255d 2023-08-04 jrmu ;; (start eceval)
1316 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents eceval 'val)
1320 665c255d 2023-08-04 jrmu ;; (set-register-contents!
1323 665c255d 2023-08-04 jrmu ;; '((define (cons x y)
1324 665c255d 2023-08-04 jrmu ;; (lambda (m) (m x y)))
1325 665c255d 2023-08-04 jrmu ;; (define (car z)
1326 665c255d 2023-08-04 jrmu ;; (z (lambda (p q) p)))
1327 665c255d 2023-08-04 jrmu ;; (define (cdr z)
1328 665c255d 2023-08-04 jrmu ;; (z (lambda (p q) q)))
1329 665c255d 2023-08-04 jrmu ;; (define pair (cons 3 2))
1330 665c255d 2023-08-04 jrmu ;; (+ (car pair) (cdr pair))))
1331 665c255d 2023-08-04 jrmu ;; (start eceval)
1332 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents eceval 'val)
1335 665c255d 2023-08-04 jrmu (define (test-interpret code expected)
1336 665c255d 2023-08-04 jrmu (set-register-contents! eceval 'code code)
1337 665c255d 2023-08-04 jrmu (start eceval)
1338 665c255d 2023-08-04 jrmu (test-case (get-register-contents eceval 'val) expected))
1340 665c255d 2023-08-04 jrmu (define (test-interpret-stack code expected)
1341 665c255d 2023-08-04 jrmu (set-register-contents! eceval 'code code)
1342 665c255d 2023-08-04 jrmu (start eceval)
1343 665c255d 2023-08-04 jrmu (test-case (get-register-contents eceval 'val) expected)
1344 665c255d 2023-08-04 jrmu (display (get-register-contents eceval 'unev))
1345 665c255d 2023-08-04 jrmu (newline))
1347 665c255d 2023-08-04 jrmu (test-interpret-stack
1348 665c255d 2023-08-04 jrmu '((define (factorial n)
1349 665c255d 2023-08-04 jrmu (if (= n 1)
1351 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))))
1352 665c255d 2023-08-04 jrmu (factorial 8))
1354 665c255d 2023-08-04 jrmu (test-interpret-stack
1355 665c255d 2023-08-04 jrmu '((define (cons x y)
1356 665c255d 2023-08-04 jrmu (lambda (m) (m x y)))
1357 665c255d 2023-08-04 jrmu (define (car z)
1358 665c255d 2023-08-04 jrmu (z (lambda (p q) p)))
1359 665c255d 2023-08-04 jrmu (define (cdr z)
1360 665c255d 2023-08-04 jrmu (z (lambda (p q) q)))
1361 665c255d 2023-08-04 jrmu (define pair (cons 3 2))
1362 665c255d 2023-08-04 jrmu (+ (car pair) (cdr pair)))
1365 665c255d 2023-08-04 jrmu ;; procedure definition / application
1367 665c255d 2023-08-04 jrmu (test-interpret-stack
1368 665c255d 2023-08-04 jrmu '((define (factorial n)
1369 665c255d 2023-08-04 jrmu (if (= n 1)
1371 665c255d 2023-08-04 jrmu (* n (factorial (- n 1)))))
1372 665c255d 2023-08-04 jrmu (factorial 8))
1374 665c255d 2023-08-04 jrmu (test-interpret-stack
1375 665c255d 2023-08-04 jrmu '((define (cons x y)
1376 665c255d 2023-08-04 jrmu (lambda (m) (m x y)))
1377 665c255d 2023-08-04 jrmu (define (car z)
1378 665c255d 2023-08-04 jrmu (z (lambda (p q) p)))
1379 665c255d 2023-08-04 jrmu (define (cdr z)
1380 665c255d 2023-08-04 jrmu (z (lambda (p q) q)))
1381 665c255d 2023-08-04 jrmu (define pair (cons 3 2))
1382 665c255d 2023-08-04 jrmu (+ (car pair) (cdr pair)))
1387 665c255d 2023-08-04 jrmu (test-interpret-stack
1388 665c255d 2023-08-04 jrmu '((define x -25)
1389 665c255d 2023-08-04 jrmu (cond ((= x -2) 'x=-2)
1390 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
1391 665c255d 2023-08-04 jrmu (else 'failed)))
1393 665c255d 2023-08-04 jrmu (test-interpret-stack
1394 665c255d 2023-08-04 jrmu '((cond ((= 2 4) 3)
1395 665c255d 2023-08-04 jrmu ((= 2 (factorial 3)) true)
1396 665c255d 2023-08-04 jrmu (((lambda (result) result) true) 5)))
1398 665c255d 2023-08-04 jrmu (test-interpret-stack
1399 665c255d 2023-08-04 jrmu '((cond (((lambda (result) result) false) 5)
1400 665c255d 2023-08-04 jrmu ((car (cons false true)) 3)))
1402 665c255d 2023-08-04 jrmu (test-interpret-stack
1403 665c255d 2023-08-04 jrmu '((cond (((lambda (result) result) false) 5)
1404 665c255d 2023-08-04 jrmu ((car (cons false true)) 3)
1405 665c255d 2023-08-04 jrmu (else 4)))
1410 665c255d 2023-08-04 jrmu (test-interpret-stack
1411 665c255d 2023-08-04 jrmu '((let ((x 4) (y 7))
1412 665c255d 2023-08-04 jrmu (+ x y (* x y))))
1413 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
1414 665c255d 2023-08-04 jrmu (test-interpret-stack
1415 665c255d 2023-08-04 jrmu '((let ((x 3)
1419 665c255d 2023-08-04 jrmu (test-interpret-stack
1420 665c255d 2023-08-04 jrmu '((let ((x 3)
1422 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
1426 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
1427 665c255d 2023-08-04 jrmu (test-interpret-stack
1428 665c255d 2023-08-04 jrmu '((let ((x 6)
1429 665c255d 2023-08-04 jrmu (y (let ((x 2))
1431 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
1432 665c255d 2023-08-04 jrmu (+ a 3))))
1433 665c255d 2023-08-04 jrmu (+ x y z)))
1434 665c255d 2023-08-04 jrmu (+ 6 5 9))
1436 665c255d 2023-08-04 jrmu ;; Exercise 5.26. Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
1438 665c255d 2023-08-04 jrmu (test-interpret-stack
1439 665c255d 2023-08-04 jrmu '((define (factorial n)
1440 665c255d 2023-08-04 jrmu (define (iter product counter)
1441 665c255d 2023-08-04 jrmu (if (> counter n)
1443 665c255d 2023-08-04 jrmu (iter (* counter product)
1444 665c255d 2023-08-04 jrmu (+ counter 1))))
1445 665c255d 2023-08-04 jrmu (iter 1 1))
1446 665c255d 2023-08-04 jrmu (factorial 1))
1448 665c255d 2023-08-04 jrmu (test-interpret-stack
1449 665c255d 2023-08-04 jrmu '((factorial 2))
1451 665c255d 2023-08-04 jrmu (test-interpret-stack
1452 665c255d 2023-08-04 jrmu '((factorial 3))
1454 665c255d 2023-08-04 jrmu (test-interpret-stack
1455 665c255d 2023-08-04 jrmu '((factorial 4))
1457 665c255d 2023-08-04 jrmu (test-interpret-stack
1458 665c255d 2023-08-04 jrmu '((factorial 5))
1460 665c255d 2023-08-04 jrmu (test-interpret-stack
1461 665c255d 2023-08-04 jrmu '((factorial 6))
1464 665c255d 2023-08-04 jrmu ;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
1466 665c255d 2023-08-04 jrmu ;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
1470 665c255d 2023-08-04 jrmu ;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants.
1472 665c255d 2023-08-04 jrmu ;; 35n + 29
