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