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