; (load "reg_machine_sim.scm")
(load "ex_5_14.scm")            ;; with stack statistics
(load "ch4-mceval.scm")         ;; Meta-circular evaluator in Scheme

;; Additional data-structure and syntax procedures for
;; the Scheme evaluator code
;;
(define (empty-arglist) '())

(define (adjoin-arg arg arglist)
  (append arglist (list arg)))

(define (last-operand? ops)
  (null? (cdr ops)))

(define (no-more-exps? seq) (null? seq))

;; Global environment
;;
(define the-global-environment (setup-environment))
(define (get-global-environment)
  the-global-environment)



;;
;;********************************;;
;;                                ;;
;; The explicit control evaluator ;;
;;                                ;;
;;********************************;;
;;
(define ec-eval
  (make-machine
    '(machine-args exp env val continue proc argl unev)
    (list 
      (qq self-evaluating?) (qq variable?) (qq quoted?)
      (qq assignment?) (qq definition?) (qq if?)
      (qq lambda?) (qq begin?) (qq application?)
      (qq operator) (qq operands) (qq empty-arglist)
      (qq adjoin-arg) (qq last-operand?) (qq no-operands?)
      (qq first-operand) (qq rest-operands) (qq adjoin-arg)
      (qq primitive-procedure?) (qq compound-procedure?)
      (qq apply-primitive-procedure) (qq procedure-parameters)
      (qq procedure-environment) (qq extend-environment)
      (qq procedure-body) (qq begin-actions) (qq first-exp)
      (qq last-exp?) (qq rest-exps) (qq if-predicate)
      (qq true?) (qq if-alternative) (qq if-consequent)
      (qq assignment-value) (qq assignment-variable)
      (qq set-variable-value!) (qq definition-variable)
      (qq definition-value) (qq define-variable!)
      (qq prompt-for-input) (qq read) (qq user-print)
      (qq get-global-environment) (qq announce-output)
      (qq text-of-quotation) (qq lookup-variable-value)
      (qq lambda-parameters) (qq lambda-body)
      (qq make-procedure) (qq cond?) (qq cond->if)
      (qq cond-actions) (qq cond-else-clause?) 
      (qq cond-predicate) (qq cond-clauses)
      (qq no-more-exps?) (qq var-val-bound?)
      (qq var-val-extract-value)
      (qq car) (qq cdr) (qq null?)
      (qq printf)
    )
    '(
        ; (perform (op initialize-stack))
        ; (goto (label read-eval-print-loop))
        (goto (label non-interactive-eval))
    
      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 cond?) (reg exp))
        (branch (label ev-cond-basic))
        (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))
        (test (op var-val-bound?) (reg val))
        (branch (label ev-variable-var-bound))
        (goto (label unbound-variable))
      ev-variable-var-bound
        (assign val (op var-val-extract-value) (reg val))
        (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)
        ;; first we evaluate the operator
        (assign exp (op operator) (reg exp))
        (assign continue (label ev-appl-did-operator))
        (goto (label eval-dispatch))
      
      ev-appl-did-operator
        (restore unev)              ; the operands
        (restore env)
        (assign argl (op empty-arglist))
        (assign proc (reg val))     ; the operator
        (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))
      
        ;; When an operand has been evaluated, the value is 
        ;; accumulated into the list held in argl. The operand 
        ;; is then removed from the list of unevaluated operands 
        ;; in unev, and the argument-evaluation continues.
        ;;
      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))
        
        ;; Evaluation of the last argument is handled differently. 
        ;; There is no need to save the environment or the list 
        ;; of unevaluated operands before going to eval-dispatch, 
        ;; since they will not be required after the last operand 
        ;; is evaluated. Thus, we return from the evaluation to a 
        ;; special entry point ev-appl-accum-last-arg, which 
        ;; restores the argument list, accumulates the new 
        ;; argument, restores the saved procedure, and goes off 
        ;; to perform the application.
        ;;
      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))
      
        ;; The entry point apply-dispatch corresponds to the 
        ;; apply procedure of the metacircular evaluator. By the 
        ;; time we get to apply-dispatch, the proc register 
        ;; contains the procedure to apply and argl contains the 
        ;; list of evaluated arguments to which it must be 
        ;; applied. The saved value of continue (originally 
        ;; passed to eval-dispatch and saved at ev-application), 
        ;; which tells where to return with the result of the 
        ;; procedure application, is on the stack. When the 
        ;; application is complete, the controller transfers to 
        ;; the entry point specified by the saved continue, with 
        ;; the result of the application in val. As with the 
        ;; metacircular apply, there are two cases to consider. 
        ;; Either the procedure to be applied is a primitive or 
        ;; it is a compound procedure.
        ;;
      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))
        
      ev-begin
        (assign unev (op begin-actions) (reg exp))
        (save continue)
        (goto (label ev-sequence))

        ;; The entries at ev-sequence and ev-sequence-continue 
        ;; form a loop that successively evaluates each 
        ;; expression in a sequence. The list of unevaluated 
        ;; expressions is kept in unev. Before evaluating each 
        ;; expression, we check to see if there are additional 
        ;; expressions to be evaluated in the sequence. If so, 
        ;; we save the rest of the unevaluated expressions 
        ;; (held in unev) and the environment in which these must 
        ;; be evaluated (held in env) and call eval-dispatch to 
        ;; evaluate the expression. The two saved registers 
        ;; are restored upon the return from this evaluation, 
        ;; at ev-sequence-continue.
        ;;
        ;; The final expression in the sequence is handled 
        ;; differently, at the entry point ev-sequence-last-exp. 
        ;; Since there are no more expressions to be evaluated 
        ;; after this one, we need not save unev or env before 
        ;; going to eval-dispatch. The value of the whole 
        ;; sequence is the value of the last expression, so 
        ;; after the evaluation of the last expression there is 
        ;; nothing left to do except continue at the entry point 
        ;; currently held on the stack (which was saved by 
        ;; ev-application or ev-begin.) Rather than setting up 
        ;; continue to arrange for eval-dispatch to return here 
        ;; and then restoring continue from the stack and 
        ;; continuing at that entry point, we restore continue 
        ;; from the stack before going to eval-dispatch, so that 
        ;; eval-dispatch will continue at that entry point after 
        ;; evaluating the expression.
        ;;
      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))

        ;; Before evaluating the predicate, we save the if 
        ;; expression itself so that we can later extract the 
        ;; consequent or alternative. We also save the 
        ;; environment, which we will need later in order to 
        ;; evaluate the consequent or the alternative, and we 
        ;; save continue, which we will need later in order 
        ;; to return to the evaluation of the expression that 
        ;; is waiting for the value of the if.
        ;;
      ev-if
        (save exp)                   ; save expression for later
        (save env)
        (save continue)
        (assign continue (label ev-if-decide))
        (assign exp (op if-predicate) (reg exp))
        (goto (label eval-dispatch)) ; evaluate the predicate
      
        ;; When we return from evaluating the predicate, we 
        ;; test whether it was true or false and, depending on 
        ;; the result, place either the consequent or the 
        ;; alternative in exp before going to eval-dispatch. 
        ;; Notice that restoring env and continue here sets 
        ;; up eval-dispatch to have the correct environment 
        ;; and to continue at the right place to receive the 
        ;; value of the if expression.
        ;;
      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))
      
        ;; Implemented as a derived expression, by converting
        ;; to a nested if
        ;;
      ev-cond
        (assign exp (op cond->if) (reg exp))
        (goto (label ev-if))
      
        ;; Implemented explicitly as a basic special form, 
        ;; without converting to a nested if
        ;;
      ev-cond-basic
        (assign unev (op cond-clauses) (reg exp))
      ev-cond-ev-clause
        (assign exp (op first-exp) (reg unev))
        (test (op cond-else-clause?) (reg exp))
        (branch (label ev-cond-action))
        (save exp)
        (save env)
        (save unev)
        (save continue)
        ;; Setup an evaluation of the clause predicate
        (assign exp (op cond-predicate) (reg exp))
        (assign continue (label ev-cond-clause-decide))
        (goto (label eval-dispatch))
        
      ev-cond-clause-decide
        (restore continue)
        (restore unev)
        (restore env)
        (restore exp)
        (test (op true?) (reg val))
        (branch (label ev-cond-action))
      ev-cond-next-clause
        (assign unev (op rest-exps) (reg unev))
        (goto (label ev-cond-ev-clause)) ; loop to next clause
        
        ;; We get here when the clause condition was found to
        ;; be true (or it was an 'else' clause), and we want
        ;; the actions to be evaluated. The clause is in exp.
        ;; We setup a call to ev-sequence and jump to it.
        ;;
      ev-cond-action
        (assign unev (op cond-actions) (reg exp))
        (save continue)
        (goto (label ev-sequence))
      
        ;; Assignments are handled by ev-assignment, which 
        ;; is reached from eval-dispatch with the assignment 
        ;; expression in exp. The code at ev-assignment first 
        ;; evaluates the value part of the expression and 
        ;; then installs the new value in the environment. 
        ;; set-variable-value! is assumed to be available 
        ;; as a machine operation.
        ;;
      ev-assignment
        (assign unev (op assignment-variable) (reg exp))
        (save unev)                     ; save variable for later
        (assign exp (op assignment-value) (reg exp))
        (save env)
        (save continue)
        (assign continue (label ev-assignment-1))
        (goto (label eval-dispatch))    ; evaluate the assignment value
      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))
      
        ;; Definitions are handled in a similar way:
        ;;
      ev-definition
        (assign unev (op definition-variable) (reg exp))
        (save unev)                   ; save variable for later
        (assign exp (op definition-value) (reg exp))
        (save env)
        (save continue)
        (assign continue (label ev-definition-1))
        (goto (label eval-dispatch))  ; evaluate the definition value
      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))
      
      unbound-variable
        (assign val (const unbound-variable-error))
        (goto (label signal-error))
      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))
        
      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))
      
      non-interactive-eval
        ; (perform (op initialize-stack))
        (test (op null?) (reg machine-args))
        (branch (label machine-end))
        (assign exp (op car) (reg machine-args))
        (assign machine-args (op cdr) (reg machine-args))
        (assign env (op get-global-environment))
        (assign continue (label non-interactive-eval))
        (goto (label eval-dispatch))
      
      machine-end
        (perform (op print-stack-statistics))
)))