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.11.  When we introduced save and restore in section 5.1.4, we didn't specify what would happen if you tried to restore a register that was not the last one saved, as in the sequence
559 665c255d 2023-08-04 jrmu 
560 665c255d 2023-08-04 jrmu ;; (save y)
561 665c255d 2023-08-04 jrmu ;; (save x)
562 665c255d 2023-08-04 jrmu ;; (restore y)
563 665c255d 2023-08-04 jrmu 
564 665c255d 2023-08-04 jrmu ;; There are several reasonable possibilities for the meaning of restore:
565 665c255d 2023-08-04 jrmu 
566 665c255d 2023-08-04 jrmu ;; a.  (restore y) puts into y the last value saved on the stack, regardless of what register that value came from. This is the way our simulator behaves. Show how to take advantage of this behavior to eliminate one instruction from the Fibonacci machine of section 5.1.4 (figure 5.12).
567 665c255d 2023-08-04 jrmu 
568 665c255d 2023-08-04 jrmu ;; (assign n (reg val))
569 665c255d 2023-08-04 jrmu ;; (restore val)
570 665c255d 2023-08-04 jrmu 
571 665c255d 2023-08-04 jrmu ;; can now be shortened to
572 665c255d 2023-08-04 jrmu 
573 665c255d 2023-08-04 jrmu ;; (restore n)
574 665c255d 2023-08-04 jrmu 
575 665c255d 2023-08-04 jrmu ;; b.  (restore y) puts into y the last value saved on the stack, but only if that value was saved from y; otherwise, it signals an error. Modify the simulator to behave this way. You will have to change save to put the register name on the stack along with the value.
576 665c255d 2023-08-04 jrmu 
577 665c255d 2023-08-04 jrmu 
578 665c255d 2023-08-04 jrmu 
579 665c255d 2023-08-04 jrmu ;; c.  (restore y) puts into y the last value saved from y regardless of what other registers were saved after y and not restored. Modify the simulator to behave this way. You will have to associate a separate stack with each register. You should make the initialize-stack operation initialize all the register stacks.