Implement till 5.28
parent
1851b11288
commit
a7dfeac4ba
|
|
@ -0,0 +1,145 @@
|
|||
(load "util.scm")
|
||||
(load "misc/sicp-regsim.scm")
|
||||
(load "misc/sicp-eceval.scm")
|
||||
|
||||
(define the-global-environment (setup-environment))
|
||||
(set-register-contents! eceval 'exp '(if false 1 2))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 2)
|
||||
|
||||
(display "\nex-5.23 - derived-expressions\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(cond
|
||||
((= 1 2) 0)
|
||||
((= 2 3) 1)
|
||||
((= 0 4) 2)
|
||||
(else 3)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 3)
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(begin
|
||||
(define (square x) (* x x))
|
||||
(let ((y (square 3)))
|
||||
y)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 9)
|
||||
|
||||
|
||||
(display "\nex-5.24 - cond-special-form\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(cond
|
||||
((= 2 1) 0)
|
||||
((= 2 3) 1)
|
||||
((= 0 4) 2)
|
||||
(else (* 2 5))))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 10)
|
||||
|
||||
(display "\nex-5.25 - lazy-evaluation\n")
|
||||
|
||||
(set-register-contents! eceval-lazy 'exp
|
||||
'(begin
|
||||
(define (try a b)
|
||||
(if (= a 0) 1 b))
|
||||
(try 0 (/ 1 0))))
|
||||
(start eceval-lazy)
|
||||
(assert (get-register-contents eceval-lazy 'val) 1)
|
||||
|
||||
|
||||
(display "\nex-5.26 - fact-iter-stack-analysis\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(begin
|
||||
(define (factorial n)
|
||||
(define (iter product counter)
|
||||
(if (> counter n)
|
||||
product
|
||||
(iter (* product counter) (+ counter 1))))
|
||||
(iter 1 1))
|
||||
(factorial 5)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 120)
|
||||
|
||||
; | 1 | 2 | 3 | 4 | 5 | n
|
||||
; |----|----|----|----|----|
|
||||
; | 10| 10| 10| 10| 10| depth
|
||||
; | 70| 105| 140| 175| 210| push count
|
||||
|
||||
; depth = 10
|
||||
; push-count = 35 * (n + 1)
|
||||
|
||||
(display "\nex-5.27 - fact-rec-stack-analysis\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(begin
|
||||
(define (factorial n)
|
||||
(if (= n 1)
|
||||
1
|
||||
(* n (factorial (- n 1)))))
|
||||
(factorial 5)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 120)
|
||||
|
||||
; | 1 | 2 | 3 | 4 | 5 | n
|
||||
; |----|----|----|----|----|
|
||||
; | 8| 11| 14| 17| 20| depth
|
||||
; | 22| 54| 86| 118| 150| push count
|
||||
|
||||
; depth = 5 + n * 3
|
||||
; push-count = 22 + (n - 1) * 32
|
||||
|
||||
(display "\nex-5.28 - fact-lazy-stack-analysis\n")
|
||||
|
||||
(set-register-contents! eceval-lazy 'exp
|
||||
'(begin
|
||||
(define (factorial n)
|
||||
(define (iter product counter)
|
||||
(if (> counter n)
|
||||
product
|
||||
(iter (* product counter) (+ counter 1))))
|
||||
(iter 1 1))
|
||||
(factorial 5)))
|
||||
(start eceval-lazy)
|
||||
(assert (get-register-contents eceval-lazy 'val) 120)
|
||||
|
||||
(set-register-contents! eceval-lazy 'exp
|
||||
'(begin
|
||||
(define (factorial n)
|
||||
(if (= n 1)
|
||||
1
|
||||
(* n (factorial (- n 1)))))
|
||||
(factorial 5)))
|
||||
(start eceval-lazy)
|
||||
(assert (get-register-contents eceval-lazy 'val) 120)
|
||||
|
||||
; | 1 | 2 | 3 | 4 | 5 | n
|
||||
; |----|----|----|----|----|
|
||||
; lazy-iter | 13| 18| 23| 28| 33| depth
|
||||
; | 61| 108| 171| 250| 345| push count
|
||||
; |----|----|----|----|----|
|
||||
; lazy-rec | 8| 16| 24| 32| 40| depth
|
||||
; | 21| 52| 99| 162| 241| push count
|
||||
|
||||
(display "\nex-5.29 - fib-stack-analysis\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(begin
|
||||
(define (fib n)
|
||||
(if (< n 2)
|
||||
n
|
||||
(+ (fib (- n 1)) (fib (- n 2)))))
|
||||
(fib 7)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 13)
|
||||
|
||||
; | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 |
|
||||
; |----|----|----|----|----|----|----|----|----|----|
|
||||
; | | | | | | | | | | | depth
|
||||
; | | | | | | | | | | | push count
|
||||
|
||||
(display "\nex-5.30\n")
|
||||
|
||||
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
(load "util.scm")
|
||||
(load "misc/sicp-regsim.scm")
|
||||
(load "misc/sicp-eceval.scm")
|
||||
|
||||
(define the-global-environment (setup-environment))
|
||||
(set-register-contents! eceval 'exp '(if false 1 2))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 2)
|
||||
|
||||
(display "\nex-5.23 - derived-expressions\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(cond
|
||||
((= 1 2) 0)
|
||||
((= 2 3) 1)
|
||||
((= 0 4) 2)
|
||||
(else 3)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 3)
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(begin
|
||||
(define (square x) (* x x))
|
||||
(let ((y (square 3)))
|
||||
y)))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 9)
|
||||
|
||||
|
||||
(display "\nex-5.24 - cond-special-form\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(cond
|
||||
((= 2 1) 0)
|
||||
((= 2 3) 1)
|
||||
((= 0 4) 2)
|
||||
(else (* 2 5))))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 10)
|
||||
|
||||
(display "\nex-5.25 - lazy-evaluation\n")
|
||||
|
||||
(set-register-contents! eceval 'exp
|
||||
'(begin
|
||||
(define (try a b)
|
||||
(if (= a 0) 1 b))
|
||||
(try 0 (/ 1 0))))
|
||||
(start eceval)
|
||||
(assert (get-register-contents eceval 'val) 1)
|
||||
|
||||
(display "\nex-5.26\n")
|
||||
|
||||
|
|
@ -102,7 +102,9 @@
|
|||
|
||||
))
|
||||
|
||||
(define eceval
|
||||
; 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
|
||||
|
|
@ -393,6 +395,245 @@ ev-thunk-before-done
|
|||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue