Implement till 5.29 and separate regular and lazy eceval
parent
a7dfeac4ba
commit
59b58cfb9a
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
)))
|
||||
|
||||
|
|
@ -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?)
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue