sicp-ex-4.16

  
  
  
 ; a 
 (define (lookup-variable-value var env) 
     (define (env-loop env) 
         (define (scan vars vals) 
             (cond ((null? vars) (env-loop (enclosing-environment env))) 
                   ((eq? var (car vars))  
                    (if (eq? '*unassigned* (car vals)) 
                        (error "Variable Unassigned -- LOOKUP-VARIABLE-VALUE" var) 
                        (car vals))) 
                   (else (scan (cdr vars) (cdr vals))))) 
         (if (eq? env the-empty-environment) 
             (error "Unbound variable" var) 
             (let ((frame (first-frame env))) 
                 (scan (frame-variables frame) 
                       (frame-values frame))))) 
     (env-loop env)) 
  
 ; b 
 (define (make-let bingings body) 
     (cons 'let (cons bindigs body))) 
  
 (define (make-assignment var exp) 
     (list 'set! var exp)) 
  
 (define (scan-out-defines body) 
  
     (define (collect seq defs exps) 
         (if (null? seq) 
             (cons defs exps) 
             (if (definition? (car seq)) 
                 (collect (cdr seq) (cons (car seq) defs) exps) 
                 (collect (cdr seq) defs (cons (car seq) exps))))) 
  
     (let ((pair (collect body '() '()))) 
         (let ((defs (car pair)) (exps (cdr pair))) 
             (make-let (map (lambda (def)  
                                 (list (definition-variable def)  
                                       '*unassigned*)) 
                            defs) 
                       (append  
                         (map (lambda (def)  
                                 (make-assignment (definition-variable def) 
                                                  (definition-value def))) 
                              defs) 
                         exps))))) 
  
 ; c  
 ; make-procedure is better because we can easily explore other transformations 
 ; along with the fact of repeated calculation everytime when procedure-body is accessed 
  
 (define (make-procedure parameters body env) 
     (list 'procedure parameters (scan-out-defines body) env)) 
  
 or  
  
 (define (make-procedure-with-transformation transformation) 
     (define (make-procedure parameters body env) 
         (list 'procedure parameters (transformation body) env)) 
     make-procedure) 

  
  
  
 ;; a, change look-up-variable-value 
 (define (lookup-variable-value var env) 
         (define (env-lookup env) 
                 (define (scan vars vals) 
                         (cond ((null? vars) (env-lookup (enclosing-environment env))) 
                                   ((eq? var (car vars))  
                                    (if (eq? (car vals) '*unassigned*) 
                                            (error "variable is unassigned" var) 
                                            (car vals))) 
                                   (else (scan (cdr vars) (cdr vals))))) 
                 (if (eq? env the-empty-environment) 
                         (error "Unbound variable" var) 
                         (let ((frame (first-frame env))) 
                                 (scan (frame-variables frame) 
                                           (frame-values frame))))) 
         (env-lookup env)) 
  
  
 ;; b 
 (define (scan-out-defines body) 
         (define (name-unassigned defines) 
                 (map (lambda (x) (list (definition-variable x) '*unassigned*)) defines)) 
         (define (set-values defines) 
                 (map (lambda (x)  
                                         (list 'set! (definition-variable x) (definition-value x)))  
                          defines)) 
         (define (defines->let exprs defines not-defines) 
                 (cond ((null? exprs)  
                            (if (null? defines) 
                                    body 
                                    (list (list 'let (name-unassigned defines)  
                                                                 (make-begin (append (set-values defines)  
                                                                                                 (reverse not-defines))))))) 
                       ((definition?(car exprs)) 
                            (defines->let (cdr exprs) (cons (car exprs) defines) not-defines)) 
                           (else (defines->let (cdr exprs) defines (cons (car exprs) not-defines))))) 
         (defines->let body '() '())) 
  
 ;; c 
 install scan-out-defines into make-procedure. otherwise, when we call procedure-body, procedure scan-out-defines will be called. 

Why move all set! before any other expressions? The book seems not require that.

  
  
 ; Start Exercise 4.16 
 ;a 
 (define (lookup-variable-value-4.16a var env) 
   (define (env-loop env) 
     (define (scan vars vals) 
       (cond ((null? vars) 
              (env-loop (enclosing-enviroment env))) 
             ((eq? var (car vars)) (car vals)) 
             (else (scan (cdr vars) (cdr vals))))) 
     (if (eq? env the-empty-environment) 
       (error "Unbound variable" var) 
       (let ((frame (first-frame env))) 
         (scan (frame-variables frame) 
               (frame-values frame))))) 
   (let ((value (env-loop env))) 
     (if (eq? value '*unassigned*) 
       (error "Unassigned varable: *unassigned*") 
       value))) 
 (define lookup-variable-value lookup-variable-value-4.16a) 
 ;b 
 (define (split-body-out-defines body) 
   (if (null? body) 
     (let ((defines '()) 
           (others  '())) 
       (cons defines others)) 
     (let ((exp (car body)) 
           (rest (split-body-out-defines (cdr body)))) 
       (if (definition? exp) 
         (cons (cons exp (car rest)) (cdr rest)) 
         (cons (car rest) (cons exp (cdr rest))))))) 
 (define (make-let varvals body) 
   (list 'let varvals body)) 
 (define (defines->let-defines-body defines) 
   (if (null? defines) 
     (let ((let-defines '()) 
           (let-body    '())) 
       (cons let-defines let-body)) 
     (let* ((rest-let-defines-body (defines->let-defines-body (cdr defines))) 
            (rest-defines (car rest-let-defines-body)) 
            (rest-body    (cdr rest-let-defines-body)) 
            (name  (definition-variable (car defines))) 
            (value (definition-value    (car defines))) 
            (current-define (list name ''*unassigned*)) 
            (current-body   (list 'set! name value))) 
       (cons (cons current-define rest-defines) 
             (cons current-body   rest-body))))) 
 (define (scan-out-defines procedure-body) 
   (let* ((splited-body (split-body-out-defines procedure-body)) 
          (defines (car splited-body)) 
          (others  (cdr splited-body)) 
          (let-defines-body (defines->let-defines-body defines))) 
     (list (append (list 'let 
                         (car let-defines-body)) 
                   (append (cdr let-defines-body) 
                           others))))) 
 ;c 
 (define (contain-defines exps) 
   (if (null? exps) 
     false 
     (or (if (definition? (car exps)) 
           true 
           false) 
         (contain-defines (cdr exps))))) 
 (define (make-procedure-ex4.16 parameters body env) 
   (if (contain-defines body) 
     (list 'procedure parameters (scan-out-defines body) env) 
     (list 'procedure parameters body env))) 
 (define make-procedure make-procedure-ex4.16) 
  
  

 ;;;note that if there aren't any definitions at all,you have to keep the original form of procedure body,otherwise an infinite recursion will be caused. 
 ;;;consider the evaluating of (let () 5),which is very interesting 
 (define (make-let bindings body) 
   (cons 'let (cons bindings body))) 
 (define (scan-out-defines body) 
   (define (append x y) 
     (if (null? x) y (cons (car x) (append (cdr x) y)))) 
   (let* ((definitions 
            (filter (lambda (x) 
                      (and (pair? x) (eq? (car x) 'define))) body)) 
          (non-definitions 
           (filter (lambda (x) 
                     (or (not (pair? x)) 
                         (not (eq? (car x) 'define)))) body)) 
          (let-vars (map definition-variable definitions)) 
          (let-vals (map definition-value definitions)) 
          (let-bindings 
           (map (lambda (x) (list x ''*unassigned*)) let-vars)) 
          (assignments 
           (map (lambda (x y) (list 'set! x y)) let-vars let-vals))) 
     (if (null? let-bindings) 
         body 
         (list (make-let let-bindings (append assignments non-definitions)))))) 

  
 (define (make-let vars body) 
   (if (null? vars) 
       body 
       (let ((inlet (map (lambda (x) (list (car x) ''*unassigned)) vars)) 
             (sets (map (lambda (x) (list 'set! (car x) (cdr x))) vars))) 
           (list (append (list 'let inlet) (append sets body)))))) 
 (define (scan-out-defines body) 
   (define (iter vars rest body) 
     (cond ((null? body) 
            (make-let vars rest)) 
           ((definition? (car body)) 
            (iter (append vars (list (cons (definition-variable (car body)) 
                                           (definition-value (car body))))) 
                  rest (cdr body))) 
           (else  
            (iter vars  
                  (append rest (list (car body))) 
                  (cdr body))))) 
   (iter '() '() body)) 
  

be careful if there's no definition. (let () <body>) will cause infinitely recurse.

I don't know where you all got the impression that (let () <body>) causes an infinite recursion... It's ugly but it definitely does not do any such thing. I tried it on four different Scheme implementations and all of them evaluate such an expression correctly. In fact (let () <body>) is exactly equivalent to ((lambda () <body>)), which is absolutely fine. Also seeing as it's just an internal representation it doesn't really matter how ugly it is. It is still valid to want to reserve the original procedure, just not necessary. Please correct me if I'm wrong.

Here's my solution:

 ;; a 
 (define (lookup-variable-value var env) 
   (search-environment var 
                       env 
                       (lambda (res) (and res (if (eq? res '*unassigned*) 
                                                  (error "Unassigned variable" var) 
                                                  (cdr res)))) 
                       (lambda () (lookup-variable-value var (enclosing-environment env))) 
                       "Unbound variable")) 
  
 ;; b 
 (define (scan-out-defines proc-body) 
   (define (iter exps vars) 
     (if (null? exps) 
         vars 
         (let ((this-exp (car exps))) 
           (if (definition? this-exp) 
               (iter (cdr exps) (cons (cons (definition-variable this-exp) 
                                            (list (definition-value this-exp))) 
                                      vars)) 
               (iter (cdr exps) vars))))) 
   (let* ((body (lambda-body proc-body)) 
          (vars (reverse (iter body '())))) 
     (make-lambda (lambda-parameters proc-body) 
                  (list (make-let (map (lambda (x) (list (car x) ''*unassigned*)) vars) 
                                  (append (map (lambda (x) (list 'set! (car x) (cadr x))) vars) 
                                         (filter (lambda (x) (not (definition? x))) body))))))) 
  
 ;; c 
 (define (make-procedure parameters body env) 
   (list 'procedure parameters (scan-out-defines body) env))