1 665c255d 2023-08-04 jrmu ;; repeat 2-3 times
  2 665c255d 2023-08-04 jrmu 
  3 665c255d 2023-08-04 jrmu 
  4 665c255d 2023-08-04 jrmu (define (make-machine reg-names ops controller)
  5 665c255d 2023-08-04 jrmu   (let ((machine (make-new-machine)))
  6 665c255d 2023-08-04 jrmu     (for-each
  7 665c255d 2023-08-04 jrmu      (lambda (name)
  8 665c255d 2023-08-04 jrmu        ((machine 'allocate-register) name))
  9 665c255d 2023-08-04 jrmu      reg-names)
 10 665c255d 2023-08-04 jrmu     ((machine 'install-operations) ops)
 11 665c255d 2023-08-04 jrmu     ((machine 'install-instruction-sequence)
 12 665c255d 2023-08-04 jrmu      (assemble controller machine))
 13 665c255d 2023-08-04 jrmu     machine))
 14 665c255d 2023-08-04 jrmu 
 15 665c255d 2023-08-04 jrmu (define (make-register name)
 16 665c255d 2023-08-04 jrmu   (let ((contents '*unassigned*))
 17 665c255d 2023-08-04 jrmu     (define (dispatch message)
 18 665c255d 2023-08-04 jrmu       (cond ((eq? message 'get) contents)
 19 665c255d 2023-08-04 jrmu 	    ((eq? message 'set)
 20 665c255d 2023-08-04 jrmu 	     (lambda (val) (set! contents val)))
 21 665c255d 2023-08-04 jrmu 	    (else (error "Unknown request -- REGISTER" 
 22 665c255d 2023-08-04 jrmu 			 message))))
 23 665c255d 2023-08-04 jrmu     dispatch))
 24 665c255d 2023-08-04 jrmu 
 25 665c255d 2023-08-04 jrmu (define (set-contents! reg val)
 26 665c255d 2023-08-04 jrmu   ((reg 'set) val))
 27 665c255d 2023-08-04 jrmu (define (get-contents reg)
 28 665c255d 2023-08-04 jrmu   (reg 'get))
 29 665c255d 2023-08-04 jrmu 
 30 665c255d 2023-08-04 jrmu (define (make-stack)
 31 665c255d 2023-08-04 jrmu   (let ((s '()))
 32 665c255d 2023-08-04 jrmu     (define (push x)
 33 665c255d 2023-08-04 jrmu       (set! s (cons x s)))
 34 665c255d 2023-08-04 jrmu     (define (pop)
 35 665c255d 2023-08-04 jrmu       (if (null? s)
 36 665c255d 2023-08-04 jrmu 	  (error "Empty stack -- POP")
 37 665c255d 2023-08-04 jrmu 	  (let ((top (car s)))
 38 665c255d 2023-08-04 jrmu 	    (set! s (cdr s))
 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       'done)
 43 665c255d 2023-08-04 jrmu     (define (dispatch message)
 44 665c255d 2023-08-04 jrmu       (cond ((eq? message 'push) push)
 45 665c255d 2023-08-04 jrmu 	    ((eq? message 'pop) (pop))
 46 665c255d 2023-08-04 jrmu 	    ((eq? message 'initialize) (initialize))
 47 665c255d 2023-08-04 jrmu 	    (else (error "Unknown request -- STACK" 
 48 665c255d 2023-08-04 jrmu 			 message))))
 49 665c255d 2023-08-04 jrmu     dispatch))
 50 665c255d 2023-08-04 jrmu (define (push stack value)
 51 665c255d 2023-08-04 jrmu   ((stack 'push) value))
 52 665c255d 2023-08-04 jrmu (define (pop stack)
 53 665c255d 2023-08-04 jrmu   (stack 'pop))
 54 665c255d 2023-08-04 jrmu (define (make-new-machine)
 55 665c255d 2023-08-04 jrmu   (let* ((pc (make-register 'pc))
 56 665c255d 2023-08-04 jrmu 	 (flag (make-register 'flag))
 57 665c255d 2023-08-04 jrmu 	 (stack (make-stack))
 58 665c255d 2023-08-04 jrmu 	 (the-instruction-sequence '())
 59 665c255d 2023-08-04 jrmu 	 (register-table
 60 665c255d 2023-08-04 jrmu 	  `((pc ,pc)
 61 665c255d 2023-08-04 jrmu 	    (flag ,flag)))
 62 665c255d 2023-08-04 jrmu 	 (the-ops
 63 665c255d 2023-08-04 jrmu 	  (list (list 'initialize-stack
 64 665c255d 2023-08-04 jrmu 		      (lambda ()
 65 665c255d 2023-08-04 jrmu 			(stack 'initialize))))))
 66 665c255d 2023-08-04 jrmu     (define (lookup-register name)
 67 665c255d 2023-08-04 jrmu       (let ((val (assoc name register-table)))
 68 665c255d 2023-08-04 jrmu 	(if val
 69 665c255d 2023-08-04 jrmu 	    (cadr val)
 70 665c255d 2023-08-04 jrmu 	    (error "Unknown register -- LOOKUP" name))))
 71 665c255d 2023-08-04 jrmu     (define (allocate-register name)
 72 665c255d 2023-08-04 jrmu       (let ((val (assoc name register-table)))
 73 665c255d 2023-08-04 jrmu 	(if val
 74 665c255d 2023-08-04 jrmu 	    (error "Multiply defined register: " name)
 75 665c255d 2023-08-04 jrmu 	    (set! register-table 
 76 665c255d 2023-08-04 jrmu 		  (cons (list name (make-register name))
 77 665c255d 2023-08-04 jrmu 			register-table))))
 78 665c255d 2023-08-04 jrmu       'done)
 79 665c255d 2023-08-04 jrmu     (define (execute)
 80 665c255d 2023-08-04 jrmu       (let ((insts (get-contents pc)))
 81 665c255d 2023-08-04 jrmu 	(if (null? insts)
 82 665c255d 2023-08-04 jrmu 	    'done
 83 665c255d 2023-08-04 jrmu 	    (begin ((instruction-execution-proc (car insts)))
 84 665c255d 2023-08-04 jrmu 		   (execute)))))
 85 665c255d 2023-08-04 jrmu     (define (dispatch message)
 86 665c255d 2023-08-04 jrmu       (cond ((eq? message 'start) 
 87 665c255d 2023-08-04 jrmu 	     (set-contents! pc the-instruction-sequence)
 88 665c255d 2023-08-04 jrmu 	     (execute))
 89 665c255d 2023-08-04 jrmu 	    ((eq? message 'lookup-register) lookup-register)
 90 665c255d 2023-08-04 jrmu 	    ((eq? message 'allocate-register) allocate-register)
 91 665c255d 2023-08-04 jrmu 	    ((eq? message 'stack) stack)
 92 665c255d 2023-08-04 jrmu 	    ((eq? message 'install-operations)
 93 665c255d 2023-08-04 jrmu 	     (lambda (ops) 
 94 665c255d 2023-08-04 jrmu 	       (set! the-ops (append the-ops ops))))
 95 665c255d 2023-08-04 jrmu 	    ((eq? message 'operations) the-ops)
 96 665c255d 2023-08-04 jrmu 	    ((eq? message 'install-instruction-sequence)
 97 665c255d 2023-08-04 jrmu 	     (lambda (seq)
 98 665c255d 2023-08-04 jrmu 	       (set! the-instruction-sequence seq)))))
 99 665c255d 2023-08-04 jrmu     dispatch))
100 665c255d 2023-08-04 jrmu (define (make-instruction text)
101 665c255d 2023-08-04 jrmu   (cons text '()))
102 665c255d 2023-08-04 jrmu (define (instruction-text inst)
103 665c255d 2023-08-04 jrmu   (car inst))
104 665c255d 2023-08-04 jrmu (define (instruction-execution-proc inst)
105 665c255d 2023-08-04 jrmu   (cdr inst))
106 665c255d 2023-08-04 jrmu (define (set-instruction-execution-proc! inst proc)
107 665c255d 2023-08-04 jrmu   (set-cdr! inst proc))
108 665c255d 2023-08-04 jrmu 
109 665c255d 2023-08-04 jrmu (define (get-register machine name)
110 665c255d 2023-08-04 jrmu   ((machine 'lookup-register) name))
111 665c255d 2023-08-04 jrmu (define (get-register-contents machine name)
112 665c255d 2023-08-04 jrmu   (get-contents (get-register machine name)))
113 665c255d 2023-08-04 jrmu (define (set-register-contents! machine name value)
114 665c255d 2023-08-04 jrmu   (set-contents! (get-register machine name) value))
115 665c255d 2023-08-04 jrmu (define (start machine)
116 665c255d 2023-08-04 jrmu   (machine 'start))
117 665c255d 2023-08-04 jrmu 
118 665c255d 2023-08-04 jrmu (define (assemble controller machine)
119 665c255d 2023-08-04 jrmu   (extract-labels 
120 665c255d 2023-08-04 jrmu    controller
121 665c255d 2023-08-04 jrmu    (lambda (insts labels)
122 665c255d 2023-08-04 jrmu      (update-insts! insts labels machine)
123 665c255d 2023-08-04 jrmu      insts)))
124 665c255d 2023-08-04 jrmu 
125 665c255d 2023-08-04 jrmu ;; (define (extract-labels text receive)
126 665c255d 2023-08-04 jrmu ;;   (if (null? text)
127 665c255d 2023-08-04 jrmu ;;       (cons '() '())
128 665c255d 2023-08-04 jrmu ;;       (let* ((result (extract-labels (cdr text)))
129 665c255d 2023-08-04 jrmu ;; 	     (insts (car result))
130 665c255d 2023-08-04 jrmu ;; 	     (labels (cdr result))
131 665c255d 2023-08-04 jrmu ;; 	     (next-inst (car text)))
132 665c255d 2023-08-04 jrmu ;; 	(if (symbol? next-inst)
133 665c255d 2023-08-04 jrmu ;; 	    (cons insts
134 665c255d 2023-08-04 jrmu ;; 		  (cons (make-label-entry next-inst insts)
135 665c255d 2023-08-04 jrmu ;; 			labels))
136 665c255d 2023-08-04 jrmu ;; 	    (cons (cons (make-instruction next-inst)
137 665c255d 2023-08-04 jrmu ;; 			insts)
138 665c255d 2023-08-04 jrmu ;; 		  labels)))))
139 665c255d 2023-08-04 jrmu ;; (define (assemble controller machine)
140 665c255d 2023-08-04 jrmu ;;   (let* ((result (extract-labels controller))
141 665c255d 2023-08-04 jrmu ;; 	 (insts (car result))
142 665c255d 2023-08-04 jrmu ;; 	 (labels (cdr result)))
143 665c255d 2023-08-04 jrmu ;;     (update-insts! insts labels machine)
144 665c255d 2023-08-04 jrmu ;;     insts))
145 665c255d 2023-08-04 jrmu 
146 665c255d 2023-08-04 jrmu (define (extract-labels text receive)
147 665c255d 2023-08-04 jrmu   (if (null? text)
148 665c255d 2023-08-04 jrmu       (receive '() '())
149 665c255d 2023-08-04 jrmu       (extract-labels 
150 665c255d 2023-08-04 jrmu        (cdr text)
151 665c255d 2023-08-04 jrmu        (lambda (insts labels)
152 665c255d 2023-08-04 jrmu 	 (let ((next-inst (car text)))
153 665c255d 2023-08-04 jrmu 	   (if (symbol? next-inst)
154 665c255d 2023-08-04 jrmu 	       (receive
155 665c255d 2023-08-04 jrmu 		   insts
156 665c255d 2023-08-04 jrmu 		   (cons (make-label-entry next-inst insts)
157 665c255d 2023-08-04 jrmu 			 labels))
158 665c255d 2023-08-04 jrmu 	       (receive
159 665c255d 2023-08-04 jrmu 		   (cons (make-instruction next-inst)
160 665c255d 2023-08-04 jrmu 			 insts)
161 665c255d 2023-08-04 jrmu 		   labels)))))))
162 665c255d 2023-08-04 jrmu 
163 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
164 665c255d 2023-08-04 jrmu   (let ((pc (get-register machine 'pc))
165 665c255d 2023-08-04 jrmu 	(flag (get-register machine 'flag))
166 665c255d 2023-08-04 jrmu 	(stack (machine 'stack))
167 665c255d 2023-08-04 jrmu 	(ops (machine 'operations)))
168 665c255d 2023-08-04 jrmu     (for-each
169 665c255d 2023-08-04 jrmu      (lambda (inst)
170 665c255d 2023-08-04 jrmu        (set-instruction-execution-proc!
171 665c255d 2023-08-04 jrmu 	inst
172 665c255d 2023-08-04 jrmu 	(make-execution-procedure 
173 665c255d 2023-08-04 jrmu 	 (instruction-text inst) labels machine
174 665c255d 2023-08-04 jrmu 	 pc flag stack ops)))
175 665c255d 2023-08-04 jrmu      insts)))
176 665c255d 2023-08-04 jrmu 
177 665c255d 2023-08-04 jrmu (define (make-label-entry label-name insts)
178 665c255d 2023-08-04 jrmu   (cons label-name insts))
179 665c255d 2023-08-04 jrmu (define (make-execution-procedure text labels machine 
180 665c255d 2023-08-04 jrmu 				  pc flags stack ops)
181 665c255d 2023-08-04 jrmu   ...)
182 665c255d 2023-08-04 jrmu ;; unfinished!