diff --git a/ex-4_31-34.scm b/ex-4_31-34.scm index 22f014e..6067e4e 100644 --- a/ex-4_31-34.scm +++ b/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")