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