Exercise 5.25.  Modify the evaluator so that it uses normal-order 
evaluation, based on the lazy evaluator of section 4.2.

————————————————————————————————————————————————————————————————————————

The evaluation of simple expressions is unchanged.

Procedure application however needs to be changed so that arguments to a 
procedure are stored as a thunk, but not forced until the procedure 
actually needs to use them.

1 ]=> (define the-global-environment (setup-environment))

;Value: the-global-environment

1 ]=> (start eceval)


;;; L-Eval input:
(define (try a b) (if (= a 0) 1 b))

(total-pushes = 3 maximum-depth = 3)
;;; L-Eval value:
ok

;;; L-Eval input:
(try 0 (/ 1 0))

(total-pushes = 19 maximum-depth = 9)
;;; L-Eval value:
1

From section 4.2:

Exercise 4.28.  Eval uses actual-value rather than eval to evaluate the 
operator before passing it to apply, in order to force the value of the 
operator. Give an example that demonstrates the need for this forcing.

Similarly here, we must force in ev-application before testing the 
procedure type, here is an example that demonstrates this:

;;; L-Eval input:
(define (ap f x) (f x))

(total-pushes = 3 maximum-depth = 3)
;;; L-Eval value:
ok

;;; L-Eval input:
(ap (lambda (x) (+ x x)) 2)

(total-pushes = 19 maximum-depth = 6)
;;; L-Eval value:
4


Code is in 5.25-load-eceval.scm, 5.25-eceval.scm, and 
5.25-eceval-support.scm.

This implementation does not do memoization, though it would be 
trivial to add, in the same way as was done in section 4.2.


Here are the main changed sections in eceval:

[ ... ]

   ;;operations in eceval-support.scm
   (list 'true? true?)
   (list 'make-procedure make-procedure)
   (list 'compound-procedure? compound-procedure?)
   (list 'procedure-parameters procedure-parameters)
   (list 'procedure-body procedure-body)
   (list 'procedure-environment procedure-environment)
   (list 'extend-environment extend-environment)
   (list 'lookup-variable-value lookup-variable-value)
   (list 'set-variable-value! set-variable-value!)
   (list 'define-variable! define-variable!)
   (list 'primitive-procedure? primitive-procedure?)
   (list 'apply-primitive-procedure apply-primitive-procedure)
   (list 'prompt-for-input prompt-for-input)
   (list 'announce-output announce-output)
   (list 'user-print user-print)
   (list 'empty-arglist empty-arglist)
   (list 'adjoin-arg adjoin-arg)
   (list 'last-operand? last-operand?)
   (list 'no-more-exps? no-more-exps?)	;for non-tail-recursive machine
   (list 'get-global-environment get-global-environment)
   (list 'thunk? thunk?)
   (list 'make-thunk make-thunk)
   (list 'thunk-exp thunk-exp)
   (list 'thunk-env thunk-env))
   )

(define eceval
  (make-machine
   '(exp env val proc argl continue unev)
   eceval-operations
  '(
;;SECTION 5.4.4
read-eval-print-loop
  (perform (op initialize-stack))
  (perform
   (op prompt-for-input) (const ";;; L-Eval input:"))
  (assign exp (op read))
  (assign env (op get-global-environment))
  (assign continue (label print-result))
  (goto (label eval-forcing))

[ ... ]

;;SECTION 5.4.1
eval-forcing
  (test (op thunk?) (reg exp))
  (branch (label force-thunk))
  (test (op variable?) (reg exp))
  (branch (label ev-variable-forcing))
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 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-variable-forcing
  (assign exp (op lookup-variable-value) (reg exp) (reg env))
  (test (op thunk?) (reg exp))
  (branch (label force-thunk))
  (assign val (reg exp))
  (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-forcing))
ev-appl-did-operator
  (restore unev)
  (restore env)
  (assign proc (reg val))
  (assign argl (op empty-arglist))
  (test (op primitive-procedure?) (reg proc))
  (branch (label ev-appl-force-operands))
  (test (op compound-procedure?) (reg proc))
  (branch (label ev-appl-thunkify-operands))
  (goto (label unknown-procedure-type))
ev-appl-thunkify-operands
  (test (op no-operands?) (reg unev))
  (branch (label compound-apply))
  (assign exp (op first-operand) (reg unev))
  (assign val (op make-thunk) (reg exp) (reg env))
  (assign argl (op adjoin-arg) (reg val) (reg argl))
  (assign unev (op rest-operands) (reg unev))
  (goto (label ev-appl-thunkify-operands))
ev-appl-force-operands
  (test (op no-operands?) (reg unev))
  (branch (label primitive-apply))
  (assign exp (op first-operand) (reg unev))
  (save continue)
  (save env)
  (save proc)
  (save unev)
  (save argl)
  (assign continue (label ev-appl-forced-operand))
  (goto (label eval-forcing))
ev-appl-forced-operand
  (restore argl)
  (restore unev)
  (restore proc)
  (restore env)
  (restore continue)
  (assign argl (op adjoin-arg) (reg val) (reg argl))
  (assign unev (op rest-operands) (reg unev))
  (goto (label ev-appl-force-operands))

force-thunk
  ;(save env)
  ;(save continue)
  (assign env (op thunk-env) (reg exp))
  (assign exp (op thunk-exp) (reg exp))
  (goto (label eval-forcing))

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-if
  (save exp)
  (save env)
  (save continue)
  (assign continue (label ev-if-decide))
  (assign exp (op if-predicate) (reg exp))
  (goto (label eval-forcing))

[ ... ]

The changes made to eceval-support:

--- ch5-eceval-support.scm	2010-04-22 11:09:43.000000000 -0600
+++ 5.25-eceval-support.scm	2010-05-09 01:10:05.000000000 -0600
@@ -185,3 +185,10 @@
 (define (compiled-procedure-entry c-proc) (cadr c-proc))
 (define (compiled-procedure-env c-proc) (caddr c-proc))
 
+
+;;; Thunk operations for exercise 5.25
+(define thunk-tag (list 'this-is-a-thunk))
+(define (thunk? exp) (and (pair? exp) (eq? (car exp) thunk-tag)))
+(define (make-thunk exp env) (list thunk-tag exp env))
+(define thunk-exp cadr)
+(define thunk-env caddr)