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
|
(make-machine
|
||||||
'(exp env val proc argl continue unev)
|
'(exp env val proc argl continue unev)
|
||||||
eceval-operations
|
eceval-operations
|
||||||
|
@ -393,6 +395,245 @@ ev-thunk-before-done
|
||||||
(assign continue (label ev-done))
|
(assign continue (label ev-done))
|
||||||
(goto (label eval-dispatch))
|
(goto (label eval-dispatch))
|
||||||
ev-done
|
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)
|
'(EXPLICIT CONTROL EVALUATOR LOADED)
|
||||||
|
|
Loading…
Reference in New Issue