1 (define (make-machine register-names ops controller-text)
2   (let ((machine (make-new-machine)))
3     (for-each (lambda (register-name)
4                 ((machine 'allocate-register) register-name))
5               register-names)
6     ((machine 'install-operations) ops)    
7     ((machine 'install-instruction-sequence)
8      (assemble controller-text machine))
9     machine))
10 (define (make-register name)
11   (let ((contents '*unassigned*))
12     (define (dispatch message)
13       (cond ((eq? message 'get) contents)
14             ((eq? message 'set)
15              (lambda (value) (set! contents value)))
16             (else
17              (error "Unknown request -- REGISTER" message))))
18     dispatch))
19 (define (get-contents register)
20   (register 'get))
21 (define (set-contents! register value)
22   ((register 'set) value))
23 (define (make-stack)
24   (let ((s '())
25         (number-pushes 0)
26         (max-depth 0)
27         (current-depth 0))
28     (define (push x)
29       (set! s (cons x s))
30       (set! number-pushes (+ 1 number-pushes))
31       (set! current-depth (+ 1 current-depth))
32       (set! max-depth (max current-depth max-depth)))
33     (define (pop)
34       (if (null? s)
35           (error "Empty stack -- POP")
36           (let ((top (car s)))
37             (set! s (cdr s))
38             (set! current-depth (- current-depth 1))
39             top)))    
40     (define (initialize)
41       (set! s '())
42       (set! number-pushes 0)
43       (set! max-depth 0)
44       (set! current-depth 0)
45       'done)
46     (define (print-statistics)
47       (newline)
48       (display (list 'total-pushes  '= number-pushes
49                      'maximum-depth '= max-depth)))
50     (define (dispatch message)
51       (cond ((eq? message 'push) push)
52             ((eq? message 'pop) (pop))
53             ((eq? message 'initialize) (initialize))
54             ((eq? message 'print-statistics)
55              (print-statistics))
56             (else
57              (error "Unknown request -- STACK" message))))
58     dispatch))
59 (define (pop stack)
60   (stack 'pop))
61 (define (push stack value)
62   ((stack 'push) value))
63 (define (make-new-machine)
64   (let ((pc (make-register 'pc))
65         (flag (make-register 'flag))
66         (stack (make-stack))
67         (the-instruction-sequence '()))
68     (let ((the-ops
69 	   (list (list 'initialize-stack
70 		       (lambda () (stack 'initialize)))
71 		 (list 'print-stack-statistics
72 		       (lambda () (stack 'print-statistics)))))
73           (register-table
74            (list (list 'pc pc) (list 'flag flag))))
75       (define (allocate-register name)
76         (if (assoc name register-table)
77             (error "Multiply defined register: " name)
78             (set! register-table
79                   (cons (list name (make-register name))
80                         register-table)))
81         'register-allocated)
82       (define (lookup-register name)
83         (let ((val (assoc name register-table)))
84           (if val
85               (cadr val)
86               (error "Unknown register:" name))))
87       (define (execute)
88         (let ((insts (get-contents pc)))
89           (if (null? insts)
90               'done
91               (begin
92                 ((instruction-execution-proc (car insts)))
93                 (execute)))))
94       (define (dispatch message)
95         (cond ((eq? message 'start)
96                (set-contents! pc the-instruction-sequence)
97                (execute))
98               ((eq? message 'install-instruction-sequence)
99                (lambda (seq) (set! the-instruction-sequence seq)))
100               ((eq? message 'allocate-register) allocate-register)
101               ((eq? message 'get-register) lookup-register)
102               ((eq? message 'install-operations)
103                (lambda (ops) (set! the-ops (append the-ops ops))))
104               ((eq? message 'stack) stack)
105               ((eq? message 'operations) the-ops)
106               (else (error "Unknown request -- MACHINE" message))))
107       dispatch)))
108 (define (start machine)
109   (machine 'start))
110 (define (get-register-contents machine register-name)
111   (get-contents (get-register machine register-name)))
112 (define (set-register-contents! machine register-name value)
113   (set-contents! (get-register machine register-name) value)
114   'done)
115 (define (get-register machine reg-name)
116   ((machine 'get-register) reg-name))
117 (define (assemble controller-text machine)
118   (extract-labels controller-text
119     (lambda (insts labels)
120       (update-insts! insts labels machine)
121       insts)))
122 (define (extract-labels text receive)
123   (if (null? text)
124       (receive '() '())
125       (extract-labels (cdr text)
126        (lambda (insts labels)
127          (let ((next-inst (car text)))
128            (if (symbol? next-inst)
129 	       (if (label-defined? labels next-inst)
130 		   (error "Duplicate label -- ASSEMBLE"
131 			  next-inst)
132 		   (receive 
133 		       insts
134 		       (cons (make-label-entry next-inst
135 					       insts)
136 			     labels)))
137                (receive
138 		   (cons (make-instruction next-inst)
139 			 insts)
140 		   labels)))))))
141 (define (update-insts! insts labels machine)
142   (let ((pc (get-register machine 'pc))
143         (flag (get-register machine 'flag))
144         (stack (machine 'stack))
145         (ops (machine 'operations)))
146     (for-each
147      (lambda (inst)
148        (set-instruction-execution-proc! 
149         inst
150         (make-execution-procedure
151          (instruction-text inst) labels machine
152          pc flag stack ops)))
153      insts)))
154 (define (make-instruction text)
155   (cons text '()))
156 (define (instruction-text inst)
157   (car inst))
158 (define (instruction-execution-proc inst)
159   (cdr inst))
160 (define (set-instruction-execution-proc! inst proc)
161   (set-cdr! inst proc))
162 (define (make-label-entry label-name insts)
163   (cons label-name insts))
164 (define (label-defined? labels label-name)
165   (not (false? (assoc label-name labels))))
166 (define (lookup-label labels label-name)
167   (let ((val (assoc label-name labels)))
168     (if val
169         (cdr val)
170         (error "Undefined label -- ASSEMBLE" label-name))))
171 (define (make-execution-procedure inst labels machine
172                                   pc flag stack ops)
173   (cond ((eq? (car inst) 'assign)
174          (make-assign inst machine labels ops pc))
175         ((eq? (car inst) 'test)
176          (make-test inst machine labels ops flag pc))
177         ((eq? (car inst) 'branch)
178          (make-branch inst machine labels flag pc))
179         ((eq? (car inst) 'goto)
180          (make-goto inst machine labels pc))
181         ((eq? (car inst) 'save)
182          (make-save inst machine stack pc))
183         ((eq? (car inst) 'restore)
184          (make-restore inst machine stack pc))
185         ((eq? (car inst) 'perform)
186          (make-perform inst machine labels ops pc))
187         (else (error "Unknown instruction type -- ASSEMBLE"
188                      inst))))
189 (define (make-assign inst machine labels operations pc)
190   (let ((target
191          (get-register machine (assign-reg-name inst)))
192         (value-exp (assign-value-exp inst)))
193     (let ((value-proc
194            (if (operation-exp? value-exp)
195                (make-operation-exp
196                 value-exp machine labels operations)
197                (make-primitive-exp
198                 (car value-exp) machine labels))))
199       (lambda ()                ; execution procedure for assign
200         (set-contents! target (value-proc))
201         (advance-pc pc)))))
202 (define (assign-reg-name assign-instruction)
203   (cadr assign-instruction))
204 (define (assign-value-exp assign-instruction)
205   (cddr assign-instruction))
206 (define (advance-pc pc)
207   (set-contents! pc (cdr (get-contents pc))))
208 (define (make-test inst machine labels operations flag pc)
209   (let ((condition (test-condition inst)))
210     (if (operation-exp? condition)
211         (let ((condition-proc
212                (make-operation-exp
213                 condition machine labels operations)))
214           (lambda ()
215             (set-contents! flag (condition-proc))
216             (advance-pc pc)))
217         (error "Bad TEST instruction -- ASSEMBLE" inst))))
218 (define (test-condition test-instruction)
219   (cdr test-instruction))
220 (define (make-branch inst machine labels flag pc)
221   (let ((dest (branch-dest inst)))
222     (if (label-exp? dest)
223         (let ((insts
224                (lookup-label labels (label-exp-label dest))))
225           (lambda ()
226             (if (get-contents flag)
227                 (set-contents! pc insts)
228                 (advance-pc pc))))
229         (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
230 (define (branch-dest branch-instruction)
231   (cadr branch-instruction))
232 (define (make-goto inst machine labels pc)
233   (let ((dest (goto-dest inst)))
234     (cond ((label-exp? dest)
235            (let ((insts
236                   (lookup-label labels
237                                 (label-exp-label dest))))
238              (lambda () (set-contents! pc insts))))
239           ((register-exp? dest)
240            (let ((reg
241                   (get-register machine
242                                 (register-exp-reg dest))))
243              (lambda ()
244                (set-contents! pc (get-contents reg)))))
245           (else (error "Bad GOTO instruction -- ASSEMBLE"
246                        inst)))))
247 (define (goto-dest goto-instruction)
248   (cadr goto-instruction))
249 (define (make-stack-pair reg-name contents)
250   (cons reg-name contents))
251 (define (stack-pair-reg-name pair)
252   (car pair))
253 (define (stack-pair-val pair)
254   (cdr pair))
255 (define (make-save inst machine stack pc)
256   (let* ((reg-name (stack-inst-reg-name inst))
257 	 (reg (get-register machine reg-name)))
258     (lambda ()
259       (push stack (make-stack-pair reg-name (get-contents reg)))
260       (advance-pc pc))))
261 (define (make-restore inst machine stack pc)
262   (let* ((reg-name (stack-inst-reg-name inst))
263 	 (reg (get-register machine reg-name)))
264     (lambda ()
265       (let* ((stack-pair (pop stack))
266 	     (stack-reg-name (stack-pair-reg-name stack-pair))
267 	     (stack-val (stack-pair-val stack-pair)))
268 	(if (eq? stack-reg-name reg-name)
269 	    (begin (set-contents! reg stack-val)
270 		   (advance-pc pc))
271 	    (error "Stack/register mismatch -- Save/Restore: "
272 		   stack-reg-name reg-name)))))) 
273 (define (stack-inst-reg-name stack-instruction)
274   (cadr stack-instruction))
275 (define (make-perform inst machine labels operations pc)
276   (let ((action (perform-action inst)))
277     (if (operation-exp? action)
278         (let ((action-proc
279                (make-operation-exp
280                 action machine labels operations)))
281           (lambda ()
282             (action-proc)
283             (advance-pc pc)))
284         (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
285 (define (perform-action inst) (cdr inst))
286 (define (make-primitive-exp exp machine labels)
287   (cond ((constant-exp? exp)
288          (let ((c (constant-exp-value exp)))
289            (lambda () c)))
290         ((label-exp? exp)
291          (let ((insts
292                 (lookup-label labels
293                               (label-exp-label exp))))
294            (lambda () insts)))
295         ((register-exp? exp)
296          (let ((r (get-register machine
297                                 (register-exp-reg exp))))
298            (lambda () (get-contents r))))
299         (else
300          (error "Unknown expression type -- ASSEMBLE" exp))))
301 (define (tagged-list? exp tag)
302   (and (pair? exp) (eq? (car exp) tag)))
303 (define (register-exp? exp) (tagged-list? exp 'reg))
304 (define (register-exp-reg exp) (cadr exp))
305 (define (constant-exp? exp) (tagged-list? exp 'const))
306 (define (constant-exp-value exp) (cadr exp))
307 (define (label-exp? exp) (tagged-list? exp 'label))
308 (define (label-exp-label exp) (cadr exp))
309 (define (make-operation-exp exp machine labels operations)
310   (let ((op (lookup-prim (operation-exp-op exp) operations)) 
311         (aprocs
312          (map (lambda (e)
313 		;; (if (label-exp? e)
314 		;;     (error "Operation exp cannot operate on labels -- ASSEMBLE"
315 		;; 	   exp)
316 		(make-primitive-exp e machine labels))
317               (operation-exp-operands exp))))
318     (lambda ()
319       (apply op (map (lambda (p) (p)) aprocs)))))
320 (define (operation-exp? exp)
321   (and (pair? exp) (tagged-list? (car exp) 'op)))
322 (define (operation-exp-op operation-exp)
323   (cadr (car operation-exp)))
324 (define (operation-exp-operands operation-exp)
325   (cdr operation-exp))
326 (define (lookup-prim symbol operations)
327   (let ((val (assoc symbol operations)))
328     (if val
329         (cadr val)
330         (error "Unknown operation -- ASSEMBLE" symbol))))
331 
332 ;; test suite
333 
334 (define (test-case actual expected)
335   (newline)
336   (display "Actual:   ")
337   (display actual)
338   (newline)
339   (display "Expected: ")
340   (display expected)
341   (newline))
342 
343 (define gcd-machine
344   (make-machine
345    '(a b t)
346    (list (list 'rem remainder) (list '= =))
347    '(test-b
348        (test (op =) (reg b) (const 0))
349        (branch (label gcd-done))
350        (assign t (op rem) (reg a) (reg b))
351        (assign a (reg b))
352        (assign b (reg t))
353        (goto (label test-b))
354      gcd-done)))
355 (set-register-contents! gcd-machine 'a 206)
356 (set-register-contents! gcd-machine 'b 40)
357 (start gcd-machine)
358 (test-case (get-register-contents gcd-machine 'a) 2)
359 
360 (define fib-machine
361   (make-machine 
362    '(n val continue)
363    `((< ,<) (- ,-) (+ ,+))
364    '(controller
365      (assign continue (label fib-done))
366      fib-loop
367      (test (op <) (reg n) (const 2))
368      (branch (label immediate-answer))
369      (save continue)
370      (assign continue (label afterfib-n-1))
371      (save n)
372      (assign n (op -) (reg n) (const 1))
373      (goto (label fib-loop))
374      afterfib-n-1           
375      (restore n)
376      (restore continue)
377      (assign n (op -) (reg n) (const 2))
378      (save continue)
379      (assign continue (label afterfib-n-2))
380      (save val)
381      (goto (label fib-loop))
382      afterfib-n-2
383      (assign n (reg val))
384      (restore val)       
385      (restore continue)
386      (assign val         
387 	     (op +) (reg val) (reg n)) 
388      (goto (reg continue))
389      immediate-answer
390      (assign val (reg n)) 
391      (goto (reg continue))
392      fib-done)))
393 (set-register-contents! fib-machine 'val 0)
394 (set-register-contents! fib-machine 'n 15)
395 (start fib-machine)
396 (test-case (get-register-contents fib-machine 'val) 610)
397 
398 (define fact-iter
399   (make-machine
400    '(product counter n)
401    `((> ,>) (* ,*) (+ ,+))
402    '((assign product (const 1))
403      (assign counter (const 1))
404      fact-loop
405      (test (op >) (reg counter) (reg n))
406      (branch (label fact-end))
407      (assign product (op *) (reg counter) (reg product))
408      (assign counter (op +) (reg counter) (const 1))
409      (goto (label fact-loop))
410      fact-end)))
411 (set-register-contents! fact-iter 'n 10)
412 (start fact-iter)
413 (test-case (get-register-contents fact-iter 'product) 3628800)
414 
415 (define (sqrt x)
416   (define (good-enough? guess)
417     (< (abs (- (square guess) x)) 0.001))
418   (define (improve guess)
419     (average guess (/ x guess)))
420   (define (sqrt-iter guess)
421     (if (good-enough? guess)
422         guess
423         (sqrt-iter (improve guess))))
424   (sqrt-iter 1.0))
425 
426 (define (good-enough? guess x)
427   (< (abs (- (square guess) x)) 0.001))
428 (define (improve guess x)
429   (average guess (/ x guess)))
430 (define (average x y)
431   (/ (+ x y) 2))
432 (define sqrt-iter-ops
433   (make-machine
434    '(guess x)
435    `((good-enough? ,good-enough?)
436      (improve ,improve)
437      (abs ,abs)
438      (square ,square) 
439      (average ,average)
440      (< ,<)
441      (- ,-)
442      (/ ,/))
443    '((assign guess (const 1.0))
444      sqrt-iter
445      (test (op good-enough?) (reg guess) (reg x))
446      (branch (label sqrt-done))
447      (assign guess (op improve) (reg guess) (reg x))
448      (goto (label sqrt-iter))
449      sqrt-done)))
450 
451 (set-register-contents! sqrt-iter-ops 'x 27)
452 (start sqrt-iter-ops)
453 (test-case (get-register-contents sqrt-iter-ops 'guess)
454 	   5.19615242)
455 
456 (define (good-enough? guess x)
457   (< (abs (- (square guess) x)) 0.001))
458 (define (improve guess x)
459   (average guess (/ x guess)))
460 (define (average x y)
461   (/ (+ x y) 2))
462 (define sqrt-iter
463   (make-machine
464    '(guess x temp)
465    `((abs ,abs)
466      (square ,square) 
467      (average ,average)
468      (< ,<)
469      (- ,-)
470      (/ ,/))
471    '((assign guess (const 1.0))
472      sqrt-iter
473      ;; (test (op good-enough?) (reg guess) (reg x))
474      (assign temp (op square) (reg guess))
475      (assign temp (op -) (reg temp) (reg x))
476      (assign temp (op abs) (reg temp))
477      (test (op <) (reg temp) (const 0.001))
478      (branch (label sqrt-done))
479      ;; (assign guess (op improve) (reg guess) (reg x))
480      (assign temp (op /) (reg x) (reg guess))
481      (assign guess (op average) (reg guess) (reg temp))
482      (goto (label sqrt-iter))
483      sqrt-done)))
484 (set-register-contents! sqrt-iter-ops 'x 91)
485 (start sqrt-iter-ops)
486 (test-case (get-register-contents sqrt-iter-ops 'guess)
487 	   9.53939201)
488 
489 (define (expt b n)
490   (if (= n 0)
491       1
492       (* b (expt b (- n 1)))))
493 
494 (define expt-rec
495   (make-machine
496    '(b n product continue)
497    `((= ,=)
498      (* ,*)
499      (- ,-))
500    '((assign continue (label expt-done))
501      expt-rec
502      (test (op =) (reg n) (const 0))
503      (branch (label base-case))
504      (assign n (op -) (reg n) (const 1))
505      (save continue)
506      (assign continue (label after-b-n-1))
507      (goto (label expt-rec))
508      after-b-n-1
509      (restore continue)
510      (assign product (op *) (reg b) (reg product))
511      (goto (reg continue))
512      base-case
513      (assign product (const 1))
514      (goto (reg continue))
515      expt-done)))
516 
517 (set-register-contents! expt-rec 'b 3.2)
518 (set-register-contents! expt-rec 'n 6)
519 (start expt-rec)
520 (test-case (get-register-contents expt-rec 'product)
521 	   1073.74182)
522 
523 (define (expt b n)
524   (define (expt-iter counter product)
525     (if (= counter 0)
526         product
527         (expt-iter (- counter 1) (* b product))))
528   (expt-iter n 1))
529 
530 (define expt-iter
531   (make-machine
532    '(b n counter product)
533    `((= ,=)
534      (* ,*)
535      (- ,-))
536    '((assign counter (reg n))
537      (assign product (const 1))
538      expt-iter
539      (test (op =) (reg counter) (const 0))
540      (branch (label expt-iter-done))
541      (assign counter (op -) (reg counter) (const 1))
542      (assign product (op *) (reg b) (reg product))
543      (goto (label expt-iter))
544      expt-iter-done)))
545 (set-register-contents! expt-iter 'b 1.6)
546 (set-register-contents! expt-iter 'n 17)
547 (start expt-iter)
548 (test-case (get-register-contents expt-iter 'product) 
549 	   2951.47905)
550 
551 ;; (define amb-machine
552 ;;   (make-machine
553 ;;    '(a)
554 ;;    '()
555 ;;    '(start
556 ;;      (goto (label here))
557 ;;      here
558 ;;      (assign a (const 3))
559 ;;      (goto (label there))
560 ;;      here
561 ;;      (assign a (const 4))
562 ;;      (goto (label there))
563 ;;      there)))
564 
565 ;; (start amb-machine)
566 ;; (test-case (get-register-contents amb-machine 'a)
567 ;; 	   3)
568 ;; this now raises an error
569 
570 (define fact-rec
571   (make-machine
572    '(n val continue)
573    `((= ,=) (- ,-) (* ,*))
574    '((assign continue (label fact-done))     ; set up final return address
575      fact-loop
576      (test (op =) (reg n) (const 1))
577      (branch (label base-case))
578      ;; Set up for the recursive call by saving n and continue.
579      ;; Set up continue so that the computation will continue
580      ;; at after-fact when the subroutine returns.
581      (save continue)
582      (save n)
583      (assign n (op -) (reg n) (const 1))
584      (assign continue (label after-fact))
585      (goto (label fact-loop))
586      after-fact
587      (restore n)
588      (restore continue)
589      (assign val (op *) (reg n) (reg val))   ; val now contains n(n - 1)!
590      (goto (reg continue))                   ; return to caller
591      base-case
592      (assign val (const 1))                  ; base case: 1! = 1
593      (goto (reg continue))                   ; return to caller
594      fact-done
595      (perform (op print-stack-statistics)))))
596 
597 (define count-leaves-rec
598   (make-machine
599    '(tree val continue)
600    `((pair? ,pair?)
601      (null? ,null?)
602      (car ,car)
603      (cdr ,cdr)
604      (+ ,+))
605    '((assign continue (label count-leaves-done))
606      count-leaves
607      (test (op null?) (reg tree))
608      (branch (label null-tree))
609      (test (op pair?) (reg tree))
610      (branch (label pair-tree))
611      (assign val (const 1))
612      (goto (reg continue))
613      pair-tree
614      (save continue)
615      (save tree)
616      (assign tree (op car) (reg tree))
617      (assign continue (label left-tree-done))
618      (goto (label count-leaves))
619      left-tree-done
620      (restore tree)
621      (assign tree (op cdr) (reg tree))
622      (assign continue (label right-tree-done))
623      (save val)
624      (goto (label count-leaves))
625      right-tree-done
626      (assign tree (reg val))
627      (restore val)
628      (assign val (op +) (reg tree) (reg val))
629      (restore continue)
630      (goto (reg continue))
631      null-tree
632      (assign val (const 0))
633      (goto (reg continue))
634      count-leaves-done)))
635      
636 (set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
637 (start count-leaves-rec)
638 (test-case (get-register-contents count-leaves-rec 'val)
639 	   11)
640 
641 (define count-leaves-iter
642   (make-machine
643    '(tree n val continue)
644    `((null? ,null?)
645      (pair? ,pair?)
646      (car ,car)
647      (cdr ,cdr)
648      (+ ,+))
649    '((assign n (const 0))
650      (assign continue (label count-iter-done))
651      count-iter
652      (test (op null?) (reg tree))
653      (branch (label null-tree))
654      (test (op pair?) (reg tree))
655      (branch (label pair-tree))
656      (assign val (op +) (reg n) (const 1))
657      (goto (reg continue))
658      null-tree
659      (assign val (reg n))
660      (goto (reg continue))
661      pair-tree
662      (save continue)
663      (save tree)
664      (assign continue (label left-tree-done))
665      (assign tree (op car) (reg tree))
666      (goto (label count-iter))
667      left-tree-done
668      (assign n (reg val))
669      (restore tree)
670      (assign tree (op cdr) (reg tree))
671      (restore continue)
672      (goto (label count-iter))
673      count-iter-done)))
674 
675 (set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
676 (start count-leaves-iter)
677 (test-case (get-register-contents count-leaves-iter 'val)
678 	   12)
679 (set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
680 (start count-leaves-iter)
681 (test-case (get-register-contents count-leaves-iter 'val)
682 	   7)
683 
684 (define (append x y)
685   (if (null? x)
686       y
687       (cons (car x) (append (cdr x) y))))
688 
689 (define append-machine
690   (make-machine
691    '(x y carx val continue)
692    `((cons ,cons)
693      (car ,car)
694      (cdr ,cdr)
695      (null? ,null?))
696    '((assign continue (label append-done))
697      append
698      (test (op null?) (reg x))
699      (branch (label null-x))
700      (assign carx (op car) (reg x))
701      (save carx)
702      (assign x (op cdr) (reg x))
703      (save continue)
704      (assign continue (label after-null-x))
705      (goto (label append))
706      null-x
707      (assign val (reg y))
708      (goto (reg continue))
709      after-null-x
710      (restore continue)
711      (restore carx)
712      (assign val (op cons) (reg carx) (reg val))
713      (goto (reg continue))
714      append-done)))
715 (set-register-contents! append-machine 'x '(a (b c) ((d) e)))
716 (set-register-contents! append-machine 'y '(((f g) (h)) i))
717 (start append-machine)
718 (test-case (get-register-contents append-machine 'val)
719 	   '(a (b c) ((d) e) ((f g) (h)) i))
720 
721 (define append!-machine
722   (make-machine
723    '(x y cdrx)
724    `((set-cdr! ,set-cdr!)
725      (cdr ,cdr)
726      (null? ,null?))
727    '((save x)
728      (assign cdrx (op cdr) (reg x))
729      last-pair
730      (test (op null?) (reg cdrx))
731      (branch (label set-cdr!))
732      (assign x (reg cdrx))
733      (assign cdrx (op cdr) (reg x))
734      (goto (label last-pair))
735      set-cdr!
736      (perform (op set-cdr!) (reg x) (reg y))
737      (restore x)
738      append!-done)))
739 (define (append! x y)
740   (set-cdr! (last-pair x) y)
741   x)
742 
743 (define (last-pair x)
744   (if (null? (cdr x))
745       x
746       (last-pair (cdr x))))
747 
748 (set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
749 (set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
750 (start append!-machine)
751 (test-case (get-register-contents append!-machine 'x)
752 	   '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
753 
754 ;; 5 more times
755 
756 eval-dispatch
757 (test (op self-evaluating?) (reg exp))
758 (branch (label ev-self-eval))
759 (test (op quoted?) (reg exp))
760 (branch (label ev-quoted))
761 (test (op variable?) (reg exp))
762 (branch (label ev-variable))
763 (test (op assignment?) (reg exp))
764 (branch (label ev-assignment))
765 (test (op definition?) (reg exp))
766 (branch (label ev-definition))
767 (test (op if?) (reg exp))
768 (branch (label ev-if))
769 (test (op begin?) (reg exp))
770 (branch (label ev-begin))
771 (test (op lambda?) (reg exp))
772 (branch (label ev-lambda))
773 (test (op application?) (reg exp))
774 (branch (label ev-application))
775 (goto (label unknown-expression-type))
776 
777 ev-self-eval
778 (assign val (reg exp))
779 (goto (reg continue))
780 ev-quoted
781 (assign val (op text-of-quotation) (reg exp))
782 (goto (reg continue))
783 ev-variable
784 (assign val (op lookup-variable-value) (reg exp) (reg env))
785 (goto (reg continue))
786 ev-assignment
787 (assign unev (op assignment-variable) (reg exp))
788 (save unev)
789 (save env)
790 (save continue)
791 (assign continue (label ev-assignment1))
792 (assign exp (op assignment-value) (reg exp))
793 (goto (label eval-dispatch))
794 ev-assignment1
795 (restore continue)
796 (restore env)
797 (restore unev)
798 (perform (op set-variable-value!) (reg unev) (reg val) (reg env))
799 (assign val (const ok))
800 (goto (reg continue))
801 
802 ev-definition
803 (assign unev (op definition-variable) (reg exp))
804 (save unev)
805 (save env)
806 (assign exp (op definition-value) (reg exp))
807 (save continue)
808 (assign continue (label ev-definition1))
809 (goto (label eval-dispatch))
810 ev-definition1
811 (restore continue)
812 (restore env)
813 (restore unev)
814 (perform (op define-variable!) (reg unev) (reg val) (reg env))
815 (assign val (const ok))
816 (goto (reg continue))
817 
818 ev-if
819 (save env)
820 (save exp)
821 (save continue)
822 (assign exp (op if-predicate) (reg exp))
823 (assign continue (label if-decide))
824 (goto (label eval-dispatch))
825 if-decide
826 (restore continue)
827 (restore exp)
828 (restore env)
829 (test (op true?) (reg val))
830 (branch (label if-consequent))
831 if-alternative
832 (assign exp (op if-alternative) (reg exp))
833 (goto (label eval-dispatch))
834 if-consequent
835 (assign exp (op if-consequent) (reg exp))
836 (goto (label eval-dispatch))
837 
838 ev-lambda
839 (assign unev (op lambda-parameters) (reg exp))
840 (assign exp (op lambda-body) (reg exp))
841 (assign val (op make-procedure) (reg unev) (reg exp) (reg env))
842 (goto (reg continue))
843 
844 ev-begin
845 (save continue)
846 (assign unev (op begin-actions) (reg exp))
847 (goto (eval-sequence))
848 
849 ev-application
850 (save continue)
851 (assign unev (op operands) (reg exp))
852 (save unev)
853 (save env)
854 (assign exp (op operator) (reg exp))
855 (assign continue (label ev-appl-did-operator))
856 (goto (label eval-dispatch))
857 ev-appl-did-operator
858 (restore env)
859 (restore unev)
860 (assign proc (reg val))
861 (assign argl (op empty-arglist))
862 (test (op no-operands?) (reg unev))
863 (branch (label apply-dispatch))
864 (save proc)
865 eval-operands
866 (save argl)
867 (assign exp (op first-operand) (reg unev))
868 (test (op last-operand?) (reg unev))
869 (branch (label ev-appl-last-operand))
870 (save unev)
871 (save env)
872 (assign continue (label ev-appl-accum-arg))
873 ev-appl-last-operand
874 (assign continue (label ev-appl-accum-last-arg))
875 (goto (label eval-dispatch))
876 ev-appl-accum-last-arg
877 (restore argl)
878 (restore proc)
879 (assign argl (op adjoin-arg) (reg val) (reg argl))
880 (goto (label apply-dispatch))
881 ev-appl-accum-arg
882 (restore env)
883 (restore unev)
884 (restore argl)
885 (assign argl (op adjoin-arg) (reg val) (reg argl))
886 (assign unev (op rest-operands) (reg unev))
887 (goto (label eval-operands))
888 
889 apply-dispatch
890 (test (op primitive-procedure?) (reg proc))
891 (branch (label apply-primitive-procedure))
892 (test (op compound-procedure?) (reg proc))
893 (branch (label compound-apply))
894 (goto (label unknown-procedure-type))
895 
896 
897 apply-primitive-procedure
898 (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
899 (restore continue)
900 (goto (reg continue))
901 
902 compound-apply
903 (assign env (op procedure-environment) (reg proc))
904 (assign unev (op procedure-parameters) (reg proc))
905 (assign env (op extend-environment) (reg unev) (reg argl) (reg env))
906 (assign unev (op procedure-body) (reg proc))
907 (goto (label eval-sequence))
908 
909 eval-sequence
910 (assign exp (op first-exp) (reg unev))
911 (test (op last-exp?) (reg unev))
912 (branch (label ev-last-exp))
913 (save unev)
914 (save env)
915 (assign continue (after-eval-operand))
916 (goto (label eval-dispatch))
917 after-eval-operand
918 (restore env)
919 (restore unev)
920 (assign unev (op rest-operands) (reg unev))
921 (goto (label eval-sequence))
922 
923 ev-last-exp
924 (restore continue)
925 (goto (label eval-dispatch))
926 
927 ev-sequence
928 (test (op no-exps?) (reg unev))
929 (branch (label no-exps))
930 (assign exp (op first-operand) (reg unev))
931 (save env)
932 (save unev)
933 (assign continue (ev-sequence-continue))
934 (goto (label eval-dispatch))
935 ev-sequence-continue
936 (restore unev)
937 (restore env)
938 (assign unev (op rest-operands) (reg unev))
939 (goto (label ev-sequence))
940 
941 no-exps
942 (restore continue)
943 (goto (reg continue))
944 
945 
946 read-eval-print-loop
947 (perform (op initialize-stack))
948 (perform (op prompt-for-input) (const ";;; EC-Eval Input: "))
949 (assign exp (op read))
950 (assign env (op get-global-environment))
951 (assign continue (label print-result))
952 (goto (label eval-dispatch))
953 print-result
954 (perform (op print-stack-statistics))
955 (perform (op announce-output) (const ";;; EC-Eval Output: "))
956 (perform (op user-print) (reg val))
957 (goto (label read-eval-print-loop))
958 
959 unknown-expression-type
960 (assign val (const unknown-expression-type))
961 (goto (label signal-error))
962 unknown-procedure-type
963 (restore continue)
964 (assign val (const unknown-procedure-type))
965 (goto (label signal-error))
966 signal-error
967 (perform (op user-print) (reg val))
968 (goto (label read-eval-print-loop))
969 
970 (define eceval
971   (make-machine 
972    '(exp env proc val continue unev argl)
973    eceval-operations
974    '(
975      read-eval-print-loop
976      )))
977 
978 (define eceval-operations
979   `((self-evaluating? ,self-evaluating?)))
980 (define the-global-environment (setup-environment))
981 (start eceval)
982