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 (define 
157 (define (update-insts! insts labels machine)
158   )
159 
160 (define (make-label-entry label insts)
161   (cons label insts))
162 (define (lookup labels label-name)
163   ...)