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))
  9 665c255d 2023-08-04 jrmu     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)))
 16 665c255d 2023-08-04 jrmu             (else
 17 665c255d 2023-08-04 jrmu              (error "Unknown request -- REGISTER" message))))
 18 665c255d 2023-08-04 jrmu     dispatch))
 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))
 39 665c255d 2023-08-04 jrmu             top)))    
 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)
 45 665c255d 2023-08-04 jrmu       'done)
 46 665c255d 2023-08-04 jrmu     (define (print-statistics)
 47 665c255d 2023-08-04 jrmu       (newline)
 48 665c255d 2023-08-04 jrmu       (display (list 'total-pushes  '= number-pushes
 49 665c255d 2023-08-04 jrmu                      'maximum-depth '= max-depth)))
 50 665c255d 2023-08-04 jrmu     (define (dispatch message)
 51 665c255d 2023-08-04 jrmu       (cond ((eq? message 'push) push)
 52 665c255d 2023-08-04 jrmu             ((eq? message 'pop) (pop))
 53 665c255d 2023-08-04 jrmu             ((eq? message 'initialize) (initialize))
 54 665c255d 2023-08-04 jrmu             ((eq? message 'print-statistics)
 55 665c255d 2023-08-04 jrmu              (print-statistics))
 56 665c255d 2023-08-04 jrmu             (else
 57 665c255d 2023-08-04 jrmu              (error "Unknown request -- STACK" message))))
 58 665c255d 2023-08-04 jrmu     dispatch))
 59 665c255d 2023-08-04 jrmu (define (pop stack)
 60 665c255d 2023-08-04 jrmu   (stack 'pop))
 61 665c255d 2023-08-04 jrmu (define (push stack value)
 62 665c255d 2023-08-04 jrmu   ((stack 'push) value))
 63 665c255d 2023-08-04 jrmu (define (make-new-machine)
 64 665c255d 2023-08-04 jrmu   (let ((pc (make-register 'pc))
 65 665c255d 2023-08-04 jrmu         (flag (make-register 'flag))
 66 665c255d 2023-08-04 jrmu         (stack (make-stack))
 67 665c255d 2023-08-04 jrmu         (the-instruction-sequence '()))
 68 665c255d 2023-08-04 jrmu     (let ((the-ops
 69 665c255d 2023-08-04 jrmu 	   (list (list 'initialize-stack
 70 665c255d 2023-08-04 jrmu 		       (lambda () (stack 'initialize)))
 71 665c255d 2023-08-04 jrmu 		 (list 'print-stack-statistics
 72 665c255d 2023-08-04 jrmu 		       (lambda () (stack 'print-statistics)))))
 73 665c255d 2023-08-04 jrmu           (register-table
 74 665c255d 2023-08-04 jrmu            (list (list 'pc pc) (list 'flag flag))))
 75 665c255d 2023-08-04 jrmu       (define (allocate-register name)
 76 665c255d 2023-08-04 jrmu         (if (assoc name register-table)
 77 665c255d 2023-08-04 jrmu             (error "Multiply defined register: " name)
 78 665c255d 2023-08-04 jrmu             (set! register-table
 79 665c255d 2023-08-04 jrmu                   (cons (list name (make-register name))
 80 665c255d 2023-08-04 jrmu                         register-table)))
 81 665c255d 2023-08-04 jrmu         'register-allocated)
 82 665c255d 2023-08-04 jrmu       (define (lookup-register name)
 83 665c255d 2023-08-04 jrmu         (let ((val (assoc name register-table)))
 84 665c255d 2023-08-04 jrmu           (if val
 85 665c255d 2023-08-04 jrmu               (cadr val)
 86 665c255d 2023-08-04 jrmu               (error "Unknown register:" name))))
 87 665c255d 2023-08-04 jrmu       (define (execute)
 88 665c255d 2023-08-04 jrmu         (let ((insts (get-contents pc)))
 89 665c255d 2023-08-04 jrmu           (if (null? insts)
 90 665c255d 2023-08-04 jrmu               'done
 91 665c255d 2023-08-04 jrmu               (begin
 92 665c255d 2023-08-04 jrmu                 ((instruction-execution-proc (car insts)))
 93 665c255d 2023-08-04 jrmu                 (execute)))))
 94 665c255d 2023-08-04 jrmu       (define (dispatch message)
 95 665c255d 2023-08-04 jrmu         (cond ((eq? message 'start)
 96 665c255d 2023-08-04 jrmu                (set-contents! pc the-instruction-sequence)
 97 665c255d 2023-08-04 jrmu                (execute))
 98 665c255d 2023-08-04 jrmu               ((eq? message 'install-instruction-sequence)
 99 665c255d 2023-08-04 jrmu                (lambda (seq) (set! the-instruction-sequence seq)))
100 665c255d 2023-08-04 jrmu               ((eq? message 'allocate-register) allocate-register)
101 665c255d 2023-08-04 jrmu               ((eq? message 'get-register) lookup-register)
102 665c255d 2023-08-04 jrmu               ((eq? message 'install-operations)
103 665c255d 2023-08-04 jrmu                (lambda (ops) (set! the-ops (append the-ops ops))))
104 665c255d 2023-08-04 jrmu               ((eq? message 'stack) stack)
105 665c255d 2023-08-04 jrmu               ((eq? message 'operations) the-ops)
106 665c255d 2023-08-04 jrmu               (else (error "Unknown request -- MACHINE" message))))
107 665c255d 2023-08-04 jrmu       dispatch)))
108 665c255d 2023-08-04 jrmu (define (start machine)
109 665c255d 2023-08-04 jrmu   (machine 'start))
110 665c255d 2023-08-04 jrmu (define (get-register-contents machine register-name)
111 665c255d 2023-08-04 jrmu   (get-contents (get-register machine register-name)))
112 665c255d 2023-08-04 jrmu (define (set-register-contents! machine register-name value)
113 665c255d 2023-08-04 jrmu   (set-contents! (get-register machine register-name) value)
114 665c255d 2023-08-04 jrmu   'done)
115 665c255d 2023-08-04 jrmu (define (get-register machine reg-name)
116 665c255d 2023-08-04 jrmu   ((machine 'get-register) reg-name))
117 665c255d 2023-08-04 jrmu (define (assemble controller-text machine)
118 665c255d 2023-08-04 jrmu   (extract-labels controller-text
119 665c255d 2023-08-04 jrmu     (lambda (insts labels)
120 665c255d 2023-08-04 jrmu       (update-insts! insts labels machine)
121 665c255d 2023-08-04 jrmu       insts)))
122 665c255d 2023-08-04 jrmu (define (extract-labels text receive)
123 665c255d 2023-08-04 jrmu   (if (null? text)
124 665c255d 2023-08-04 jrmu       (receive '() '())
125 665c255d 2023-08-04 jrmu       (extract-labels (cdr text)
126 665c255d 2023-08-04 jrmu        (lambda (insts labels)
127 665c255d 2023-08-04 jrmu          (let ((next-inst (car text)))
128 665c255d 2023-08-04 jrmu            (if (symbol? next-inst)
129 665c255d 2023-08-04 jrmu 	       (if (label-defined? labels next-inst)
130 665c255d 2023-08-04 jrmu 		   (error "Duplicate label -- ASSEMBLE"
131 665c255d 2023-08-04 jrmu 			  next-inst)
132 665c255d 2023-08-04 jrmu 		   (receive 
133 665c255d 2023-08-04 jrmu 		       insts
134 665c255d 2023-08-04 jrmu 		       (cons (make-label-entry next-inst
135 665c255d 2023-08-04 jrmu 					       insts)
136 665c255d 2023-08-04 jrmu 			     labels)))
137 665c255d 2023-08-04 jrmu                (receive
138 665c255d 2023-08-04 jrmu 		   (cons (make-instruction next-inst)
139 665c255d 2023-08-04 jrmu 			 insts)
140 665c255d 2023-08-04 jrmu 		   labels)))))))
141 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
142 665c255d 2023-08-04 jrmu   (let ((pc (get-register machine 'pc))
143 665c255d 2023-08-04 jrmu         (flag (get-register machine 'flag))
144 665c255d 2023-08-04 jrmu         (stack (machine 'stack))
145 665c255d 2023-08-04 jrmu         (ops (machine 'operations)))
146 665c255d 2023-08-04 jrmu     (for-each
147 665c255d 2023-08-04 jrmu      (lambda (inst)
148 665c255d 2023-08-04 jrmu        (set-instruction-execution-proc! 
149 665c255d 2023-08-04 jrmu         inst
150 665c255d 2023-08-04 jrmu         (make-execution-procedure
151 665c255d 2023-08-04 jrmu          (instruction-text inst) labels machine
152 665c255d 2023-08-04 jrmu          pc flag stack ops)))
153 665c255d 2023-08-04 jrmu      insts)))
154 665c255d 2023-08-04 jrmu (define (make-instruction text)
155 665c255d 2023-08-04 jrmu   (cons text '()))
156 665c255d 2023-08-04 jrmu (define (instruction-text inst)
157 665c255d 2023-08-04 jrmu   (car inst))
158 665c255d 2023-08-04 jrmu (define (instruction-execution-proc inst)
159 665c255d 2023-08-04 jrmu   (cdr inst))
160 665c255d 2023-08-04 jrmu (define (set-instruction-execution-proc! inst proc)
161 665c255d 2023-08-04 jrmu   (set-cdr! inst proc))
162 665c255d 2023-08-04 jrmu (define (make-label-entry label-name insts)
163 665c255d 2023-08-04 jrmu   (cons label-name insts))
164 665c255d 2023-08-04 jrmu (define (label-defined? labels label-name)
165 665c255d 2023-08-04 jrmu   (not (false? (assoc label-name labels))))
166 665c255d 2023-08-04 jrmu (define (lookup-label labels label-name)
167 665c255d 2023-08-04 jrmu   (let ((val (assoc label-name labels)))
168 665c255d 2023-08-04 jrmu     (if val
169 665c255d 2023-08-04 jrmu         (cdr val)
170 665c255d 2023-08-04 jrmu         (error "Undefined label -- ASSEMBLE" label-name))))
171 665c255d 2023-08-04 jrmu (define (make-execution-procedure inst labels machine
172 665c255d 2023-08-04 jrmu                                   pc flag stack ops)
173 665c255d 2023-08-04 jrmu   (cond ((eq? (car inst) 'assign)
174 665c255d 2023-08-04 jrmu          (make-assign inst machine labels ops pc))
175 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'test)
176 665c255d 2023-08-04 jrmu          (make-test inst machine labels ops flag pc))
177 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'branch)
178 665c255d 2023-08-04 jrmu          (make-branch inst machine labels flag pc))
179 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'goto)
180 665c255d 2023-08-04 jrmu          (make-goto inst machine labels pc))
181 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'save)
182 665c255d 2023-08-04 jrmu          (make-save inst machine stack pc))
183 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'restore)
184 665c255d 2023-08-04 jrmu          (make-restore inst machine stack pc))
185 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'perform)
186 665c255d 2023-08-04 jrmu          (make-perform inst machine labels ops pc))
187 665c255d 2023-08-04 jrmu         (else (error "Unknown instruction type -- ASSEMBLE"
188 665c255d 2023-08-04 jrmu                      inst))))
189 665c255d 2023-08-04 jrmu (define (make-assign inst machine labels operations pc)
190 665c255d 2023-08-04 jrmu   (let ((target
191 665c255d 2023-08-04 jrmu          (get-register machine (assign-reg-name inst)))
192 665c255d 2023-08-04 jrmu         (value-exp (assign-value-exp inst)))
193 665c255d 2023-08-04 jrmu     (let ((value-proc
194 665c255d 2023-08-04 jrmu            (if (operation-exp? value-exp)
195 665c255d 2023-08-04 jrmu                (make-operation-exp
196 665c255d 2023-08-04 jrmu                 value-exp machine labels operations)
197 665c255d 2023-08-04 jrmu                (make-primitive-exp
198 665c255d 2023-08-04 jrmu                 (car value-exp) machine labels))))
199 665c255d 2023-08-04 jrmu       (lambda ()                ; execution procedure for assign
200 665c255d 2023-08-04 jrmu         (set-contents! target (value-proc))
201 665c255d 2023-08-04 jrmu         (advance-pc pc)))))
202 665c255d 2023-08-04 jrmu (define (assign-reg-name assign-instruction)
203 665c255d 2023-08-04 jrmu   (cadr assign-instruction))
204 665c255d 2023-08-04 jrmu (define (assign-value-exp assign-instruction)
205 665c255d 2023-08-04 jrmu   (cddr assign-instruction))
206 665c255d 2023-08-04 jrmu (define (advance-pc pc)
207 665c255d 2023-08-04 jrmu   (set-contents! pc (cdr (get-contents pc))))
208 665c255d 2023-08-04 jrmu (define (make-test inst machine labels operations flag pc)
209 665c255d 2023-08-04 jrmu   (let ((condition (test-condition inst)))
210 665c255d 2023-08-04 jrmu     (if (operation-exp? condition)
211 665c255d 2023-08-04 jrmu         (let ((condition-proc
212 665c255d 2023-08-04 jrmu                (make-operation-exp
213 665c255d 2023-08-04 jrmu                 condition machine labels operations)))
214 665c255d 2023-08-04 jrmu           (lambda ()
215 665c255d 2023-08-04 jrmu             (set-contents! flag (condition-proc))
216 665c255d 2023-08-04 jrmu             (advance-pc pc)))
217 665c255d 2023-08-04 jrmu         (error "Bad TEST instruction -- ASSEMBLE" inst))))
218 665c255d 2023-08-04 jrmu (define (test-condition test-instruction)
219 665c255d 2023-08-04 jrmu   (cdr test-instruction))
220 665c255d 2023-08-04 jrmu (define (make-branch inst machine labels flag pc)
221 665c255d 2023-08-04 jrmu   (let ((dest (branch-dest inst)))
222 665c255d 2023-08-04 jrmu     (if (label-exp? dest)
223 665c255d 2023-08-04 jrmu         (let ((insts
224 665c255d 2023-08-04 jrmu                (lookup-label labels (label-exp-label dest))))
225 665c255d 2023-08-04 jrmu           (lambda ()
226 665c255d 2023-08-04 jrmu             (if (get-contents flag)
227 665c255d 2023-08-04 jrmu                 (set-contents! pc insts)
228 665c255d 2023-08-04 jrmu                 (advance-pc pc))))
229 665c255d 2023-08-04 jrmu         (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
230 665c255d 2023-08-04 jrmu (define (branch-dest branch-instruction)
231 665c255d 2023-08-04 jrmu   (cadr branch-instruction))
232 665c255d 2023-08-04 jrmu (define (make-goto inst machine labels pc)
233 665c255d 2023-08-04 jrmu   (let ((dest (goto-dest inst)))
234 665c255d 2023-08-04 jrmu     (cond ((label-exp? dest)
235 665c255d 2023-08-04 jrmu            (let ((insts
236 665c255d 2023-08-04 jrmu                   (lookup-label labels
237 665c255d 2023-08-04 jrmu                                 (label-exp-label dest))))
238 665c255d 2023-08-04 jrmu              (lambda () (set-contents! pc insts))))
239 665c255d 2023-08-04 jrmu           ((register-exp? dest)
240 665c255d 2023-08-04 jrmu            (let ((reg
241 665c255d 2023-08-04 jrmu                   (get-register machine
242 665c255d 2023-08-04 jrmu                                 (register-exp-reg dest))))
243 665c255d 2023-08-04 jrmu              (lambda ()
244 665c255d 2023-08-04 jrmu                (set-contents! pc (get-contents reg)))))
245 665c255d 2023-08-04 jrmu           (else (error "Bad GOTO instruction -- ASSEMBLE"
246 665c255d 2023-08-04 jrmu                        inst)))))
247 665c255d 2023-08-04 jrmu (define (goto-dest goto-instruction)
248 665c255d 2023-08-04 jrmu   (cadr goto-instruction))
249 665c255d 2023-08-04 jrmu (define (make-save inst machine stack pc)
250 665c255d 2023-08-04 jrmu   (let ((reg (get-register machine
251 665c255d 2023-08-04 jrmu                            (stack-inst-reg-name inst))))
252 665c255d 2023-08-04 jrmu     (lambda ()
253 665c255d 2023-08-04 jrmu       (push stack (get-contents reg))
254 665c255d 2023-08-04 jrmu       (advance-pc pc))))
255 665c255d 2023-08-04 jrmu (define (make-restore inst machine stack pc)
256 665c255d 2023-08-04 jrmu   (let ((reg (get-register machine
257 665c255d 2023-08-04 jrmu                            (stack-inst-reg-name inst))))
258 665c255d 2023-08-04 jrmu     (lambda ()
259 665c255d 2023-08-04 jrmu       (set-contents! reg (pop stack))    
260 665c255d 2023-08-04 jrmu       (advance-pc pc))))
261 665c255d 2023-08-04 jrmu (define (stack-inst-reg-name stack-instruction)
262 665c255d 2023-08-04 jrmu   (cadr stack-instruction))
263 665c255d 2023-08-04 jrmu (define (make-perform inst machine labels operations pc)
264 665c255d 2023-08-04 jrmu   (let ((action (perform-action inst)))
265 665c255d 2023-08-04 jrmu     (if (operation-exp? action)
266 665c255d 2023-08-04 jrmu         (let ((action-proc
267 665c255d 2023-08-04 jrmu                (make-operation-exp
268 665c255d 2023-08-04 jrmu                 action machine labels operations)))
269 665c255d 2023-08-04 jrmu           (lambda ()
270 665c255d 2023-08-04 jrmu             (action-proc)
271 665c255d 2023-08-04 jrmu             (advance-pc pc)))
272 665c255d 2023-08-04 jrmu         (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
273 665c255d 2023-08-04 jrmu (define (perform-action inst) (cdr inst))
274 665c255d 2023-08-04 jrmu (define (make-primitive-exp exp machine labels)
275 665c255d 2023-08-04 jrmu   (cond ((constant-exp? exp)
276 665c255d 2023-08-04 jrmu          (let ((c (constant-exp-value exp)))
277 665c255d 2023-08-04 jrmu            (lambda () c)))
278 665c255d 2023-08-04 jrmu         ((label-exp? exp)
279 665c255d 2023-08-04 jrmu          (let ((insts
280 665c255d 2023-08-04 jrmu                 (lookup-label labels
281 665c255d 2023-08-04 jrmu                               (label-exp-label exp))))
282 665c255d 2023-08-04 jrmu            (lambda () insts)))
283 665c255d 2023-08-04 jrmu         ((register-exp? exp)
284 665c255d 2023-08-04 jrmu          (let ((r (get-register machine
285 665c255d 2023-08-04 jrmu                                 (register-exp-reg exp))))
286 665c255d 2023-08-04 jrmu            (lambda () (get-contents r))))
287 665c255d 2023-08-04 jrmu         (else
288 665c255d 2023-08-04 jrmu          (error "Unknown expression type -- ASSEMBLE" exp))))
289 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
290 665c255d 2023-08-04 jrmu   (and (pair? exp) (eq? (car exp) tag)))
291 665c255d 2023-08-04 jrmu (define (register-exp? exp) (tagged-list? exp 'reg))
292 665c255d 2023-08-04 jrmu (define (register-exp-reg exp) (cadr exp))
293 665c255d 2023-08-04 jrmu (define (constant-exp? exp) (tagged-list? exp 'const))
294 665c255d 2023-08-04 jrmu (define (constant-exp-value exp) (cadr exp))
295 665c255d 2023-08-04 jrmu (define (label-exp? exp) (tagged-list? exp 'label))
296 665c255d 2023-08-04 jrmu (define (label-exp-label exp) (cadr exp))
297 665c255d 2023-08-04 jrmu (define (make-operation-exp exp machine labels operations)
298 665c255d 2023-08-04 jrmu   (let ((op (lookup-prim (operation-exp-op exp) operations)) 
299 665c255d 2023-08-04 jrmu         (aprocs
300 665c255d 2023-08-04 jrmu          (map (lambda (e)
301 665c255d 2023-08-04 jrmu 		(if (label-exp? e)
302 665c255d 2023-08-04 jrmu 		    (error "Operation exp cannot operate on labels -- ASSEMBLE"
303 665c255d 2023-08-04 jrmu 			   exp)
304 665c255d 2023-08-04 jrmu 		    (make-primitive-exp e machine labels)))
305 665c255d 2023-08-04 jrmu               (operation-exp-operands exp))))
306 665c255d 2023-08-04 jrmu     (lambda ()
307 665c255d 2023-08-04 jrmu       (apply op (map (lambda (p) (p)) aprocs)))))
308 665c255d 2023-08-04 jrmu (define (operation-exp? exp)
309 665c255d 2023-08-04 jrmu   (and (pair? exp) (tagged-list? (car exp) 'op)))
310 665c255d 2023-08-04 jrmu (define (operation-exp-op operation-exp)
311 665c255d 2023-08-04 jrmu   (cadr (car operation-exp)))
312 665c255d 2023-08-04 jrmu (define (operation-exp-operands operation-exp)
313 665c255d 2023-08-04 jrmu   (cdr operation-exp))
314 665c255d 2023-08-04 jrmu (define (lookup-prim symbol operations)
315 665c255d 2023-08-04 jrmu   (let ((val (assoc symbol operations)))
316 665c255d 2023-08-04 jrmu     (if val
317 665c255d 2023-08-04 jrmu         (cadr val)
318 665c255d 2023-08-04 jrmu         (error "Unknown operation -- ASSEMBLE" symbol))))
319 665c255d 2023-08-04 jrmu 
320 665c255d 2023-08-04 jrmu ;; test suite
321 665c255d 2023-08-04 jrmu 
322 665c255d 2023-08-04 jrmu (define (test-case actual expected)
323 665c255d 2023-08-04 jrmu   (newline)
324 665c255d 2023-08-04 jrmu   (display "Actual:   ")
325 665c255d 2023-08-04 jrmu   (display actual)
326 665c255d 2023-08-04 jrmu   (newline)
327 665c255d 2023-08-04 jrmu   (display "Expected: ")
328 665c255d 2023-08-04 jrmu   (display expected)
329 665c255d 2023-08-04 jrmu   (newline))
330 665c255d 2023-08-04 jrmu 
331 665c255d 2023-08-04 jrmu (define gcd-machine
332 665c255d 2023-08-04 jrmu   (make-machine
333 665c255d 2023-08-04 jrmu    '(a b t)
334 665c255d 2023-08-04 jrmu    (list (list 'rem remainder) (list '= =))
335 665c255d 2023-08-04 jrmu    '(test-b
336 665c255d 2023-08-04 jrmu        (test (op =) (reg b) (const 0))
337 665c255d 2023-08-04 jrmu        (branch (label gcd-done))
338 665c255d 2023-08-04 jrmu        (assign t (op rem) (reg a) (reg b))
339 665c255d 2023-08-04 jrmu        (assign a (reg b))
340 665c255d 2023-08-04 jrmu        (assign b (reg t))
341 665c255d 2023-08-04 jrmu        (goto (label test-b))
342 665c255d 2023-08-04 jrmu      gcd-done)))
343 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'a 206)
344 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'b 40)
345 665c255d 2023-08-04 jrmu (start gcd-machine)
346 665c255d 2023-08-04 jrmu (test-case (get-register-contents gcd-machine 'a) 2)
347 665c255d 2023-08-04 jrmu 
348 665c255d 2023-08-04 jrmu (define fib-machine
349 665c255d 2023-08-04 jrmu   (make-machine 
350 665c255d 2023-08-04 jrmu    '(n val continue)
351 665c255d 2023-08-04 jrmu    `((< ,<) (- ,-) (+ ,+))
352 665c255d 2023-08-04 jrmu    '(controller
353 665c255d 2023-08-04 jrmu      (assign continue (label fib-done))
354 665c255d 2023-08-04 jrmu      fib-loop
355 665c255d 2023-08-04 jrmu      (test (op <) (reg n) (const 2))
356 665c255d 2023-08-04 jrmu      (branch (label immediate-answer))
357 665c255d 2023-08-04 jrmu      (save continue)
358 665c255d 2023-08-04 jrmu      (assign continue (label afterfib-n-1))
359 665c255d 2023-08-04 jrmu      (save n)
360 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 1))
361 665c255d 2023-08-04 jrmu      (goto (label fib-loop))
362 665c255d 2023-08-04 jrmu      afterfib-n-1           
363 665c255d 2023-08-04 jrmu      (restore n)
364 665c255d 2023-08-04 jrmu      (restore continue)
365 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 2))
366 665c255d 2023-08-04 jrmu      (save continue)
367 665c255d 2023-08-04 jrmu      (assign continue (label afterfib-n-2))
368 665c255d 2023-08-04 jrmu      (save val)
369 665c255d 2023-08-04 jrmu      (goto (label fib-loop))
370 665c255d 2023-08-04 jrmu      afterfib-n-2
371 665c255d 2023-08-04 jrmu      (assign n (reg val))
372 665c255d 2023-08-04 jrmu      (restore val)       
373 665c255d 2023-08-04 jrmu      (restore continue)
374 665c255d 2023-08-04 jrmu      (assign val         
375 665c255d 2023-08-04 jrmu 	     (op +) (reg val) (reg n)) 
376 665c255d 2023-08-04 jrmu      (goto (reg continue))
377 665c255d 2023-08-04 jrmu      immediate-answer
378 665c255d 2023-08-04 jrmu      (assign val (reg n)) 
379 665c255d 2023-08-04 jrmu      (goto (reg continue))
380 665c255d 2023-08-04 jrmu      fib-done)))
381 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'val 0)
382 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'n 15)
383 665c255d 2023-08-04 jrmu (start fib-machine)
384 665c255d 2023-08-04 jrmu (test-case (get-register-contents fib-machine 'val) 610)
385 665c255d 2023-08-04 jrmu 
386 665c255d 2023-08-04 jrmu (define fact-iter
387 665c255d 2023-08-04 jrmu   (make-machine
388 665c255d 2023-08-04 jrmu    '(product counter n)
389 665c255d 2023-08-04 jrmu    `((> ,>) (* ,*) (+ ,+))
390 665c255d 2023-08-04 jrmu    '((assign product (const 1))
391 665c255d 2023-08-04 jrmu      (assign counter (const 1))
392 665c255d 2023-08-04 jrmu      fact-loop
393 665c255d 2023-08-04 jrmu      (test (op >) (reg counter) (reg n))
394 665c255d 2023-08-04 jrmu      (branch (label fact-end))
395 665c255d 2023-08-04 jrmu      (assign product (op *) (reg counter) (reg product))
396 665c255d 2023-08-04 jrmu      (assign counter (op +) (reg counter) (const 1))
397 665c255d 2023-08-04 jrmu      (goto (label fact-loop))
398 665c255d 2023-08-04 jrmu      fact-end)))
399 665c255d 2023-08-04 jrmu (set-register-contents! fact-iter 'n 10)
400 665c255d 2023-08-04 jrmu (start fact-iter)
401 665c255d 2023-08-04 jrmu (test-case (get-register-contents fact-iter 'product) 3628800)
402 665c255d 2023-08-04 jrmu 
403 665c255d 2023-08-04 jrmu (define (sqrt x)
404 665c255d 2023-08-04 jrmu   (define (good-enough? guess)
405 665c255d 2023-08-04 jrmu     (< (abs (- (square guess) x)) 0.001))
406 665c255d 2023-08-04 jrmu   (define (improve guess)
407 665c255d 2023-08-04 jrmu     (average guess (/ x guess)))
408 665c255d 2023-08-04 jrmu   (define (sqrt-iter guess)
409 665c255d 2023-08-04 jrmu     (if (good-enough? guess)
410 665c255d 2023-08-04 jrmu         guess
411 665c255d 2023-08-04 jrmu         (sqrt-iter (improve guess))))
412 665c255d 2023-08-04 jrmu   (sqrt-iter 1.0))
413 665c255d 2023-08-04 jrmu 
414 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
415 665c255d 2023-08-04 jrmu   (< (abs (- (square guess) x)) 0.001))
416 665c255d 2023-08-04 jrmu (define (improve guess x)
417 665c255d 2023-08-04 jrmu   (average guess (/ x guess)))
418 665c255d 2023-08-04 jrmu (define (average x y)
419 665c255d 2023-08-04 jrmu   (/ (+ x y) 2))
420 665c255d 2023-08-04 jrmu (define sqrt-iter-ops
421 665c255d 2023-08-04 jrmu   (make-machine
422 665c255d 2023-08-04 jrmu    '(guess x)
423 665c255d 2023-08-04 jrmu    `((good-enough? ,good-enough?)
424 665c255d 2023-08-04 jrmu      (improve ,improve)
425 665c255d 2023-08-04 jrmu      (abs ,abs)
426 665c255d 2023-08-04 jrmu      (square ,square) 
427 665c255d 2023-08-04 jrmu      (average ,average)
428 665c255d 2023-08-04 jrmu      (< ,<)
429 665c255d 2023-08-04 jrmu      (- ,-)
430 665c255d 2023-08-04 jrmu      (/ ,/))
431 665c255d 2023-08-04 jrmu    '((assign guess (const 1.0))
432 665c255d 2023-08-04 jrmu      sqrt-iter
433 665c255d 2023-08-04 jrmu      (test (op good-enough?) (reg guess) (reg x))
434 665c255d 2023-08-04 jrmu      (branch (label sqrt-done))
435 665c255d 2023-08-04 jrmu      (assign guess (op improve) (reg guess) (reg x))
436 665c255d 2023-08-04 jrmu      (goto (label sqrt-iter))
437 665c255d 2023-08-04 jrmu      sqrt-done)))
438 665c255d 2023-08-04 jrmu 
439 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 27)
440 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
441 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
442 665c255d 2023-08-04 jrmu 	   5.19615242)
443 665c255d 2023-08-04 jrmu 
444 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
445 665c255d 2023-08-04 jrmu   (< (abs (- (square guess) x)) 0.001))
446 665c255d 2023-08-04 jrmu (define (improve guess x)
447 665c255d 2023-08-04 jrmu   (average guess (/ x guess)))
448 665c255d 2023-08-04 jrmu (define (average x y)
449 665c255d 2023-08-04 jrmu   (/ (+ x y) 2))
450 665c255d 2023-08-04 jrmu (define sqrt-iter
451 665c255d 2023-08-04 jrmu   (make-machine
452 665c255d 2023-08-04 jrmu    '(guess x temp)
453 665c255d 2023-08-04 jrmu    `((abs ,abs)
454 665c255d 2023-08-04 jrmu      (square ,square) 
455 665c255d 2023-08-04 jrmu      (average ,average)
456 665c255d 2023-08-04 jrmu      (< ,<)
457 665c255d 2023-08-04 jrmu      (- ,-)
458 665c255d 2023-08-04 jrmu      (/ ,/))
459 665c255d 2023-08-04 jrmu    '((assign guess (const 1.0))
460 665c255d 2023-08-04 jrmu      sqrt-iter
461 665c255d 2023-08-04 jrmu      ;; (test (op good-enough?) (reg guess) (reg x))
462 665c255d 2023-08-04 jrmu      (assign temp (op square) (reg guess))
463 665c255d 2023-08-04 jrmu      (assign temp (op -) (reg temp) (reg x))
464 665c255d 2023-08-04 jrmu      (assign temp (op abs) (reg temp))
465 665c255d 2023-08-04 jrmu      (test (op <) (reg temp) (const 0.001))
466 665c255d 2023-08-04 jrmu      (branch (label sqrt-done))
467 665c255d 2023-08-04 jrmu      ;; (assign guess (op improve) (reg guess) (reg x))
468 665c255d 2023-08-04 jrmu      (assign temp (op /) (reg x) (reg guess))
469 665c255d 2023-08-04 jrmu      (assign guess (op average) (reg guess) (reg temp))
470 665c255d 2023-08-04 jrmu      (goto (label sqrt-iter))
471 665c255d 2023-08-04 jrmu      sqrt-done)))
472 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 91)
473 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
474 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
475 665c255d 2023-08-04 jrmu 	   9.53939201)
476 665c255d 2023-08-04 jrmu 
477 665c255d 2023-08-04 jrmu (define (expt b n)
478 665c255d 2023-08-04 jrmu   (if (= n 0)
479 665c255d 2023-08-04 jrmu       1
480 665c255d 2023-08-04 jrmu       (* b (expt b (- n 1)))))
481 665c255d 2023-08-04 jrmu 
482 665c255d 2023-08-04 jrmu (define expt-rec
483 665c255d 2023-08-04 jrmu   (make-machine
484 665c255d 2023-08-04 jrmu    '(b n product continue)
485 665c255d 2023-08-04 jrmu    `((= ,=)
486 665c255d 2023-08-04 jrmu      (* ,*)
487 665c255d 2023-08-04 jrmu      (- ,-))
488 665c255d 2023-08-04 jrmu    '((assign continue (label expt-done))
489 665c255d 2023-08-04 jrmu      expt-rec
490 665c255d 2023-08-04 jrmu      (test (op =) (reg n) (const 0))
491 665c255d 2023-08-04 jrmu      (branch (label base-case))
492 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 1))
493 665c255d 2023-08-04 jrmu      (save continue)
494 665c255d 2023-08-04 jrmu      (assign continue (label after-b-n-1))
495 665c255d 2023-08-04 jrmu      (goto (label expt-rec))
496 665c255d 2023-08-04 jrmu      after-b-n-1
497 665c255d 2023-08-04 jrmu      (restore continue)
498 665c255d 2023-08-04 jrmu      (assign product (op *) (reg b) (reg product))
499 665c255d 2023-08-04 jrmu      (goto (reg continue))
500 665c255d 2023-08-04 jrmu      base-case
501 665c255d 2023-08-04 jrmu      (assign product (const 1))
502 665c255d 2023-08-04 jrmu      (goto (reg continue))
503 665c255d 2023-08-04 jrmu      expt-done)))
504 665c255d 2023-08-04 jrmu 
505 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'b 3.2)
506 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'n 6)
507 665c255d 2023-08-04 jrmu (start expt-rec)
508 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-rec 'product)
509 665c255d 2023-08-04 jrmu 	   1073.74182)
510 665c255d 2023-08-04 jrmu 
511 665c255d 2023-08-04 jrmu (define (expt b n)
512 665c255d 2023-08-04 jrmu   (define (expt-iter counter product)
513 665c255d 2023-08-04 jrmu     (if (= counter 0)
514 665c255d 2023-08-04 jrmu         product
515 665c255d 2023-08-04 jrmu         (expt-iter (- counter 1) (* b product))))
516 665c255d 2023-08-04 jrmu   (expt-iter n 1))
517 665c255d 2023-08-04 jrmu 
518 665c255d 2023-08-04 jrmu (define expt-iter
519 665c255d 2023-08-04 jrmu   (make-machine
520 665c255d 2023-08-04 jrmu    '(b n counter product)
521 665c255d 2023-08-04 jrmu    `((= ,=)
522 665c255d 2023-08-04 jrmu      (* ,*)
523 665c255d 2023-08-04 jrmu      (- ,-))
524 665c255d 2023-08-04 jrmu    '((assign counter (reg n))
525 665c255d 2023-08-04 jrmu      (assign product (const 1))
526 665c255d 2023-08-04 jrmu      expt-iter
527 665c255d 2023-08-04 jrmu      (test (op =) (reg counter) (const 0))
528 665c255d 2023-08-04 jrmu      (branch (label expt-iter-done))
529 665c255d 2023-08-04 jrmu      (assign counter (op -) (reg counter) (const 1))
530 665c255d 2023-08-04 jrmu      (assign product (op *) (reg b) (reg product))
531 665c255d 2023-08-04 jrmu      (goto (label expt-iter))
532 665c255d 2023-08-04 jrmu      expt-iter-done)))
533 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'b 1.6)
534 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'n 17)
535 665c255d 2023-08-04 jrmu (start expt-iter)
536 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-iter 'product) 
537 665c255d 2023-08-04 jrmu 	   2951.47905)
538 665c255d 2023-08-04 jrmu 
539 665c255d 2023-08-04 jrmu ;; (define amb-machine
540 665c255d 2023-08-04 jrmu ;;   (make-machine
541 665c255d 2023-08-04 jrmu ;;    '(a)
542 665c255d 2023-08-04 jrmu ;;    '()
543 665c255d 2023-08-04 jrmu ;;    '(start
544 665c255d 2023-08-04 jrmu ;;      (goto (label here))
545 665c255d 2023-08-04 jrmu ;;      here
546 665c255d 2023-08-04 jrmu ;;      (assign a (const 3))
547 665c255d 2023-08-04 jrmu ;;      (goto (label there))
548 665c255d 2023-08-04 jrmu ;;      here
549 665c255d 2023-08-04 jrmu ;;      (assign a (const 4))
550 665c255d 2023-08-04 jrmu ;;      (goto (label there))
551 665c255d 2023-08-04 jrmu ;;      there)))
552 665c255d 2023-08-04 jrmu 
553 665c255d 2023-08-04 jrmu ;; (start amb-machine)
554 665c255d 2023-08-04 jrmu ;; (test-case (get-register-contents amb-machine 'a)
555 665c255d 2023-08-04 jrmu ;; 	   3)
556 665c255d 2023-08-04 jrmu ;; this now raises an error
557 665c255d 2023-08-04 jrmu 
558 665c255d 2023-08-04 jrmu  ;; Exercise 5.9.  The treatment of machine operations above permits them to operate on labels as well as on constants and the contents of registers. Modify the expression-processing procedures to enforce the condition that operations can be used only with registers and constants. 
559 665c255d 2023-08-04 jrmu 
560 665c255d 2023-08-04 jrmu (define op-label-machine
561 665c255d 2023-08-04 jrmu   (make-machine
562 665c255d 2023-08-04 jrmu    '(x)
563 665c255d 2023-08-04 jrmu    `((+ ,+))
564 665c255d 2023-08-04 jrmu    '((assign x (op +) (label a) (label b)))))