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