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 (stack-statistics)
51       (list 'total-pushes '= number-pushes
52 	    'maximum-depth '= max-depth))
53     (define (dispatch message)
54       (cond ((eq? message 'push) push)
55             ((eq? message 'pop) (pop))
56             ((eq? message 'initialize) (initialize))
57             ((eq? message 'print-statistics)
58              (print-statistics))
59 	    ((eq? message 'stack-statistics)
60 	     (stack-statistics))
61             (else
62              (error "Unknown request -- STACK" message))))
63     dispatch))
64 (define (pop stack)
65   (stack 'pop))
66 (define (push stack value)
67   ((stack 'push) value))
68 (define (make-new-machine)
69   (let ((pc (make-register 'pc))
70         (flag (make-register 'flag))
71         (stack (make-stack))
72         (the-instruction-sequence '()))
73     (let ((the-ops
74 	   (list (list 'initialize-stack
75 		       (lambda () (stack 'initialize)))
76 		 (list 'print-stack-statistics
77 		       (lambda () (stack 'print-statistics)))
78 		 (list 'stack-statistics
79 		       (lambda () (stack 'stack-statistics)))))
80           (register-table
81            (list (list 'pc pc) (list 'flag flag))))
82       (define (allocate-register name)
83         (if (assoc name register-table)
84             (error "Multiply defined register: " name)
85             (set! register-table
86                   (cons (list name (make-register name))
87                         register-table)))
88         'register-allocated)
89       (define (lookup-register name)
90         (let ((val (assoc name register-table)))
91           (if val
92               (cadr val)
93               (error "Unknown register:" name))))
94       (define (execute)
95         (let ((insts (get-contents pc)))
96           (if (null? insts)
97               'done
98               (begin
99                 ((instruction-execution-proc (car insts)))
100                 (execute)))))
101       (define (dispatch message)
102         (cond ((eq? message 'start)
103                (set-contents! pc the-instruction-sequence)
104                (execute))
105               ((eq? message 'install-instruction-sequence)
106                (lambda (seq) (set! the-instruction-sequence seq)))
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 'stack) stack)
112               ((eq? message 'operations) the-ops)
113               (else (error "Unknown request -- MACHINE" message))))
114       dispatch)))
115 (define (start machine)
116   (machine 'start))
117 (define (get-register-contents machine register-name)
118   (get-contents (get-register machine register-name)))
119 (define (set-register-contents! machine register-name value)
120   (set-contents! (get-register machine register-name) value)
121   'done)
122 (define (get-register machine reg-name)
123   ((machine 'get-register) reg-name))
124 (define (assemble controller-text machine)
125   (extract-labels controller-text
126     (lambda (insts labels)
127       (update-insts! insts labels machine)
128       insts)))
129 (define (extract-labels text receive)
130   (if (null? text)
131       (receive '() '())
132       (extract-labels (cdr text)
133        (lambda (insts labels)
134          (let ((next-inst (car text)))
135            (if (symbol? next-inst)
136 	       (if (label-defined? labels next-inst)
137 		   (error "Duplicate label -- ASSEMBLE"
138 			  next-inst)
139 		   (receive 
140 		       insts
141 		       (cons (make-label-entry next-inst
142 					       insts)
143 			     labels)))
144                (receive
145 		   (cons (make-instruction next-inst)
146 			 insts)
147 		   labels)))))))
148 (define (update-insts! insts labels machine)
149   (let ((pc (get-register machine 'pc))
150         (flag (get-register machine 'flag))
151         (stack (machine 'stack))
152         (ops (machine 'operations)))
153     (for-each
154      (lambda (inst)
155        (set-instruction-execution-proc! 
156         inst
157         (make-execution-procedure
158          (instruction-text inst) labels machine
159          pc flag stack ops)))
160      insts)))
161 (define (make-instruction text)
162   (cons text '()))
163 (define (instruction-text inst)
164   (car inst))
165 (define (instruction-execution-proc inst)
166   (cdr inst))
167 (define (set-instruction-execution-proc! inst proc)
168   (set-cdr! inst proc))
169 (define (make-label-entry label-name insts)
170   (cons label-name insts))
171 (define (label-defined? labels label-name)
172   (not (false? (assoc label-name labels))))
173 (define (lookup-label labels label-name)
174   (let ((val (assoc label-name labels)))
175     (if val
176         (cdr val)
177         (error "Undefined label -- ASSEMBLE" label-name))))
178 (define (make-execution-procedure inst labels machine
179                                   pc flag stack ops)
180   (cond ((eq? (car inst) 'assign)
181          (make-assign inst machine labels ops pc))
182         ((eq? (car inst) 'test)
183          (make-test inst machine labels ops flag pc))
184         ((eq? (car inst) 'branch)
185          (make-branch inst machine labels flag pc))
186         ((eq? (car inst) 'goto)
187          (make-goto inst machine labels pc))
188         ((eq? (car inst) 'save)
189          (make-save inst machine stack pc))
190         ((eq? (car inst) 'restore)
191          (make-restore inst machine stack pc))
192         ((eq? (car inst) 'perform)
193          (make-perform inst machine labels ops pc))
194         (else (error "Unknown instruction type -- ASSEMBLE"
195                      inst))))
196 (define (make-assign inst machine labels operations pc)
197   (let ((target
198          (get-register machine (assign-reg-name inst)))
199         (value-exp (assign-value-exp inst)))
200     (let ((value-proc
201            (if (operation-exp? value-exp)
202                (make-operation-exp
203                 value-exp machine labels operations)
204                (make-primitive-exp
205                 (car value-exp) machine labels))))
206       (lambda ()                ; execution procedure for assign
207         (set-contents! target (value-proc))
208         (advance-pc pc)))))
209 (define (assign-reg-name assign-instruction)
210   (cadr assign-instruction))
211 (define (assign-value-exp assign-instruction)
212   (cddr assign-instruction))
213 (define (advance-pc pc)
214   (set-contents! pc (cdr (get-contents pc))))
215 (define (make-test inst machine labels operations flag pc)
216   (let ((condition (test-condition inst)))
217     (if (operation-exp? condition)
218         (let ((condition-proc
219                (make-operation-exp
220                 condition machine labels operations)))
221           (lambda ()
222             (set-contents! flag (condition-proc))
223             (advance-pc pc)))
224         (error "Bad TEST instruction -- ASSEMBLE" inst))))
225 (define (test-condition test-instruction)
226   (cdr test-instruction))
227 (define (make-branch inst machine labels flag pc)
228   (let ((dest (branch-dest inst)))
229     (if (label-exp? dest)
230         (let ((insts
231                (lookup-label labels (label-exp-label dest))))
232           (lambda ()
233             (if (get-contents flag)
234                 (set-contents! pc insts)
235                 (advance-pc pc))))
236         (error "Bad BRANCH instruction -- ASSEMBLE" inst))))
237 (define (branch-dest branch-instruction)
238   (cadr branch-instruction))
239 (define (make-goto inst machine labels pc)
240   (let ((dest (goto-dest inst)))
241     (cond ((label-exp? dest)
242            (let ((insts
243                   (lookup-label labels
244                                 (label-exp-label dest))))
245              (lambda () (set-contents! pc insts))))
246           ((register-exp? dest)
247            (let ((reg
248                   (get-register machine
249                                 (register-exp-reg dest))))
250              (lambda ()
251                (set-contents! pc (get-contents reg)))))
252           (else (error "Bad GOTO instruction -- ASSEMBLE"
253                        inst)))))
254 (define (goto-dest goto-instruction)
255   (cadr goto-instruction))
256 (define (make-stack-pair reg-name contents)
257   (cons reg-name contents))
258 (define (stack-pair-reg-name pair)
259   (car pair))
260 (define (stack-pair-val pair)
261   (cdr pair))
262 (define (make-save inst machine stack pc)
263   (let* ((reg-name (stack-inst-reg-name inst))
264 	 (reg (get-register machine reg-name)))
265     (lambda ()
266       (push stack (make-stack-pair reg-name (get-contents reg)))
267       (advance-pc pc))))
268 (define (make-restore inst machine stack pc)
269   (let* ((reg-name (stack-inst-reg-name inst))
270 	 (reg (get-register machine reg-name)))
271     (lambda ()
272       (let* ((stack-pair (pop stack))
273 	     (stack-reg-name (stack-pair-reg-name stack-pair))
274 	     (stack-val (stack-pair-val stack-pair)))
275 	(if (eq? stack-reg-name reg-name)
276 	    (begin (set-contents! reg stack-val)
277 		   (advance-pc pc))
278 	    (error "Stack/register mismatch -- Save/Restore: "
279 		   stack-reg-name reg-name)))))) 
280 (define (stack-inst-reg-name stack-instruction)
281   (cadr stack-instruction))
282 (define (make-perform inst machine labels operations pc)
283   (let ((action (perform-action inst)))
284     (if (operation-exp? action)
285         (let ((action-proc
286                (make-operation-exp
287                 action machine labels operations)))
288           (lambda ()
289             (action-proc)
290             (advance-pc pc)))
291         (error "Bad PERFORM instruction -- ASSEMBLE" inst))))
292 (define (perform-action inst) (cdr inst))
293 (define (make-primitive-exp exp machine labels)
294   (cond ((constant-exp? exp)
295          (let ((c (constant-exp-value exp)))
296            (lambda () c)))
297         ((label-exp? exp)
298          (let ((insts
299                 (lookup-label labels
300                               (label-exp-label exp))))
301            (lambda () insts)))
302         ((register-exp? exp)
303          (let ((r (get-register machine
304                                 (register-exp-reg exp))))
305            (lambda () (get-contents r))))
306         (else
307          (error "Unknown expression type -- ASSEMBLE" exp))))
308 (define (tagged-list? exp tag)
309   (and (pair? exp) (eq? (car exp) tag)))
310 (define (register-exp? exp) (tagged-list? exp 'reg))
311 (define (register-exp-reg exp) (cadr exp))
312 (define (constant-exp? exp) (tagged-list? exp 'const))
313 (define (constant-exp-value exp) (cadr exp))
314 (define (label-exp? exp) (tagged-list? exp 'label))
315 (define (label-exp-label exp) (cadr exp))
316 (define (make-operation-exp exp machine labels operations)
317   (let ((op (lookup-prim (operation-exp-op exp) operations)) 
318         (aprocs
319          (map (lambda (e)
320 		;; (if (label-exp? e)
321 		;;     (error "Operation exp cannot operate on labels -- ASSEMBLE"
322 		;; 	   exp)
323 		(make-primitive-exp e machine labels))
324               (operation-exp-operands exp))))
325     (lambda ()
326       (apply op (map (lambda (p) (p)) aprocs)))))
327 (define (operation-exp? exp)
328   (and (pair? exp) (tagged-list? (car exp) 'op)))
329 (define (operation-exp-op operation-exp)
330   (cadr (car operation-exp)))
331 (define (operation-exp-operands operation-exp)
332   (cdr operation-exp))
333 (define (lookup-prim symbol operations)
334   (let ((val (assoc symbol operations)))
335     (if val
336         (cadr val)
337         (error "Unknown operation -- ASSEMBLE" symbol))))
338 
339 ;; test suite
340 
341 (define (test-case actual expected)
342   (newline)
343   (display "Actual:   ")
344   (display actual)
345   (newline)
346   (display "Expected: ")
347   (display expected)
348   (newline))
349 
350 (define gcd-machine
351   (make-machine
352    '(a b t)
353    (list (list 'rem remainder) (list '= =))
354    '(test-b
355        (test (op =) (reg b) (const 0))
356        (branch (label gcd-done))
357        (assign t (op rem) (reg a) (reg b))
358        (assign a (reg b))
359        (assign b (reg t))
360        (goto (label test-b))
361      gcd-done)))
362 (set-register-contents! gcd-machine 'a 206)
363 (set-register-contents! gcd-machine 'b 40)
364 (start gcd-machine)
365 (test-case (get-register-contents gcd-machine 'a) 2)
366 
367 (define fib-machine
368   (make-machine 
369    '(n val continue)
370    `((< ,<) (- ,-) (+ ,+))
371    '(controller
372      (assign continue (label fib-done))
373      fib-loop
374      (test (op <) (reg n) (const 2))
375      (branch (label immediate-answer))
376      (save continue)
377      (assign continue (label afterfib-n-1))
378      (save n)
379      (assign n (op -) (reg n) (const 1))
380      (goto (label fib-loop))
381      afterfib-n-1           
382      (restore n)
383      (restore continue)
384      (assign n (op -) (reg n) (const 2))
385      (save continue)
386      (assign continue (label afterfib-n-2))
387      (save val)
388      (goto (label fib-loop))
389      afterfib-n-2
390      (assign n (reg val))
391      (restore val)       
392      (restore continue)
393      (assign val         
394 	     (op +) (reg val) (reg n)) 
395      (goto (reg continue))
396      immediate-answer
397      (assign val (reg n)) 
398      (goto (reg continue))
399      fib-done)))
400 (set-register-contents! fib-machine 'val 0)
401 (set-register-contents! fib-machine 'n 15)
402 (start fib-machine)
403 (test-case (get-register-contents fib-machine 'val) 610)
404 
405 (define fact-iter
406   (make-machine
407    '(product counter n)
408    `((> ,>) (* ,*) (+ ,+))
409    '((assign product (const 1))
410      (assign counter (const 1))
411      fact-loop
412      (test (op >) (reg counter) (reg n))
413      (branch (label fact-end))
414      (assign product (op *) (reg counter) (reg product))
415      (assign counter (op +) (reg counter) (const 1))
416      (goto (label fact-loop))
417      fact-end)))
418 (set-register-contents! fact-iter 'n 10)
419 (start fact-iter)
420 (test-case (get-register-contents fact-iter 'product) 3628800)
421 
422 (define (sqrt x)
423   (define (good-enough? guess)
424     (< (abs (- (square guess) x)) 0.001))
425   (define (improve guess)
426     (average guess (/ x guess)))
427   (define (sqrt-iter guess)
428     (if (good-enough? guess)
429         guess
430         (sqrt-iter (improve guess))))
431   (sqrt-iter 1.0))
432 
433 (define (good-enough? guess x)
434   (< (abs (- (square guess) x)) 0.001))
435 (define (improve guess x)
436   (average guess (/ x guess)))
437 (define (average x y)
438   (/ (+ x y) 2))
439 (define sqrt-iter-ops
440   (make-machine
441    '(guess x)
442    `((good-enough? ,good-enough?)
443      (improve ,improve)
444      (abs ,abs)
445      (square ,square) 
446      (average ,average)
447      (< ,<)
448      (- ,-)
449      (/ ,/))
450    '((assign guess (const 1.0))
451      sqrt-iter
452      (test (op good-enough?) (reg guess) (reg x))
453      (branch (label sqrt-done))
454      (assign guess (op improve) (reg guess) (reg x))
455      (goto (label sqrt-iter))
456      sqrt-done)))
457 
458 (set-register-contents! sqrt-iter-ops 'x 27)
459 (start sqrt-iter-ops)
460 (test-case (get-register-contents sqrt-iter-ops 'guess)
461 	   5.19615242)
462 
463 (define (good-enough? guess x)
464   (< (abs (- (square guess) x)) 0.001))
465 (define (improve guess x)
466   (average guess (/ x guess)))
467 (define (average x y)
468   (/ (+ x y) 2))
469 (define sqrt-iter
470   (make-machine
471    '(guess x temp)
472    `((abs ,abs)
473      (square ,square) 
474      (average ,average)
475      (< ,<)
476      (- ,-)
477      (/ ,/))
478    '((assign guess (const 1.0))
479      sqrt-iter
480      ;; (test (op good-enough?) (reg guess) (reg x))
481      (assign temp (op square) (reg guess))
482      (assign temp (op -) (reg temp) (reg x))
483      (assign temp (op abs) (reg temp))
484      (test (op <) (reg temp) (const 0.001))
485      (branch (label sqrt-done))
486      ;; (assign guess (op improve) (reg guess) (reg x))
487      (assign temp (op /) (reg x) (reg guess))
488      (assign guess (op average) (reg guess) (reg temp))
489      (goto (label sqrt-iter))
490      sqrt-done)))
491 (set-register-contents! sqrt-iter-ops 'x 91)
492 (start sqrt-iter-ops)
493 (test-case (get-register-contents sqrt-iter-ops 'guess)
494 	   9.53939201)
495 
496 (define (expt b n)
497   (if (= n 0)
498       1
499       (* b (expt b (- n 1)))))
500 
501 (define expt-rec
502   (make-machine
503    '(b n product continue)
504    `((= ,=)
505      (* ,*)
506      (- ,-))
507    '((assign continue (label expt-done))
508      expt-rec
509      (test (op =) (reg n) (const 0))
510      (branch (label base-case))
511      (assign n (op -) (reg n) (const 1))
512      (save continue)
513      (assign continue (label after-b-n-1))
514      (goto (label expt-rec))
515      after-b-n-1
516      (restore continue)
517      (assign product (op *) (reg b) (reg product))
518      (goto (reg continue))
519      base-case
520      (assign product (const 1))
521      (goto (reg continue))
522      expt-done)))
523 
524 (set-register-contents! expt-rec 'b 3.2)
525 (set-register-contents! expt-rec 'n 6)
526 (start expt-rec)
527 (test-case (get-register-contents expt-rec 'product)
528 	   1073.74182)
529 
530 (define (expt b n)
531   (define (expt-iter counter product)
532     (if (= counter 0)
533         product
534         (expt-iter (- counter 1) (* b product))))
535   (expt-iter n 1))
536 
537 (define expt-iter
538   (make-machine
539    '(b n counter product)
540    `((= ,=)
541      (* ,*)
542      (- ,-))
543    '((assign counter (reg n))
544      (assign product (const 1))
545      expt-iter
546      (test (op =) (reg counter) (const 0))
547      (branch (label expt-iter-done))
548      (assign counter (op -) (reg counter) (const 1))
549      (assign product (op *) (reg b) (reg product))
550      (goto (label expt-iter))
551      expt-iter-done)))
552 (set-register-contents! expt-iter 'b 1.6)
553 (set-register-contents! expt-iter 'n 17)
554 (start expt-iter)
555 (test-case (get-register-contents expt-iter 'product) 
556 	   2951.47905)
557 
558 ;; (define amb-machine
559 ;;   (make-machine
560 ;;    '(a)
561 ;;    '()
562 ;;    '(start
563 ;;      (goto (label here))
564 ;;      here
565 ;;      (assign a (const 3))
566 ;;      (goto (label there))
567 ;;      here
568 ;;      (assign a (const 4))
569 ;;      (goto (label there))
570 ;;      there)))
571 
572 ;; (start amb-machine)
573 ;; (test-case (get-register-contents amb-machine 'a)
574 ;; 	   3)
575 ;; this now raises an error
576 
577 (define fact-rec
578   (make-machine
579    '(n val continue)
580    `((= ,=) (- ,-) (* ,*))
581    '((assign continue (label fact-done))     ; set up final return address
582      fact-loop
583      (test (op =) (reg n) (const 1))
584      (branch (label base-case))
585      ;; Set up for the recursive call by saving n and continue.
586      ;; Set up continue so that the computation will continue
587      ;; at after-fact when the subroutine returns.
588      (save continue)
589      (save n)
590      (assign n (op -) (reg n) (const 1))
591      (assign continue (label after-fact))
592      (goto (label fact-loop))
593      after-fact
594      (restore n)
595      (restore continue)
596      (assign val (op *) (reg n) (reg val))   ; val now contains n(n - 1)!
597      (goto (reg continue))                   ; return to caller
598      base-case
599      (assign val (const 1))                  ; base case: 1! = 1
600      (goto (reg continue))                   ; return to caller
601      fact-done
602      (perform (op print-stack-statistics)))))
603 
604 (define count-leaves-rec
605   (make-machine
606    '(tree val continue)
607    `((pair? ,pair?)
608      (null? ,null?)
609      (car ,car)
610      (cdr ,cdr)
611      (+ ,+))
612    '((assign continue (label count-leaves-done))
613      count-leaves
614      (test (op null?) (reg tree))
615      (branch (label null-tree))
616      (test (op pair?) (reg tree))
617      (branch (label pair-tree))
618      (assign val (const 1))
619      (goto (reg continue))
620      pair-tree
621      (save continue)
622      (save tree)
623      (assign tree (op car) (reg tree))
624      (assign continue (label left-tree-done))
625      (goto (label count-leaves))
626      left-tree-done
627      (restore tree)
628      (assign tree (op cdr) (reg tree))
629      (assign continue (label right-tree-done))
630      (save val)
631      (goto (label count-leaves))
632      right-tree-done
633      (assign tree (reg val))
634      (restore val)
635      (assign val (op +) (reg tree) (reg val))
636      (restore continue)
637      (goto (reg continue))
638      null-tree
639      (assign val (const 0))
640      (goto (reg continue))
641      count-leaves-done)))
642      
643 (set-register-contents! count-leaves-rec 'tree '(1 (2 3 (4 5) (6) ((7 (8 9)) 10) 11)))
644 (start count-leaves-rec)
645 (test-case (get-register-contents count-leaves-rec 'val)
646 	   11)
647 
648 (define count-leaves-iter
649   (make-machine
650    '(tree n val continue)
651    `((null? ,null?)
652      (pair? ,pair?)
653      (car ,car)
654      (cdr ,cdr)
655      (+ ,+))
656    '((assign n (const 0))
657      (assign continue (label count-iter-done))
658      count-iter
659      (test (op null?) (reg tree))
660      (branch (label null-tree))
661      (test (op pair?) (reg tree))
662      (branch (label pair-tree))
663      (assign val (op +) (reg n) (const 1))
664      (goto (reg continue))
665      null-tree
666      (assign val (reg n))
667      (goto (reg continue))
668      pair-tree
669      (save continue)
670      (save tree)
671      (assign continue (label left-tree-done))
672      (assign tree (op car) (reg tree))
673      (goto (label count-iter))
674      left-tree-done
675      (assign n (reg val))
676      (restore tree)
677      (assign tree (op cdr) (reg tree))
678      (restore continue)
679      (goto (label count-iter))
680      count-iter-done)))
681 
682 (set-register-contents! count-leaves-iter 'tree '((1 (2 3)) 4 (5 (((6)) 7) 8) (((9) 10) 11) 12))
683 (start count-leaves-iter)
684 (test-case (get-register-contents count-leaves-iter 'val)
685 	   12)
686 (set-register-contents! count-leaves-iter 'tree '(1 ((2 3)) (4 (5 (6 7)))))
687 (start count-leaves-iter)
688 (test-case (get-register-contents count-leaves-iter 'val)
689 	   7)
690 
691 (define (append x y)
692   (if (null? x)
693       y
694       (cons (car x) (append (cdr x) y))))
695 
696 (define append-machine
697   (make-machine
698    '(x y carx val continue)
699    `((cons ,cons)
700      (car ,car)
701      (cdr ,cdr)
702      (null? ,null?))
703    '((assign continue (label append-done))
704      append
705      (test (op null?) (reg x))
706      (branch (label null-x))
707      (assign carx (op car) (reg x))
708      (save carx)
709      (assign x (op cdr) (reg x))
710      (save continue)
711      (assign continue (label after-null-x))
712      (goto (label append))
713      null-x
714      (assign val (reg y))
715      (goto (reg continue))
716      after-null-x
717      (restore continue)
718      (restore carx)
719      (assign val (op cons) (reg carx) (reg val))
720      (goto (reg continue))
721      append-done)))
722 (set-register-contents! append-machine 'x '(a (b c) ((d) e)))
723 (set-register-contents! append-machine 'y '(((f g) (h)) i))
724 (start append-machine)
725 (test-case (get-register-contents append-machine 'val)
726 	   '(a (b c) ((d) e) ((f g) (h)) i))
727 
728 (define append!-machine
729   (make-machine
730    '(x y cdrx)
731    `((set-cdr! ,set-cdr!)
732      (cdr ,cdr)
733      (null? ,null?))
734    '((save x)
735      (assign cdrx (op cdr) (reg x))
736      last-pair
737      (test (op null?) (reg cdrx))
738      (branch (label set-cdr!))
739      (assign x (reg cdrx))
740      (assign cdrx (op cdr) (reg x))
741      (goto (label last-pair))
742      set-cdr!
743      (perform (op set-cdr!) (reg x) (reg y))
744      (restore x)
745      append!-done)))
746 (define (append! x y)
747   (set-cdr! (last-pair x) y)
748   x)
749 
750 (define (last-pair x)
751   (if (null? (cdr x))
752       x
753       (last-pair (cdr x))))
754 
755 (set-register-contents! append!-machine 'x '((1 2 (3 ((4) 5)) 6) 7))
756 (set-register-contents! append!-machine 'y '((8 9) ((10 11) 12) 13))
757 (start append!-machine)
758 (test-case (get-register-contents append!-machine 'x)
759 	   '((1 2 (3 ((4) 5)) 6) 7 (8 9) ((10 11) 12) 13))
760 
761 ;; procedures from metacircular evaluator
762 
763 ;; REPL
764 
765 (define (prompt-for-input string)
766   (newline) (newline) (display string) (newline))
767 (define (announce-output string)
768   (newline) (display string) (newline))
769 (define (user-print object)
770   (if (compound-procedure? object)
771       (display (list 'compound-procedure
772                      (procedure-parameters object)
773                      (procedure-body object)
774                      '<procedure-env>))
775       (display object)))
776 
777 ;; self-evaluating/variables/quoted
778 
779 (define (self-evaluating? exp)
780   (cond ((number? exp) true)
781         ((string? exp) true)
782         (else false)))
783 (define (variable? exp) (symbol? exp))
784 (define (quoted? exp)
785   (tagged-list? exp 'quote))
786 (define (text-of-quotation exp) (cadr exp))
787 (define (assignment? exp)
788   (tagged-list? exp 'set!))
789 
790 ;; assignments/definitions
791 
792 (define (assignment-variable exp) (cadr exp))
793 (define (assignment-value exp) (caddr exp))
794 (define (definition? exp)
795   (tagged-list? exp 'define))
796 (define (definition-variable exp)
797   (if (symbol? (cadr exp))
798       (cadr exp)
799       (caadr exp)))
800 (define (definition-value exp)
801   (if (symbol? (cadr exp))
802       (caddr exp)
803       (make-lambda (cdadr exp)   ; formal parameters
804                    (cddr exp)))) ; body
805 
806 ;; if
807 
808 (define (if? exp) (tagged-list? exp 'if))
809 (define (if-predicate exp) (cadr exp))
810 (define (if-consequent exp) (caddr exp))
811 (define (if-alternative exp)
812   (if (not (null? (cdddr exp)))
813       (cadddr exp)
814       'false))
815 (define (make-if predicate consequent alternative)
816   (list 'if predicate consequent alternative))
817 
818 ;; cond
819 (define (cond? exp) (tagged-list? exp 'cond))
820 (define (cond-clauses exp) (cdr exp))
821 (define (cond-else-clause? clause)
822   (eq? (cond-predicate clause) 'else))
823 (define (cond-predicate clause) (car clause))
824 (define (cond-actions clause) (cdr clause))
825 (define (cond->if exp)
826   (expand-clauses (cond-clauses exp)))
827 (define (expand-clauses clauses)
828   (if (null? clauses)
829       'false                          ; no else clause
830       (let ((first (car clauses))
831             (rest (cdr clauses)))
832         (if (cond-else-clause? first)
833             (if (null? rest)
834                 (sequence->exp (cond-actions first))
835                 (error "ELSE clause isn't last -- COND->IF"
836                        clauses))
837 	    (make-if (cond-predicate first)
838 		     (sequence->exp (cond-actions first))
839 		     (expand-clauses rest))))))
840 
841 
842 ;; lambda 
843 
844 (define (lambda? exp) (tagged-list? exp 'lambda))
845 (define (lambda-parameters exp) (cadr exp))
846 (define (lambda-body exp) (cddr exp))
847 (define (make-procedure parameters body env)
848   (list 'procedure parameters body env))
849 (define (make-lambda parameters body)
850   (cons 'lambda (cons parameters body)))
851 
852 (define (make-lambda parameters body)
853   (cons 'lambda (cons parameters body)))
854 
855 ;; let
856 
857 (define (make-let vars vals body)
858   (cons 'let
859 	(cons (map list vars vals)
860 	      body)))
861 (define (let? exp)
862   (and (tagged-list? exp 'let)
863        (not (symbol? (cadr exp)))))
864 (define (let-vars exp)
865   (map car (cadr exp)))
866 (define (let-vals exp)
867   (map cadr (cadr exp)))
868 (define (let-body exp)
869   (cddr exp))
870 (define (let->combination exp)
871   (make-application (make-lambda (let-vars exp) (let-body exp))
872 		    (let-vals exp)))
873 (define (make-application op args)
874   (cons op args))
875 
876 ;; begin
877 
878 (define (begin? exp) (tagged-list? exp 'begin))
879 (define (begin-actions exp) (cdr exp))
880 (define (last-exp? seq) (null? (cdr seq)))
881 (define (first-exp seq) (car seq))
882 (define (rest-exps seq) (cdr seq))
883 (define (sequence->exp seq)
884   (cond ((null? seq) seq)
885         ((last-exp? seq) (first-exp seq))
886         (else (make-begin seq))))
887 (define (make-begin seq) (cons 'begin seq))
888 
889 ;; applications
890 
891 (define (application? exp) (pair? exp))
892 (define (operator exp) (car exp))
893 (define (operands exp) (cdr exp))
894 (define (no-operands? ops) (null? ops))
895 (define (first-operand ops) (car ops))
896 (define (rest-operands ops) (cdr ops))
897 (define (empty-arglist) '())
898 (define (adjoin-arg arg arglist)
899   (append arglist (list arg)))
900 (define (last-operand? ops)
901   (null? (cdr ops)))
902 
903 ;; true/false
904 
905 (define (true? x)
906   (not (eq? x false)))
907 (define (false? x)
908   (eq? x false))
909 
910 ;; compound procedures
911 
912 (define (compound-procedure? p)
913   (tagged-list? p 'procedure))
914 (define (procedure-parameters p) (cadr p))
915 (define (procedure-body p) (caddr p))
916 (define (procedure-environment p) (cadddr p))
917 
918 ;; environment procedures/data structures
919 
920 (define (enclosing-environment env) (cdr env))
921 (define (first-frame env) (car env))
922 (define the-empty-environment '())
923 (define (make-frame variables values)
924   (cons variables values))
925 (define (frame-variables frame) (car frame))
926 (define (frame-values frame) (cdr frame))
927 (define (add-binding-to-frame! var val frame)
928   (set-car! frame (cons var (car frame)))
929   (set-cdr! frame (cons val (cdr frame))))
930 (define (extend-environment vars vals base-env)
931   (if (= (length vars) (length vals))
932       (cons (make-frame vars vals) base-env)
933       (if (< (length vars) (length vals))
934           (error "Too many arguments supplied" vars vals)
935           (error "Too few arguments supplied" vars vals))))
936 (define (lookup-variable-value var env)
937   (define (env-loop env)
938     (define (scan vars vals)
939       (cond ((null? vars)
940              (env-loop (enclosing-environment env)))
941             ((eq? var (car vars))
942 	     (let ((val (car vals)))
943 	       (if (eq? val '*unassigned*)
944 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
945 		   val)))
946             (else (scan (cdr vars) (cdr vals)))))
947     (if (eq? env the-empty-environment)
948         (error "Unbound variable" var)
949         (let ((frame (first-frame env)))
950           (scan (frame-variables frame)
951                 (frame-values frame)))))
952   (env-loop env))
953 (define (set-variable-value! var val env)
954   (define (env-loop env)
955     (define (scan vars vals)
956       (cond ((null? vars)
957              (env-loop (enclosing-environment env)))
958             ((eq? var (car vars))
959              (set-car! vals val))
960             (else (scan (cdr vars) (cdr vals)))))
961     (if (eq? env the-empty-environment)
962         (error "Unbound variable -- SET!" var)
963         (let ((frame (first-frame env)))
964           (scan (frame-variables frame)
965                 (frame-values frame)))))
966   (env-loop env))
967 (define (define-variable! var val env)
968   (let ((frame (first-frame env)))
969     (define (scan vars vals)
970       (cond ((null? vars)
971              (add-binding-to-frame! var val frame))
972             ((eq? var (car vars))
973              (set-car! vals val))
974             (else (scan (cdr vars) (cdr vals)))))
975     (scan (frame-variables frame)
976           (frame-values frame))))
977 (define (primitive-procedure? proc)
978   (tagged-list? proc 'primitive))
979 (define (primitive-implementation proc) (cadr proc))
980 (define primitive-procedures
981   (list (list 'car car)
982         (list 'cdr cdr)
983 	(list 'caar caar)
984 	(list 'cadr cadr)
985 	(list 'cddr cddr)
986         (list 'cons cons)
987         (list 'null? null?)
988 	(list '* *)
989 	(list '/ /)
990 	(list '+ +)
991 	(list '- -)
992 	(list '= =)
993 	(list '< <)
994 	(list '> >)
995 	(list '<= <=)
996 	(list '>= >=)
997 	(list 'remainder remainder)
998 	(list 'eq? eq?)
999 	(list 'equal? equal?)
1000 	(list 'display display)))
1001 (define (primitive-procedure-names)
1002   (map car
1003        primitive-procedures))
1004 (define (primitive-procedure-objects)
1005   (map (lambda (proc) (list 'primitive (cadr proc)))
1006        primitive-procedures))
1007 (define (apply-primitive-procedure proc args)
1008   (apply (primitive-implementation proc) args))
1009 (define (setup-environment)
1010   (let ((initial-env
1011          (extend-environment (primitive-procedure-names)
1012                              (primitive-procedure-objects)
1013                              the-empty-environment)))
1014     (define-variable! 'true true initial-env)
1015     (define-variable! 'false false initial-env)
1016     initial-env))
1017 (define the-global-environment (setup-environment))
1018 (define (get-global-environment)
1019   the-global-environment)
1020 
1021 ;; Explicit Control Evaluator Machine
1022 
1023 (define eceval-operations
1024   `((prompt-for-input ,prompt-for-input)
1025     (read ,read)
1026     (get-global-environment ,get-global-environment)
1027     (announce-output ,announce-output)
1028     (user-print ,user-print)
1029     (self-evaluating? ,self-evaluating?)
1030     (variable? ,variable?)
1031     (quoted? ,quoted?)
1032     (assignment? ,assignment?)
1033     (definition? ,definition?)
1034     (if? ,if?)
1035     (cond? ,cond?)
1036     (cond->if ,cond->if)
1037     (lambda? ,lambda?)
1038     (begin? ,begin?)
1039     (application? ,application?)
1040     (lookup-variable-value ,lookup-variable-value)
1041     (text-of-quotation ,text-of-quotation)
1042     (lambda-parameters ,lambda-parameters)
1043     (lambda-body ,lambda-body)
1044     (make-procedure ,make-procedure)
1045     (let->combination ,let->combination)
1046     (let? ,let?)
1047     (operands ,operands)
1048     (operator ,operator)
1049     (empty-arglist ,empty-arglist)
1050     (no-operands? ,no-operands?)
1051     (first-operand ,first-operand)
1052     (rest-operands ,rest-operands)
1053     (last-operand? ,last-operand?)
1054     (adjoin-arg ,adjoin-arg)
1055     (procedure-parameters ,procedure-parameters)
1056     (procedure-environment ,procedure-environment)
1057     (extend-environment ,extend-environment)
1058     (procedure-body ,procedure-body)
1059     (begin-actions ,begin-actions)
1060     (first-exp ,first-exp)
1061     (last-exp? ,last-exp?)
1062     (rest-exps ,rest-exps)
1063     (true? ,true?)
1064     (if-predicate ,if-predicate)
1065     (if-alternative ,if-alternative)
1066     (if-consequent ,if-consequent)
1067     (assignment-variable ,assignment-variable)
1068     (assignment-value ,assignment-value)
1069     (set-variable-value! ,set-variable-value!)
1070     (definition-variable ,definition-variable)
1071     (definition-value ,definition-value)
1072     (define-variable! ,define-variable!)
1073     (primitive-procedure? ,primitive-procedure?)
1074     (apply-primitive-procedure ,apply-primitive-procedure)
1075     (compound-procedure? ,compound-procedure?)
1076     (user-print ,user-print)
1077     (null? ,null?)))
1078 
1079 (define eceval
1080   (make-machine
1081    '(exp env val proc argl continue unev code)
1082    eceval-operations
1083    '(
1084      eval-loop
1085      (test (op null?) (reg code))
1086      (branch (label eval-done))
1087      (perform (op initialize-stack))
1088      (assign env (op get-global-environment))
1089      (assign exp (op first-exp) (reg code))
1090      (assign code (op rest-exps) (reg code))
1091      (assign continue (label eval-continue))
1092      (goto (label eval-dispatch))
1093      
1094      eval-continue
1095      (assign unev (op stack-statistics))
1096      (goto (label eval-loop))
1097 
1098      read-eval-print-loop
1099      (perform (op initialize-stack))
1100      (perform
1101       (op prompt-for-input) (const ";;; EC-Eval input:"))
1102      (assign exp (op read))
1103      (assign env (op get-global-environment))
1104      (assign continue (label print-result))
1105      (goto (label eval-dispatch))
1106      print-result
1107      (perform (op print-stack-statistics)); added instruction
1108      (perform
1109       (op announce-output) (const ";;; EC-Eval value:"))
1110      (perform (op user-print) (reg val))
1111      (goto (label read-eval-print-loop))
1112 
1113      eval-dispatch
1114      (test (op self-evaluating?) (reg exp))
1115      (branch (label ev-self-eval))
1116      (test (op variable?) (reg exp))
1117      (branch (label ev-variable))
1118      (test (op quoted?) (reg exp))
1119      (branch (label ev-quoted))
1120      (test (op assignment?) (reg exp))
1121      (branch (label ev-assignment))
1122      (test (op definition?) (reg exp))
1123      (branch (label ev-definition))
1124      (test (op if?) (reg exp))
1125      (branch (label ev-if))
1126      (test (op cond?) (reg exp))
1127      (branch (label ev-cond))
1128      (test (op lambda?) (reg exp))
1129      (branch (label ev-lambda))
1130      (test (op let?) (reg exp))
1131      (branch (label ev-let))
1132      (test (op begin?) (reg exp))
1133      (branch (label ev-begin))
1134      (test (op application?) (reg exp))
1135      (branch (label ev-application))
1136      (goto (label unknown-expression-type))
1137      ev-self-eval
1138      (assign val (reg exp))
1139      (goto (reg continue))
1140      ev-variable
1141      (assign val (op lookup-variable-value) (reg exp) (reg env))
1142      (goto (reg continue))
1143      ev-quoted
1144      (assign val (op text-of-quotation) (reg exp))
1145      (goto (reg continue))
1146      ev-lambda
1147      (assign unev (op lambda-parameters) (reg exp))
1148      (assign exp (op lambda-body) (reg exp))
1149      (assign val (op make-procedure)
1150 	     (reg unev) (reg exp) (reg env))
1151      (goto (reg continue))
1152      ev-let
1153      (assign exp (op let->combination) (reg exp))
1154      (goto (label eval-dispatch))
1155      ev-application
1156      (save continue)
1157      (save env)
1158      (assign unev (op operands) (reg exp))
1159      (save unev)
1160      (assign exp (op operator) (reg exp))
1161      (assign continue (label ev-appl-did-operator))
1162      (goto (label eval-dispatch))
1163      ev-appl-did-operator
1164      (restore unev)                  ; the operands
1165      (restore env)
1166      (assign argl (op empty-arglist))
1167      (assign proc (reg val))         ; the operator
1168      (test (op no-operands?) (reg unev))
1169      (branch (label apply-dispatch))
1170      (save proc)
1171      ev-appl-operand-loop
1172      (save argl)
1173      (assign exp (op first-operand) (reg unev))
1174      (test (op last-operand?) (reg unev))
1175      (branch (label ev-appl-last-arg))
1176      (save env)
1177      (save unev)
1178      (assign continue (label ev-appl-accumulate-arg))
1179      (goto (label eval-dispatch))
1180      ev-appl-accumulate-arg
1181      (restore unev)
1182      (restore env)
1183      (restore argl)
1184      (assign argl (op adjoin-arg) (reg val) (reg argl))
1185      (assign unev (op rest-operands) (reg unev))
1186      (goto (label ev-appl-operand-loop))
1187      ev-appl-last-arg
1188      (assign continue (label ev-appl-accum-last-arg))
1189      (goto (label eval-dispatch))
1190      ev-appl-accum-last-arg
1191      (restore argl)
1192      (assign argl (op adjoin-arg) (reg val) (reg argl))
1193      (restore proc)
1194      (goto (label apply-dispatch))
1195      apply-dispatch
1196      (test (op primitive-procedure?) (reg proc))
1197      (branch (label primitive-apply))
1198      (test (op compound-procedure?) (reg proc))  
1199      (branch (label compound-apply))
1200      (goto (label unknown-procedure-type))
1201      primitive-apply
1202      (assign val (op apply-primitive-procedure)
1203 	     (reg proc)
1204 	     (reg argl))
1205      (restore continue)
1206      (goto (reg continue))
1207      compound-apply
1208      (assign unev (op procedure-parameters) (reg proc))
1209      (assign env (op procedure-environment) (reg proc))
1210      (assign env (op extend-environment)
1211 	     (reg unev) (reg argl) (reg env))
1212      (assign unev (op procedure-body) (reg proc))
1213      (goto (label ev-sequence))
1214      ev-begin
1215      (assign unev (op begin-actions) (reg exp))
1216      (save continue)
1217      (goto (label ev-sequence))
1218      ev-sequence
1219      (assign exp (op first-exp) (reg unev))
1220      (test (op last-exp?) (reg unev))
1221      (branch (label ev-sequence-last-exp))
1222      (save unev)
1223      (save env)
1224      (assign continue (label ev-sequence-continue))
1225      (goto (label eval-dispatch))
1226      ev-sequence-continue
1227      (restore env)
1228      (restore unev)
1229      (assign unev (op rest-exps) (reg unev))
1230      (goto (label ev-sequence))
1231      ev-sequence-last-exp
1232      (restore continue)
1233      (goto (label eval-dispatch))
1234      ev-if
1235      (save exp)                    ; save expression for later
1236      (save env)
1237      (save continue)
1238      (assign continue (label ev-if-decide))
1239      (assign exp (op if-predicate) (reg exp))
1240      (goto (label eval-dispatch))  ; evaluate the predicate
1241      ev-if-decide
1242      (restore continue)
1243      (restore env)
1244      (restore exp)
1245      (test (op true?) (reg val))
1246      (branch (label ev-if-consequent))
1247 
1248      ev-if-alternative
1249      (assign exp (op if-alternative) (reg exp))
1250      (goto (label eval-dispatch))
1251      ev-if-consequent
1252      (assign exp (op if-consequent) (reg exp))
1253      (goto (label eval-dispatch))
1254 
1255      ev-cond
1256      (assign exp (op cond->if) (reg exp))
1257      (goto (label eval-dispatch))
1258 
1259      ev-assignment
1260      (assign unev (op assignment-variable) (reg exp))
1261      (save unev)                   ; save variable for later
1262      (assign exp (op assignment-value) (reg exp))
1263      (save env)
1264      (save continue)
1265      (assign continue (label ev-assignment-1))
1266      (goto (label eval-dispatch))  ; evaluate the assignment value
1267      ev-assignment-1
1268      (restore continue)
1269      (restore env)
1270      (restore unev)
1271      (perform
1272       (op set-variable-value!) (reg unev) (reg val) (reg env))
1273      (assign val (const ok))
1274      (goto (reg continue))
1275      ev-definition
1276      (assign unev (op definition-variable) (reg exp))
1277      (save unev)                   ; save variable for later
1278      (assign exp (op definition-value) (reg exp))
1279      (save env)
1280      (save continue)
1281      (assign continue (label ev-definition-1))
1282      (goto (label eval-dispatch))  ; evaluate the definition value
1283      ev-definition-1
1284      (restore continue)
1285      (restore env)
1286      (restore unev)
1287      (perform
1288       (op define-variable!) (reg unev) (reg val) (reg env))
1289      (assign val (const ok))
1290      (goto (reg continue))
1291 
1292      unknown-expression-type
1293      (assign val (const unknown-expression-type-error))
1294      (goto (label signal-error))
1295      unknown-procedure-type
1296      (restore continue)    ; clean up stack (from apply-dispatch)
1297      (assign val (const unknown-procedure-type-error))
1298      (goto (label signal-error))
1299      signal-error
1300      (perform (op user-print) (reg val))
1301      (goto (label read-eval-print-loop))
1302      
1303      eval-done)))
1304 
1305 ;; test suite
1306 
1307 ;; (set-register-contents! 
1308 ;;  eceval
1309 ;;  'code 
1310 ;;  '((define (factorial n)
1311 ;;      (if (= n 1) 
1312 ;; 	 1
1313 ;; 	 (* n (factorial (- n 1)))))
1314 ;;    (factorial 8)))
1315 ;; (start eceval)
1316 ;; (test-case (get-register-contents eceval 'val)
1317 ;; 	   40320)
1318 
1319 
1320 ;; (set-register-contents! 
1321 ;;  eceval
1322 ;;  'code 
1323 ;;  '((define (cons x y)
1324 ;;      (lambda (m) (m x y)))
1325 ;;    (define (car z)
1326 ;;      (z (lambda (p q) p)))
1327 ;;    (define (cdr z)
1328 ;;      (z (lambda (p q) q)))
1329 ;;    (define pair (cons 3 2))
1330 ;;    (+ (car pair) (cdr pair))))
1331 ;; (start eceval)
1332 ;; (test-case (get-register-contents eceval 'val)
1333 ;; 	   5)
1334 
1335 (define (test-interpret code expected)
1336   (set-register-contents! eceval 'code code)
1337   (start eceval)
1338   (test-case (get-register-contents eceval 'val) expected))
1339 
1340 (define (test-interpret-stack code expected)
1341   (set-register-contents! eceval 'code code)
1342   (start eceval)
1343   (test-case (get-register-contents eceval 'val) expected)
1344   (display (get-register-contents eceval 'unev))
1345   (newline))
1346 
1347 (test-interpret-stack
1348  '((define (factorial n)
1349      (if (= n 1) 
1350 	 1
1351 	 (* n (factorial (- n 1)))))
1352    (factorial 8))
1353  40320)
1354 (test-interpret-stack
1355  '((define (cons x y)
1356      (lambda (m) (m x y)))
1357    (define (car z)
1358      (z (lambda (p q) p)))
1359    (define (cdr z)
1360      (z (lambda (p q) q)))
1361    (define pair (cons 3 2))
1362    (+ (car pair) (cdr pair)))
1363  5)
1364 
1365 ;; procedure definition / application
1366 
1367 (test-interpret-stack
1368  '((define (factorial n)
1369      (if (= n 1) 
1370 	 1
1371 	 (* n (factorial (- n 1)))))
1372    (factorial 8))
1373  40320)
1374 (test-interpret-stack
1375  '((define (cons x y)
1376      (lambda (m) (m x y)))
1377    (define (car z)
1378      (z (lambda (p q) p)))
1379    (define (cdr z)
1380      (z (lambda (p q) q)))
1381    (define pair (cons 3 2))
1382    (+ (car pair) (cdr pair)))
1383  5)
1384 
1385 ;; cond
1386 
1387 (test-interpret-stack
1388  '((define x -25)
1389    (cond ((= x -2) 'x=-2)
1390 	 ((= x -25) 'x=-25)
1391 	 (else 'failed)))
1392  'x=-25)
1393 (test-interpret-stack
1394  '((cond ((= 2 4) 3)
1395 	 ((= 2 (factorial 3)) true)
1396 	 (((lambda (result) result) true) 5)))
1397  5)
1398 (test-interpret-stack
1399  '((cond (((lambda (result) result) false) 5)
1400 	 ((car (cons false true)) 3)))
1401  false)
1402 (test-interpret-stack
1403  '((cond (((lambda (result) result) false) 5)
1404 	 ((car (cons false true)) 3)
1405 	 (else 4)))
1406  4)
1407 
1408 ;; let
1409 
1410 (test-interpret-stack
1411  '((let ((x 4) (y 7))
1412      (+ x y (* x y))))
1413  (+ 4 7 (* 4 7)))
1414 (test-interpret-stack
1415  '((let ((x 3)
1416 	 (y 5))
1417      (+ x y)))
1418  8)
1419 (test-interpret-stack
1420  '((let ((x 3)
1421 	 (y 2))
1422      (+ (let ((x (+ y 2))
1423 	      (y x))
1424 	  (* x y))
1425 	x y)))
1426  (+ (* 4 3) 3 2))
1427 (test-interpret-stack
1428  '((let ((x 6)
1429 	 (y (let ((x 2))
1430 	      (+ x 3)))
1431 	 (z (let ((a (* 3 2)))
1432 	      (+ a 3))))
1433      (+ x y z)))
1434  (+ 6 5 9))
1435 
1436 (test-interpret-stack
1437  '((define (factorial n)
1438      (define (iter product counter)
1439        (if (> counter n)
1440 	   product
1441 	   (iter (* counter product)
1442 		 (+ counter 1))))
1443      (iter 1 1)))
1444  'ok)
1445 (test-interpret-stack
1446  '((factorial 9))
1447  362880)
1448 
1449 (test-interpret-stack
1450  '((define (fact-rec n)
1451      (if (= n 1)
1452 	 1
1453 	 (* (fact-rec (- n 1)) n))))
1454  'ok)
1455 (test-interpret-stack
1456  '((fact-rec 10))
1457  3628800)
1458 
1459 (test-interpret-stack
1460  '((define (fib n)
1461      (if (< n 2)
1462 	 n
1463 	 (+ (fib (- n 1)) (fib (- n 2))))))
1464  'ok)
1465 (test-interpret-stack
1466  '((fib 13))
1467  233)
1468 
1469 ;; repeat 5 times
1470 
1471 (define (compile exp target linkage)
1472   (cond ((self-evaluating? exp) (compile-self-evaluating exp target linkage))
1473 	((quoted? exp) (compile-quoted exp target linkage))
1474 	((variable? exp) (compile-variable exp target linkage))
1475 	((lambda? exp) (compile-lambda exp target linkage))
1476 	((begin? exp) (compile-sequence (begin-actions exp) target linkage))
1477 	((if? exp) (compile-if exp target linkage))
1478 	((cond? exp) (compile (cond->if exp) target linkage))
1479 	((assignment? exp) (compile-assignment exp target linkage))
1480 	((definition? exp) (compile-definition exp target linkage))
1481 	((application? exp) (compile-application exp target linkage))
1482 	(else (error "Unknown expression type -- COMPILE" exp))))
1483 
1484 (define (make-instruction-sequence needs modifies statements)
1485   (list needs modifies statements))
1486 (define (empty-instruction-sequence)
1487   (make-instruction-sequence '() '() '()))
1488 
1489 (define (compile-linkage linkage)
1490   (cond ((eq? linkage 'next) (empty-instruction-sequence))
1491 	((eq? linkage 'return) 
1492 	 (make-instruction-sequence
1493 	  '(continue) '()
1494 	  '((goto (reg continue)))))
1495 	(else
1496 	 (make-instruction-sequence
1497 	  '() '()
1498 	  `((goto (label ,linkage)))))))
1499 (define (end-with-linkage linkage instruction-sequence)
1500   (preserving '(continue)
1501    instruction-sequence
1502    (compile-linkage linkage)))
1503 
1504 (define (compile-self-evaluating exp target linkage)
1505   (end-with-linkage 
1506    linkage
1507    (make-instruction-sequence
1508     '() (list target)
1509     `((assign ,target (const ,exp))))))
1510 (define (compile-quoted exp target linkage)
1511   (end-with-linkage linkage
1512    (make-instruction-sequence
1513     '() (list target)
1514     `((assign ,target (const ,(text-of-quotation exp)))))))
1515 (define (compile-variable exp target linkage)
1516   (end-with-linkage linkage
1517    (make-instruction-sequence
1518     '(env) (list target)
1519     `((assign ,target (op lookup-variable-value) (const ,exp) (reg env))))))
1520 (define (compile-assignment exp target linkage)
1521   (let ((var (assignment-variable exp))
1522 	(val-code (compile (assignment-value exp) 'val 'next)))
1523     (preserving '(continue env)
1524      val-code
1525      (end-with-linkage linkage
1526       (make-instruction-sequence
1527        '(val env) (list target)
1528        `((perform (op set-variable-value!) (const ,var) (reg val) (reg env))
1529 	 (assign ,target (const ok))))))))
1530 (define (compile-definition exp target linkage)
1531   (let ((var (definition-variable exp))
1532 	(get-value-code (compile (definition-value exp) 'val 'next)))
1533     (preserving '(continue env)
1534       get-value-code
1535       (end-with-linkage linkage
1536 	(make-instruction-sequence
1537 	 '(val env) (list target)
1538 	 `((perform (op define-variable!) (const ,var) (reg val) (reg env))
1539 	   (assign ,target (const ok))))))))
1540 (define (compile-if exp target linkage)
1541   (let* ((t-branch (make-label 't-branch))
1542 	 (f-branch (make-label 'f-branch))
1543 	 (after-if (make-label 'after-if))
1544 	 (consequent-linkage (if (eq? linkage 'next) after-if linkage))
1545 	 (p-code (compile (if-predicate exp) 'val 'next))
1546 	 (c-code (compile (if-consequent exp) target consequent-linkage))
1547 	 (a-code (compile (if-alternative exp) target linkage)))
1548     (preserving '(continue env)
1549      p-code
1550      (append-instruction-sequences
1551       (make-instruction-sequence
1552        '(val) '()
1553        `((test (op false?) (reg val))
1554 	 (branch (label ,f-branch))))
1555       (parallel-instruction-sequences
1556        (append-instruction-sequences t-branch c-code)
1557        (append-instruction-sequences f-branch a-code))
1558       after-if))
1559 (define (compile-sequence seq target linkage)
1560   (if (last-exp? seq)
1561       (compile (first-exp seq) target linkage)
1562       (preserving '(env continue)
1563        (compile (first-exp seq) target 'next)
1564        (compile-sequence (rest-exps seq) target linkage))))
1565 (define (compile-lambda exp target linkage)
1566   (let* ((after-lambda (make-label 'after-lambda))
1567 	 (proc-entry (make-label 'proc-entry))
1568 	 (lambda-linkage (if (eq? linkage 'next) after-lambda linkage)))
1569     (append-instruction-sequence
1570      (tack-on-instruction-sequence
1571       (end-with-linkage lambda-linkage
1572        (make-instruction-sequence
1573 	'(env) (list target)
1574 	`((assign ,target (op make-compiled-procedure) (label ,proc-entry) (reg env)))))
1575       (compile-lambda-body exp proc-entry))
1576      after-lambda)))
1577 (define (compile-lambda-body exp proc-entry)
1578   
1579 
1580 (compile-application exp target linkage)
1581 
1582 (define label-counter 0)
1583 (define (new-label-number)
1584   (set! label-counter (+ label-counter 1))
1585   label-counter)
1586 (define (make-label name)
1587   (string->symbol
1588    (string-append
1589     (symbol->string name)
1590     (number->string (new-label-number)))))
1591 
1592 (define (preserving regs seq1 seq2)
1593   ...)
1594 (define (append-instruction-sequences . seq)
1595   ...)
1596 tack-on-instruction-sequence
1597 parallel-instruction-sequence