<< Previous exercise (4.30) | Index | Next exercise (4.32) >>
(include "4.2.2.scm") ;;comment (driver-loop) in 4.2.2.scm ;; omit the "lazy-memo" requirement for simplicity... (define (apply procedure arguments env) (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure (list-of-arg-values arguments env))) ((compound-procedure? procedure) (eval-compound-procedure procedure arguments env)) (else (error "Unknown procedure type -- APPLY" procedure)))) (define (eval-compound-procedure procedure arguments env) (define (iter-args formal-args actual-args) (if (null? formal-args) '() (cons (let ((this-arg (car formal-args))) (if (and (pair? this-arg) (pair? (cdr this-arg)) ; avoid error if arg is ; 1 element list. (eq? (cadr this-arg) 'lazy)) (delay-it (car actual-args) env) ;force the argument if it is not lazy. (actual-value (car actual-args) env))) (iter-args (cdr formal-args) (cdr actual-args))))) (define (procedure-arg-names parameters) (map (lambda (x) (if (pair? x) (car x) x)) parameters)) (eval-sequence (procedure-body procedure) (extend-environment (procedure-arg-names (procedure-parameters procedure)) (iter-args (procedure-parameters procedure) arguments) (procedure-environment procedure)))) (driver-loop) ;; test ;; ; ; M-Eval input: ;(define x 1) ; ; M-Eval value: ;ok ; ; M-Eval input: ;(define (p (e lazy)) e x) ; ; M-Eval value: ;ok ; ; M-Eval input: ;(p (set! x (cons x '(2)))) ; ; M-Eval value: ;1 ; ; M-Eval input: ;(exit) ;
; start Exercise 4.31 (define (procedure-parameters-ex4.31 p) (define (name parameter) (if (pair? parameter) (car parameter) parameter)) (define (parameter-names parameters) (if (null? parameters) '() (cons (name (car parameters)) (parameter-names (cdr parameters))))) (parameter-names (cadr p))) (define (procedure-raw-parameters p) (cadr p)) (define (apply-ex4.31 procedure arguments env) (cond [(primitive-procedure? procedure) (apply-primitive-procedure procedure (list-of-arg-values arguments env))] ; changed ((compound-procedure? procedure) (eval-sequence (procedure-body procedure) (extend-environment (procedure-parameters procedure) (list-of-delayed-args (procedure-raw-parameters procedure) arguments env) (procedure-environment procedure)))) ; changed (else (error "Unknow procedure type: APPLY" procedure)))) (define (list-of-delayed-args-ex4.31 raw_parameters exps env) (define (arg-value raw_parameter exp) (if (pair? raw_parameter) (cond ((eq? (cadr raw_parameter) 'lazy) (delay-it-no-memo exp env)) ((eq? (cadr raw_parameter) 'lazy-memo) (delay-it exp env)) (else (error "Unknow parameter type LIST-OF-DELAYED-ARGS:" (cadr raw_parameter)))) (actual-value exp env))) (if (no-operands? exps) '() (cons (arg-value (car raw_parameters) (first-operand exps)) (list-of-delayed-args-ex4.31 (cdr raw_parameters) (rest-operands exps) env)))) (define (delay-it-no-memo exp env) (list 'thunk-no-memo exp env)) (define (thunk-no-memo? obj) (tagged-list? obj 'thunk-no-memo)) (define (force-it-ex4.31 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) '()) result)) ((evaluated-thunk? obj) (thunk-value obj)) ((thunk-no-memo? obj) (actual-value (thunk-exp obj) (thunk-env obj))) (else obj))) ; forget unneeded env (define apply apply-ex4.31) (define force-it force-it-ex4.31) (define procedure-parameters procedure-parameters-ex4.31) (define list-of-delayed-args list-of-delayed-args-ex4.31) ;(define (id x) ; (set! count (+ count 1)) x) ; ; (define count 0) ; ; (define (square x) (* x x)) ; ; (square (id 10)) ; ; count ; 1 ; ; (define count 0) ; ; (define (square (x lazy)) (* x x)) ; ; (square (id 10)) ; ; count ; 2 ; ; (define count 0) ; ; (define (square (x lazy-memo)) (* x x)) ; ; (square (id 10)) ; ; count ; 1 ; end exercise 4.31
I prefer to implement the lazy and lazy-memo as expressions, and the thunk selection funtions still work because the lazy and lazy-memo are still thunk, which I just change its tag.
;; the expression of lazy and lazy-memo (define (lazy-parameter? p) (and (pair? p) (eq? (cadr p) 'lazy) (null? (cddr p)))) (define (lazy-memo-parameter? p) (and (pair? p) (eq? (cadr p) 'lazy-memo) (null? (cddr p)))) (define (lazy? obj) (tagged-list? obj 'lazy)) (define (lazy-memo? obj) (tagged-list? obj 'lazy-memo)) (define (eval-lazy-memo? obj) (tagged-list? obj 'eval-lazy-memo)) (define (delay-lazy exp env) (list 'lazy exp env)) (define (delay-lazy-memo exp env) (list 'lazy-memo exp env)) (define (force-it obj) (cond ((lazy? obj) (actual-value (thunk-exp obj) (thunk-env obj))) ((lazy-memo? obj) (let ((result (actual-value (thunk-exp obj) (thunk-env obj)))) (set-car! obj 'eval-lazy-memo) (set-car! (cdr obj) result) (set-cdr! (cdr obj) '()) result)) ((eval-lazy-memo? obj) (thunk-value obj)) (else obj))) (define (actual-value exp env) (force-it (eval exp env))) ;; change some details (define (apply procedure arguments env) (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure (list-of-arg-values arguments env))) ((compound-procedure? procedure) (let ((parameters (procedure-parameters procedure))) (eval-sequence (procedure-body procedure) (extend-environment (rib-statements parameters) ; changed (list-of-delayed-args parameters arguments env) ; (procedure-environment procedure))))) (else (error "Unknown procedure type -- APPLY" procedure)))) (define (rib-statements parameters) (if (null? parameters) '() (let ((first (car parameters)) (rest (cdr parameters))) (cond ((or (lazy-parameter? first) (lazy-memo-parameter? first)) (cons (car first) (rib-statements rest))) ((variable? first) (cons first (rib-statements rest))) (else (error "Bad Syntax" first)))))) (define (list-of-delayed-args paras exps env) ; changed (if (no-operands? exps) '() (cons (cond ((lazy-parameter? (car paras)) (delay-lazy (first-operand exps) env)) ((lazy-memo-parameter? (car paras)) (delay-lazy-memo (first-operand exps) env)) (else (eval (first-operand exps) env))) (list-of-delayed-args (cdr paras) (rest-operands exps) env))))
the other things remain the same.
mceval.scm and leval.scm can be downloaded from "Complete Code from SICP 2/e"
The following procedures were written by modifying existing procedures or adding new procedures. I will mark it (modified? or added?) with comments.
;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; for mceval.scm;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (procedure-parameters p) (map (lambda (x) (if (pair? x) (car x) x)) (cadr p))) ;;; modified ;;; return a list of keywords consisting of three elements(active, lazy or lazy-memo) (define (procedure-keywords p) (map (lambda (x) (if (pair? x) (cadr x) 'active)) (cadr p))) ;;; added ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; for leval.scm;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (apply procedure operands env) (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure (list-of-arg-values operands env))) ((compound-procedure? procedure) (eval-sequence (procedure-body procedure) (extend-environment (procedure-parameters procedure) (list-of-keyworded-args procedure operands env) ; changed (procedure-environment procedure)))) (else (error "Unknown procedure type -- APPLY" procedure)))) ;; modified ;;; return a list of arguments in which the operation to an operand depends on its corresponding keyword, which is either transforming it into a thunk or evaluating its value directly. (define (list-of-keyworded-args procedure exps env) (let loop ([keywords (procedure-keywords procedure)] [operands exps] [reversed-keyworded-args '()]) (cond [(null? keywords) (reverse reversed-keyworded-args)] [(eq? (car keywords) 'lazy) (loop (cdr keywords) (cdr operands) (cons (delay-it-nonmemo (first-operand operands) env) reversed-keyworded-args))] [(eq? (car keywords) 'lazy-memo) (loop (cdr keywords) (cdr operands) (cons (delay-it-memo (first-operand operands) env) reversed-keyworded-args))] [(eq? (car keywords) 'active) (loop (cdr keywords) (cdr operands) (cons (actual-value (first-operand operands) env) reversed-keyworded-args))] [else (error "Unknown keyword" (car keywords))]))) ;; added ;;; Representing thunks ;; non-memoizing version of force-it (define (force-it-nonmemo obj) (actual-value (thunk-exp obj) (thunk-env obj))) ;; added ;; memoizing version of force-it (define (force-it-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)) ;; added ;; thunks (define (delay-it-memo exp env) (list 'thunk-memo exp env)) ;; added (define (delay-it-nonmemo exp env) (list 'thunk-nonmemo exp env)) ;; added (define (thunk-memo? obj) (tagged-list? obj 'thunk-memo)) ;; added (define (thunk-nonmemo? obj) (tagged-list? obj 'thunk-nonmemo)) ;; added ;; generalized version of force-it (define (force-it obj) (cond ((thunk-memo? obj) (force-it-memo obj)) ((thunk-nonmemo? obj) (force-it-nonmemo obj)) ((evaluated-thunk? obj) (thunk-value obj)) (else obj))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;; test;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;; ;;;;lazy;;;; ;;;;;;;;;;;; ;;; L-Eval input: (define (try a (b lazy)) (if (= a 0) 1 b)) ;;; L-Eval value: ok ;;; L-Eval input: (try 0 1) ;;; L-Eval value: 1 ;;; L-Eval input: (try 0 (/ 1 0)) ;;; L-Eval value: 1 ;;;;;;;;;;;;;;;; ;;; lazy-memo;;; ;;;;;;;;;;;;;;;; ;;; L-Eval input: (define (try a (b lazy-memo)) (if (= a 0) 1 b)) ;;; L-Eval value: ok ;;; L-Eval input: (try 0 (/ 1 0)) ;;; L-Eval value: 1 ;;;;;;;;;;;;;;;; ;;; non-lazy;;;; ;;;;;;;;;;;;;;;; ;;; L-Eval input: (define (try a b) (if (= a 0) 1 b)) ;;; L-Eval value: ok ;;; L-Eval input: (try 0 (/ 1 0)) Exception in /: undefined for 0
Modification based on 4.2.2 in the book
(define normal 'normal) (define lazy 'lazy) (define lazy-memo 'lazy-memo) (define (is-lazy-memo? thunk) (tagged-list? thunk lazy-memo)) (define (is-lazy? thunk) (tagged-list? thunk lazy)) (define (type-arg arg) (if (pair? arg) (let ((type (cadr arg))) (cond ((eq? type lazy) lazy) ((eq? type lazy-memo) lazy-memo) (else (error "Unknown parameter type -- TYPE-ARG" type)))) normal)) (define (get-arg arg) (if (pair? arg) (car arg) arg)) (define (list-of-delayed-args types exps env) (if (no-operands? exps) '() (let ((first (first-operand exps)) (type (car types))) (cons (if (eq? normal type) (eval- first env) (cons type (delay-it first env))) (list-of-delayed-args (cdr types) (rest-operands exps) env))))) (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 (map get-arg (procedure-parameters procedure)) (list-of-delayed-args (map type-arg (procedure-parameters procedure)) arguments env) (procedure-environment procedure)))) (else (error "Unknown procedure type -- APPLY" procedure)))) (define (force-it-memo obj) (cond ((thunk? obj) (let ((result (actual-value (thunk-exp obj) (thunk-env obj)))) (set-car! obj 'evaluated-thunk) (set-car! (cdr obj) result) (set-cdr! (cdr obj) '()) result)) ((evaluated-thunk? obj) (thunk-value obj)) (else obj))) (define (actual-value exp- env) (let ((result (eval- exp- env))) (cond ((is-lazy-memo? result) (force-it-memo (cdr result))) ((is-lazy? result) (force-it (cdr result))) (else result))))
Ordinary procedure definitions bind names to lambda expressions, which are then evaluated to procedure objects. I make a definition of the form:
(define (foo x (y lazy) (z lazy-memo)) ...)
bind foo to a "lazy-lambda" expression of the form
(lazy-lambda (x y z) (strict lazy lazy-memo) ...)
which evaluates to a "lazy-procedure" object of the same shape. For upwards compatibility, procedure definitions with no lazy arguments are bound to ordinary lambdas.
;; Changes to definition evluation (define (definition-value exp) (cond ((symbol? (cadr exp)) (caddr exp)) ((contains-lazy-args? (cadr exp)) (make-lazy-lambda (arg-names (cdadr exp)) (arg-lazinesses (cdadr exp)) (cddr exp))) (else (make-lambda (cdadr exp) (cddr exp))))) (define (contains-lazy-args? exp) (cond ((null? exp) #f) ((pair? (car exp)) #t) (else (contains-lazy-args? (cdr exp))))) (define (arg-names exp) (cond ((null? exp) '()) ((pair? (car exp)) (cons (caar exp) (arg-names (cdr exp)))) (else (cons (car exp) (arg-names (cdr exp)))))) (define (arg-lazinesses exp) (cond ((null? exp) '()) ((pair? (car exp)) (if (memq (cadar exp) '(strict lazy lazy-memo)) (cons (cadar exp) (arg-lazinesses (cdr exp))) (error ("Unrecognized laziness:" (cadar exp))))) (else (cons 'strict (arg-lazinesses (cdr exp)))))) ;; Lazy lambdas (define (lazy-lambda? exp) (tagged-list? exp 'lazy-lambda)) ;; As with lambda, the body is a list (define (make-lazy-lambda vars lazinesses body) (cons 'lazy-lambda (cons vars (cons lazinesses body)))) (define (lazy-lambda-parameters exp) (cadr exp)) (define (lazy-lambda-lazinesses exp) (caddr exp)) (define (lazy-lambda-body exp) (cdddr exp)) ;; Lazy procedures ;; procedure-body and procedure-environment are modified for the new case (define (lazy-compound-procedure? procedure) (tagged-list? procedure 'lazy-procedure)) (define (make-lazy-procedure vars lazinesses body env) (list 'lazy-procedure vars lazinesses body env)) (define (procedure-parameters p) (cadr p)) (define (procedure-lazinesses p) (if (lazy-compound-procedure? p) (caddr p) (error "Attempted to lazily evaluate non-lazy procedure" p))) (define (procedure-body p) (if (lazy-compound-procedure? p) (cadddr p) (caddr p))) (define (procedure-environment p) (if (lazy-compound-procedure? p) (car (cddddr p)) (cadddr p))) ;; Forcing and delaying (define (actual-value exp env) (force-it (evaln 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 lazinesses env) (if (no-operands? exps) '() (cons (maybe-delay-it (first-operand exps) (car lazinesses) env) (list-of-delayed-args (rest-operands exps) (cdr lazinesses) env)))) (define (maybe-delay-it exp laziness env) (cond ((eq? laziness 'strict) (actual-value exp env)) ((eq? laziness 'lazy) (list 'thunk exp env)) ((eq? laziness 'lazy-memo) (list 'memoizable-thunk exp env)) (else (error "Unrecognized laziness for arg:" exp laziness)))) (define (memoizable-thunk? obj) (tagged-list? obj 'memoizable-thunk)) (define (force-it obj) (cond ((thunk? obj) (actual-value (thunk-exp obj) (thunk-env obj))) ((memoizable-thunk? obj) (let ((result (actual-value (thunk-exp obj) (thunk-env obj)))) (set-car! obj 'evaluated-thunk) (set-car! (cdr obj) result) (set-cdr! (cdr obj) '()) result)) ((evaluated-thunk? obj) (thunk-value obj)) (else obj))) ;; Evaluator core (define (evaln-lazy-optional 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-lazy exp env)) ;; retained from lazy evaluator ((lambda? exp) (make-procedure (lambda-parameters exp) (lambda-body exp) env)) ((lazy-lambda? exp) (make-lazy-procedure (lazy-lambda-parameters exp) (lazy-lambda-lazinesses exp) (lazy-lambda-body exp) env)) ;; new ((begin? exp) (eval-sequence (begin-actions exp) env)) ((cond? exp) (evaln (cond->if exp) env)) ((and? exp) (evaln (and->if exp) env)) ((or? exp) (evaln (or->if exp) env)) ((not? exp) (evaln (not->if exp) env)) ((let? exp) (evaln (let->combination exp) env)) ((let*? exp) (evaln (let*->nested-lets exp) env)) ((letrec? exp) (evaln (letrec->let exp) env)) ((while? exp) (evaln (while->recursion exp) env)) ((for? exp) (evaln (for->while exp) env)) ((unless? exp) (evaln (unless->if exp) env)) ((application? exp) (applyn (actual-value (operator exp) env) (operands exp) env)) (else (error "Unknown expression type: EVAL" exp)))) (define (applyn-lazy-optional 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 procedure) (list-of-arg-values arguments env) (procedure-environment procedure)))) ((lazy-compound-procedure? procedure) (eval-sequence (procedure-body procedure) (extend-environment (procedure-parameters procedure) (list-of-delayed-args arguments (procedure-lazinesses procedure) env) (procedure-environment procedure)))) (else (error "Unknown procedure type: APPLYN" procedure)))) (define evaln evaln-lazy-optional) (define applyn applyn-lazy-optional)
woofy