1 (make-machine <regs> <ops> <controller>)
2 (start <machine>)
3 (set-register-contents! <machine> <reg> <value>)
4 (get-register-contents <machine> <reg>)
5 
6 (define (make-register name)
7   (let ((contents '*unassigned*))
8     (define (dispatch message)
9       (cond ((eq? message 'get) contents)
10 	    ((eq? message 'set)
11 	     (lambda (val) (set! contents val)))
12 	    (else
13 	     (error "Unknown request -- REGISTER"
14 		    message))))
15     dispatch))
16 
17 (define (get-contents reg)
18   (reg 'get))
19 (define (set-contents! reg val)
20   ((reg 'set) val))
21 
22 (define (make-stack)
23   (let ((s '())
24 	(number-pushes 0)
25 	(current-depth 0)
26 	(max-depth 0))
27     (define (push x)
28       (set! s (cons x s))
29       (set! number-pushes (+ number-pushes 1))
30       (set! current-depth (+ current-depth 1))
31       (set! max-depth (max max-depth current-depth)))
32     (define (pop)
33       (if (null? s)
34 	  (error "Empty stack -- POP")
35 	  (let ((top (car s)))
36 	    (set! s (cdr s))
37 	    (set! current-depth (- current-depth 1))
38 	    top)))
39     (define (initialize)
40       (set! s '())
41       (set! number-pushes 0)
42       (set! current-depth 0)
43       (set! max-depth 0))
44     (define (print-statistics)
45       `(total-pushes = ,number-pushes
46 	max-depth = ,max-depth))
47     (define (dispatch message)
48       (cond ((eq? message 'push) push)
49 	    ((eq? message 'pop) (pop))
50 	    ((eq? message 'initialize) (initialize))
51 	    ((eq? message 'print-statistics) (print-statistics))
52 	    (else
53 	     (error "Unknown request -- STACK"
54 		    message))))
55     dispatch))
56 (define (push stack val)
57   ((stack 'push) val))
58 (define (pop stack)
59   (stack 'pop))
60 
61 (define (make-machine regs ops controller)
62   (let ((machine (make-new-machine)))
63     (for-each
64      (lambda (reg)
65        ((machine 'allocate-register) reg))
66      regs)
67     ((machine 'install-operations) ops)
68     ((machine 'install-instruction-sequence)
69      (assemble controller machine))
70     machine))
71 
72 (define (make-new-machine)
73   (let* ((pc (make-register 'pc))
74 	 (flag (make-register 'flag))
75 	 (stack (make-stack))
76 	 (the-instruction-sequence '())
77 	 (register-table
78 	  `((pc ,pc) 
79 	    (flag ,flag)))
80 	 (the-ops
81 	  `((initialize 
82 	     ,(lambda () (stack 'initialize)))
83 	    (print-statistics 
84 	     ,(lambda () (stack 'print-statistics))))))
85     (define (execute)
86       (let ((insts (get-contents pc)))
87 	(if (null? insts)
88 	    'done
89 	    (begin ((instruction-proc (car insts)))
90 		   (execute)))))
91     (define (allocate-register name)
92       (let ((val (assoc name register-table)))
93 	(if val
94 	    (error "Multiply defined register: " name)
95 	    (set! register-table
96 		  (cons (list name (make-register name))
97 			register-table)))))
98     (define (lookup-register name)
99       (let ((val (assoc name register-table)))
100 	(if val
101 	    (cadr val)
102 	    (error "Undefined register: " name))))
103     (define (dispatch message)
104       (cond ((eq? message 'start)
105 	     (set-contents! pc the-instruction-sequence)
106 	     (execute))
107 	    ((eq? message 'allocate-register) allocate-register)
108 	    ((eq? message 'get-register) lookup-register)
109 	    ((eq? message 'install-operations)
110 	     (lambda (ops) (set! the-ops (append the-ops ops))))
111 	    ((eq? message 'install-instruction-sequence)
112 	     (lambda (seq) (set! the-instruction-sequence seq)))
113 	    ((eq? message 'stack) stack)
114 	    ((eq? message 'operations) the-ops)))
115     dispatch))
116 
117 (define (make-instruction text)
118   (cons text '()))
119 (define (instruction-proc inst)
120   (cdr inst))
121 (define (instruction-text inst)
122   (car inst))
123 (define (set-instruction-proc! inst proc)
124   (set-cdr! inst proc))
125 
126 (define (start machine)
127   (machine 'start))
128 (define (get-register machine reg-name)
129   ((machine 'get-register) reg-name))
130 (define (set-register-contents! machine reg val)
131   (set-contents! (get-register machine reg) val)
132   'done)
133 (define (get-register-contents machine reg)
134   (get-contents (get-register machine reg)))
135 
136 (define (assemble controller-text machine)
137   (extract-labels
138    controller-text
139    (lambda (insts labels)
140      (update-insts! insts labels machine)
141      insts)))
142 (define (extract-labels text receive)
143   (if (null? text)
144       (receive '() '())
145       (extract-labels
146        (cdr text)
147        (lambda (insts labels)
148 	 (let ((next-inst (car text)))
149 	   (if (symbol? next-inst)
150 	       (receive
151 		   insts
152 		   (cons (make-label-entry next-inst insts) labels))
153 	       (receive
154 		   (cons (make-instruction next-inst) insts)
155 		   labels)))))))
156 
157 (define (extract-labels text)
158   (if (null? text)
159       (cons '() '())
160       (let* ((result (extract-labels (cdr text)))
161 	     (insts (car result))
162 	     (labels (cdr result))
163 	     (next-inst (car text)))
164 	(if (symbol? next-inst)
165 	    (cons insts
166 		  (cons (make-label-entry next-inst insts)
167 			labels))
168 	    (cons (cons (make-instruction next-inst) insts)
169 		  labels)))))
170 (define (assemble controller machine)
171   (let* ((result (extract-labels controller))
172 	 (insts (car result))
173 	 (labels (cdr result)))
174     (update-insts! insts labels machine)
175     insts))
176 
177 (define (update-insts! insts labels machine)
178   (let* ((pc (get-register machine 'pc))
179 	 (flag (get-register machine 'flag))
180 	 (stack (machine 'stack))
181 	 (ops (machine 'operations)))
182     (for-each
183      (lambda (inst)
184        (set-instruction-proc! 
185 	inst
186 	(make-execution-procedure
187 	 (instruction-text inst) labels machine
188 	 pc flag stack ops)))
189      insts)))
190 
191 (define (make-execution-procedure text labels machine
192 				  pc stack flag ops)
193   (cond ((eq? (car text) 'assign)
194 	 (make-assign
195 	  text machine labels ops pc))
196 	((eq? (car text) 'test)
197 	 (make-test
198 	  text machine labels ops pc))
199 	((eq? (car text) 'branch)
200 	 (make-branch
201 	  text machine labels flag pc))
202 	((eq? (car text) 'goto)
203 	 (make-goto
204 	  text machine labels pc))
205 	((eq? (car text) 'perform)
206 	 (make-perform
207 	  text machine labels ops pc))
208 	((eq? (car text) 'save)
209 	 (make-save
210 	  text machine stack pc))
211 	((eq? (car text) 'restore)
212 	 (make-restore
213 	  text machine stack pc))
214 	(else
215 	 (error "Unknown instruction type -- ASSEMBLE"
216 		text))))
217 (define (make-assign inst machine labels ops pc)
218   (let* ((reg (get-register machine (assign-reg-name inst)))
219 	 (value-exp (assign-reg-value inst))
220 	 (value-proc
221 	  (if (operation-exp? value-exp)
222 	      (make-operation-exp
223 	       value-exp machine labels ops)
224 	      (make-primitive-exp
225 	       (car value-exp) machine labels))))
226     (lambda ()
227       (set-contents! reg (value-proc))
228       (advance-pc pc))))
229 (define (assign-reg-name inst)
230   (cadr inst))
231 (define (assign-reg-value inst)
232   (cddr inst))
233 (define (advance-pc pc)
234   (set-contents! pc (cdr (get-contents pc))))
235 (define (make-test inst machine labels ops pc)
236   (let* ((test (test-cond inst)))
237     (if (operation-exp? test)
238 	(let ((test-proc (make-operation-exp
239 			  test machine labels ops)))
240 	  (lambda ()
241 	    (set-contents! flag (test-proc))
242 	    (advance-pc pc)))
243 	(error "Bad TEST instruction -- ASSEMBLE"
244 	       inst))))
245 (define (test-cond exp)
246   (cdr exp))
247 (define (make-branch text machine labels flag pc)
248   (let ((dest (branch-dest text)))
249     (if (label-exp? dest)
250 	(let ((insts (lookup-label labels (label-exp-label dest))))
251 	  (lambda ()
252 	    (if (get-contents flag)
253 		(set-contents! pc insts)
254 		(advance-pc pc))))
255 	(error "Bad BRANCH instruction -- ASSEMBLE"
256 	       text))))
257 (define (branch-dest exp)
258   (cadr exp))
259 (define (make-goto text machine labels pc)
260   (let ((dest (goto-dest text)))
261     (cond ((register-exp? dest)
262 	   (let ((reg (get-register machine (register-exp-name dest))))
263 	     (lambda ()
264 	       (set-contents! pc (get-contents reg)))))
265 	  ((label-exp? dest)
266 	   (let ((insts (lookup-label labels (label-exp-label dest))))
267 	     (lambda ()
268 	       (set-contents! pc insts))))
269 	  (else 
270 	   (error "Bad GOTO instruction -- ASSEMBLE"
271 		  text)))))
272 (define (goto-dest exp)
273   (cadr exp))
274 (define (make-perform text machine labels ops pc)
275   (let ((action (perform-action text)))
276     (if (operation-exp? action)
277 	(let ((action-proc (make-operation-exp
278 			    action machine labels ops)))
279 	  (lambda ()
280 	    (action-proc)
281 	    (advance-pc pc)))
282 	(error "Bad PERFORM instruction -- ASSEMBLE"
283 	       text))))
284 (define (perform-action exp)
285   (cdr exp))
286 (define (make-save text machine stack pc)
287   (let ((reg (get-register machine (stack-inst-reg text))))
288     (lambda ()
289       (push stack (get-contents reg))
290       (advance-pc pc))))
291 (define (stack-inst-reg exp)
292   (cadr exp))
293 (define (make-restore text machine stack pc)
294   (let ((reg (get-register machine (stack-inst-reg text))))
295     (lambda ()
296       (set-contents! reg (pop stack))
297       (advance-pc pc))))
298 
299 (define (make-primitive-exp exp machine labels)
300   (cond ((register-exp? exp) 
301 	 (let ((reg (get-register machine (register-exp-name exp))))
302 	   (lambda ()
303 	     (get-contents reg))))
304 	((const-exp? exp) 
305 	 (let ((val (const-exp-value exp)))
306 	   (lambda () val)))
307 	((label-exp? exp) 
308 	 (let ((insts (lookup-label labels (label-exp-label exp))))
309 	   (lambda () insts)))
310 	(else 
311 	 "Unknown expression type -- ASSEMBLE"
312 	 exp)))
313 (define (register-exp? exp)
314   (tagged-list? exp 'reg))
315 (define (register-exp-name exp)
316   (cadr exp))
317 (define (const-exp? exp)
318   (tagged-list? exp 'const))
319 (define (const-exp-value exp)
320   (cadr exp))
321 (define (label-exp? exp)
322   (tagged-list? exp 'label))
323 (define (label-exp-label exp)
324   (cadr exp))
325 (define (make-operation-exp exp machine labels ops)
326   (let* ((proc (lookup-prim (operation-exp-op exp) ops))
327 	 (aprocs 
328 	  (map (lambda (e) 
329 		 (make-primitive-exp
330 		  e machine labels))
331 	       (operation-exp-operands exp))))
332     (lambda ()
333       (apply proc (map (lambda (p) (p)) aprocs)))))
334 (define (operation-exp? exp)
335   (and (pair? exp) (tagged-list? (car exp) 'op))))
336 (define (operation-exp-op exp)
337   (cadr (car exp)))
338 (define (operation-exp-operands exp)
339   (cdr exp))
340 (define (lookup-prim symbol ops)
341   (let ((val (assoc symbol ops)))
342     (if val
343 	(cadr val)
344 	(error "Undefined operation -- ASSEMBLE"
345 	       symbol))))
346 (define (make-label-entry label insts)
347   (cons label insts))
348 (define (lookup-label labels label-name)
349   (let ((val (assoc label-name labels)))
350     (if val
351 	(cdr val)
352 	(error "Undefined label -- ASSEMBLE"
353 	       label-name))))