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)))
808 (define (make-if predicate consequent alternative)
809 (list 'if predicate consequent alternative))
812 (define (cond? exp) (tagged-list? exp 'cond))
813 (define (cond-clauses exp) (cdr exp))
814 (define (cond-else-clause? clause)
815 (eq? (cond-predicate clause) 'else))
816 (define (cond-predicate clause) (car clause))
817 (define (cond-actions clause) (cdr clause))
818 (define (cond->if exp)
819 (expand-clauses (cond-clauses exp)))
820 (define (expand-clauses clauses)
822 'false ; no else clause
823 (let ((first (car clauses))
824 (rest (cdr clauses)))
825 (if (cond-else-clause? first)
827 (sequence->exp (cond-actions first))
828 (error "ELSE clause isn't last -- COND->IF"
830 (make-if (cond-predicate first)
831 (sequence->exp (cond-actions first))
832 (expand-clauses rest))))))
837 (define (lambda? exp) (tagged-list? exp 'lambda))
838 (define (lambda-parameters exp) (cadr exp))
839 (define (lambda-body exp) (cddr exp))
840 (define (make-procedure parameters body env)
841 (list 'procedure parameters body env))
842 (define (make-lambda parameters body)
843 (cons 'lambda (cons parameters body)))
845 (define (make-lambda parameters body)
846 (cons 'lambda (cons parameters body)))
850 (define (make-let vars vals body)
852 (cons (map list vars vals)
855 (and (tagged-list? exp 'let)
856 (not (symbol? (cadr exp)))))
857 (define (let-vars exp)
858 (map car (cadr exp)))
859 (define (let-vals exp)
860 (map cadr (cadr exp)))
861 (define (let-body exp)
863 (define (let->combination exp)
864 (make-application (make-lambda (let-vars exp) (let-body exp))
866 (define (make-application op args)
871 (define (begin? exp) (tagged-list? exp 'begin))
872 (define (begin-actions exp) (cdr exp))
873 (define (last-exp? seq) (null? (cdr seq)))
874 (define (first-exp seq) (car seq))
875 (define (rest-exps seq) (cdr seq))
876 (define (sequence->exp seq)
877 (cond ((null? seq) seq)
878 ((last-exp? seq) (first-exp seq))
879 (else (make-begin seq))))
880 (define (make-begin seq) (cons 'begin seq))
884 (define (application? exp) (pair? exp))
885 (define (operator exp) (car exp))
886 (define (operands exp) (cdr exp))
887 (define (no-operands? ops) (null? ops))
888 (define (first-operand ops) (car ops))
889 (define (rest-operands ops) (cdr ops))
890 (define (empty-arglist) '())
891 (define (adjoin-arg arg arglist)
892 (append arglist (list arg)))
893 (define (last-operand? ops)
903 ;; compound procedures
905 (define (compound-procedure? p)
906 (tagged-list? p 'procedure))
907 (define (procedure-parameters p) (cadr p))
908 (define (procedure-body p) (caddr p))
909 (define (procedure-environment p) (cadddr p))
911 ;; environment procedures/data structures
913 (define (enclosing-environment env) (cdr env))
914 (define (first-frame env) (car env))
915 (define the-empty-environment '())
916 (define (make-frame variables values)
917 (cons variables values))
918 (define (frame-variables frame) (car frame))
919 (define (frame-values frame) (cdr frame))
920 (define (add-binding-to-frame! var val frame)
921 (set-car! frame (cons var (car frame)))
922 (set-cdr! frame (cons val (cdr frame))))
923 (define (extend-environment vars vals base-env)
924 (if (= (length vars) (length vals))
925 (cons (make-frame vars vals) base-env)
926 (if (< (length vars) (length vals))
927 (error "Too many arguments supplied" vars vals)
928 (error "Too few arguments supplied" vars vals))))
929 (define (lookup-variable-value var env)
930 (define (env-loop env)
931 (define (scan vars vals)
933 (env-loop (enclosing-environment env)))
934 ((eq? var (car vars))
935 (let ((val (car vals)))
936 (if (eq? val '*unassigned*)
937 (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
939 (else (scan (cdr vars) (cdr vals)))))
940 (if (eq? env the-empty-environment)
941 (error "Unbound variable" var)
942 (let ((frame (first-frame env)))
943 (scan (frame-variables frame)
944 (frame-values frame)))))
946 (define (set-variable-value! var val env)
947 (define (env-loop env)
948 (define (scan vars vals)
950 (env-loop (enclosing-environment env)))
951 ((eq? var (car vars))
953 (else (scan (cdr vars) (cdr vals)))))
954 (if (eq? env the-empty-environment)
955 (error "Unbound variable -- SET!" var)
956 (let ((frame (first-frame env)))
957 (scan (frame-variables frame)
958 (frame-values frame)))))
960 (define (define-variable! var val env)
961 (let ((frame (first-frame env)))
962 (define (scan vars vals)
964 (add-binding-to-frame! var val frame))
965 ((eq? var (car vars))
967 (else (scan (cdr vars) (cdr vals)))))
968 (scan (frame-variables frame)
969 (frame-values frame))))
970 (define (primitive-procedure? proc)
971 (tagged-list? proc 'primitive))
972 (define (primitive-implementation proc) (cadr proc))
973 (define primitive-procedures
974 (list (list 'car car)
990 (list 'remainder remainder)
992 (list 'equal? equal?)
993 (list 'display display)))
994 (define (primitive-procedure-names)
996 primitive-procedures))
997 (define (primitive-procedure-objects)
998 (map (lambda (proc) (list 'primitive (cadr proc)))
999 primitive-procedures))
1000 (define (apply-primitive-procedure proc args)
1001 (apply (primitive-implementation proc) args))
1002 (define (setup-environment)
1004 (extend-environment (primitive-procedure-names)
1005 (primitive-procedure-objects)
1006 the-empty-environment)))
1007 (define-variable! 'true true initial-env)
1008 (define-variable! 'false false initial-env)
1010 (define the-global-environment (setup-environment))
1011 (define (get-global-environment)
1012 the-global-environment)
1014 ;; Explicit Control Evaluator Machine
1016 (define eceval-operations
1017 `((prompt-for-input ,prompt-for-input)
1019 (get-global-environment ,get-global-environment)
1020 (announce-output ,announce-output)
1021 (user-print ,user-print)
1022 (self-evaluating? ,self-evaluating?)
1023 (variable? ,variable?)
1025 (assignment? ,assignment?)
1026 (definition? ,definition?)
1029 (cond->if ,cond->if)
1032 (application? ,application?)
1033 (lookup-variable-value ,lookup-variable-value)
1034 (text-of-quotation ,text-of-quotation)
1035 (lambda-parameters ,lambda-parameters)
1036 (lambda-body ,lambda-body)
1037 (make-procedure ,make-procedure)
1038 (let->combination ,let->combination)
1040 (operands ,operands)
1041 (operator ,operator)
1042 (empty-arglist ,empty-arglist)
1043 (no-operands? ,no-operands?)
1044 (first-operand ,first-operand)
1045 (rest-operands ,rest-operands)
1046 (last-operand? ,last-operand?)
1047 (adjoin-arg ,adjoin-arg)
1048 (procedure-parameters ,procedure-parameters)
1049 (procedure-environment ,procedure-environment)
1050 (extend-environment ,extend-environment)
1051 (procedure-body ,procedure-body)
1052 (begin-actions ,begin-actions)
1053 (first-exp ,first-exp)
1054 (last-exp? ,last-exp?)
1055 (rest-exps ,rest-exps)
1057 (if-predicate ,if-predicate)
1058 (if-alternative ,if-alternative)
1059 (if-consequent ,if-consequent)
1060 (assignment-variable ,assignment-variable)
1061 (assignment-value ,assignment-value)
1062 (set-variable-value! ,set-variable-value!)
1063 (definition-variable ,definition-variable)
1064 (definition-value ,definition-value)
1065 (define-variable! ,define-variable!)
1066 (primitive-procedure? ,primitive-procedure?)
1067 (apply-primitive-procedure ,apply-primitive-procedure)
1068 (compound-procedure? ,compound-procedure?)
1069 (user-print ,user-print)
1074 '(exp env val proc argl continue unev code)
1078 (test (op null?) (reg code))
1079 (branch (label eval-done))
1080 (perform (op initialize-stack))
1081 (assign env (op get-global-environment))
1082 (assign exp (op first-exp) (reg code))
1083 (assign code (op rest-exps) (reg code))
1084 (assign continue (label eval-loop))
1085 (goto (label eval-dispatch))
1087 read-eval-print-loop
1088 (perform (op initialize-stack))
1090 (op prompt-for-input) (const ";;; EC-Eval input:"))
1091 (assign exp (op read))
1092 (assign env (op get-global-environment))
1093 (assign continue (label print-result))
1094 (goto (label eval-dispatch))
1096 (perform (op print-stack-statistics)); added instruction
1098 (op announce-output) (const ";;; EC-Eval value:"))
1099 (perform (op user-print) (reg val))
1100 (goto (label read-eval-print-loop))
1103 (test (op self-evaluating?) (reg exp))
1104 (branch (label ev-self-eval))
1105 (test (op variable?) (reg exp))
1106 (branch (label ev-variable))
1107 (test (op quoted?) (reg exp))
1108 (branch (label ev-quoted))
1109 (test (op assignment?) (reg exp))
1110 (branch (label ev-assignment))
1111 (test (op definition?) (reg exp))
1112 (branch (label ev-definition))
1113 (test (op if?) (reg exp))
1114 (branch (label ev-if))
1115 (test (op cond?) (reg exp))
1116 (branch (label ev-cond))
1117 (test (op lambda?) (reg exp))
1118 (branch (label ev-lambda))
1119 (test (op let?) (reg exp))
1120 (branch (label ev-let))
1121 (test (op begin?) (reg exp))
1122 (branch (label ev-begin))
1123 (test (op application?) (reg exp))
1124 (branch (label ev-application))
1125 (goto (label unknown-expression-type))
1127 (assign val (reg exp))
1128 (goto (reg continue))
1130 (assign val (op lookup-variable-value) (reg exp) (reg env))
1131 (goto (reg continue))
1133 (assign val (op text-of-quotation) (reg exp))
1134 (goto (reg continue))
1136 (assign unev (op lambda-parameters) (reg exp))
1137 (assign exp (op lambda-body) (reg exp))
1138 (assign val (op make-procedure)
1139 (reg unev) (reg exp) (reg env))
1140 (goto (reg continue))
1142 (assign exp (op let->combination) (reg exp))
1143 (goto (label eval-dispatch))
1147 (assign unev (op operands) (reg exp))
1149 (assign exp (op operator) (reg exp))
1150 (assign continue (label ev-appl-did-operator))
1151 (goto (label eval-dispatch))
1152 ev-appl-did-operator
1153 (restore unev) ; the operands
1155 (assign argl (op empty-arglist))
1156 (assign proc (reg val)) ; the operator
1157 (test (op no-operands?) (reg unev))
1158 (branch (label apply-dispatch))
1160 ev-appl-operand-loop
1162 (assign exp (op first-operand) (reg unev))
1163 (test (op last-operand?) (reg unev))
1164 (branch (label ev-appl-last-arg))
1167 (assign continue (label ev-appl-accumulate-arg))
1168 (goto (label eval-dispatch))
1169 ev-appl-accumulate-arg
1173 (assign argl (op adjoin-arg) (reg val) (reg argl))
1174 (assign unev (op rest-operands) (reg unev))
1175 (goto (label ev-appl-operand-loop))
1177 (assign continue (label ev-appl-accum-last-arg))
1178 (goto (label eval-dispatch))
1179 ev-appl-accum-last-arg
1181 (assign argl (op adjoin-arg) (reg val) (reg argl))
1183 (goto (label apply-dispatch))
1185 (test (op primitive-procedure?) (reg proc))
1186 (branch (label primitive-apply))
1187 (test (op compound-procedure?) (reg proc))
1188 (branch (label compound-apply))
1189 (goto (label unknown-procedure-type))
1191 (assign val (op apply-primitive-procedure)
1195 (goto (reg continue))
1197 (assign unev (op procedure-parameters) (reg proc))
1198 (assign env (op procedure-environment) (reg proc))
1199 (assign env (op extend-environment)
1200 (reg unev) (reg argl) (reg env))
1201 (assign unev (op procedure-body) (reg proc))
1202 (goto (label ev-sequence))
1204 (assign unev (op begin-actions) (reg exp))
1206 (goto (label ev-sequence))
1208 (assign exp (op first-exp) (reg unev))
1209 (test (op last-exp?) (reg unev))
1210 (branch (label ev-sequence-last-exp))
1213 (assign continue (label ev-sequence-continue))
1214 (goto (label eval-dispatch))
1215 ev-sequence-continue
1218 (assign unev (op rest-exps) (reg unev))
1219 (goto (label ev-sequence))
1220 ev-sequence-last-exp
1222 (goto (label eval-dispatch))
1224 (save exp) ; save expression for later
1227 (assign continue (label ev-if-decide))
1228 (assign exp (op if-predicate) (reg exp))
1229 (goto (label eval-dispatch)) ; evaluate the predicate
1234 (test (op true?) (reg val))
1235 (branch (label ev-if-consequent))
1238 (assign exp (op if-alternative) (reg exp))
1239 (goto (label eval-dispatch))
1241 (assign exp (op if-consequent) (reg exp))
1242 (goto (label eval-dispatch))
1245 (assign exp (op cond->if) (reg exp))
1246 (goto (label eval-dispatch))
1249 (assign unev (op assignment-variable) (reg exp))
1250 (save unev) ; save variable for later
1251 (assign exp (op assignment-value) (reg exp))
1254 (assign continue (label ev-assignment-1))
1255 (goto (label eval-dispatch)) ; evaluate the assignment value
1261 (op set-variable-value!) (reg unev) (reg val) (reg env))
1262 (assign val (const ok))
1263 (goto (reg continue))
1265 (assign unev (op definition-variable) (reg exp))
1266 (save unev) ; save variable for later
1267 (assign exp (op definition-value) (reg exp))
1270 (assign continue (label ev-definition-1))
1271 (goto (label eval-dispatch)) ; evaluate the definition value
1277 (op define-variable!) (reg unev) (reg val) (reg env))
1278 (assign val (const ok))
1279 (goto (reg continue))
1281 unknown-expression-type
1282 (assign val (const unknown-expression-type-error))
1283 (goto (label signal-error))
1284 unknown-procedure-type
1285 (restore continue) ; clean up stack (from apply-dispatch)
1286 (assign val (const unknown-procedure-type-error))
1287 (goto (label signal-error))
1289 (perform (op user-print) (reg val))
1290 (goto (label read-eval-print-loop))
1296 ;; (set-register-contents!
1299 ;; '((define (factorial n)
1302 ;; (* n (factorial (- n 1)))))
1305 ;; (test-case (get-register-contents eceval 'val)
1309 ;; (set-register-contents!
1312 ;; '((define (cons x y)
1313 ;; (lambda (m) (m x y)))
1315 ;; (z (lambda (p q) p)))
1317 ;; (z (lambda (p q) q)))
1318 ;; (define pair (cons 3 2))
1319 ;; (+ (car pair) (cdr pair))))
1321 ;; (test-case (get-register-contents eceval 'val)
1324 (define (test-interpret code expected)
1325 (set-register-contents! eceval 'code code)
1327 (test-case (get-register-contents eceval 'val) expected))
1330 '((define (factorial n)
1333 (* n (factorial (- n 1)))))
1337 '((define (cons x y)
1338 (lambda (m) (m x y)))
1340 (z (lambda (p q) p)))
1342 (z (lambda (p q) q)))
1343 (define pair (cons 3 2))
1344 (+ (car pair) (cdr pair)))
1348 ;; 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
1352 (cond ((= x -2) 'x=-2)
1358 ((= 2 (factorial 3)) true)
1359 (((lambda (result) result) true) 5)))
1363 '((let ((x 4) (y 7))
1374 (+ (let ((x (+ y 2))
1383 (z (let ((a (* 3 2)))