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 (test-interpret-stack
1437 665c255d 2023-08-04 jrmu '((define (factorial n)
1438 665c255d 2023-08-04 jrmu (define (iter product counter)
1439 665c255d 2023-08-04 jrmu (if (> counter n)
1441 665c255d 2023-08-04 jrmu (iter (* counter product)
1442 665c255d 2023-08-04 jrmu (+ counter 1))))
1443 665c255d 2023-08-04 jrmu (iter 1 1)))
1445 665c255d 2023-08-04 jrmu (test-interpret-stack
1446 665c255d 2023-08-04 jrmu '((factorial 9))
1449 665c255d 2023-08-04 jrmu (test-interpret-stack
1450 665c255d 2023-08-04 jrmu '((define (fact-rec n)
1451 665c255d 2023-08-04 jrmu (if (= n 1)
1453 665c255d 2023-08-04 jrmu (* (fact-rec (- n 1)) n))))
1455 665c255d 2023-08-04 jrmu (test-interpret-stack
1456 665c255d 2023-08-04 jrmu '((fact-rec 10))
1459 665c255d 2023-08-04 jrmu (test-interpret-stack
1460 665c255d 2023-08-04 jrmu '((define (fib n)
1461 665c255d 2023-08-04 jrmu (if (< n 2)
1463 665c255d 2023-08-04 jrmu (+ (fib (- n 1)) (fib (- n 2))))))
1465 665c255d 2023-08-04 jrmu (test-interpret-stack
1466 665c255d 2023-08-04 jrmu '((fib 13))
1469 665c255d 2023-08-04 jrmu ;; repeat 5 times
1471 665c255d 2023-08-04 jrmu (define (compile exp target linkage)
1472 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage))
1473 665c255d 2023-08-04 jrmu ((quoted? exp) (compile-quoted exp target linkage))
1474 665c255d 2023-08-04 jrmu ((variable? exp) (compile-variable exp target linkage))
1475 665c255d 2023-08-04 jrmu ((lambda? exp) (compile-lambda exp target linkage))
1476 665c255d 2023-08-04 jrmu ((begin? exp) (compile-sequence (begin-actions exp) target linkage))
1477 665c255d 2023-08-04 jrmu ((if? exp) (compile-if exp target linkage))
1478 665c255d 2023-08-04 jrmu ((cond? exp) (compile (cond->if exp) target linkage))
1479 665c255d 2023-08-04 jrmu ((assignment? exp) (compile-assignment exp target linkage))
1480 665c255d 2023-08-04 jrmu ((definition? exp) (compile-definition exp target linkage))
1481 665c255d 2023-08-04 jrmu ((application? exp) (compile-application exp target linkage))
1482 665c255d 2023-08-04 jrmu (else (error "Unknown expression type -- COMPILE" exp))))
1484 665c255d 2023-08-04 jrmu (define (make-instruction-sequence needs modifies statements)
1485 665c255d 2023-08-04 jrmu (list needs modifies statements))
1486 665c255d 2023-08-04 jrmu (define (empty-instruction-sequence)
1487 665c255d 2023-08-04 jrmu (make-instruction-sequence '() '() '()))
1489 665c255d 2023-08-04 jrmu (define (compile-linkage linkage)
1490 665c255d 2023-08-04 jrmu (cond ((eq? linkage 'next) (empty-instruction-sequence))
1491 665c255d 2023-08-04 jrmu ((eq? linkage 'return)
1492 665c255d 2023-08-04 jrmu (make-instruction-sequence
1493 665c255d 2023-08-04 jrmu '(continue) '()
1494 665c255d 2023-08-04 jrmu '((goto (reg continue)))))
1496 665c255d 2023-08-04 jrmu (make-instruction-sequence
1498 665c255d 2023-08-04 jrmu `((goto (label ,linkage)))))))
1499 665c255d 2023-08-04 jrmu (define (end-with-linkage linkage instruction-sequence)
1500 665c255d 2023-08-04 jrmu (preserving '(continue)
1501 665c255d 2023-08-04 jrmu instruction-sequence
1502 665c255d 2023-08-04 jrmu (compile-linkage linkage)))
1504 665c255d 2023-08-04 jrmu (define (compile-self-evaluating exp target linkage)
1505 665c255d 2023-08-04 jrmu (end-with-linkage
1507 665c255d 2023-08-04 jrmu (make-instruction-sequence
1508 665c255d 2023-08-04 jrmu '() (list target)
1509 665c255d 2023-08-04 jrmu `((assign ,target (const ,exp))))))
1510 665c255d 2023-08-04 jrmu (define (compile-quoted exp target linkage)
1511 665c255d 2023-08-04 jrmu (end-with-linkage linkage
1512 665c255d 2023-08-04 jrmu (make-instruction-sequence
1513 665c255d 2023-08-04 jrmu '() (list target)
1514 665c255d 2023-08-04 jrmu `((assign ,target (const ,(text-of-quotation exp)))))))
1515 665c255d 2023-08-04 jrmu (define (compile-variable exp target linkage)
1516 665c255d 2023-08-04 jrmu (end-with-linkage linkage
1517 665c255d 2023-08-04 jrmu (make-instruction-sequence
1518 665c255d 2023-08-04 jrmu '(env) (list target)
1519 665c255d 2023-08-04 jrmu `((assign ,target (op lookup-variable-value) (const ,exp) (reg env))))))
1520 665c255d 2023-08-04 jrmu (define (compile-assignment exp target linkage)
1521 665c255d 2023-08-04 jrmu (let ((var (assignment-variable exp))
1522 665c255d 2023-08-04 jrmu (val-code (compile (assignment-value exp) 'val 'next)))
1523 665c255d 2023-08-04 jrmu (preserving '(continue env)
1525 665c255d 2023-08-04 jrmu (end-with-linkage linkage
1526 665c255d 2023-08-04 jrmu (make-instruction-sequence
1527 665c255d 2023-08-04 jrmu '(val env) (list target)
1528 665c255d 2023-08-04 jrmu `((perform (op set-variable-value!) (const ,var) (reg val) (reg env))
1529 665c255d 2023-08-04 jrmu (assign ,target (const ok))))))))
1530 665c255d 2023-08-04 jrmu (define (compile-definition exp target linkage)
1531 665c255d 2023-08-04 jrmu (let ((var (definition-variable exp))
1532 665c255d 2023-08-04 jrmu (get-value-code (compile (definition-value exp) 'val 'next)))
1533 665c255d 2023-08-04 jrmu (preserving '(continue env)
1534 665c255d 2023-08-04 jrmu get-value-code
1535 665c255d 2023-08-04 jrmu (end-with-linkage linkage
1536 665c255d 2023-08-04 jrmu (make-instruction-sequence
1537 665c255d 2023-08-04 jrmu '(val env) (list target)
1538 665c255d 2023-08-04 jrmu `((perform (op define-variable!) (const ,var) (reg val) (reg env))
1539 665c255d 2023-08-04 jrmu (assign ,target (const ok))))))))
1540 665c255d 2023-08-04 jrmu (define (compile-if exp target linkage)
1541 665c255d 2023-08-04 jrmu (let* ((t-branch (make-label 't-branch))
1542 665c255d 2023-08-04 jrmu (f-branch (make-label 'f-branch))
1543 665c255d 2023-08-04 jrmu (after-if (make-label 'after-if))
1544 665c255d 2023-08-04 jrmu (consequent-linkage (if (eq? linkage 'next) after-if linkage))
1545 665c255d 2023-08-04 jrmu (p-code (compile (if-predicate exp) 'val 'next))
1546 665c255d 2023-08-04 jrmu (c-code (compile (if-consequent exp) target consequent-linkage))
1547 665c255d 2023-08-04 jrmu (a-code (compile (if-alternative exp) target linkage)))
1548 665c255d 2023-08-04 jrmu (preserving '(continue env)
1550 665c255d 2023-08-04 jrmu (append-instruction-sequences
1551 665c255d 2023-08-04 jrmu (make-instruction-sequence
1552 665c255d 2023-08-04 jrmu '(val) '()
1553 665c255d 2023-08-04 jrmu `((test (op false?) (reg val))
1554 665c255d 2023-08-04 jrmu (branch (label ,f-branch))))
1555 665c255d 2023-08-04 jrmu (parallel-instruction-sequences
1556 665c255d 2023-08-04 jrmu (append-instruction-sequences t-branch c-code)
1557 665c255d 2023-08-04 jrmu (append-instruction-sequences f-branch a-code))
1558 665c255d 2023-08-04 jrmu after-if))
1559 665c255d 2023-08-04 jrmu (define (compile-sequence seq target linkage)
1560 665c255d 2023-08-04 jrmu (if (last-exp? seq)
1561 665c255d 2023-08-04 jrmu (compile (first-exp seq) target linkage)
1562 665c255d 2023-08-04 jrmu (preserving '(env continue)
1563 665c255d 2023-08-04 jrmu (compile (first-exp seq) target 'next)
1564 665c255d 2023-08-04 jrmu (compile-sequence (rest-exps seq) target linkage))))
1565 665c255d 2023-08-04 jrmu (define (compile-lambda exp target linkage)
1566 665c255d 2023-08-04 jrmu (let* ((after-lambda (make-label 'after-lambda))
1567 665c255d 2023-08-04 jrmu (proc-entry (make-label 'proc-entry))
1568 665c255d 2023-08-04 jrmu (lambda-linkage (if (eq? linkage 'next) after-lambda linkage)))
1569 665c255d 2023-08-04 jrmu (append-instruction-sequence
1570 665c255d 2023-08-04 jrmu (tack-on-instruction-sequence
1571 665c255d 2023-08-04 jrmu (end-with-linkage lambda-linkage
1572 665c255d 2023-08-04 jrmu (make-instruction-sequence
1573 665c255d 2023-08-04 jrmu '(env) (list target)
1574 665c255d 2023-08-04 jrmu `((assign ,target (op make-compiled-procedure) (label ,proc-entry) (reg env)))))
1575 665c255d 2023-08-04 jrmu (compile-lambda-body exp proc-entry))
1576 665c255d 2023-08-04 jrmu after-lambda)))
1577 665c255d 2023-08-04 jrmu (define (compile-lambda-body exp proc-entry)
1580 665c255d 2023-08-04 jrmu (compile-application exp target linkage)
1582 665c255d 2023-08-04 jrmu (define label-counter 0)
1583 665c255d 2023-08-04 jrmu (define (new-label-number)
1584 665c255d 2023-08-04 jrmu (set! label-counter (+ label-counter 1))
1585 665c255d 2023-08-04 jrmu label-counter)
1586 665c255d 2023-08-04 jrmu (define (make-label name)
1587 665c255d 2023-08-04 jrmu (string->symbol
1588 665c255d 2023-08-04 jrmu (string-append
1589 665c255d 2023-08-04 jrmu (symbol->string name)
1590 665c255d 2023-08-04 jrmu (number->string (new-label-number)))))
1592 665c255d 2023-08-04 jrmu (define (preserving regs seq1 seq2)
1594 665c255d 2023-08-04 jrmu (define (append-instruction-sequences . seq)
1596 665c255d 2023-08-04 jrmu tack-on-instruction-sequence
1597 665c255d 2023-08-04 jrmu parallel-instruction-sequence
