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>)
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)))
13 665c255d 2023-08-04 jrmu (error "Unknown request -- REGISTER"
17 665c255d 2023-08-04 jrmu (define (get-contents reg)
19 665c255d 2023-08-04 jrmu (define (set-contents! reg val)
20 665c255d 2023-08-04 jrmu ((reg 'set) val))
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))
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))
53 665c255d 2023-08-04 jrmu (error "Unknown request -- STACK"
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))
61 665c255d 2023-08-04 jrmu (define (make-machine regs ops controller)
62 665c255d 2023-08-04 jrmu (let ((machine (make-new-machine)))
64 665c255d 2023-08-04 jrmu (lambda (reg)
65 665c255d 2023-08-04 jrmu ((machine 'allocate-register) reg))
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))
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
79 665c255d 2023-08-04 jrmu (flag ,flag)))
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)
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)))
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)))
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)
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)))
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))
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)
133 665c255d 2023-08-04 jrmu (define (get-register-contents machine reg)
134 665c255d 2023-08-04 jrmu (get-contents (get-register machine reg)))
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)
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
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)
152 665c255d 2023-08-04 jrmu (cons (make-label-entry next-inst insts) labels))
154 665c255d 2023-08-04 jrmu (cons (make-instruction next-inst) insts)
155 665c255d 2023-08-04 jrmu labels)))))))
157 665c255d 2023-08-04 jrmu (define (update-insts! insts labels machine)
160 665c255d 2023-08-04 jrmu (define (make-label-entry label insts)
161 665c255d 2023-08-04 jrmu (cons label insts))
162 665c255d 2023-08-04 jrmu (define (lookup labels label-name)
