SICP/misc/sicp-eceval.scm

;;;;EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS

;;;;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)
;;;;;;;;;;


;;**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.
(define eceval
  (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-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 cond?) (reg exp))
  (branch (label ev-cond))
  (test (op let?) (reg exp))
  (branch (label ev-let))
  (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-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)
ev-appl-operand-loop
  (save argl)
  (assign exp (op first-operand) (reg unev))
  (test (op last-operand?) (reg unev))
  (branch (label ev-appl-last-arg))
  (save env)
  (save unev)
  (assign continue (label ev-appl-accumulate-arg))
  (goto (label eval-dispatch))
ev-appl-accumulate-arg
  (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))
ev-appl-last-arg
  (assign continue (label ev-appl-accum-last-arg))
  (goto (label eval-dispatch))
ev-appl-accum-last-arg
  (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-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))

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))

;;;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-done
  ;(perform (op print-stack-statistics))
  )))

'(EXPLICIT CONTROL EVALUATOR LOADED)