sicp 4.16

[aa_niaofang]

代码所引用的其他部分可以在上一篇帖子中找到，这里只是贴出相关部分代码

;; procedure
(define (make-procedure parameters body env)
  (list 'procedure parameters  (scan-out-defines body) env))

;;;4.16 b) scan-out-defines
(define (scan-out-defines procedure-body)
  (define (unassigned-define defines)
    (map (lambda (x) 
           (list (definition-variable x) ''*unassigned*)) 
         defines))
  (define (set-defines defines)
    (map (lambda (x) 
           (list 'set! (definition-variable x) (definition-value x)))
           defines))
  (define (get-defines body)
    (if (pair? body)
        (if (definition? (car body))
            (cons (car body) (get-defines (cdr body)))
            '())
        '()))
  (define (not-defines body)
    (if (null? body)
        '()
        (if (pair? body)
            (if (definition? (car body))
                (not-defines (cdr body))
                body)
            '())))
  (define (connect head tail)
    (if (null? head)
        tail
        (cons (car head)
              (connect (cdr head) tail))))
  (if (null? (get-defines procedure-body))
      procedure-body
      (list (make-let (unassigned-define (get-defines procedure-body))
                (list (make-begin (connect (set-defines (get-defines procedure-body))
                                           (not-defines procedure-body))))))))