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 (define (no-more-exps? seq) (null? seq))
889 
890 ;; applications
891 
892 (define (application? exp) (pair? exp))
893 (define (operator exp) (car exp))
894 (define (operands exp) (cdr exp))
895 (define (no-operands? ops) (null? ops))
896 (define (first-operand ops) (car ops))
897 (define (rest-operands ops) (cdr ops))
898 (define (empty-arglist) '())
899 (define (adjoin-arg arg arglist)
900   (append arglist (list arg)))
901 (define (last-operand? ops)
902   (null? (cdr ops)))
903 
904 ;; true/false
905 
906 (define (true? x)
907   (not (eq? x false)))
908 (define (false? x)
909   (eq? x false))
910 
911 ;; compound procedures
912 
913 (define (compound-procedure? p)
914   (tagged-list? p 'procedure))
915 (define (procedure-parameters p) (cadr p))
916 (define (procedure-body p) (caddr p))
917 (define (procedure-environment p) (cadddr p))
918 
919 ;; environment procedures/data structures
920 
921 (define (enclosing-environment env) (cdr env))
922 (define (first-frame env) (car env))
923 (define the-empty-environment '())
924 (define (make-frame variables values)
925   (cons variables values))
926 (define (frame-variables frame) (car frame))
927 (define (frame-values frame) (cdr frame))
928 (define (add-binding-to-frame! var val frame)
929   (set-car! frame (cons var (car frame)))
930   (set-cdr! frame (cons val (cdr frame))))
931 (define (extend-environment vars vals base-env)
932   (if (= (length vars) (length vals))
933       (cons (make-frame vars vals) base-env)
934       (if (< (length vars) (length vals))
935           (error "Too many arguments supplied" vars vals)
936           (error "Too few arguments supplied" vars vals))))
937 (define (lookup-variable-value var env)
938   (define (env-loop env)
939     (define (scan vars vals)
940       (cond ((null? vars)
941              (env-loop (enclosing-environment env)))
942             ((eq? var (car vars))
943 	     (let ((val (car vals)))
944 	       (if (eq? val '*unassigned*)
945 		   (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
946 		   val)))
947             (else (scan (cdr vars) (cdr vals)))))
948     (if (eq? env the-empty-environment)
949         (error "Unbound variable" var)
950         (let ((frame (first-frame env)))
951           (scan (frame-variables frame)
952                 (frame-values frame)))))
953   (env-loop env))
954 (define (set-variable-value! var val env)
955   (define (env-loop env)
956     (define (scan vars vals)
957       (cond ((null? vars)
958              (env-loop (enclosing-environment env)))
959             ((eq? var (car vars))
960              (set-car! vals val))
961             (else (scan (cdr vars) (cdr vals)))))
962     (if (eq? env the-empty-environment)
963         (error "Unbound variable -- SET!" var)
964         (let ((frame (first-frame env)))
965           (scan (frame-variables frame)
966                 (frame-values frame)))))
967   (env-loop env))
968 (define (define-variable! var val env)
969   (let ((frame (first-frame env)))
970     (define (scan vars vals)
971       (cond ((null? vars)
972              (add-binding-to-frame! var val frame))
973             ((eq? var (car vars))
974              (set-car! vals val))
975             (else (scan (cdr vars) (cdr vals)))))
976     (scan (frame-variables frame)
977           (frame-values frame))))
978 (define (primitive-procedure? proc)
979   (tagged-list? proc 'primitive))
980 (define (primitive-implementation proc) (cadr proc))
981 (define primitive-procedures
982   (list (list 'car car)
983         (list 'cdr cdr)
984 	(list 'caar caar)
985 	(list 'cadr cadr)
986 	(list 'cddr cddr)
987         (list 'cons cons)
988         (list 'null? null?)
989 	(list '* *)
990 	(list '/ /)
991 	(list '+ +)
992 	(list '- -)
993 	(list '= =)
994 	(list '< <)
995 	(list '> >)
996 	(list '<= <=)
997 	(list '>= >=)
998 	(list 'remainder remainder)
999 	(list 'eq? eq?)
1000 	(list 'equal? equal?)
1001 	(list 'display display)))
1002 (define (primitive-procedure-names)
1003   (map car
1004        primitive-procedures))
1005 (define (primitive-procedure-objects)
1006   (map (lambda (proc) (list 'primitive (cadr proc)))
1007        primitive-procedures))
1008 (define (apply-primitive-procedure proc args)
1009   (apply (primitive-implementation proc) args))
1010 (define (setup-environment)
1011   (let ((initial-env
1012          (extend-environment (primitive-procedure-names)
1013                              (primitive-procedure-objects)
1014                              the-empty-environment)))
1015     (define-variable! 'true true initial-env)
1016     (define-variable! 'false false initial-env)
1017     initial-env))
1018 (define the-global-environment (setup-environment))
1019 (define (get-global-environment)
1020   the-global-environment)
1021 
1022 ;; Explicit Control Evaluator Machine
1023 
1024 (define eceval-operations
1025   `((prompt-for-input ,prompt-for-input)
1026     (read ,read)
1027     (get-global-environment ,get-global-environment)
1028     (announce-output ,announce-output)
1029     (user-print ,user-print)
1030     (self-evaluating? ,self-evaluating?)
1031     (variable? ,variable?)
1032     (quoted? ,quoted?)
1033     (assignment? ,assignment?)
1034     (definition? ,definition?)
1035     (if? ,if?)
1036     (cond? ,cond?)
1037     (cond->if ,cond->if)
1038     (lambda? ,lambda?)
1039     (begin? ,begin?)
1040     (application? ,application?)
1041     (lookup-variable-value ,lookup-variable-value)
1042     (text-of-quotation ,text-of-quotation)
1043     (lambda-parameters ,lambda-parameters)
1044     (lambda-body ,lambda-body)
1045     (make-procedure ,make-procedure)
1046     (let->combination ,let->combination)
1047     (let? ,let?)
1048     (operands ,operands)
1049     (operator ,operator)
1050     (empty-arglist ,empty-arglist)
1051     (no-operands? ,no-operands?)
1052     (first-operand ,first-operand)
1053     (rest-operands ,rest-operands)
1054     (last-operand? ,last-operand?)
1055     (adjoin-arg ,adjoin-arg)
1056     (procedure-parameters ,procedure-parameters)
1057     (procedure-environment ,procedure-environment)
1058     (extend-environment ,extend-environment)
1059     (procedure-body ,procedure-body)
1060     (begin-actions ,begin-actions)
1061     (first-exp ,first-exp)
1062     (last-exp? ,last-exp?)
1063     (rest-exps ,rest-exps)
1064     (no-more-exps? ,no-more-exps?)
1065     (true? ,true?)
1066     (if-predicate ,if-predicate)
1067     (if-alternative ,if-alternative)
1068     (if-consequent ,if-consequent)
1069     (assignment-variable ,assignment-variable)
1070     (assignment-value ,assignment-value)
1071     (set-variable-value! ,set-variable-value!)
1072     (definition-variable ,definition-variable)
1073     (definition-value ,definition-value)
1074     (define-variable! ,define-variable!)
1075     (primitive-procedure? ,primitive-procedure?)
1076     (apply-primitive-procedure ,apply-primitive-procedure)
1077     (compound-procedure? ,compound-procedure?)
1078     (user-print ,user-print)
1079     (null? ,null?)))
1080 
1081 (define eceval
1082   (make-machine
1083    '(exp env val proc argl continue unev code)
1084    eceval-operations
1085    '(
1086      eval-loop
1087      (test (op null?) (reg code))
1088      (branch (label eval-done))
1089      (perform (op initialize-stack))
1090      (assign env (op get-global-environment))
1091      (assign exp (op first-exp) (reg code))
1092      (assign code (op rest-exps) (reg code))
1093      (assign continue (label eval-continue))
1094      (goto (label eval-dispatch))
1095      
1096      eval-continue
1097      (assign unev (op stack-statistics))
1098      (goto (label eval-loop))
1099 
1100      read-eval-print-loop
1101      (perform (op initialize-stack))
1102      (perform
1103       (op prompt-for-input) (const ";;; EC-Eval input:"))
1104      (assign exp (op read))
1105      (assign env (op get-global-environment))
1106      (assign continue (label print-result))
1107      (goto (label eval-dispatch))
1108      print-result
1109      (perform (op print-stack-statistics)); added instruction
1110      (perform
1111       (op announce-output) (const ";;; EC-Eval value:"))
1112      (perform (op user-print) (reg val))
1113      (goto (label read-eval-print-loop))
1114 
1115      eval-dispatch
1116      (test (op self-evaluating?) (reg exp))
1117      (branch (label ev-self-eval))
1118      (test (op variable?) (reg exp))
1119      (branch (label ev-variable))
1120      (test (op quoted?) (reg exp))
1121      (branch (label ev-quoted))
1122      (test (op assignment?) (reg exp))
1123      (branch (label ev-assignment))
1124      (test (op definition?) (reg exp))
1125      (branch (label ev-definition))
1126      (test (op if?) (reg exp))
1127      (branch (label ev-if))
1128      (test (op cond?) (reg exp))
1129      (branch (label ev-cond))
1130      (test (op lambda?) (reg exp))
1131      (branch (label ev-lambda))
1132      (test (op let?) (reg exp))
1133      (branch (label ev-let))
1134      (test (op begin?) (reg exp))
1135      (branch (label ev-begin))
1136      (test (op application?) (reg exp))
1137      (branch (label ev-application))
1138      (goto (label unknown-expression-type))
1139      ev-self-eval
1140      (assign val (reg exp))
1141      (goto (reg continue))
1142      ev-variable
1143      (assign val (op lookup-variable-value) (reg exp) (reg env))
1144      (goto (reg continue))
1145      ev-quoted
1146      (assign val (op text-of-quotation) (reg exp))
1147      (goto (reg continue))
1148      ev-lambda
1149      (assign unev (op lambda-parameters) (reg exp))
1150      (assign exp (op lambda-body) (reg exp))
1151      (assign val (op make-procedure)
1152 	     (reg unev) (reg exp) (reg env))
1153      (goto (reg continue))
1154      ev-let
1155      (assign exp (op let->combination) (reg exp))
1156      (goto (label eval-dispatch))
1157      ev-application
1158      (save continue)
1159      (save env)
1160      (assign unev (op operands) (reg exp))
1161      (save unev)
1162      (assign exp (op operator) (reg exp))
1163      (assign continue (label ev-appl-did-operator))
1164      (goto (label eval-dispatch))
1165      ev-appl-did-operator
1166      (restore unev)                  ; the operands
1167      (restore env)
1168      (assign argl (op empty-arglist))
1169      (assign proc (reg val))         ; the operator
1170      (test (op no-operands?) (reg unev))
1171      (branch (label apply-dispatch))
1172      (save proc)
1173      ev-appl-operand-loop
1174      (save argl)
1175      (assign exp (op first-operand) (reg unev))
1176      (test (op last-operand?) (reg unev))
1177      (branch (label ev-appl-last-arg))
1178      (save env)
1179      (save unev)
1180      (assign continue (label ev-appl-accumulate-arg))
1181      (goto (label eval-dispatch))
1182      ev-appl-accumulate-arg
1183      (restore unev)
1184      (restore env)
1185      (restore argl)
1186      (assign argl (op adjoin-arg) (reg val) (reg argl))
1187      (assign unev (op rest-operands) (reg unev))
1188      (goto (label ev-appl-operand-loop))
1189      ev-appl-last-arg
1190      (assign continue (label ev-appl-accum-last-arg))
1191      (goto (label eval-dispatch))
1192      ev-appl-accum-last-arg
1193      (restore argl)
1194      (assign argl (op adjoin-arg) (reg val) (reg argl))
1195      (restore proc)
1196      (goto (label apply-dispatch))
1197      apply-dispatch
1198      (test (op primitive-procedure?) (reg proc))
1199      (branch (label primitive-apply))
1200      (test (op compound-procedure?) (reg proc))  
1201      (branch (label compound-apply))
1202      (goto (label unknown-procedure-type))
1203      primitive-apply
1204      (assign val (op apply-primitive-procedure)
1205 	     (reg proc)
1206 	     (reg argl))
1207      (restore continue)
1208      (goto (reg continue))
1209      compound-apply
1210      (assign unev (op procedure-parameters) (reg proc))
1211      (assign env (op procedure-environment) (reg proc))
1212      (assign env (op extend-environment)
1213 	     (reg unev) (reg argl) (reg env))
1214      (assign unev (op procedure-body) (reg proc))
1215      (goto (label ev-sequence))
1216      ev-begin
1217      (assign unev (op begin-actions) (reg exp))
1218      (save continue)
1219      (goto (label ev-sequence))
1220      ;; ev-sequence
1221      ;; (assign exp (op first-exp) (reg unev))
1222      ;; (test (op last-exp?) (reg unev))
1223      ;; (branch (label ev-sequence-last-exp))
1224      ;; (save unev)
1225      ;; (save env)
1226      ;; (assign continue (label ev-sequence-continue))
1227      ;; (goto (label eval-dispatch))
1228      ;; ev-sequence-continue
1229      ;; (restore env)
1230      ;; (restore unev)
1231      ;; (assign unev (op rest-exps) (reg unev))
1232      ;; (goto (label ev-sequence))
1233      ;; ev-sequence-last-exp
1234      ;; (restore continue)
1235      ;; (goto (label eval-dispatch))
1236 
1237      ev-sequence
1238      (test (op no-more-exps?) (reg unev))
1239      (branch (label ev-sequence-done))
1240      (save unev)
1241      (save env)
1242      (assign exp (op first-exp) (reg unev))
1243      (assign continue (label ev-sequence-continue))
1244      (goto (label eval-dispatch))
1245      ev-sequence-continue
1246      (restore env)
1247      (restore unev)
1248      (assign unev (op rest-exps) (reg unev))
1249      (goto (label ev-sequence))
1250      ev-sequence-done
1251      (restore continue)
1252      (goto (reg continue))
1253 
1254      ev-if
1255      (save exp)                    ; save expression for later
1256      (save env)
1257      (save continue)
1258      (assign continue (label ev-if-decide))
1259      (assign exp (op if-predicate) (reg exp))
1260      (goto (label eval-dispatch))  ; evaluate the predicate
1261      ev-if-decide
1262      (restore continue)
1263      (restore env)
1264      (restore exp)
1265      (test (op true?) (reg val))
1266      (branch (label ev-if-consequent))
1267 
1268      ev-if-alternative
1269      (assign exp (op if-alternative) (reg exp))
1270      (goto (label eval-dispatch))
1271      ev-if-consequent
1272      (assign exp (op if-consequent) (reg exp))
1273      (goto (label eval-dispatch))
1274 
1275      ev-cond
1276      (assign exp (op cond->if) (reg exp))
1277      (goto (label eval-dispatch))
1278 
1279      ev-assignment
1280      (assign unev (op assignment-variable) (reg exp))
1281      (save unev)                   ; save variable for later
1282      (assign exp (op assignment-value) (reg exp))
1283      (save env)
1284      (save continue)
1285      (assign continue (label ev-assignment-1))
1286      (goto (label eval-dispatch))  ; evaluate the assignment value
1287      ev-assignment-1
1288      (restore continue)
1289      (restore env)
1290      (restore unev)
1291      (perform
1292       (op set-variable-value!) (reg unev) (reg val) (reg env))
1293      (assign val (const ok))
1294      (goto (reg continue))
1295      ev-definition
1296      (assign unev (op definition-variable) (reg exp))
1297      (save unev)                   ; save variable for later
1298      (assign exp (op definition-value) (reg exp))
1299      (save env)
1300      (save continue)
1301      (assign continue (label ev-definition-1))
1302      (goto (label eval-dispatch))  ; evaluate the definition value
1303      ev-definition-1
1304      (restore continue)
1305      (restore env)
1306      (restore unev)
1307      (perform
1308       (op define-variable!) (reg unev) (reg val) (reg env))
1309      (assign val (const ok))
1310      (goto (reg continue))
1311 
1312      unknown-expression-type
1313      (assign val (const unknown-expression-type-error))
1314      (goto (label signal-error))
1315      unknown-procedure-type
1316      (restore continue)    ; clean up stack (from apply-dispatch)
1317      (assign val (const unknown-procedure-type-error))
1318      (goto (label signal-error))
1319      signal-error
1320      (perform (op user-print) (reg val))
1321      (goto (label read-eval-print-loop))
1322      
1323      eval-done)))
1324 
1325 ;; test suite
1326 
1327 ;; (set-register-contents! 
1328 ;;  eceval
1329 ;;  'code 
1330 ;;  '((define (factorial n)
1331 ;;      (if (= n 1) 
1332 ;; 	 1
1333 ;; 	 (* n (factorial (- n 1)))))
1334 ;;    (factorial 8)))
1335 ;; (start eceval)
1336 ;; (test-case (get-register-contents eceval 'val)
1337 ;; 	   40320)
1338 
1339 
1340 ;; (set-register-contents! 
1341 ;;  eceval
1342 ;;  'code 
1343 ;;  '((define (cons x y)
1344 ;;      (lambda (m) (m x y)))
1345 ;;    (define (car z)
1346 ;;      (z (lambda (p q) p)))
1347 ;;    (define (cdr z)
1348 ;;      (z (lambda (p q) q)))
1349 ;;    (define pair (cons 3 2))
1350 ;;    (+ (car pair) (cdr pair))))
1351 ;; (start eceval)
1352 ;; (test-case (get-register-contents eceval 'val)
1353 ;; 	   5)
1354 
1355 (define (test-interpret code expected)
1356   (set-register-contents! eceval 'code code)
1357   (start eceval)
1358   (test-case (get-register-contents eceval 'val) expected))
1359 
1360 (define (test-interpret-stack code expected)
1361   (set-register-contents! eceval 'code code)
1362   (start eceval)
1363   (test-case (get-register-contents eceval 'val) expected)
1364   (display (get-register-contents eceval 'unev))
1365   (newline))
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 ;; procedure definition / application
1386 
1387 (test-interpret-stack
1388  '((define (factorial n)
1389      (if (= n 1) 
1390 	 1
1391 	 (* n (factorial (- n 1)))))
1392    (factorial 8))
1393  40320)
1394 (test-interpret-stack
1395  '((define (cons x y)
1396      (lambda (m) (m x y)))
1397    (define (car z)
1398      (z (lambda (p q) p)))
1399    (define (cdr z)
1400      (z (lambda (p q) q)))
1401    (define pair (cons 3 2))
1402    (+ (car pair) (cdr pair)))
1403  5)
1404 
1405 ;; cond
1406 
1407 (test-interpret-stack
1408  '((define x -25)
1409    (cond ((= x -2) 'x=-2)
1410 	 ((= x -25) 'x=-25)
1411 	 (else 'failed)))
1412  'x=-25)
1413 (test-interpret-stack
1414  '((cond ((= 2 4) 3)
1415 	 ((= 2 (factorial 3)) true)
1416 	 (((lambda (result) result) true) 5)))
1417  5)
1418 (test-interpret-stack
1419  '((cond (((lambda (result) result) false) 5)
1420 	 ((car (cons false true)) 3)))
1421  false)
1422 (test-interpret-stack
1423  '((cond (((lambda (result) result) false) 5)
1424 	 ((car (cons false true)) 3)
1425 	 (else 4)))
1426  4)
1427 
1428 ;; let
1429 
1430 (test-interpret-stack
1431  '((let ((x 4) (y 7))
1432      (+ x y (* x y))))
1433  (+ 4 7 (* 4 7)))
1434 (test-interpret-stack
1435  '((let ((x 3)
1436 	 (y 5))
1437      (+ x y)))
1438  8)
1439 (test-interpret-stack
1440  '((let ((x 3)
1441 	 (y 2))
1442      (+ (let ((x (+ y 2))
1443 	      (y x))
1444 	  (* x y))
1445 	x y)))
1446  (+ (* 4 3) 3 2))
1447 (test-interpret-stack
1448  '((let ((x 6)
1449 	 (y (let ((x 2))
1450 	      (+ x 3)))
1451 	 (z (let ((a (* 3 2)))
1452 	      (+ a 3))))
1453      (+ x y z)))
1454  (+ 6 5 9))
1455 
1456 ;; Exercise 5.26.  Use the monitored stack to explore the tail-recursive property of the evaluator (section 5.4.2). Start the evaluator and define the iterative factorial procedure from section 1.2.1:
1457 
1458 (test-interpret-stack
1459  '((define (factorial n)
1460      (define (iter product counter)
1461        (if (> counter n)
1462 	   product
1463 	   (iter (* counter product)
1464 		 (+ counter 1))))
1465      (iter 1 1))
1466    (factorial 1))
1467  1)
1468 (test-interpret-stack
1469  '((factorial 2))
1470  2)
1471 (test-interpret-stack
1472  '((factorial 3))
1473  6)
1474 (test-interpret-stack
1475  '((factorial 4))
1476  24)
1477 (test-interpret-stack
1478  '((factorial 5))
1479  120)
1480 (test-interpret-stack
1481  '((factorial 6))
1482  720)
1483 (test-interpret-stack
1484  '((factorial 7))
1485  5040)
1486 (test-interpret-stack
1487  '((factorial 8))
1488  40320)
1489 (test-interpret-stack
1490  '((factorial 9))
1491  362880)
1492 
1493 ;; Run the procedure with some small values of n. Record the maximum stack depth and the number of pushes required to compute n! for each of these values.
1494 
1495 ;; a. You will find that the maximum depth required to evaluate n! is independent of n. What is that depth?
1496 
1497 ;; 10
1498 
1499 ;; b. Determine from your data a formula in terms of n for the total number of push operations used in evaluating n! for any n > 1. Note that the number of operations used is a linear function of n and is thus determined by two constants. 
1500 
1501 ;; 35n + 29
1502 
1503 ;; Exercise 5.27.  For comparison with exercise 5.26, explore the behavior of the following procedure for computing factorials recursively:
1504 
1505 (test-interpret-stack
1506  '((define (fact-rec n)
1507      (if (= n 1)
1508 	 1
1509 	 (* (fact-rec (- n 1)) n)))
1510    (fact-rec 1))
1511  1)
1512 (test-interpret-stack
1513  '((fact-rec 2))
1514  2)
1515 (test-interpret-stack
1516  '((fact-rec 3))
1517  6)
1518 (test-interpret-stack
1519  '((fact-rec 4))
1520  24)
1521 (test-interpret-stack
1522  '((fact-rec 5))
1523  120)
1524 (test-interpret-stack
1525  '((fact-rec 6))
1526  720)
1527 (test-interpret-stack
1528  '((fact-rec 7))
1529  5040)
1530 (test-interpret-stack
1531  '((fact-rec 8))
1532  40320)
1533 (test-interpret-stack
1534  '((fact-rec 9))
1535  362880)
1536 (test-interpret-stack
1537  '((fact-rec 10))
1538  3628800)
1539 
1540 ;; total-pushes = 32n - 16
1541 ;; max-depth = 5n + 3
1542 
1543 ;; Exercise 5.28.  Modify the definition of the evaluator by changing eval-sequence as described in section 5.4.2 so that the evaluator is no longer tail-recursive. Rerun your experiments from exercises 5.26 and 5.27 to demonstrate that both versions of the factorial procedure now require space that grows linearly with their input. 
1544 
1545 ;; max depth for fact-iter: 3n + 14
1546 ;; max depth for fact-rec: 8n + 3