From 59b58cfb9afe2b16dca32ab00de37faab208348d Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Sat, 10 Apr 2021 11:22:42 -0400 Subject: [PATCH] Implement till 5.29 and separate regular and lazy eceval --- ex-5_23-30.scm | 32 ++- misc/sicp-eceval-lazy.scm | 301 ++++++++++++++++++++++++ misc/sicp-eceval-support.scm | 86 ++++++- misc/sicp-eceval.scm | 438 +++-------------------------------- 4 files changed, 444 insertions(+), 413 deletions(-) create mode 100644 misc/sicp-eceval-lazy.scm diff --git a/ex-5_23-30.scm b/ex-5_23-30.scm index aa86d5d..492a19d 100644 --- a/ex-5_23-30.scm +++ b/ex-5_23-30.scm @@ -1,6 +1,7 @@ (load "util.scm") (load "misc/sicp-regsim.scm") (load "misc/sicp-eceval.scm") +(load "misc/sicp-eceval-lazy.scm") (define the-global-environment (setup-environment)) (set-register-contents! eceval 'exp '(if false 1 2)) @@ -137,9 +138,34 @@ ; | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | ; |----|----|----|----|----|----|----|----|----|----| -; | | | | | | | | | | | depth -; | | | | | | | | | | | push count +; | 8| 13| 18| 23| 28| 33| 38| 43| 48| 53| depth +; | 22| 78| 134| 246| 414| 694|1142|1870|3046|4950| push count -(display "\nex-5.30\n") +; a. +; depth = 3 + 5 * n +; push-count = +; b. +; S(n) := push-count for n +; S(n) = S(n - 2) + S(n - 1) + k +; k = 34 ; calculated from table + +; S(n) = a * Fib(n + 1) + b +; a = 56, b = -34 ; calculated on paper +; S(7) = a * Fib(8) + b +; = 56 * 21 - 34 +; = 1142 + +(display "\nex-5.30 - error-handling\n") + +(set-register-contents! eceval 'exp + '(begin + (define (foo x) x) + (foo a))) +(start eceval) +(newline) +(assert (get-register-contents eceval 'val) 'unbound-variable-error)) +(newline) + +;; CONTINUE HERE diff --git a/misc/sicp-eceval-lazy.scm b/misc/sicp-eceval-lazy.scm new file mode 100644 index 0000000..5dbc27a --- /dev/null +++ b/misc/sicp-eceval-lazy.scm @@ -0,0 +1,301 @@ +; Uncomment the import if you want to use the lazy-evaluator standalone. We +; only use it in ex-5_23-30.scm right now and in that context everything is +; already imported for the regular evaluator. +;(load "misc/sicp-eceval-support.scm") + +; Below is the original version of the evaluator-machine from the book modified +; for lazy-evaluation. +(define eceval-lazy + (make-machine + '(exp env val proc argl continue unev) + eceval-operations + '( + + (perform (op initialize-stack)) + (assign env (op get-global-environment)) + (assign continue (label ev-almost-done)) + (goto (label eval-dispatch)) + +unknown-expression-type + (assign val (const unknown-expression-type-error)) + (goto (label signal-error)) + +unknown-procedure-type + (restore continue) + (assign val (const unknown-procedure-type-error)) + (goto (label signal-error)) + +signal-error + (perform (op user-print) (reg val)) + (goto (label ev-done)) + +;;SECTION 5.4.1 +eval-dispatch + (test (op self-evaluating?) (reg exp)) + (branch (label ev-self-eval)) + (test (op variable?) (reg exp)) + (branch (label ev-variable)) + (test (op quoted?) (reg exp)) + (branch (label ev-quoted)) + (test (op assignment?) (reg exp)) + (branch (label ev-assignment)) + (test (op definition?) (reg exp)) + (branch (label ev-definition)) + (test (op if?) (reg exp)) + (branch (label ev-if)) + (test (op cond?) (reg exp)) + (branch (label ev-cond)) + (test (op let?) (reg exp)) + (branch (label ev-let)) + (test (op lambda?) (reg exp)) + (branch (label ev-lambda)) + (test (op begin?) (reg exp)) + (branch (label ev-begin)) + (test (op application?) (reg exp)) + (branch (label ev-application)) + (goto (label unknown-expression-type)) + +ev-self-eval + (assign val (reg exp)) + (goto (reg continue)) +ev-variable + (assign val (op lookup-variable-value) (reg exp) (reg env)) + (goto (reg continue)) +ev-quoted + (assign val (op text-of-quotation) (reg exp)) + (goto (reg continue)) +ev-lambda + (assign unev (op lambda-parameters) (reg exp)) + (assign exp (op lambda-body) (reg exp)) + (assign val (op make-procedure) + (reg unev) (reg exp) (reg env)) + (goto (reg continue)) + +ev-application + (save continue) + (save env) + (assign unev (op operands) (reg exp)) + (save unev) + (assign exp (op operator) (reg exp)) + (assign continue (label ev-appl-did-operator)) + (goto (label eval-dispatch)) +ev-appl-did-operator + (restore unev) + (restore env) + (assign argl (op empty-arglist)) + (assign proc (reg val)) + (test (op no-operands?) (reg unev)) + (branch (label apply-dispatch)) + (save proc) + + (test (op primitive-procedure?) (reg proc)) + (branch (label ev-appl-operand-loop-force)) + (test (op compound-procedure?) (reg proc)) + (branch (label ev-appl-operand-loop-delay)) + (goto (label unknown-procedure-type)) + +ev-force-it + (assign env (op thunk-env) (reg val)) + (assign exp (op thunk-exp) (reg val)) + (goto (label eval-dispatch)) + +ev-appl-operand-loop-force + (save argl) + (assign exp (op first-operand) (reg unev)) + (test (op last-operand?) (reg unev)) + (branch (label ev-appl-last-arg-force)) + (save env) + (save unev) + (assign continue (label ev-appl-accumulate-arg-force)) + (goto (label eval-dispatch)) +ev-appl-accumulate-arg-force + (test (op thunk?) (reg val)) + (branch (label ev-force-it)) + (restore unev) + (restore env) + (restore argl) + (assign argl (op adjoin-arg) (reg val) (reg argl)) + (assign unev (op rest-operands) (reg unev)) + (goto (label ev-appl-operand-loop-force)) +ev-appl-last-arg-force + (assign continue (label ev-appl-accum-last-arg-force)) + (goto (label eval-dispatch)) +ev-appl-accum-last-arg-force + (test (op thunk?) (reg val)) + (branch (label ev-force-it)) + (restore argl) + (assign argl (op adjoin-arg) (reg val) (reg argl)) + (restore proc) + (goto (label apply-dispatch)) + +ev-appl-operand-loop-delay + ;(save argl) + (assign exp (op first-operand) (reg unev)) + (test (op last-operand?) (reg unev)) + (branch (label ev-appl-last-arg-delay)) + ;(save env) + ;(save unev) + (assign val (op delay-it) (reg exp) (reg env)) + ;(assign continue (label ev-appl-accumulate-arg-delay)) + ;(goto (label eval-dispatch)) +ev-appl-accumulate-arg-delay + ;(restore unev) + ;(restore env) + ;(restore argl) + (assign argl (op adjoin-arg) (reg val) (reg argl)) + (assign unev (op rest-operands) (reg unev)) + (goto (label ev-appl-operand-loop-delay)) +ev-appl-last-arg-delay + (assign val (op delay-it) (reg exp) (reg env)) + ;(assign continue (label ev-appl-accum-last-arg-delay)) + ;(goto (label eval-dispatch)) +ev-appl-accum-last-arg-delay + ;(restore argl) + (assign argl (op adjoin-arg) (reg val) (reg argl)) + (restore proc) + (goto (label apply-dispatch)) + +apply-dispatch + (test (op primitive-procedure?) (reg proc)) + (branch (label primitive-apply)) + (test (op compound-procedure?) (reg proc)) + (branch (label compound-apply)) + (goto (label unknown-procedure-type)) + +primitive-apply + (assign val (op apply-primitive-procedure) + (reg proc) + (reg argl)) + (restore continue) + (goto (reg continue)) + +compound-apply + (assign unev (op procedure-parameters) (reg proc)) + (assign env (op procedure-environment) (reg proc)) + (assign env (op extend-environment) + (reg unev) (reg argl) (reg env)) + (assign unev (op procedure-body) (reg proc)) + (goto (label ev-sequence)) + +;;;SECTION 5.4.2 +ev-begin + (assign unev (op begin-actions) (reg exp)) + (save continue) + (goto (label ev-sequence)) + +ev-sequence + (assign exp (op first-exp) (reg unev)) + (test (op last-exp?) (reg unev)) + (branch (label ev-sequence-last-exp)) + (save unev) + (save env) + (assign continue (label ev-sequence-continue)) + (goto (label eval-dispatch)) +ev-sequence-continue + (restore env) + (restore unev) + (assign unev (op rest-exps) (reg unev)) + (goto (label ev-sequence)) +ev-sequence-last-exp + (restore continue) + (goto (label eval-dispatch)) + +;;; ex-5.23 +ev-cond-transform + (assign exp (op cond->if) (reg exp)) + (goto (label eval-dispatch)) + +;;; ex-5.24 +ev-cond + (save continue) + (assign unev (op cond-clauses) (reg exp)) ; unev contains all clauses +ev-cond-loop + (assign exp (op cond-first-clause) (reg unev)) ; exp contains first clause + (test (op cond-else-clause?) (reg exp)) ; test for else-clause + (branch (label ev-cond-done)) + (assign continue (label ev-cond-decide)) + (save unev) + (assign exp (op cond-predicate) (reg exp)) ; exp contains first predicate + (goto (label eval-dispatch)) ; eval predicate +ev-cond-decide + (restore unev) + (test (op true?) (reg val)) ; test if predicate is true + (branch (label ev-cond-done)) + (assign unev (op cond-clauses) (reg unev)) ; unev contains remainging clauses + (goto (label ev-cond-loop)) +ev-cond-done + (restore continue) + (assign exp (op cond-first-clause) (reg unev)) ; exp contains true clause + (goto (label ev-begin)) + +ev-let + (assign exp (op let->combination) (reg exp)) + (goto (label eval-dispatch)) + +;;;SECTION 5.4.3 +ev-if + (save exp) + (save env) + (save continue) + (assign continue (label ev-if-decide)) + (assign exp (op if-predicate) (reg exp)) + (goto (label eval-dispatch)) +ev-if-decide + (restore continue) + (restore env) + (restore exp) + (test (op true?) (reg val)) + (branch (label ev-if-consequent)) +ev-if-alternative + (assign exp (op if-alternative) (reg exp)) + (goto (label eval-dispatch)) +ev-if-consequent + (assign exp (op if-consequent) (reg exp)) + (goto (label eval-dispatch)) + +ev-assignment + (assign unev (op assignment-variable) (reg exp)) + (save unev) + (assign exp (op assignment-value) (reg exp)) + (save env) + (save continue) + (assign continue (label ev-assignment-1)) + (goto (label eval-dispatch)) +ev-assignment-1 + (restore continue) + (restore env) + (restore unev) + (perform + (op set-variable-value!) (reg unev) (reg val) (reg env)) + (assign val (const ok)) + (goto (reg continue)) + +ev-definition + (assign unev (op definition-variable) (reg exp)) + (save unev) + (assign exp (op definition-value) (reg exp)) + (save env) + (save continue) + (assign continue (label ev-definition-1)) + (goto (label eval-dispatch)) +ev-definition-1 + (restore continue) + (restore env) + (restore unev) + (perform + (op define-variable!) (reg unev) (reg val) (reg env)) + (assign val (const ok)) + (goto (reg continue)) +ev-almost-done + (test (op thunk?) (reg val)) + (branch (label ev-thunk-before-done)) + (goto (label ev-done)) +ev-thunk-before-done + (assign env (op thunk-env) (reg val)) + (assign exp (op thunk-exp) (reg val)) + (assign continue (label ev-done)) + (goto (label eval-dispatch)) +ev-done + ;;(perform (op print-stack-statistics)) + ))) + diff --git a/misc/sicp-eceval-support.scm b/misc/sicp-eceval-support.scm index d2616fb..4ef707b 100644 --- a/misc/sicp-eceval-support.scm +++ b/misc/sicp-eceval-support.scm @@ -5,6 +5,7 @@ ;(load "ch5-syntax.scm"); ;section 4.1.2 syntax procedures (load "misc/sicp-eceval-syntax.scm") ;section 4.1.2 syntax procedures +(load "misc/sicp-leval.scm") ; for lazy evaluation in eceval ;;;SECTION 4.1.3 ;;; operations used by compiled code and eceval except as noted @@ -63,12 +64,15 @@ (car vals)) (else (scan (cdr vars) (cdr vals))))) (if (eq? env the-empty-environment) - (error "Unbound variable" var) + 'unbound-variable-error (let ((frame (first-frame env))) (scan (frame-variables frame) (frame-values frame))))) (env-loop env)) +(define (unbound-variable? var) + (eq? var 'unbound-variable-error)) + (define (set-variable-value! var val env) (define (env-loop env) (define (scan vars vals) @@ -230,3 +234,83 @@ (define (compiled-procedure-entry c-proc) (cadr c-proc)) (define (compiled-procedure-env c-proc) (caddr c-proc)) +(define eceval-operations + (list + ;;primitive Scheme operations + (list 'display display) + (list 'newline newline) + (list 'read read) + + ;;operations in syntax.scm + (list 'application? application?) + (list 'assignment-value assignment-value) + (list 'assignment-variable assignment-variable) + (list 'assignment? assignment?) + (list 'begin-actions begin-actions) + (list 'begin? begin?) + (list 'definition-value definition-value) + (list 'definition-variable definition-variable) + (list 'definition? definition?) + (list 'first-exp first-exp) + (list 'first-operand first-operand) + (list 'if-alternative if-alternative) + (list 'if-consequent if-consequent) + (list 'if-predicate if-predicate) + (list 'if? if?) + (list 'lambda-body lambda-body) + (list 'lambda-parameters lambda-parameters) + (list 'lambda? lambda?) + (list 'last-exp? last-exp?) + (list 'no-operands? no-operands?) + (list 'operands operands) + (list 'operator operator) + (list 'quoted? quoted?) + (list 'rest-exps rest-exps) + (list 'rest-operands rest-operands) + (list 'self-evaluating? self-evaluating?) + (list 'text-of-quotation text-of-quotation) + (list 'variable? variable?) + + ;;operations in eceval-support.scm + (list 'adjoin-arg adjoin-arg) + (list 'announce-output announce-output) + (list 'apply-primitive-procedure apply-primitive-procedure) + (list 'compound-procedure? compound-procedure?) + (list 'define-variable! define-variable!) + (list 'empty-arglist empty-arglist) + (list 'extend-environment extend-environment) + (list 'get-global-environment get-global-environment) + (list 'last-operand? last-operand?) + (list 'lookup-variable-value lookup-variable-value) + (list 'make-procedure make-procedure) + (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine + (list 'primitive-procedure? primitive-procedure?) + (list 'procedure-body procedure-body) + (list 'procedure-environment procedure-environment) + (list 'procedure-parameters procedure-parameters) + (list 'prompt-for-input prompt-for-input) + (list 'set-variable-value! set-variable-value!) + (list 'true? true?) + (list 'user-print user-print) + + ;;5.23 + (list 'cond->if cond->if) + (list 'cond-actions cond-actions) + (list 'cond-clauses cond-clauses) + (list 'cond-else-clause? cond-else-clause?) + (list 'cond-first-clause cond-first-clause) + (list 'cond-predicate cond-predicate) + (list 'cond? cond?) + (list 'let->combination let->combination) + (list 'let? let?) + + ;;5.25 + (list 'delay-it delay-it) + (list 'thunk? thunk?) + (list 'thunk-exp thunk-exp) + (list 'thunk-env thunk-env) + + ;;5.30 + (list 'unbound-variable? unbound-variable?) + + )) diff --git a/misc/sicp-eceval.scm b/misc/sicp-eceval.scm index 3583071..bab0713 100644 --- a/misc/sicp-eceval.scm +++ b/misc/sicp-eceval.scm @@ -1,411 +1,27 @@ -;;;;EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF -;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS +; Copied and adapted from: +; https://mitpress.mit.edu/sites/default/files/sicp/code/index.html -;;;;Matches code in ch5.scm - -;;; To use it -;;; -- load "load-eceval.scm", which loads this file and the -;;; support it needs (including the register-machine simulator) - -;;; -- To initialize and start the machine, do - -;: (define the-global-environment (setup-environment)) - -;: (start eceval) (load "misc/sicp-eceval-support.scm") -(load "misc/sicp-leval.scm") -;; To restart, can do just -;: (start eceval) -;;;;;;;;;; +; To run: +; - Setup global environment +; > (define the-global-environment (setup-environment)) +; - Assign code to exp register +; > (set-register-contents! eceval 'exp '(if false 1 2)) +; - And start the machine +; > (start eceval) -;;**NB. To [not] monitor stack operations, comment in/[out] the line after -;; print-result in the machine controller below -;;**Also choose the desired make-stack version in regsim.scm - -(define eceval-operations - (list - ;;primitive Scheme operations - (list 'display display) - (list 'newline newline) - (list 'read read) - - ;;operations in syntax.scm - (list 'application? application?) - (list 'assignment-value assignment-value) - (list 'assignment-variable assignment-variable) - (list 'assignment? assignment?) - (list 'begin-actions begin-actions) - (list 'begin? begin?) - (list 'definition-value definition-value) - (list 'definition-variable definition-variable) - (list 'definition? definition?) - (list 'first-exp first-exp) - (list 'first-operand first-operand) - (list 'if-alternative if-alternative) - (list 'if-consequent if-consequent) - (list 'if-predicate if-predicate) - (list 'if? if?) - (list 'lambda-body lambda-body) - (list 'lambda-parameters lambda-parameters) - (list 'lambda? lambda?) - (list 'last-exp? last-exp?) - (list 'no-operands? no-operands?) - (list 'operands operands) - (list 'operator operator) - (list 'quoted? quoted?) - (list 'rest-exps rest-exps) - (list 'rest-operands rest-operands) - (list 'self-evaluating? self-evaluating?) - (list 'text-of-quotation text-of-quotation) - (list 'variable? variable?) - - ;;operations in eceval-support.scm - (list 'adjoin-arg adjoin-arg) - (list 'announce-output announce-output) - (list 'apply-primitive-procedure apply-primitive-procedure) - (list 'compound-procedure? compound-procedure?) - (list 'define-variable! define-variable!) - (list 'empty-arglist empty-arglist) - (list 'extend-environment extend-environment) - (list 'get-global-environment get-global-environment) - (list 'last-operand? last-operand?) - (list 'lookup-variable-value lookup-variable-value) - (list 'make-procedure make-procedure) - (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine - (list 'primitive-procedure? primitive-procedure?) - (list 'procedure-body procedure-body) - (list 'procedure-environment procedure-environment) - (list 'procedure-parameters procedure-parameters) - (list 'prompt-for-input prompt-for-input) - (list 'set-variable-value! set-variable-value!) - (list 'true? true?) - (list 'user-print user-print) - - ;;5.23 - (list 'cond->if cond->if) - (list 'cond-actions cond-actions) - (list 'cond-clauses cond-clauses) - (list 'cond-else-clause? cond-else-clause?) - (list 'cond-first-clause cond-first-clause) - (list 'cond-predicate cond-predicate) - (list 'cond? cond?) - (list 'let->combination let->combination) - (list 'let? let?) - - ;;5.25 - (list 'delay-it delay-it) - (list 'thunk? thunk?) - (list 'thunk-exp thunk-exp) - (list 'thunk-env thunk-env) - - )) - -; Below is the original version of the evaluator-machine from the book modified -; for lazy-evaluation. -(define eceval-lazy - (make-machine - '(exp env val proc argl continue unev) - eceval-operations - '( - - (perform (op initialize-stack)) - (assign env (op get-global-environment)) - (assign continue (label ev-almost-done)) - (goto (label eval-dispatch)) - -unknown-expression-type - (assign val (const unknown-expression-type-error)) - (goto (label signal-error)) - -unknown-procedure-type - (restore continue) - (assign val (const unknown-procedure-type-error)) - (goto (label signal-error)) - -signal-error - (perform (op user-print) (reg val)) - (goto (label ev-done)) - -;;SECTION 5.4.1 -eval-dispatch - (test (op self-evaluating?) (reg exp)) - (branch (label ev-self-eval)) - (test (op variable?) (reg exp)) - (branch (label ev-variable)) - (test (op quoted?) (reg exp)) - (branch (label ev-quoted)) - (test (op assignment?) (reg exp)) - (branch (label ev-assignment)) - (test (op definition?) (reg exp)) - (branch (label ev-definition)) - (test (op if?) (reg exp)) - (branch (label ev-if)) - (test (op cond?) (reg exp)) - (branch (label ev-cond)) - (test (op let?) (reg exp)) - (branch (label ev-let)) - (test (op lambda?) (reg exp)) - (branch (label ev-lambda)) - (test (op begin?) (reg exp)) - (branch (label ev-begin)) - (test (op application?) (reg exp)) - (branch (label ev-application)) - (goto (label unknown-expression-type)) - -ev-self-eval - (assign val (reg exp)) - (goto (reg continue)) -ev-variable - (assign val (op lookup-variable-value) (reg exp) (reg env)) - (goto (reg continue)) -ev-quoted - (assign val (op text-of-quotation) (reg exp)) - (goto (reg continue)) -ev-lambda - (assign unev (op lambda-parameters) (reg exp)) - (assign exp (op lambda-body) (reg exp)) - (assign val (op make-procedure) - (reg unev) (reg exp) (reg env)) - (goto (reg continue)) - -ev-application - (save continue) - (save env) - (assign unev (op operands) (reg exp)) - (save unev) - (assign exp (op operator) (reg exp)) - (assign continue (label ev-appl-did-operator)) - (goto (label eval-dispatch)) -ev-appl-did-operator - (restore unev) - (restore env) - (assign argl (op empty-arglist)) - (assign proc (reg val)) - (test (op no-operands?) (reg unev)) - (branch (label apply-dispatch)) - (save proc) - - (test (op primitive-procedure?) (reg proc)) - (branch (label ev-appl-operand-loop-force)) - (test (op compound-procedure?) (reg proc)) - (branch (label ev-appl-operand-loop-delay)) - (goto (label unknown-procedure-type)) - -ev-force-it - (assign env (op thunk-env) (reg val)) - (assign exp (op thunk-exp) (reg val)) - (goto (label eval-dispatch)) - -ev-appl-operand-loop-force - (save argl) - (assign exp (op first-operand) (reg unev)) - (test (op last-operand?) (reg unev)) - (branch (label ev-appl-last-arg-force)) - (save env) - (save unev) - (assign continue (label ev-appl-accumulate-arg-force)) - (goto (label eval-dispatch)) -ev-appl-accumulate-arg-force - (test (op thunk?) (reg val)) - (branch (label ev-force-it)) - (restore unev) - (restore env) - (restore argl) - (assign argl (op adjoin-arg) (reg val) (reg argl)) - (assign unev (op rest-operands) (reg unev)) - (goto (label ev-appl-operand-loop-force)) -ev-appl-last-arg-force - (assign continue (label ev-appl-accum-last-arg-force)) - (goto (label eval-dispatch)) -ev-appl-accum-last-arg-force - (test (op thunk?) (reg val)) - (branch (label ev-force-it)) - (restore argl) - (assign argl (op adjoin-arg) (reg val) (reg argl)) - (restore proc) - (goto (label apply-dispatch)) - -ev-appl-operand-loop-delay - ;(save argl) - (assign exp (op first-operand) (reg unev)) - (test (op last-operand?) (reg unev)) - (branch (label ev-appl-last-arg-delay)) - ;(save env) - ;(save unev) - (assign val (op delay-it) (reg exp) (reg env)) - ;(assign continue (label ev-appl-accumulate-arg-delay)) - ;(goto (label eval-dispatch)) -ev-appl-accumulate-arg-delay - ;(restore unev) - ;(restore env) - ;(restore argl) - (assign argl (op adjoin-arg) (reg val) (reg argl)) - (assign unev (op rest-operands) (reg unev)) - (goto (label ev-appl-operand-loop-delay)) -ev-appl-last-arg-delay - (assign val (op delay-it) (reg exp) (reg env)) - ;(assign continue (label ev-appl-accum-last-arg-delay)) - ;(goto (label eval-dispatch)) -ev-appl-accum-last-arg-delay - ;(restore argl) - (assign argl (op adjoin-arg) (reg val) (reg argl)) - (restore proc) - (goto (label apply-dispatch)) - -apply-dispatch - (test (op primitive-procedure?) (reg proc)) - (branch (label primitive-apply)) - (test (op compound-procedure?) (reg proc)) - (branch (label compound-apply)) - (goto (label unknown-procedure-type)) - -primitive-apply - (assign val (op apply-primitive-procedure) - (reg proc) - (reg argl)) - (restore continue) - (goto (reg continue)) - -compound-apply - (assign unev (op procedure-parameters) (reg proc)) - (assign env (op procedure-environment) (reg proc)) - (assign env (op extend-environment) - (reg unev) (reg argl) (reg env)) - (assign unev (op procedure-body) (reg proc)) - (goto (label ev-sequence)) - -;;;SECTION 5.4.2 -ev-begin - (assign unev (op begin-actions) (reg exp)) - (save continue) - (goto (label ev-sequence)) - -ev-sequence - (assign exp (op first-exp) (reg unev)) - (test (op last-exp?) (reg unev)) - (branch (label ev-sequence-last-exp)) - (save unev) - (save env) - (assign continue (label ev-sequence-continue)) - (goto (label eval-dispatch)) -ev-sequence-continue - (restore env) - (restore unev) - (assign unev (op rest-exps) (reg unev)) - (goto (label ev-sequence)) -ev-sequence-last-exp - (restore continue) - (goto (label eval-dispatch)) - -;;; ex-5.23 -ev-cond-transform - (assign exp (op cond->if) (reg exp)) - (goto (label eval-dispatch)) - -;;; ex-5.24 -ev-cond - (save continue) - (assign unev (op cond-clauses) (reg exp)) ; unev contains all clauses -ev-cond-loop - (assign exp (op cond-first-clause) (reg unev)) ; exp contains first clause - (test (op cond-else-clause?) (reg exp)) ; test for else-clause - (branch (label ev-cond-done)) - (assign continue (label ev-cond-decide)) - (save unev) - (assign exp (op cond-predicate) (reg exp)) ; exp contains first predicate - (goto (label eval-dispatch)) ; eval predicate -ev-cond-decide - (restore unev) - (test (op true?) (reg val)) ; test if predicate is true - (branch (label ev-cond-done)) - (assign unev (op cond-clauses) (reg unev)) ; unev contains remainging clauses - (goto (label ev-cond-loop)) -ev-cond-done - (restore continue) - (assign exp (op cond-first-clause) (reg unev)) ; exp contains true clause - (goto (label ev-begin)) - -ev-let - (assign exp (op let->combination) (reg exp)) - (goto (label eval-dispatch)) - -;;;SECTION 5.4.3 -ev-if - (save exp) - (save env) - (save continue) - (assign continue (label ev-if-decide)) - (assign exp (op if-predicate) (reg exp)) - (goto (label eval-dispatch)) -ev-if-decide - (restore continue) - (restore env) - (restore exp) - (test (op true?) (reg val)) - (branch (label ev-if-consequent)) -ev-if-alternative - (assign exp (op if-alternative) (reg exp)) - (goto (label eval-dispatch)) -ev-if-consequent - (assign exp (op if-consequent) (reg exp)) - (goto (label eval-dispatch)) - -ev-assignment - (assign unev (op assignment-variable) (reg exp)) - (save unev) - (assign exp (op assignment-value) (reg exp)) - (save env) - (save continue) - (assign continue (label ev-assignment-1)) - (goto (label eval-dispatch)) -ev-assignment-1 - (restore continue) - (restore env) - (restore unev) - (perform - (op set-variable-value!) (reg unev) (reg val) (reg env)) - (assign val (const ok)) - (goto (reg continue)) - -ev-definition - (assign unev (op definition-variable) (reg exp)) - (save unev) - (assign exp (op definition-value) (reg exp)) - (save env) - (save continue) - (assign continue (label ev-definition-1)) - (goto (label eval-dispatch)) -ev-definition-1 - (restore continue) - (restore env) - (restore unev) - (perform - (op define-variable!) (reg unev) (reg val) (reg env)) - (assign val (const ok)) - (goto (reg continue)) -ev-almost-done - (test (op thunk?) (reg val)) - (branch (label ev-thunk-before-done)) - (goto (label ev-done)) -ev-thunk-before-done - (assign env (op thunk-env) (reg val)) - (assign exp (op thunk-exp) (reg val)) - (assign continue (label ev-done)) - (goto (label eval-dispatch)) -ev-done - ;;(perform (op print-stack-statistics)) - ))) - -; Below is the original version of the evaluator from the book without the -; read-eval-print loop. We assign to the expression before we start the -; machine. The machine has added support for let and cond. +; Below is the machine evaluator with some changes: +; - Remove the read-eval-print lool and instead execute from exp. +; - Machine does not print the result. Get it from val instead after running. +; - Add support for let and cond. (define eceval (make-machine - '(exp env val proc argl continue unev) - eceval-operations - '( + '(exp env val proc argl continue unev) + eceval-operations + '( +ev-start (perform (op initialize-stack)) (assign env (op get-global-environment)) (assign continue (label ev-done)) @@ -420,6 +36,10 @@ unknown-procedure-type (assign val (const unknown-procedure-type-error)) (goto (label signal-error)) +unbound-variable-error + (assign val (const unbound-variable-error)) + (goto (label signal-error)) + signal-error (perform (op user-print) (reg val)) (goto (label ev-done)) @@ -454,7 +74,10 @@ ev-self-eval (assign val (reg exp)) (goto (reg continue)) ev-variable + ;(perform (op user-print) (reg exp)) (assign val (op lookup-variable-value) (reg exp) (reg env)) + (test (op unbound-variable?) (reg val)) + (branch (label unbound-variable-error)) (goto (reg continue)) ev-quoted (assign val (op text-of-quotation) (reg exp)) @@ -528,12 +151,6 @@ compound-apply (assign unev (op procedure-body) (reg proc)) (goto (label ev-sequence)) -;;;SECTION 5.4.2 -ev-begin - (assign unev (op begin-actions) (reg exp)) - (save continue) - (goto (label ev-sequence)) - ev-cond (save continue) (assign unev (op cond-clauses) (reg exp)) ; unev contains all clauses @@ -560,6 +177,11 @@ ev-let (assign exp (op let->combination) (reg exp)) (goto (label eval-dispatch)) +ev-begin + (assign unev (op begin-actions) (reg exp)) + (save continue) + (goto (label ev-sequence)) + ev-sequence (assign exp (op first-exp) (reg unev)) (test (op last-exp?) (reg unev)) @@ -577,8 +199,6 @@ ev-sequence-last-exp (restore continue) (goto (label eval-dispatch)) -;;;SECTION 5.4.3 - ev-if (save exp) (save env)