SICP/shared/sicp-eceval.scm

268 lines
7.4 KiB
Scheme
Raw Normal View History

; Copied and adapted from:
; https://mitpress.mit.edu/sites/default/files/sicp/code/index.html
2021-04-03 16:27:19 +02:00
2021-04-25 14:57:17 +02:00
(load "shared/sicp-eceval-support.scm")
2021-04-03 16:27:19 +02:00
; 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)
2021-04-03 16:27:19 +02:00
; 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.
2021-04-09 14:57:35 +02:00
(define eceval
(make-machine
'(exp env val proc argl continue unev)
eceval-operations
'(
ev-start
2021-04-09 14:57:35 +02:00
(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))
error-unbound-variable
(assign val (const error-unbound-variable))
(goto (label signal-error))
apply-primitive-error
(assign val (op apply-primitive-result) (reg val))
(goto (label signal-error))
2021-04-09 14:57:35 +02:00
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))
(test (op unbound-variable?) (reg val))
(branch (label error-unbound-variable))
2021-04-09 14:57:35 +02:00
(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-safe)
2021-04-09 14:57:35 +02:00
(reg proc)
(reg argl))
;(perform (op user-print) (reg val))
;(perform (op newline))
(test (op apply-primitive-error?) (reg val))
(branch (label apply-primitive-error))
(assign val (op apply-primitive-result) (reg val))
2021-04-09 14:57:35 +02:00
(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-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-begin
(assign unev (op begin-actions) (reg exp))
(save continue)
(goto (label ev-sequence))
2021-04-09 14:57:35 +02:00
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))
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))
)))
2021-04-03 16:27:19 +02:00
'(EXPLICIT CONTROL EVALUATOR LOADED)