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
1350 ;; procedure definition / application
1353 '((define (factorial n)
1356 (* n (factorial (- n 1)))))
1360 '((define (cons x y)
1361 (lambda (m) (m x y)))
1363 (z (lambda (p q) p)))
1365 (z (lambda (p q) q)))
1366 (define pair (cons 3 2))
1367 (+ (car pair) (cdr pair)))
1374 (cond ((= x -2) 'x=-2)
1380 ((= 2 (factorial 3)) true)
1381 (((lambda (result) result) true) 5)))
1384 '((cond (((lambda (result) result) false) 5)
1385 ((car (cons false true)) 3)))
1388 '((cond (((lambda (result) result) false) 5)
1389 ((car (cons false true)) 3)
1396 '((let ((x 4) (y 7))
1407 (+ (let ((x (+ y 2))
1416 (z (let ((a (* 3 2)))