The explicit-control evaluator from SICP §5.4

explicit-control.scm

;; Explicit control evaluator from SICP 5.4

;; required "machine" operations from underlying Scheme
(define eceval-operations
  (list (list 'self-evaluating? self-evaluating)
        (list 'variable? variable)
        ;... etc
        ;self-evaluating?
        ;variable?
        ;quoted?
        ;assignment?
        ;definition?
        ;if?
        ;lambda?
        ;begin?
        ;application?
        ;lookup-variable-value
        ;text-of-quotation
        ;lambda-parameters
        ;lambda-body
        ;make-procedure
        ;operands
        ;operator
        ;empty-list
        ;no-operands?
        ;first-operand
        ;last-operand?
        ;adjoin-arg
        ;rest-operands
        ;primitive-procedure?
        ;compound-procedure?
        ;apply-primitive-procedure
        ;procedure-parameters
        ;extend-environment
        ;first-exp
        ;last-exp?
        ;rest-exps
        ;if-predicate
        ;true?
        ;if-alternative
        ;if-consequent
        ;assignment-variable
        ;assignment-value
        ;set-variable-value!
        ;define-variable!
        ;initialize-stack
        ;prompt-for-input
        ;read
        ;get-global-environment
        ;announce-output
        ;user-print
))

(define eceval
  (make-machine

    '(exp env val proc arg1 continue unev)

    eceval-operations

    '(
    read-eval-print-loop
      (perform (op initialize-stack))
      (perform (op prompt-for-input) (const ";;; EC-Eval input:"))
      (assign exp (op read))
      (assign env (op get-global-environment))
      (assign continue (label print-result))
      (goto (label eval-dispatch))
    print-result
      (perform (op announce-output) (const ";;; EC-Eval value:"))
      (perform (op user-print) (reg val))
      (goto (label read-eval-print-loop)

    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 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-application-operator-is-evaluated))
      (goto (label eval-dispatch))
    ev-application-operator-is-evaluated
      (restore unev) ;; operands
      (restore env)
      (assign arg1 (op empty-list))
      (assign proc (reg val)) ;; evaluated operator, ie. a proc object
      (test (op no-operands?) (reg unev))
      (branch (label apply-dispatch))
      (save proc) ;; save because eval might call apply
    ev-application-operand-evaluation-loop
      (save arg1)
      (assign exp (op first-operand) (reg unev))
      (test (op last-operand?) (reg unev))
      (branch (label ev-application-found-last-argument))
      (save env)
      (save unev)
      (assign continue (label ev-application-accumulate-argument))
      (goto (label eval-dispatch))
    ev-application-accumulate-argument
      (restore unev)
      (restore env)
      (restore arg1)
      (assign arg1 (op adjoin-arg) (reg val) (reg arg1))
      (assign unev (op rest-operands) (reg unev))
      (goto (label ev-application-operand-evaluation-loop))
    ev-application-found-last-argument
      (assign continue (label ev-application-accumulate-last-argument))
      (goto (label eval-dispatch))
    ev-application-accumulate-last-argument
      (restore arg1)
      (assign arg1 (op adjoin-arg) (reg val) (reg arg1))
      (restore proc) ;; in case nested eval changed it
      (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 arg1))
      (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 arg1) (reg env))
      (assign unev (op procedure-body) (reg proc))
      (goto (label ev-sequence))

    ;; ev-begin (unimplemented)
    ;; place sequence of expressions in unev
    ;; save continue on the stack
    ;; jump (or just fall through) to ev-sequence

    ev-sequence
      (assign exp (op first-exp) (reg unev))
      (test (op last-exp?) (reg unev))
      (branch (label ev-sequence-on-last-expression))
      (save unev)
      (save env)
      (assign continue (label ev-sequence-return-from-eval))
      (goto (label eval-dispatch))
    ev-sequence-return-from-eval
      (restore env)
      (restore unev)
      (assign unev (op rest-exps) (reg unev))
      (goto (label ev-sequence))
    ev-sequence-on-last-expression
      (restore continue)
      (goto (label eval-dispatch))

    ;; non-tail recursive version of ev sequence
    ;;
    ;; change is in treating the last exp the same as others
    ;; consequence: deeply nested recursion will cause useless saves of unev and
    ;; env to build up and eventually exhaust stack
    ;;
    ;; ev-sequence
    ;;  (test (op no-more-exps?) (reg unev))
    ;;  (branch (label ev-sequence-end))
    ;;  (assign exp (op first-exp) (reg unev))
    ;;  (save unev)
    ;;  (save env)
    ;;  (assign continue (label ev-sequence-return-from-eval))
    ;;  (goto (label eval-dispatch))
    ;; ev-sequence-return-from-eval
    ;;  (restore env)
    ;;  (restore unev)
    ;;  (assign unev (op rest-exps) (reg unev))
    ;;  (goto (label ev-sequence))
    ;; ev-sequence-end
    ;;  (restore continue)
    ;;  (goto (reg continue))

    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)) ; evals predicate
    ev-if-decide
      (restore continue)
      (restore env)
      (restore exp)
      (test (op true?) (reg val)) ; value of predicate
      (branch (label ev-if-consequent)) ; fall through on false
    ev-if-alternative ; never jump to here
      (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) ; need variable later
      (assign exp (op assignment-value) (reg exp))
      (save env)
      (save continue)
      (assign continue (label ev-assignment-evaluated-value))
      (goto (label eval-dispatch)) ; get assignment value
    ev-assignment-evaluated-value
      (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) ; need variable later
      (assign exp (op definition-value) (reg exp))
      (save env)
      (save continue)
      (assign continue (label ev-definition-evaluated-value))
      (goto (label eval-dispatch)) ; get assignment value
    ev-definition-evaluated-value
      (restore continue)
      (restore env)
      (restore unev)
      (perform (op define-variable!) (reg unev) (reg val) (reg env))
      (assign val (const ok))
      (goto (reg continue))

    unknown-expression-type
      (assign val (const unknown-expression-type-error))
      (goto (label signal-error))
    unknown-procedure-type
      (restore continue) ; clean up stack from apply-dispatch
      (assign val (const unknown-procedure-type-error))
      (goto (label signal-error))
    signal-error
      (perform (op user-print) (reg val))
      (goto (label read-eval-print-loop))

)))