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