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 ;; Exercise 5.22.  Exercise 3.12 of section 3.3.1 presented an append procedure that appends two lists to form a new list and an append! procedure that splices two lists together. Design a register machine to implement each of these procedures. Assume that the list-structure memory operations are available as primitive operations. 
685 
686 (define (append x y)
687   (if (null? x)
688       y
689       (cons (car x) (append (cdr x) y))))
690 
691 (define append-machine
692   (make-machine
693    '(x y carx val continue)
694    `((cons ,cons)
695      (car ,car)
696      (cdr ,cdr)
697      (null? ,null?))
698    '((assign continue (label append-done))
699      append
700      (test (op null?) (reg x))
701      (branch (label null-x))
702      (assign carx (op car) (reg x))
703      (save carx)
704      (assign x (op cdr) (reg x))
705      (save continue)
706      (assign continue (label after-null-x))
707      (goto (label append))
708      null-x
709      (assign val (reg y))
710      (goto (reg continue))
711      after-null-x
712      (restore continue)
713      (restore carx)
714      (assign val (op cons) (reg carx) (reg val))
715      (goto (reg continue))
716      append-done)))
717 (set-register-contents! append-machine 'x '(a (b c) ((d) e)))
718 (set-register-contents! append-machine 'y '(((f g) (h)) i))
719 (start append-machine)
720 (test-case (get-register-contents append-machine 'val)
721 	   '(a (b c) ((d) e) ((f g) (h)) i))
722 
723 (define append!-machine
724   (make-machine
725    '(x y cdrx)
726    `((set-cdr! ,set-cdr!)
727      (cdr ,cdr)
728      (null? ,null?))
729    '((save x)
730      (assign cdrx (op cdr) (reg x))
731      last-pair
732      (test (op null?) (reg cdrx))
733      (branch (label set-cdr!))
734      (assign x (reg cdrx))
735      (assign cdrx (op cdr) (reg x))
736      (goto (label last-pair))
737      set-cdr!
738      (perform (op set-cdr!) (reg x) (reg y))
739      (restore x)
740      append!-done)))
741 (define (append! x y)
742   (set-cdr! (last-pair x) y)
743   x)
744 
745 (define (last-pair x)
746   (if (null? (cdr x))
747       x
748       (last-pair (cdr x))))
749 
750 (set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
751 (set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
752 (start append!-machine)
753 (test-case (get-register-contents append!-machine 'x)
754 	   '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
755