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))
6 ((machine 'install-operations) ops)
7 ((machine 'install-instruction-sequence)
8 (assemble controller-text machine))
10 (define (make-register name)
11 (let ((contents '*unassigned*))
12 (define (dispatch message)
13 (cond ((eq? message 'get) contents)
15 (lambda (value) (set! contents value)))
17 (error "Unknown request -- REGISTER" message))))
19 (define (get-contents register)
21 (define (set-contents! register value)
22 ((register 'set) value))
30 (set! number-pushes (+ 1 number-pushes))
31 (set! current-depth (+ 1 current-depth))
32 (set! max-depth (max current-depth max-depth)))
35 (error "Empty stack -- POP")
38 (set! current-depth (- current-depth 1))
42 (set! number-pushes 0)
44 (set! current-depth 0)
46 (define (print-statistics)
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)
57 (error "Unknown request -- STACK" message))))
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))
67 (the-instruction-sequence '()))
69 (list (list 'initialize-stack
70 (lambda () (stack 'initialize)))
71 (list 'print-stack-statistics
72 (lambda () (stack 'print-statistics)))))
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)
79 (cons (list name (make-register name))
82 (define (lookup-register name)
83 (let ((val (assoc name register-table)))
86 (error "Unknown register:" name))))
88 (let ((insts (get-contents pc)))
92 ((instruction-execution-proc (car insts)))
94 (define (dispatch message)
95 (cond ((eq? message 'start)
96 (set-contents! pc the-instruction-sequence)
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))))
108 (define (start machine)
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)
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)
122 (define (extract-labels text 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"
134 (cons (make-label-entry next-inst
138 (cons (make-instruction next-inst)
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)))
148 (set-instruction-execution-proc!
150 (make-execution-procedure
151 (instruction-text inst) labels machine
154 (define (make-instruction text)
156 (define (instruction-text inst)
158 (define (instruction-execution-proc 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)))
170 (error "Undefined label -- ASSEMBLE" label-name))))
171 (define (make-execution-procedure inst labels machine
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"
189 (define (make-assign inst machine labels operations pc)
191 (get-register machine (assign-reg-name inst)))
192 (value-exp (assign-value-exp inst)))
194 (if (operation-exp? value-exp)
196 value-exp machine labels operations)
198 (car value-exp) machine labels))))
199 (lambda () ; execution procedure for assign
200 (set-contents! target (value-proc))
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
213 condition machine labels operations)))
215 (set-contents! flag (condition-proc))
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)
224 (lookup-label labels (label-exp-label dest))))
226 (if (get-contents flag)
227 (set-contents! pc insts)
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)
237 (label-exp-label dest))))
238 (lambda () (set-contents! pc insts))))
239 ((register-exp? dest)
241 (get-register machine
242 (register-exp-reg dest))))
244 (set-contents! pc (get-contents reg)))))
245 (else (error "Bad GOTO instruction -- ASSEMBLE"
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)
253 (define (stack-pair-val 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)))
259 (push stack (make-stack-pair reg-name (get-contents reg)))
261 (define (make-restore inst machine stack pc)
262 (let* ((reg-name (stack-inst-reg-name inst))
263 (reg (get-register machine reg-name)))
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)
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)
280 action machine labels operations)))
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)))
293 (label-exp-label exp))))
296 (let ((r (get-register machine
297 (register-exp-reg exp))))
298 (lambda () (get-contents r))))
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))
313 ;; (if (label-exp? e)
314 ;; (error "Operation exp cannot operate on labels -- ASSEMBLE"
316 (make-primitive-exp e machine labels))
317 (operation-exp-operands exp))))
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)
326 (define (lookup-prim symbol operations)
327 (let ((val (assoc symbol operations)))
330 (error "Unknown operation -- ASSEMBLE" symbol))))
334 (define (test-case actual expected)
339 (display "Expected: ")
346 (list (list 'rem remainder) (list '= =))
348 (test (op =) (reg b) (const 0))
349 (branch (label gcd-done))
350 (assign t (op rem) (reg a) (reg b))
353 (goto (label test-b))
355 (set-register-contents! gcd-machine 'a 206)
356 (set-register-contents! gcd-machine 'b 40)
358 (test-case (get-register-contents gcd-machine 'a) 2)
363 `((< ,<) (- ,-) (+ ,+))
365 (assign continue (label fib-done))
367 (test (op <) (reg n) (const 2))
368 (branch (label immediate-answer))
370 (assign continue (label afterfib-n-1))
372 (assign n (op -) (reg n) (const 1))
373 (goto (label fib-loop))
377 (assign n (op -) (reg n) (const 2))
379 (assign continue (label afterfib-n-2))
381 (goto (label fib-loop))
387 (op +) (reg val) (reg n))
388 (goto (reg continue))
391 (goto (reg continue))
393 (set-register-contents! fib-machine 'val 0)
394 (set-register-contents! fib-machine 'n 15)
396 (test-case (get-register-contents fib-machine 'val) 610)
401 `((> ,>) (* ,*) (+ ,+))
402 '((assign product (const 1))
403 (assign counter (const 1))
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))
411 (set-register-contents! fact-iter 'n 10)
413 (test-case (get-register-contents fact-iter 'product) 3628800)
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)
423 (sqrt-iter (improve guess))))
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)
432 (define sqrt-iter-ops
435 `((good-enough? ,good-enough?)
443 '((assign guess (const 1.0))
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))
451 (set-register-contents! sqrt-iter-ops 'x 27)
452 (start sqrt-iter-ops)
453 (test-case (get-register-contents sqrt-iter-ops 'guess)
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)
471 '((assign guess (const 1.0))
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))
484 (set-register-contents! sqrt-iter-ops 'x 91)
485 (start sqrt-iter-ops)
486 (test-case (get-register-contents sqrt-iter-ops 'guess)
492 (* b (expt b (- n 1)))))
496 '(b n product continue)
500 '((assign continue (label expt-done))
502 (test (op =) (reg n) (const 0))
503 (branch (label base-case))
504 (assign n (op -) (reg n) (const 1))
506 (assign continue (label after-b-n-1))
507 (goto (label expt-rec))
510 (assign product (op *) (reg b) (reg product))
511 (goto (reg continue))
513 (assign product (const 1))
514 (goto (reg continue))
517 (set-register-contents! expt-rec 'b 3.2)
518 (set-register-contents! expt-rec 'n 6)
520 (test-case (get-register-contents expt-rec 'product)
524 (define (expt-iter counter product)
527 (expt-iter (- counter 1) (* b product))))
532 '(b n counter product)
536 '((assign counter (reg n))
537 (assign product (const 1))
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))
545 (set-register-contents! expt-iter 'b 1.6)
546 (set-register-contents! expt-iter 'n 17)
548 (test-case (get-register-contents expt-iter 'product)
551 ;; (define amb-machine
556 ;; (goto (label here))
558 ;; (assign a (const 3))
559 ;; (goto (label there))
561 ;; (assign a (const 4))
562 ;; (goto (label there))
565 ;; (start amb-machine)
566 ;; (test-case (get-register-contents amb-machine 'a)
568 ;; this now raises an error
573 `((= ,=) (- ,-) (* ,*))
574 '((assign continue (label fact-done)) ; set up final return address
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.
583 (assign n (op -) (reg n) (const 1))
584 (assign continue (label after-fact))
585 (goto (label fact-loop))
589 (assign val (op *) (reg n) (reg val)) ; val now contains n(n - 1)!
590 (goto (reg continue)) ; return to caller
592 (assign val (const 1)) ; base case: 1! = 1
593 (goto (reg continue)) ; return to caller
595 (perform (op print-stack-statistics)))))
597 (define count-leaves-rec
605 '((assign continue (label count-leaves-done))
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))
616 (assign tree (op car) (reg tree))
617 (assign continue (label left-tree-done))
618 (goto (label count-leaves))
621 (assign tree (op cdr) (reg tree))
622 (assign continue (label right-tree-done))
624 (goto (label count-leaves))
626 (assign tree (reg val))
628 (assign val (op +) (reg tree) (reg val))
630 (goto (reg continue))
632 (assign val (const 0))
633 (goto (reg continue))
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)
641 (define count-leaves-iter
643 '(tree n val continue)
649 '((assign n (const 0))
650 (assign continue (label count-iter-done))
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))
660 (goto (reg continue))
664 (assign continue (label left-tree-done))
665 (assign tree (op car) (reg tree))
666 (goto (label count-iter))
670 (assign tree (op cdr) (reg tree))
672 (goto (label count-iter))
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)
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)
687 (cons (car x) (append (cdr x) y))))
689 (define append-machine
691 '(x y carx val continue)
696 '((assign continue (label append-done))
698 (test (op null?) (reg x))
699 (branch (label null-x))
700 (assign carx (op car) (reg x))
702 (assign x (op cdr) (reg x))
704 (assign continue (label after-null-x))
705 (goto (label append))
708 (goto (reg continue))
712 (assign val (op cons) (reg carx) (reg val))
713 (goto (reg continue))
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))
721 (define append!-machine
724 `((set-cdr! ,set-cdr!)
728 (assign cdrx (op cdr) (reg x))
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))
736 (perform (op set-cdr!) (reg x) (reg y))
739 (define (append! x y)
740 (set-cdr! (last-pair x) y)
743 (define (last-pair x)
746 (last-pair (cdr x))))
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))
754 ;; procedures from metacircular evaluator
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)
770 ;; self-evaluating/variables/quoted
772 (define (self-evaluating? exp)
773 (cond ((number? exp) true)
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!))
783 ;; assignments/definitions
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))
793 (define (definition-value exp)
794 (if (symbol? (cadr exp))
796 (make-lambda (cdadr exp) ; formal parameters
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)))
811 (define (lambda? exp) (tagged-list? exp 'lambda))
812 (define (lambda-parameters exp) (cadr exp))
813 (define (lambda-body exp) (cddr exp))
814 (define (make-procedure parameters body env)
815 (list 'procedure parameters body env))
816 (define (make-lambda parameters body)
817 (cons 'lambda (cons parameters body)))
821 (define (begin? exp) (tagged-list? exp 'begin))
822 (define (begin-actions exp) (cdr exp))
823 (define (last-exp? seq) (null? (cdr seq)))
824 (define (first-exp seq) (car seq))
825 (define (rest-exps seq) (cdr seq))
829 (define (application? exp) (pair? exp))
830 (define (operator exp) (car exp))
831 (define (operands exp) (cdr exp))
832 (define (no-operands? ops) (null? ops))
833 (define (first-operand ops) (car ops))
834 (define (rest-operands ops) (cdr ops))
835 (define (empty-arglist) '())
836 (define (adjoin-arg arg arglist)
837 (append arglist (list arg)))
838 (define (last-operand? ops)
848 ;; compound procedures
850 (define (compound-procedure? p)
851 (tagged-list? p 'procedure))
852 (define (procedure-parameters p) (cadr p))
853 (define (procedure-body p) (caddr p))
854 (define (procedure-environment p) (cadddr p))
856 ;; environment procedures/data structures
858 (define (enclosing-environment env) (cdr env))
859 (define (first-frame env) (car env))
860 (define the-empty-environment '())
861 (define (make-frame variables values)
862 (cons variables values))
863 (define (frame-variables frame) (car frame))
864 (define (frame-values frame) (cdr frame))
865 (define (add-binding-to-frame! var val frame)
866 (set-car! frame (cons var (car frame)))
867 (set-cdr! frame (cons val (cdr frame))))
868 (define (extend-environment vars vals base-env)
869 (if (= (length vars) (length vals))
870 (cons (make-frame vars vals) base-env)
871 (if (< (length vars) (length vals))
872 (error "Too many arguments supplied" vars vals)
873 (error "Too few arguments supplied" vars vals))))
874 (define (lookup-variable-value var env)
875 (define (env-loop env)
876 (define (scan vars vals)
878 (env-loop (enclosing-environment env)))
879 ((eq? var (car vars))
880 (let ((val (car vals)))
881 (if (eq? val '*unassigned*)
882 (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
884 (else (scan (cdr vars) (cdr vals)))))
885 (if (eq? env the-empty-environment)
886 (error "Unbound variable" var)
887 (let ((frame (first-frame env)))
888 (scan (frame-variables frame)
889 (frame-values frame)))))
891 (define (set-variable-value! var val env)
892 (define (env-loop env)
893 (define (scan vars vals)
895 (env-loop (enclosing-environment env)))
896 ((eq? var (car vars))
898 (else (scan (cdr vars) (cdr vals)))))
899 (if (eq? env the-empty-environment)
900 (error "Unbound variable -- SET!" var)
901 (let ((frame (first-frame env)))
902 (scan (frame-variables frame)
903 (frame-values frame)))))
905 (define (define-variable! var val env)
906 (let ((frame (first-frame env)))
907 (define (scan vars vals)
909 (add-binding-to-frame! var val frame))
910 ((eq? var (car vars))
912 (else (scan (cdr vars) (cdr vals)))))
913 (scan (frame-variables frame)
914 (frame-values frame))))
915 (define (primitive-procedure? proc)
916 (tagged-list? proc 'primitive))
917 (define (primitive-implementation proc) (cadr proc))
918 (define primitive-procedures
919 (list (list 'car car)
935 (list 'remainder remainder)
937 (list 'equal? equal?)
938 (list 'display display)))
939 (define (primitive-procedure-names)
941 primitive-procedures))
942 (define (primitive-procedure-objects)
943 (map (lambda (proc) (list 'primitive (cadr proc)))
944 primitive-procedures))
945 (define (apply-primitive-procedure proc args)
946 (apply (primitive-implementation proc) args))
947 (define (setup-environment)
949 (extend-environment (primitive-procedure-names)
950 (primitive-procedure-objects)
951 the-empty-environment)))
952 (define-variable! 'true true initial-env)
953 (define-variable! 'false false initial-env)
955 (define the-global-environment (setup-environment))
956 (define (get-global-environment)
957 the-global-environment)
959 ;; Explicit Control Evaluator Machine
961 (define eceval-operations
962 `((prompt-for-input ,prompt-for-input)
964 (get-global-environment ,get-global-environment)
965 (announce-output ,announce-output)
966 (user-print ,user-print)
967 (self-evaluating? ,self-evaluating?)
968 (variable? ,variable?)
970 (assignment? ,assignment?)
971 (definition? ,definition?)
975 (application? ,application?)
976 (lookup-variable-value ,lookup-variable-value)
977 (text-of-quotation ,text-of-quotation)
978 (lambda-parameters ,lambda-parameters)
979 (lambda-body ,lambda-body)
980 (make-procedure ,make-procedure)
983 (empty-arglist ,empty-arglist)
984 (no-operands? ,no-operands?)
985 (first-operand ,first-operand)
986 (rest-operands ,rest-operands)
987 (last-operand? ,last-operand?)
988 (adjoin-arg ,adjoin-arg)
989 (procedure-parameters ,procedure-parameters)
990 (procedure-environment ,procedure-environment)
991 (extend-environment ,extend-environment)
992 (procedure-body ,procedure-body)
993 (begin-actions ,begin-actions)
994 (first-exp ,first-exp)
995 (last-exp? ,last-exp?)
996 (rest-exps ,rest-exps)
998 (if-predicate ,if-predicate)
999 (if-alternative ,if-alternative)
1000 (if-consequent ,if-consequent)
1001 (assignment-variable ,assignment-variable)
1002 (assignment-value ,assignment-value)
1003 (set-variable-value! ,set-variable-value!)
1004 (definition-variable ,definition-variable)
1005 (definition-value ,definition-value)
1006 (define-variable! ,define-variable!)
1007 (primitive-procedure? ,primitive-procedure?)
1008 (apply-primitive-procedure ,apply-primitive-procedure)
1009 (compound-procedure? ,compound-procedure?)
1010 (user-print ,user-print)))
1014 '(exp env val proc argl continue unev)
1017 read-eval-print-loop
1018 (perform (op initialize-stack))
1020 (op prompt-for-input) (const ";;; EC-Eval input:"))
1021 (assign exp (op read))
1022 (assign env (op get-global-environment))
1023 (assign continue (label print-result))
1024 (goto (label eval-dispatch))
1026 (perform (op print-stack-statistics)); added instruction
1028 (op announce-output) (const ";;; EC-Eval value:"))
1029 (perform (op user-print) (reg val))
1030 (goto (label read-eval-print-loop))
1033 (test (op self-evaluating?) (reg exp))
1034 (branch (label ev-self-eval))
1035 (test (op variable?) (reg exp))
1036 (branch (label ev-variable))
1037 (test (op quoted?) (reg exp))
1038 (branch (label ev-quoted))
1039 (test (op assignment?) (reg exp))
1040 (branch (label ev-assignment))
1041 (test (op definition?) (reg exp))
1042 (branch (label ev-definition))
1043 (test (op if?) (reg exp))
1044 (branch (label ev-if))
1045 (test (op lambda?) (reg exp))
1046 (branch (label ev-lambda))
1047 (test (op begin?) (reg exp))
1048 (branch (label ev-begin))
1049 (test (op application?) (reg exp))
1050 (branch (label ev-application))
1051 (goto (label unknown-expression-type))
1053 (assign val (reg exp))
1054 (goto (reg continue))
1056 (assign val (op lookup-variable-value) (reg exp) (reg env))
1057 (goto (reg continue))
1059 (assign val (op text-of-quotation) (reg exp))
1060 (goto (reg continue))
1062 (assign unev (op lambda-parameters) (reg exp))
1063 (assign exp (op lambda-body) (reg exp))
1064 (assign val (op make-procedure)
1065 (reg unev) (reg exp) (reg env))
1066 (goto (reg continue))
1070 (assign unev (op operands) (reg exp))
1072 (assign exp (op operator) (reg exp))
1073 (assign continue (label ev-appl-did-operator))
1074 (goto (label eval-dispatch))
1075 ev-appl-did-operator
1076 (restore unev) ; the operands
1078 (assign argl (op empty-arglist))
1079 (assign proc (reg val)) ; the operator
1080 (test (op no-operands?) (reg unev))
1081 (branch (label apply-dispatch))
1083 ev-appl-operand-loop
1085 (assign exp (op first-operand) (reg unev))
1086 (test (op last-operand?) (reg unev))
1087 (branch (label ev-appl-last-arg))
1090 (assign continue (label ev-appl-accumulate-arg))
1091 (goto (label eval-dispatch))
1092 ev-appl-accumulate-arg
1096 (assign argl (op adjoin-arg) (reg val) (reg argl))
1097 (assign unev (op rest-operands) (reg unev))
1098 (goto (label ev-appl-operand-loop))
1100 (assign continue (label ev-appl-accum-last-arg))
1101 (goto (label eval-dispatch))
1102 ev-appl-accum-last-arg
1104 (assign argl (op adjoin-arg) (reg val) (reg argl))
1106 (goto (label apply-dispatch))
1108 (test (op primitive-procedure?) (reg proc))
1109 (branch (label primitive-apply))
1110 (test (op compound-procedure?) (reg proc))
1111 (branch (label compound-apply))
1112 (goto (label unknown-procedure-type))
1114 (assign val (op apply-primitive-procedure)
1118 (goto (reg continue))
1120 (assign unev (op procedure-parameters) (reg proc))
1121 (assign env (op procedure-environment) (reg proc))
1122 (assign env (op extend-environment)
1123 (reg unev) (reg argl) (reg env))
1124 (assign unev (op procedure-body) (reg proc))
1125 (goto (label ev-sequence))
1127 (assign unev (op begin-actions) (reg exp))
1129 (goto (label ev-sequence))
1131 (assign exp (op first-exp) (reg unev))
1132 (test (op last-exp?) (reg unev))
1133 (branch (label ev-sequence-last-exp))
1136 (assign continue (label ev-sequence-continue))
1137 (goto (label eval-dispatch))
1138 ev-sequence-continue
1141 (assign unev (op rest-exps) (reg unev))
1142 (goto (label ev-sequence))
1143 ev-sequence-last-exp
1145 (goto (label eval-dispatch))
1147 (save exp) ; save expression for later
1150 (assign continue (label ev-if-decide))
1151 (assign exp (op if-predicate) (reg exp))
1152 (goto (label eval-dispatch)) ; evaluate the predicate
1157 (test (op true?) (reg val))
1158 (branch (label ev-if-consequent))
1161 (assign exp (op if-alternative) (reg exp))
1162 (goto (label eval-dispatch))
1164 (assign exp (op if-consequent) (reg exp))
1165 (goto (label eval-dispatch))
1167 (assign unev (op assignment-variable) (reg exp))
1168 (save unev) ; save variable for later
1169 (assign exp (op assignment-value) (reg exp))
1172 (assign continue (label ev-assignment-1))
1173 (goto (label eval-dispatch)) ; evaluate the assignment value
1179 (op set-variable-value!) (reg unev) (reg val) (reg env))
1180 (assign val (const ok))
1181 (goto (reg continue))
1183 (assign unev (op definition-variable) (reg exp))
1184 (save unev) ; save variable for later
1185 (assign exp (op definition-value) (reg exp))
1188 (assign continue (label ev-definition-1))
1189 (goto (label eval-dispatch)) ; evaluate the definition value
1195 (op define-variable!) (reg unev) (reg val) (reg env))
1196 (assign val (const ok))
1197 (goto (reg continue))
1199 unknown-expression-type
1200 (assign val (const unknown-expression-type-error))
1201 (goto (label signal-error))
1202 unknown-procedure-type
1203 (restore continue) ; clean up stack (from apply-dispatch)
1204 (assign val (const unknown-procedure-type-error))
1205 (goto (label signal-error))
1207 (perform (op user-print) (reg val))
1208 (goto (label read-eval-print-loop)))))
1212 ;; Exercise 5.23. Extend the evaluator to handle derived expressions such as cond, let, and so on (section 4.1.2). You may ``cheat'' and assume that the syntax transformers such as cond->if are available as machine operations.28