Work on 5.25

misc/sicp-eceval.scm

@@ -13,6 +13,7 @@
 
 ;: (start eceval)
 (load "misc/sicp-eceval-support.scm")
+(load "misc/sicp-leval.scm")
 
 ;; To restart, can do just
 ;: (start eceval)
@@ -92,6 +93,11 @@
    (list 'cond? cond?)
    (list 'let->combination let->combination)
    (list 'let? let?)
+
+   ;;5.25
+   (list 'delay-it delay-it)
+   (list 'thunk? thunk?)
+
    ))
 
 (define eceval
@@ -176,30 +182,62 @@ ev-appl-did-operator
   (test (op no-operands?) (reg unev))
   (branch (label apply-dispatch))
   (save proc)
-ev-appl-operand-loop
+
+  (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))
+
+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))
+  (branch (label ev-appl-last-arg-force))
   (save env)
   (save unev)
-  (assign continue (label ev-appl-accumulate-arg))
+  (assign continue (label ev-appl-accumulate-arg-force))
   (goto (label eval-dispatch))
-ev-appl-accumulate-arg
+ev-appl-accumulate-arg-force
   (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 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
+ev-appl-accum-last-arg-force
   (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 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 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))

misc/sicp-leval.scm

@@ -0,0 +1,92 @@
+;;;;LAZY EVALUATOR FROM SECTION 4.2 OF
+;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
+
+;;;;Matches code in ch4.scm
+;;;; Also includes enlarged primitive-procedures list
+
+;;;;This file can be loaded into Scheme as a whole.
+;;;;**NOTE**This file loads the metacircular evaluator of
+;;;;  sections 4.1.1-4.1.4, since it uses the expression representation,
+;;;;  environment representation, etc.
+;;;;  You may need to change the (load ...) expression to work in your
+;;;;  version of Scheme.
+;;;;**WARNING: Don't load mceval twice (or you'll lose the primitives
+;;;;  interface, due to renamings of apply).
+
+;;;;Then you can initialize and start the evaluator by evaluating
+;;;; the two lines at the end of the file ch4-mceval.scm
+;;;; (setting up the global environment and starting the driver loop).
+
+
+;;;;  To run without memoization, reload the first version of force-it below
+
+
+;;**implementation-dependent loading of evaluator file
+;;Note: It is loaded first so that the section 4.2 definition
+;; of eval overrides the definition from 4.1.1
+
+;;;SECTION 4.2.2
+
+;;; Modifying the evaluator
+
+(define (actual-value exp env)
+  (force-it (eval exp env)))
+
+(define (list-of-arg-values exps env)
+  (if (no-operands? exps)
+      '()
+      (cons (actual-value (first-operand exps) env)
+            (list-of-arg-values (rest-operands exps)
+                                env))))
+
+(define (list-of-delayed-args exps env)
+  (if (no-operands? exps)
+      '()
+      (cons (delay-it (first-operand exps) env)
+            (list-of-delayed-args (rest-operands exps)
+                                  env))))
+
+(define (eval-if exp env)
+  (if (true? (actual-value (if-predicate exp) env))
+      (eval (if-consequent exp) env)
+      (eval (if-alternative exp) env)))
+
+(define (force-it obj)
+  (if (thunk? obj)
+      (actual-value (thunk-exp obj) (thunk-env obj))
+      obj))
+
+;; thunks
+
+(define (delay-it exp env)
+  (list 'thunk exp env))
+
+(define (thunk? obj)
+  (and (pair? obj)
+       (= (length obj) 3)
+       (tagged-list? obj 'thunk)))
+
+(define (thunk-exp thunk) (cadr thunk))
+(define (thunk-env thunk) (caddr thunk))
+
+;; "thunk" that has been forced and is storing its (memoized) value
+(define (evaluated-thunk? obj)
+  (tagged-list? obj 'evaluated-thunk))
+
+(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
+
+;; memoizing version of force-it
+(define (force-it obj)
+  (cond ((thunk? obj)
+         (let ((result (actual-value
+                        (thunk-exp obj)
+                        (thunk-env obj))))
+           (set-car! obj 'evaluated-thunk)
+           (set-car! (cdr obj) result)  ; replace exp with its value
+           (set-cdr! (cdr obj) '())     ; forget unneeded env
+           result))
+        ((evaluated-thunk? obj)
+         (thunk-value obj))
+        (else obj)))
+
+'LAZY-EVALUATOR-LOADED