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                (receive insts
130 665c255d 2023-08-04 jrmu                         (cons (make-label-entry next-inst
131 665c255d 2023-08-04 jrmu                                                 insts)
132 665c255d 2023-08-04 jrmu                               labels))
133 665c255d 2023-08-04 jrmu                (receive (cons (make-instruction next-inst)
134 665c255d 2023-08-04 jrmu                               insts)
135 665c255d 2023-08-04 jrmu                         labels)))))))
136 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
137 665c255d 2023-08-04 jrmu   (let ((pc (get-register machine 'pc))
138 665c255d 2023-08-04 jrmu         (flag (get-register machine 'flag))
139 665c255d 2023-08-04 jrmu         (stack (machine 'stack))
140 665c255d 2023-08-04 jrmu         (ops (machine 'operations)))
141 665c255d 2023-08-04 jrmu     (for-each
142 665c255d 2023-08-04 jrmu      (lambda (inst)
143 665c255d 2023-08-04 jrmu        (set-instruction-execution-proc! 
144 665c255d 2023-08-04 jrmu         inst
145 665c255d 2023-08-04 jrmu         (make-execution-procedure
146 665c255d 2023-08-04 jrmu          (instruction-text inst) labels machine
147 665c255d 2023-08-04 jrmu          pc flag stack ops)))
148 665c255d 2023-08-04 jrmu      insts)))
149 665c255d 2023-08-04 jrmu (define (make-instruction text)
150 665c255d 2023-08-04 jrmu   (cons text '()))
151 665c255d 2023-08-04 jrmu (define (instruction-text inst)
152 665c255d 2023-08-04 jrmu   (car inst))
153 665c255d 2023-08-04 jrmu (define (instruction-execution-proc inst)
154 665c255d 2023-08-04 jrmu   (cdr inst))
155 665c255d 2023-08-04 jrmu (define (set-instruction-execution-proc! inst proc)
156 665c255d 2023-08-04 jrmu   (set-cdr! inst proc))
157 665c255d 2023-08-04 jrmu (define (make-label-entry label-name insts)
158 665c255d 2023-08-04 jrmu   (cons label-name insts))
159 665c255d 2023-08-04 jrmu (define (lookup-label labels label-name)
160 665c255d 2023-08-04 jrmu   (let ((val (assoc label-name labels)))
161 665c255d 2023-08-04 jrmu     (if val
162 665c255d 2023-08-04 jrmu         (cdr val)
163 665c255d 2023-08-04 jrmu         (error "Undefined label -- ASSEMBLE" label-name))))
164 665c255d 2023-08-04 jrmu (define (make-execution-procedure inst labels machine
165 665c255d 2023-08-04 jrmu                                   pc flag stack ops)
166 665c255d 2023-08-04 jrmu   (cond ((eq? (car inst) 'assign)
167 665c255d 2023-08-04 jrmu          (make-assign inst machine labels ops pc))
168 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'test)
169 665c255d 2023-08-04 jrmu          (make-test inst machine labels ops flag pc))
170 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'branch)
171 665c255d 2023-08-04 jrmu          (make-branch inst machine labels flag pc))
172 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'goto)
173 665c255d 2023-08-04 jrmu          (make-goto inst machine labels pc))
174 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'save)
175 665c255d 2023-08-04 jrmu          (make-save inst machine stack pc))
176 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'restore)
177 665c255d 2023-08-04 jrmu          (make-restore inst machine stack pc))
178 665c255d 2023-08-04 jrmu         ((eq? (car inst) 'perform)
179 665c255d 2023-08-04 jrmu          (make-perform inst machine labels ops pc))
180 665c255d 2023-08-04 jrmu         (else (error "Unknown instruction type -- ASSEMBLE"
181 665c255d 2023-08-04 jrmu                      inst))))
182 665c255d 2023-08-04 jrmu (define (make-assign inst machine labels operations pc)
183 665c255d 2023-08-04 jrmu   (let ((target
184 665c255d 2023-08-04 jrmu          (get-register machine (assign-reg-name inst)))
185 665c255d 2023-08-04 jrmu         (value-exp (assign-value-exp inst)))
186 665c255d 2023-08-04 jrmu     (let ((value-proc
187 665c255d 2023-08-04 jrmu            (if (operation-exp? value-exp)
188 665c255d 2023-08-04 jrmu                (make-operation-exp
189 665c255d 2023-08-04 jrmu                 value-exp machine labels operations)
190 665c255d 2023-08-04 jrmu                (make-primitive-exp
191 665c255d 2023-08-04 jrmu                 (car value-exp) machine labels))))
192 665c255d 2023-08-04 jrmu       (lambda ()                ; execution procedure for assign
193 665c255d 2023-08-04 jrmu         (set-contents! target (value-proc))
194 665c255d 2023-08-04 jrmu         (advance-pc pc)))))
195 665c255d 2023-08-04 jrmu (define (assign-reg-name assign-instruction)
196 665c255d 2023-08-04 jrmu   (cadr assign-instruction))
197 665c255d 2023-08-04 jrmu (define (assign-value-exp assign-instruction)
198 665c255d 2023-08-04 jrmu   (cddr assign-instruction))
199 665c255d 2023-08-04 jrmu (define (advance-pc pc)
200 665c255d 2023-08-04 jrmu   (set-contents! pc (cdr (get-contents pc))))
201 665c255d 2023-08-04 jrmu (define (make-test inst machine labels operations flag pc)
202 665c255d 2023-08-04 jrmu   (let ((condition (test-condition inst)))
203 665c255d 2023-08-04 jrmu     (if (operation-exp? condition)
204 665c255d 2023-08-04 jrmu         (let ((condition-proc
205 665c255d 2023-08-04 jrmu                (make-operation-exp
206 665c255d 2023-08-04 jrmu                 condition machine labels operations)))
207 665c255d 2023-08-04 jrmu           (lambda ()
208 665c255d 2023-08-04 jrmu             (set-contents! flag (condition-proc))
209 665c255d 2023-08-04 jrmu             (advance-pc pc)))
210 665c255d 2023-08-04 jrmu         (error "Bad TEST instruction -- ASSEMBLE" inst))))
211 665c255d 2023-08-04 jrmu (define (test-condition test-instruction)
212 665c255d 2023-08-04 jrmu   (cdr test-instruction))
213 665c255d 2023-08-04 jrmu (define (make-branch inst machine labels flag pc)
214 665c255d 2023-08-04 jrmu   (let ((dest (branch-dest inst)))
215 665c255d 2023-08-04 jrmu     (if (label-exp? dest)
216 665c255d 2023-08-04 jrmu         (let ((insts
217 665c255d 2023-08-04 jrmu                (lookup-label labels (label-exp-label dest))))
218 665c255d 2023-08-04 jrmu           (lambda ()
219 665c255d 2023-08-04 jrmu             (if (get-contents flag)
220 665c255d 2023-08-04 jrmu                 (set-contents! pc insts)
221 665c255d 2023-08-04 jrmu                 (advance-pc pc))))
222 665c255d 2023-08-04 jrmu         (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
223 665c255d 2023-08-04 jrmu (define (branch-dest branch-instruction)
224 665c255d 2023-08-04 jrmu   (cadr branch-instruction))
225 665c255d 2023-08-04 jrmu (define (make-goto inst machine labels pc)
226 665c255d 2023-08-04 jrmu   (let ((dest (goto-dest inst)))
227 665c255d 2023-08-04 jrmu     (cond ((label-exp? dest)
228 665c255d 2023-08-04 jrmu            (let ((insts
229 665c255d 2023-08-04 jrmu                   (lookup-label labels
230 665c255d 2023-08-04 jrmu                                 (label-exp-label dest))))
231 665c255d 2023-08-04 jrmu              (lambda () (set-contents! pc insts))))
232 665c255d 2023-08-04 jrmu           ((register-exp? dest)
233 665c255d 2023-08-04 jrmu            (let ((reg
234 665c255d 2023-08-04 jrmu                   (get-register machine
235 665c255d 2023-08-04 jrmu                                 (register-exp-reg dest))))
236 665c255d 2023-08-04 jrmu              (lambda ()
237 665c255d 2023-08-04 jrmu                (set-contents! pc (get-contents reg)))))
238 665c255d 2023-08-04 jrmu           (else (error "Bad GOTO instruction -- ASSEMBLE"
239 665c255d 2023-08-04 jrmu                        inst)))))
240 665c255d 2023-08-04 jrmu (define (goto-dest goto-instruction)
241 665c255d 2023-08-04 jrmu   (cadr goto-instruction))
242 665c255d 2023-08-04 jrmu (define (make-save inst machine stack pc)
243 665c255d 2023-08-04 jrmu   (let ((reg (get-register machine
244 665c255d 2023-08-04 jrmu                            (stack-inst-reg-name inst))))
245 665c255d 2023-08-04 jrmu     (lambda ()
246 665c255d 2023-08-04 jrmu       (push stack (get-contents reg))
247 665c255d 2023-08-04 jrmu       (advance-pc pc))))
248 665c255d 2023-08-04 jrmu (define (make-restore inst machine stack pc)
249 665c255d 2023-08-04 jrmu   (let ((reg (get-register machine
250 665c255d 2023-08-04 jrmu                            (stack-inst-reg-name inst))))
251 665c255d 2023-08-04 jrmu     (lambda ()
252 665c255d 2023-08-04 jrmu       (set-contents! reg (pop stack))    
253 665c255d 2023-08-04 jrmu       (advance-pc pc))))
254 665c255d 2023-08-04 jrmu (define (stack-inst-reg-name stack-instruction)
255 665c255d 2023-08-04 jrmu   (cadr stack-instruction))
256 665c255d 2023-08-04 jrmu (define (make-perform inst machine labels operations pc)
257 665c255d 2023-08-04 jrmu   (let ((action (perform-action inst)))
258 665c255d 2023-08-04 jrmu     (if (operation-exp? action)
259 665c255d 2023-08-04 jrmu         (let ((action-proc
260 665c255d 2023-08-04 jrmu                (make-operation-exp
261 665c255d 2023-08-04 jrmu                 action machine labels operations)))
262 665c255d 2023-08-04 jrmu           (lambda ()
263 665c255d 2023-08-04 jrmu             (action-proc)
264 665c255d 2023-08-04 jrmu             (advance-pc pc)))
265 665c255d 2023-08-04 jrmu         (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
266 665c255d 2023-08-04 jrmu (define (perform-action inst) (cdr inst))
267 665c255d 2023-08-04 jrmu (define (make-primitive-exp exp machine labels)
268 665c255d 2023-08-04 jrmu   (cond ((constant-exp? exp)
269 665c255d 2023-08-04 jrmu          (let ((c (constant-exp-value exp)))
270 665c255d 2023-08-04 jrmu            (lambda () c)))
271 665c255d 2023-08-04 jrmu         ((label-exp? exp)
272 665c255d 2023-08-04 jrmu          (let ((insts
273 665c255d 2023-08-04 jrmu                 (lookup-label labels
274 665c255d 2023-08-04 jrmu                               (label-exp-label exp))))
275 665c255d 2023-08-04 jrmu            (lambda () insts)))
276 665c255d 2023-08-04 jrmu         ((register-exp? exp)
277 665c255d 2023-08-04 jrmu          (let ((r (get-register machine
278 665c255d 2023-08-04 jrmu                                 (register-exp-reg exp))))
279 665c255d 2023-08-04 jrmu            (lambda () (get-contents r))))
280 665c255d 2023-08-04 jrmu         (else
281 665c255d 2023-08-04 jrmu          (error "Unknown expression type -- ASSEMBLE" exp))))
282 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
283 665c255d 2023-08-04 jrmu   (and (pair? exp) (eq? (car exp) tag)))
284 665c255d 2023-08-04 jrmu (define (register-exp? exp) (tagged-list? exp 'reg))
285 665c255d 2023-08-04 jrmu (define (register-exp-reg exp) (cadr exp))
286 665c255d 2023-08-04 jrmu (define (constant-exp? exp) (tagged-list? exp 'const))
287 665c255d 2023-08-04 jrmu (define (constant-exp-value exp) (cadr exp))
288 665c255d 2023-08-04 jrmu (define (label-exp? exp) (tagged-list? exp 'label))
289 665c255d 2023-08-04 jrmu (define (label-exp-label exp) (cadr exp))
290 665c255d 2023-08-04 jrmu (define (make-operation-exp exp machine labels operations)
291 665c255d 2023-08-04 jrmu   (let ((op (lookup-prim (operation-exp-op exp) operations))
292 665c255d 2023-08-04 jrmu         (aprocs
293 665c255d 2023-08-04 jrmu          (map (lambda (e)
294 665c255d 2023-08-04 jrmu                 (make-primitive-exp e machine labels))
295 665c255d 2023-08-04 jrmu               (operation-exp-operands exp))))
296 665c255d 2023-08-04 jrmu     (lambda ()
297 665c255d 2023-08-04 jrmu       (apply op (map (lambda (p) (p)) aprocs)))))
298 665c255d 2023-08-04 jrmu (define (operation-exp? exp)
299 665c255d 2023-08-04 jrmu   (and (pair? exp) (tagged-list? (car exp) 'op)))
300 665c255d 2023-08-04 jrmu (define (operation-exp-op operation-exp)
301 665c255d 2023-08-04 jrmu   (cadr (car operation-exp)))
302 665c255d 2023-08-04 jrmu (define (operation-exp-operands operation-exp)
303 665c255d 2023-08-04 jrmu   (cdr operation-exp))
304 665c255d 2023-08-04 jrmu (define (lookup-prim symbol operations)
305 665c255d 2023-08-04 jrmu   (let ((val (assoc symbol operations)))
306 665c255d 2023-08-04 jrmu     (if val
307 665c255d 2023-08-04 jrmu         (cadr val)
308 665c255d 2023-08-04 jrmu         (error "Unknown operation -- ASSEMBLE" symbol))))
309 665c255d 2023-08-04 jrmu 
310 665c255d 2023-08-04 jrmu ;; test suite
311 665c255d 2023-08-04 jrmu 
312 665c255d 2023-08-04 jrmu (define (test-case actual expected)
313 665c255d 2023-08-04 jrmu   (newline)
314 665c255d 2023-08-04 jrmu   (display "Actual:   ")
315 665c255d 2023-08-04 jrmu   (display actual)
316 665c255d 2023-08-04 jrmu   (newline)
317 665c255d 2023-08-04 jrmu   (display "Expected: ")
318 665c255d 2023-08-04 jrmu   (display expected)
319 665c255d 2023-08-04 jrmu   (newline))
320 665c255d 2023-08-04 jrmu 
321 665c255d 2023-08-04 jrmu (define gcd-machine
322 665c255d 2023-08-04 jrmu   (make-machine
323 665c255d 2023-08-04 jrmu    '(a b t)
324 665c255d 2023-08-04 jrmu    (list (list 'rem remainder) (list '= =))
325 665c255d 2023-08-04 jrmu    '(test-b
326 665c255d 2023-08-04 jrmu        (test (op =) (reg b) (const 0))
327 665c255d 2023-08-04 jrmu        (branch (label gcd-done))
328 665c255d 2023-08-04 jrmu        (assign t (op rem) (reg a) (reg b))
329 665c255d 2023-08-04 jrmu        (assign a (reg b))
330 665c255d 2023-08-04 jrmu        (assign b (reg t))
331 665c255d 2023-08-04 jrmu        (goto (label test-b))
332 665c255d 2023-08-04 jrmu      gcd-done)))
333 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'a 206)
334 665c255d 2023-08-04 jrmu (set-register-contents! gcd-machine 'b 40)
335 665c255d 2023-08-04 jrmu (start gcd-machine)
336 665c255d 2023-08-04 jrmu (test-case (get-register-contents gcd-machine 'a) 2)
337 665c255d 2023-08-04 jrmu 
338 665c255d 2023-08-04 jrmu (define fib-machine
339 665c255d 2023-08-04 jrmu   (make-machine 
340 665c255d 2023-08-04 jrmu    '(n val continue)
341 665c255d 2023-08-04 jrmu    `((< ,<) (- ,-) (+ ,+))
342 665c255d 2023-08-04 jrmu    '(controller
343 665c255d 2023-08-04 jrmu      (assign continue (label fib-done))
344 665c255d 2023-08-04 jrmu      fib-loop
345 665c255d 2023-08-04 jrmu      (test (op <) (reg n) (const 2))
346 665c255d 2023-08-04 jrmu      (branch (label immediate-answer))
347 665c255d 2023-08-04 jrmu      (save continue)
348 665c255d 2023-08-04 jrmu      (assign continue (label afterfib-n-1))
349 665c255d 2023-08-04 jrmu      (save n)
350 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 1))
351 665c255d 2023-08-04 jrmu      (goto (label fib-loop))
352 665c255d 2023-08-04 jrmu      afterfib-n-1           
353 665c255d 2023-08-04 jrmu      (restore n)
354 665c255d 2023-08-04 jrmu      (restore continue)
355 665c255d 2023-08-04 jrmu      (assign n (op -) (reg n) (const 2))
356 665c255d 2023-08-04 jrmu      (save continue)
357 665c255d 2023-08-04 jrmu      (assign continue (label afterfib-n-2))
358 665c255d 2023-08-04 jrmu      (save val)
359 665c255d 2023-08-04 jrmu      (goto (label fib-loop))
360 665c255d 2023-08-04 jrmu      afterfib-n-2
361 665c255d 2023-08-04 jrmu      (assign n (reg val))
362 665c255d 2023-08-04 jrmu      (restore val)       
363 665c255d 2023-08-04 jrmu      (restore continue)
364 665c255d 2023-08-04 jrmu      (assign val         
365 665c255d 2023-08-04 jrmu 	     (op +) (reg val) (reg n)) 
366 665c255d 2023-08-04 jrmu      (goto (reg continue))
367 665c255d 2023-08-04 jrmu      immediate-answer
368 665c255d 2023-08-04 jrmu      (assign val (reg n)) 
369 665c255d 2023-08-04 jrmu      (goto (reg continue))
370 665c255d 2023-08-04 jrmu      fib-done)))
371 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'val 0)
372 665c255d 2023-08-04 jrmu (set-register-contents! fib-machine 'n 15)
373 665c255d 2023-08-04 jrmu (start fib-machine)
374 665c255d 2023-08-04 jrmu (test-case (get-register-contents fib-machine 'val) 610)
375 665c255d 2023-08-04 jrmu 
376 665c255d 2023-08-04 jrmu ;; (define (factorial n)
377 665c255d 2023-08-04 jrmu ;;   (define (iter product counter)
378 665c255d 2023-08-04 jrmu ;;     (if (> counter n)
379 665c255d 2023-08-04 jrmu ;;         product
380 665c255d 2023-08-04 jrmu ;;         (iter (* counter product)
381 665c255d 2023-08-04 jrmu ;;               (+ counter 1))))
382 665c255d 2023-08-04 jrmu ;;   (iter 1 1))
383 665c255d 2023-08-04 jrmu 
384 665c255d 2023-08-04 jrmu (define fact-iter
385 665c255d 2023-08-04 jrmu   (make-machine
386 665c255d 2023-08-04 jrmu    '(product counter n)
387 665c255d 2023-08-04 jrmu    `((> ,>) (* ,*) (+ ,+))
388 665c255d 2023-08-04 jrmu    '((assign product (const 1))
389 665c255d 2023-08-04 jrmu      (assign counter (const 1))
390 665c255d 2023-08-04 jrmu      fact-loop
391 665c255d 2023-08-04 jrmu      (test (op >) (reg counter) (reg n))
392 665c255d 2023-08-04 jrmu      (branch (label fact-end))
393 665c255d 2023-08-04 jrmu      (assign product (op *) (reg counter) (reg product))
394 665c255d 2023-08-04 jrmu      (assign counter (op +) (reg counter) (const 1))
395 665c255d 2023-08-04 jrmu      (goto (label fact-loop))
396 665c255d 2023-08-04 jrmu      fact-end)))
397 665c255d 2023-08-04 jrmu (set-register-contents! fact-iter 'n 10)
398 665c255d 2023-08-04 jrmu (start fact-iter)
399 665c255d 2023-08-04 jrmu (test-case (get-register-contents fact-iter 'product) 3628800)
400 665c255d 2023-08-04 jrmu 
401 665c255d 2023-08-04 jrmu  
402 665c255d 2023-08-04 jrmu ;; Exercise 5.3.  Design a machine to compute square roots using Newton's method, as described in section 1.1.7:
403 665c255d 2023-08-04 jrmu 
404 665c255d 2023-08-04 jrmu (define (sqrt x)
405 665c255d 2023-08-04 jrmu   (define (good-enough? guess)
406 665c255d 2023-08-04 jrmu     (< (abs (- (square guess) x)) 0.001))
407 665c255d 2023-08-04 jrmu   (define (improve guess)
408 665c255d 2023-08-04 jrmu     (average guess (/ x guess)))
409 665c255d 2023-08-04 jrmu   (define (sqrt-iter guess)
410 665c255d 2023-08-04 jrmu     (if (good-enough? guess)
411 665c255d 2023-08-04 jrmu         guess
412 665c255d 2023-08-04 jrmu         (sqrt-iter (improve guess))))
413 665c255d 2023-08-04 jrmu   (sqrt-iter 1.0))
414 665c255d 2023-08-04 jrmu 
415 665c255d 2023-08-04 jrmu ;; Begin by assuming that good-enough? and improve operations are available as primitives. Then show how to expand these in terms of arithmetic operations. Describe each version of the sqrt machine design by drawing a data-path diagram and writing a controller definition in the register-machine language. 
416 665c255d 2023-08-04 jrmu 
417 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
418 665c255d 2023-08-04 jrmu   (< (abs (- (square guess) x)) 0.001))
419 665c255d 2023-08-04 jrmu (define (improve guess x)
420 665c255d 2023-08-04 jrmu   (average guess (/ x guess)))
421 665c255d 2023-08-04 jrmu (define (average x y)
422 665c255d 2023-08-04 jrmu   (/ (+ x y) 2))
423 665c255d 2023-08-04 jrmu (define sqrt-iter-ops
424 665c255d 2023-08-04 jrmu   (make-machine
425 665c255d 2023-08-04 jrmu    '(guess x)
426 665c255d 2023-08-04 jrmu    `((good-enough? ,good-enough?)
427 665c255d 2023-08-04 jrmu      (improve ,improve)
428 665c255d 2023-08-04 jrmu      (abs ,abs)
429 665c255d 2023-08-04 jrmu      (square ,square) 
430 665c255d 2023-08-04 jrmu      (average ,average)
431 665c255d 2023-08-04 jrmu      (< ,<)
432 665c255d 2023-08-04 jrmu      (- ,-)
433 665c255d 2023-08-04 jrmu      (/ ,/))
434 665c255d 2023-08-04 jrmu    '((assign guess (const 1.0))
435 665c255d 2023-08-04 jrmu      sqrt-iter
436 665c255d 2023-08-04 jrmu      (test (op good-enough?) (reg guess) (reg x))
437 665c255d 2023-08-04 jrmu      (branch (label sqrt-done))
438 665c255d 2023-08-04 jrmu      (assign guess (op improve) (reg guess) (reg x))
439 665c255d 2023-08-04 jrmu      (goto (label sqrt-iter))
440 665c255d 2023-08-04 jrmu      sqrt-done)))
441 665c255d 2023-08-04 jrmu 
442 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 27)
443 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
444 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
445 665c255d 2023-08-04 jrmu 	   5.19615242)
446 665c255d 2023-08-04 jrmu 
447 665c255d 2023-08-04 jrmu (define (good-enough? guess x)
448 665c255d 2023-08-04 jrmu   (< (abs (- (square guess) x)) 0.001))
449 665c255d 2023-08-04 jrmu (define (improve guess x)
450 665c255d 2023-08-04 jrmu   (average guess (/ x guess)))
451 665c255d 2023-08-04 jrmu (define (average x y)
452 665c255d 2023-08-04 jrmu   (/ (+ x y) 2))
453 665c255d 2023-08-04 jrmu (define sqrt-iter
454 665c255d 2023-08-04 jrmu   (make-machine
455 665c255d 2023-08-04 jrmu    '(guess x temp)
456 665c255d 2023-08-04 jrmu    `((abs ,abs)
457 665c255d 2023-08-04 jrmu      (square ,square) 
458 665c255d 2023-08-04 jrmu      (average ,average)
459 665c255d 2023-08-04 jrmu      (< ,<)
460 665c255d 2023-08-04 jrmu      (- ,-)
461 665c255d 2023-08-04 jrmu      (/ ,/))
462 665c255d 2023-08-04 jrmu    '((assign guess (const 1.0))
463 665c255d 2023-08-04 jrmu      sqrt-iter
464 665c255d 2023-08-04 jrmu      ;; (test (op good-enough?) (reg guess) (reg x))
465 665c255d 2023-08-04 jrmu      (assign temp (op square) (reg guess))
466 665c255d 2023-08-04 jrmu      (assign temp (op -) (reg temp) (reg x))
467 665c255d 2023-08-04 jrmu      (assign temp (op abs) (reg temp))
468 665c255d 2023-08-04 jrmu      (test (op <) (reg temp) (const 0.001))
469 665c255d 2023-08-04 jrmu      (branch (label sqrt-done))
470 665c255d 2023-08-04 jrmu      ;; (assign guess (op improve) (reg guess) (reg x))
471 665c255d 2023-08-04 jrmu      (assign temp (op /) (reg x) (reg guess))
472 665c255d 2023-08-04 jrmu      (assign guess (op average) (reg guess) (reg temp))
473 665c255d 2023-08-04 jrmu      (goto (label sqrt-iter))
474 665c255d 2023-08-04 jrmu      sqrt-done)))
475 665c255d 2023-08-04 jrmu (set-register-contents! sqrt-iter-ops 'x 91)
476 665c255d 2023-08-04 jrmu (start sqrt-iter-ops)
477 665c255d 2023-08-04 jrmu (test-case (get-register-contents sqrt-iter-ops 'guess)
478 665c255d 2023-08-04 jrmu 	   9.53939201)