Implement 4.31

ex-4_31-34.scm

@@ -3,32 +3,140 @@
 
 (display "\nex-4.31 - explicit-laziness\n")
 
-; Exercise 4.31.  The approach taken in this section is somewhat unpleasant,
-; because it makes an incompatible change to Scheme. It might be nicer to
-; implement lazy evaluation as an upward-compatible extension, that is, so that
-; ordinary Scheme programs will work as before. We can do this by extending the
-; syntax of procedure declarations to let the user control whether or not
-; arguments are to be delayed. While we're at it, we may as well also give the
-; user the choice between delaying with and without memoization. For example,
-; the definition
+(define (parameter-qualifier parameter)
+  (if (pair? parameter) (cadr parameter) 'none))
 
-;(define (f a (b lazy) c (d lazy-memo))
-;  ...)
+(define (parameter-symbol parameter)
+  (if (pair? parameter) (car parameter) parameter))
 
-; would define f to be a procedure of four arguments, where the first and third
-; arguments are evaluated when the procedure is called, the second argument is
-; delayed, and the fourth argument is both delayed and memoized. Thus, ordinary
-; procedure definitions will produce the same behavior as ordinary Scheme,
-; while adding the lazy-memo declaration to each parameter of every compound
-; procedure will produce the behavior of the lazy evaluator defined in this
-; section. Design and implement the changes required to produce such an
-; extension to Scheme. You will have to implement new syntax procedures to
-; handle the new syntax for define. You must also arrange for eval or apply to
-; determine when arguments are to be delayed, and to force or delay arguments
-; accordingly, and you must arrange for forcing to memoize or not, as
-; appropriate.
+(define (proecure-parameters p) (cadr p))
+
+(define (procedure-parameters-only p)
+  (map parameter-symbol (cadr p)))
+
+(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 (eval exp env)
+  (cond ((self-evaluating? exp) exp)
+        ((variable? exp) (lookup-variable-value exp env))
+        ((quoted? exp) (text-of-quotation exp))
+        ((assignment? exp) (eval-assignment exp env))
+        ((definition? exp) (eval-definition exp env))
+        ((if? exp) (eval-if exp env))
+        ((lambda? exp)
+         (make-procedure (lambda-parameters exp)
+                         (lambda-body exp)
+                         env))
+        ((begin? exp)
+         (eval-sequence (begin-actions exp) env))
+        ((cond? exp) (eval (cond->if exp) env))
+        ((application? exp)
+         (apply (actual-value (operator exp) env)
+                (operands exp)
+                env))
+        (else
+         (error "Unknown expression type -- EVAL" exp))))
+
+(define (delay-arguments parameters arguments env)
+  (define (parameter->arg parameter arg)
+    (let ((qualifier (parameter-qualifier parameter)))
+      (cond
+        ((eq? qualifier 'none) (actual-value arg env))
+        ((eq? qualifier 'lazy) (delay-it arg env))
+        ((eq? qualifier 'lazy-memo) (delay-it-memo arg env))
+        (else (error "unsupported qualifier -- PARAMETER->ARG" qualifier)))))
+  (map parameter->arg parameters arguments))
+
+(define (apply procedure arguments env)
+  (cond ((primitive-procedure? procedure)
+         (apply-primitive-procedure
+          procedure
+          (list-of-arg-values arguments env)))
+        ((compound-procedure? procedure)
+         (eval-sequence
+           (procedure-body procedure)
+           (extend-environment
+             (procedure-parameters-only procedure)
+             (delay-arguments (procedure-parameters procedure) arguments env)
+             (procedure-environment procedure))))
+        (else
+         (error
+          "Unknown procedure type -- APPLY" procedure))))
+
+(define (actual-value exp env)
+  (force-it (eval exp env)))
+
+(define (force-it obj)
+  (if (thunk? obj)
+      (actual-value (thunk-exp obj) (thunk-env obj))
+      obj))
+
+(define (delay-it exp env)
+  (list 'thunk exp env))
+
+(define (delay-it-memo exp env)
+  (list 'thunk-memo exp env))
+
+(define (thunk? obj)
+  (or (tagged-list? obj 'thunk)
+      (tagged-list? obj 'thunk-memo)))
+
+(define (thunk-regular? obj)
+  (tagged-list? obj 'thunk))
+
+(define (thunk-memo? obj)
+  (tagged-list? obj 'thunk-memo))
+
+(define (thunk-exp thunk) (cadr thunk))
+
+(define (thunk-env thunk) (caddr thunk))
+
+(define (evaluated-thunk? obj)
+  (tagged-list? obj 'evaluated-thunk))
+
+(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
+
+(define (force-it obj)
+  (cond ((thunk-memo? 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))
+        ((thunk-regular? obj)
+         (actual-value (thunk-exp obj) (thunk-env obj)))
+        (else obj)))
+
+(let ((the-global-environment (setup-environment)))
+  (eval '(define count 0) the-global-environment)
+  (eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
+  (eval '(define (square (y lazy-memo)) (* y y)) the-global-environment)
+  (assert (eval '(square (id 10)) the-global-environment) 100)
+  (assert (eval 'count the-global-environment) 1))
+
+(let ((the-global-environment (setup-environment)))
+  (eval '(define count 0) the-global-environment)
+  (eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
+  (eval '(define (square (y lazy)) (* y y)) the-global-environment)
+  (assert (eval '(square (id 10)) the-global-environment) 100)
+  (assert (eval 'count the-global-environment) 2))
+
+(let ((the-global-environment (setup-environment)))
+  (eval '(define count 0) the-global-environment)
+  (eval '(define (id x) (set! count (+ count 1)) x) the-global-environment)
+  (eval '(define (square y) (* y y)) the-global-environment)
+  (assert (eval '(square (id 10)) the-global-environment) 100)
+  (assert (eval 'count the-global-environment) 1))
+
+(display "\nex-4.32\n")
 
-; (display "\nex-4.32\n")
 ; (display "\nex-4.33\n")
 ; (display "\nex-4.34\n")