Clean up

shared/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