sicp-ex-4.31



<< Previous exercise (4.30) | Index | Next exercise (4.32) >>


Felix021

  
  
  
 (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) 
 ; 

atupal

 ; 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