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                 (make-primitive-exp e machine labels))
302 665c255d 2023-08-04 jrmu               (operation-exp-operands exp))))
303 665c255d 2023-08-04 jrmu     (lambda ()
304 665c255d 2023-08-04 jrmu       (apply op (map (lambda (p) (p)) aprocs)))))
305 665c255d 2023-08-04 jrmu (define (operation-exp? exp)
306 665c255d 2023-08-04 jrmu   (and (pair? exp) (tagged-list? (car exp) 'op)))
307 665c255d 2023-08-04 jrmu (define (operation-exp-op operation-exp)
308 665c255d 2023-08-04 jrmu   (cadr (car operation-exp)))
309 665c255d 2023-08-04 jrmu (define (operation-exp-operands operation-exp)
310 665c255d 2023-08-04 jrmu   (cdr operation-exp))
311 665c255d 2023-08-04 jrmu (define (lookup-prim symbol operations)
312 665c255d 2023-08-04 jrmu   (let ((val (assoc symbol operations)))
313 665c255d 2023-08-04 jrmu     (if val
314 665c255d 2023-08-04 jrmu         (cadr val)
315 665c255d 2023-08-04 jrmu         (error "Unknown operation -- ASSEMBLE" symbol))))
316 665c255d 2023-08-04 jrmu 
317 665c255d 2023-08-04 jrmu ;; test suite
318 665c255d 2023-08-04 jrmu 
319 665c255d 2023-08-04 jrmu (define (test-case actual expected)
320 665c255d 2023-08-04 jrmu   (newline)
321 665c255d 2023-08-04 jrmu   (display "Actual:   ")
322 665c255d 2023-08-04 jrmu   (display actual)
323 665c255d 2023-08-04 jrmu   (newline)
324 665c255d 2023-08-04 jrmu   (display "Expected: ")
325 665c255d 2023-08-04 jrmu   (display expected)
326 665c255d 2023-08-04 jrmu   (newline))
327 665c255d 2023-08-04 jrmu 
328 665c255d 2023-08-04 jrmu (define gcd-machine
329 665c255d 2023-08-04 jrmu   (make-machine
330 665c255d 2023-08-04 jrmu    '(a b t)
331 665c255d 2023-08-04 jrmu    (list (list 'rem remainder) (list '= =))
332 665c255d 2023-08-04 jrmu    '(test-b
333 665c255d 2023-08-04 jrmu        (test (op =) (reg b) (const 0))
334 665c255d 2023-08-04 jrmu        (branch (label gcd-done))
335 665c255d 2023-08-04 jrmu        (assign t (op rem) (reg a) (reg b))
336 665c255d 2023-08-04 jrmu        (assign a (reg b))
337 665c255d 2023-08-04 jrmu        (assign b (reg t))
338 665c255d 2023-08-04 jrmu        (goto (label test-b))
339 665c255d 2023-08-04 jrmu      gcd-done)))
340 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'a 206)
341 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'b 40)
342 665c255d 2023-08-04 jrmu (start gcd-machine)
343 665c255d 2023-08-04 jrmu (test-case (get-register-contents gcd-machine 'a) 2)
344 665c255d 2023-08-04 jrmu 
345 665c255d 2023-08-04 jrmu (define fib-machine
346 665c255d 2023-08-04 jrmu   (make-machine 
347 665c255d 2023-08-04 jrmu    '(n val continue)
348 665c255d 2023-08-04 jrmu    `((< ,<) (- ,-) (+ ,+))
349 665c255d 2023-08-04 jrmu    '(controller
350 665c255d 2023-08-04 jrmu      (assign continue (label fib-done))
351 665c255d 2023-08-04 jrmu      fib-loop
352 665c255d 2023-08-04 jrmu      (test (op <) (reg n) (const 2))
353 665c255d 2023-08-04 jrmu      (branch (label immediate-answer))
354 665c255d 2023-08-04 jrmu      (save continue)
355 665c255d 2023-08-04 jrmu      (assign continue (label afterfib-n-1))
356 665c255d 2023-08-04 jrmu      (save n)
357 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 1))
358 665c255d 2023-08-04 jrmu      (goto (label fib-loop))
359 665c255d 2023-08-04 jrmu      afterfib-n-1           
360 665c255d 2023-08-04 jrmu      (restore n)
361 665c255d 2023-08-04 jrmu      (restore continue)
362 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 2))
363 665c255d 2023-08-04 jrmu      (save continue)
364 665c255d 2023-08-04 jrmu      (assign continue (label afterfib-n-2))
365 665c255d 2023-08-04 jrmu      (save val)
366 665c255d 2023-08-04 jrmu      (goto (label fib-loop))
367 665c255d 2023-08-04 jrmu      afterfib-n-2
368 665c255d 2023-08-04 jrmu      (assign n (reg val))
369 665c255d 2023-08-04 jrmu      (restore val)       
370 665c255d 2023-08-04 jrmu      (restore continue)
371 665c255d 2023-08-04 jrmu      (assign val         
372 665c255d 2023-08-04 jrmu 	     (op +) (reg val) (reg n)) 
373 665c255d 2023-08-04 jrmu      (goto (reg continue))
374 665c255d 2023-08-04 jrmu      immediate-answer
375 665c255d 2023-08-04 jrmu      (assign val (reg n)) 
376 665c255d 2023-08-04 jrmu      (goto (reg continue))
377 665c255d 2023-08-04 jrmu      fib-done)))
378 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'val 0)
379 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'n 15)
380 665c255d 2023-08-04 jrmu (start fib-machine)
381 665c255d 2023-08-04 jrmu (test-case (get-register-contents fib-machine 'val) 610)
382 665c255d 2023-08-04 jrmu 
383 665c255d 2023-08-04 jrmu (define fact-iter
384 665c255d 2023-08-04 jrmu   (make-machine
385 665c255d 2023-08-04 jrmu    '(product counter n)
386 665c255d 2023-08-04 jrmu    `((> ,>) (* ,*) (+ ,+))
387 665c255d 2023-08-04 jrmu    '((assign product (const 1))
388 665c255d 2023-08-04 jrmu      (assign counter (const 1))
389 665c255d 2023-08-04 jrmu      fact-loop
390 665c255d 2023-08-04 jrmu      (test (op >) (reg counter) (reg n))
391 665c255d 2023-08-04 jrmu      (branch (label fact-end))
392 665c255d 2023-08-04 jrmu      (assign product (op *) (reg counter) (reg product))
393 665c255d 2023-08-04 jrmu      (assign counter (op +) (reg counter) (const 1))
394 665c255d 2023-08-04 jrmu      (goto (label fact-loop))
395 665c255d 2023-08-04 jrmu      fact-end)))
396 665c255d 2023-08-04 jrmu (set-register-contents! fact-iter 'n 10)
397 665c255d 2023-08-04 jrmu (start fact-iter)
398 665c255d 2023-08-04 jrmu (test-case (get-register-contents fact-iter 'product) 3628800)
399 665c255d 2023-08-04 jrmu 
400 665c255d 2023-08-04 jrmu (define (sqrt x)
401 665c255d 2023-08-04 jrmu   (define (good-enough? guess)
402 665c255d 2023-08-04 jrmu     (< (abs (- (square guess) x)) 0.001))
403 665c255d 2023-08-04 jrmu   (define (improve guess)
404 665c255d 2023-08-04 jrmu     (average guess (/ x guess)))
405 665c255d 2023-08-04 jrmu   (define (sqrt-iter guess)
406 665c255d 2023-08-04 jrmu     (if (good-enough? guess)
407 665c255d 2023-08-04 jrmu         guess
408 665c255d 2023-08-04 jrmu         (sqrt-iter (improve guess))))
409 665c255d 2023-08-04 jrmu   (sqrt-iter 1.0))
410 665c255d 2023-08-04 jrmu 
411 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
412 665c255d 2023-08-04 jrmu   (< (abs (- (square guess) x)) 0.001))
413 665c255d 2023-08-04 jrmu (define (improve guess x)
414 665c255d 2023-08-04 jrmu   (average guess (/ x guess)))
415 665c255d 2023-08-04 jrmu (define (average x y)
416 665c255d 2023-08-04 jrmu   (/ (+ x y) 2))
417 665c255d 2023-08-04 jrmu (define sqrt-iter-ops
418 665c255d 2023-08-04 jrmu   (make-machine
419 665c255d 2023-08-04 jrmu    '(guess x)
420 665c255d 2023-08-04 jrmu    `((good-enough? ,good-enough?)
421 665c255d 2023-08-04 jrmu      (improve ,improve)
422 665c255d 2023-08-04 jrmu      (abs ,abs)
423 665c255d 2023-08-04 jrmu      (square ,square) 
424 665c255d 2023-08-04 jrmu      (average ,average)
425 665c255d 2023-08-04 jrmu      (< ,<)
426 665c255d 2023-08-04 jrmu      (- ,-)
427 665c255d 2023-08-04 jrmu      (/ ,/))
428 665c255d 2023-08-04 jrmu    '((assign guess (const 1.0))
429 665c255d 2023-08-04 jrmu      sqrt-iter
430 665c255d 2023-08-04 jrmu      (test (op good-enough?) (reg guess) (reg x))
431 665c255d 2023-08-04 jrmu      (branch (label sqrt-done))
432 665c255d 2023-08-04 jrmu      (assign guess (op improve) (reg guess) (reg x))
433 665c255d 2023-08-04 jrmu      (goto (label sqrt-iter))
434 665c255d 2023-08-04 jrmu      sqrt-done)))
435 665c255d 2023-08-04 jrmu 
436 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 27)
437 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
438 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
439 665c255d 2023-08-04 jrmu 	   5.19615242)
440 665c255d 2023-08-04 jrmu 
441 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
442 665c255d 2023-08-04 jrmu   (< (abs (- (square guess) x)) 0.001))
443 665c255d 2023-08-04 jrmu (define (improve guess x)
444 665c255d 2023-08-04 jrmu   (average guess (/ x guess)))
445 665c255d 2023-08-04 jrmu (define (average x y)
446 665c255d 2023-08-04 jrmu   (/ (+ x y) 2))
447 665c255d 2023-08-04 jrmu (define sqrt-iter
448 665c255d 2023-08-04 jrmu   (make-machine
449 665c255d 2023-08-04 jrmu    '(guess x temp)
450 665c255d 2023-08-04 jrmu    `((abs ,abs)
451 665c255d 2023-08-04 jrmu      (square ,square) 
452 665c255d 2023-08-04 jrmu      (average ,average)
453 665c255d 2023-08-04 jrmu      (< ,<)
454 665c255d 2023-08-04 jrmu      (- ,-)
455 665c255d 2023-08-04 jrmu      (/ ,/))
456 665c255d 2023-08-04 jrmu    '((assign guess (const 1.0))
457 665c255d 2023-08-04 jrmu      sqrt-iter
458 665c255d 2023-08-04 jrmu      ;; (test (op good-enough?) (reg guess) (reg x))
459 665c255d 2023-08-04 jrmu      (assign temp (op square) (reg guess))
460 665c255d 2023-08-04 jrmu      (assign temp (op -) (reg temp) (reg x))
461 665c255d 2023-08-04 jrmu      (assign temp (op abs) (reg temp))
462 665c255d 2023-08-04 jrmu      (test (op <) (reg temp) (const 0.001))
463 665c255d 2023-08-04 jrmu      (branch (label sqrt-done))
464 665c255d 2023-08-04 jrmu      ;; (assign guess (op improve) (reg guess) (reg x))
465 665c255d 2023-08-04 jrmu      (assign temp (op /) (reg x) (reg guess))
466 665c255d 2023-08-04 jrmu      (assign guess (op average) (reg guess) (reg temp))
467 665c255d 2023-08-04 jrmu      (goto (label sqrt-iter))
468 665c255d 2023-08-04 jrmu      sqrt-done)))
469 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 91)
470 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
471 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
472 665c255d 2023-08-04 jrmu 	   9.53939201)
473 665c255d 2023-08-04 jrmu 
474 665c255d 2023-08-04 jrmu (define (expt b n)
475 665c255d 2023-08-04 jrmu   (if (= n 0)
476 665c255d 2023-08-04 jrmu       1
477 665c255d 2023-08-04 jrmu       (* b (expt b (- n 1)))))
478 665c255d 2023-08-04 jrmu 
479 665c255d 2023-08-04 jrmu (define expt-rec
480 665c255d 2023-08-04 jrmu   (make-machine
481 665c255d 2023-08-04 jrmu    '(b n product continue)
482 665c255d 2023-08-04 jrmu    `((= ,=)
483 665c255d 2023-08-04 jrmu      (* ,*)
484 665c255d 2023-08-04 jrmu      (- ,-))
485 665c255d 2023-08-04 jrmu    '((assign continue (label expt-done))
486 665c255d 2023-08-04 jrmu      expt-rec
487 665c255d 2023-08-04 jrmu      (test (op =) (reg n) (const 0))
488 665c255d 2023-08-04 jrmu      (branch (label base-case))
489 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 1))
490 665c255d 2023-08-04 jrmu      (save continue)
491 665c255d 2023-08-04 jrmu      (assign continue (label after-b-n-1))
492 665c255d 2023-08-04 jrmu      (goto (label expt-rec))
493 665c255d 2023-08-04 jrmu      after-b-n-1
494 665c255d 2023-08-04 jrmu      (restore continue)
495 665c255d 2023-08-04 jrmu      (assign product (op *) (reg b) (reg product))
496 665c255d 2023-08-04 jrmu      (goto (reg continue))
497 665c255d 2023-08-04 jrmu      base-case
498 665c255d 2023-08-04 jrmu      (assign product (const 1))
499 665c255d 2023-08-04 jrmu      (goto (reg continue))
500 665c255d 2023-08-04 jrmu      expt-done)))
501 665c255d 2023-08-04 jrmu 
502 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'b 3.2)
503 665c255d 2023-08-04 jrmu (set-register-contents! expt-rec 'n 6)
504 665c255d 2023-08-04 jrmu (start expt-rec)
505 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-rec 'product)
506 665c255d 2023-08-04 jrmu 	   1073.74182)
507 665c255d 2023-08-04 jrmu 
508 665c255d 2023-08-04 jrmu (define (expt b n)
509 665c255d 2023-08-04 jrmu   (define (expt-iter counter product)
510 665c255d 2023-08-04 jrmu     (if (= counter 0)
511 665c255d 2023-08-04 jrmu         product
512 665c255d 2023-08-04 jrmu         (expt-iter (- counter 1) (* b product))))
513 665c255d 2023-08-04 jrmu   (expt-iter n 1))
514 665c255d 2023-08-04 jrmu 
515 665c255d 2023-08-04 jrmu (define expt-iter
516 665c255d 2023-08-04 jrmu   (make-machine
517 665c255d 2023-08-04 jrmu    '(b n counter product)
518 665c255d 2023-08-04 jrmu    `((= ,=)
519 665c255d 2023-08-04 jrmu      (* ,*)
520 665c255d 2023-08-04 jrmu      (- ,-))
521 665c255d 2023-08-04 jrmu    '((assign counter (reg n))
522 665c255d 2023-08-04 jrmu      (assign product (const 1))
523 665c255d 2023-08-04 jrmu      expt-iter
524 665c255d 2023-08-04 jrmu      (test (op =) (reg counter) (const 0))
525 665c255d 2023-08-04 jrmu      (branch (label expt-iter-done))
526 665c255d 2023-08-04 jrmu      (assign counter (op -) (reg counter) (const 1))
527 665c255d 2023-08-04 jrmu      (assign product (op *) (reg b) (reg product))
528 665c255d 2023-08-04 jrmu      (goto (label expt-iter))
529 665c255d 2023-08-04 jrmu      expt-iter-done)))
530 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'b 1.6)
531 665c255d 2023-08-04 jrmu (set-register-contents! expt-iter 'n 17)
532 665c255d 2023-08-04 jrmu (start expt-iter)
533 665c255d 2023-08-04 jrmu (test-case (get-register-contents expt-iter 'product) 
534 665c255d 2023-08-04 jrmu 	   2951.47905)
535 665c255d 2023-08-04 jrmu 
536 665c255d 2023-08-04 jrmu ;; Exercise 5.8.  The following register-machine code is ambiguous, because the label here is defined more than once:
537 665c255d 2023-08-04 jrmu 
538 665c255d 2023-08-04 jrmu (define amb-machine
539 665c255d 2023-08-04 jrmu   (make-machine
540 665c255d 2023-08-04 jrmu    '(a)
541 665c255d 2023-08-04 jrmu    '()
542 665c255d 2023-08-04 jrmu    '(start
543 665c255d 2023-08-04 jrmu      (goto (label here))
544 665c255d 2023-08-04 jrmu      here
545 665c255d 2023-08-04 jrmu      (assign a (const 3))
546 665c255d 2023-08-04 jrmu      (goto (label there))
547 665c255d 2023-08-04 jrmu      here
548 665c255d 2023-08-04 jrmu      (assign a (const 4))
549 665c255d 2023-08-04 jrmu      (goto (label there))
550 665c255d 2023-08-04 jrmu      there)))
551 665c255d 2023-08-04 jrmu 
552 665c255d 2023-08-04 jrmu ;; With the simulator as written, what will the contents of register a be when control reaches there? Modify the extract-labels procedure so that the assembler will signal an error if the same label name is used to indicate two different locations. 
553 665c255d 2023-08-04 jrmu 
554 665c255d 2023-08-04 jrmu (start amb-machine)
555 665c255d 2023-08-04 jrmu (test-case (get-register-contents amb-machine 'a)
556 665c255d 2023-08-04 jrmu 	   3)
557 665c255d 2023-08-04 jrmu ;; extract-labels builds insts/labels from the very last instruction to the first instruction and conses them in that order so that the insts/labels are in the same order as in the instruction
558 665c255d 2023-08-04 jrmu ;; since lookup-label uses assoc, the labels will also be accessed in the same order as the instruction sequence. Therefore, the (goto (label here)) will branch to the first here label and not the second one
559 665c255d 2023-08-04 jrmu