SICP 問題 5.43

内部定義を吐き出してコンパイルする．
まず4.16で作ったscan-out-definesがこれ．

(define (scan-out-defines body)
  (define (split-defines proc-body defines non-defines)
    (cond ((null? proc-body)
           (cons (reverse defines) (reverse non-defines)))
          ((definition? (car proc-body))
           (split-defines (cdr proc-body)
                          (cons (car proc-body) defines) non-defines))
          (else (split-defines (cdr proc-body) defines (cons (car proc-body) non-defines)))))
  (let ((splits (split-defines body '() '())))
    (let ((defines (car splits))
          (non-defines (cdr splits)))
      (if (null? defines)
          non-defines
         (list (make-let (map (lambda (x) (list (definition-variable x) ''*unassigned*))
                              defines)
                         (append (map (lambda (x) (list 'set! (definition-variable x)
                                                        (definition-value x)))
                                      defines)
                                 non-defines)))))))

　
これをcompile-lambda-bodyで使う

(define (compile-lambda-body exp proc-entry ct-env)
  (let ((formals (lambda-parameters exp)))
    (append-instruction-sequences
     (make-instruction-sequence
      '(env proc argl) '(env)

      `(,proc-entry
        (assign env (op compiled-procedure-env) (reg proc))
        (assign env
                (op extend-environment)
                (const ,formals)
                (reg argl)
                (reg env))))
     ;; ここでscan-out-definesでlambda-bodyを変換してからcompile-sequenceに渡す
     (compile-sequence (scan-out-defines (lambda-body exp)) 'val 'return (cons formals ct-env)))))

　　
これはletに変換するのでcompileにletを追加する．

(define (compile exp target linkage ct-env)
  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage ct-env))
        ((assignment? exp)
         (compile-assignment exp target linkage ct-env))
        ((definition? exp)
         (compile-definition exp target linkage ct-env))
        ((if? exp) (compile-if exp target linkage ct-env))
        ((lambda? exp)
         (compile-lambda exp target linkage ct-env))
        ((let? exp)                           ; letの追加
         (compile (let->combination exp) target linkage ct-env))
        ((begin? exp)
         (compile-sequence (begin-actions exp)
                           target linkage ct-env))
        ((cond? exp) (compile (cond->if exp) target linkage ct-env))
        ((open-code? exp)               ;open-code?でdispatch
         (compile-open-code exp target linkage ct-env))
        ((application? exp)
         (compile-application exp target linkage ct-env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

test まずはscan-out-definesから．

gosh> (scan-out-defines (lambda-body '(lambda (a b)
                                        (define x 1)
                                        (define (y c) (+ x c))
                                        (+ a b y))))
((let
     ((x '*unassigned*)
      (y '*unassigned*))
   (set! x 1)
   (set! y (lambda (c) (+ x c)))
   (+ a b y)))

　
期待通りに動いている．
次にcompile．
コンパイル後の命令列を追ったのでコメントをつけた．

gosh> (compile '((lambda (a b)
                   (define x 1)
                   (define (y c) (+ x c))
                   (+ a b (y 2))) 5 6) 'val 'next '())
      ((env)
       (env proc argl continue val)
       ;; procにentry56の手続き
       ((assign proc (op make-compiled-procedure) (label entry56) (reg env))
        (goto (label after-lambda57))
        entry56
        (assign env (op compiled-procedure-env) (reg proc))
        ;; (a b)を(5 6)に対応して拡張
        (assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
        ;; proc: entry58
        (assign proc (op make-compiled-procedure) (label entry58) (reg env))
        (goto (label after-lambda59))
        entry58
        (assign env (op compiled-procedure-env) (reg proc))
        ;; (x y)に(*unassigned* *unassigned*)を対応付け
        (assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
        (assign val (const 1))
        ;; x のオブジェクトを1にする
        (perform (op lexical-address-set!) (const (0 0)) (reg val) (const ((x y) (a b))))
        (assign val (const ok))
        ;; val: entry60
        (assign val (op make-compiled-procedure) (label entry60) (reg env))
        (goto (label after-lambda61))
        entry60
        (assign env (op compiled-procedure-env) (reg proc))
        ;; ((c) (6))
        (assign env (op extend-environment) (const (c)) (reg argl) (reg env))
        ;; arg1: 1
        (assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((c) (x y) (a b))))
        ;; arg2: 2
        (assign arg2 (op lexical-address-lookup) (const (0 0)) (const ((c) (x y) (a b))))
        ;; val: (+ 1 2) = 3
        (assign val (op +) (reg arg1) (reg arg2))
        (goto (reg continue))
        after-lambda61
        ;; y <= entry60
        (perform (op lexical-address-set!) (const (0 1)) (reg val) (const ((x y) (a b))))
        (assign val (const ok))
        (save continue)                 ;aftercall71
        (assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((x y) (a b))))
        (assign arg2 (op lexical-address-lookup) (const (1 1)) (const ((x y) (a b))))
        (assign arg1 (op +) (reg arg1) (reg arg2)) ;(+ a b) =>(+ 5 6) => 11
        (assign proc (op lexical-address-lookup) (const (0 1)) (const ((x y) (a b))))
        (assign val (const 2))
        (assign argl (op list) (reg val)) ;argl: (2)
        (test (op primitive-procedure?) (reg proc))
        (branch (label primitive-branch62))
        compiled-branch63
        (assign continue (label proc-return65)) ;continue: proc-return65
        (assign val (op compiled-procedure-entry) (reg proc))
        (goto (reg val))
        proc-return65
        ;; arg2: 7
        (assign arg2 (reg val))
        (goto (label after-call64))
        primitive-branch62
        (assign arg2 (op apply-primitive-procedure) (reg proc) (reg argl))
        after-call64
        ;; val: (+ 11 3) = 14
        (assin val (op +) (reg arg1) (reg arg2))
        (restore continue)              ;aftercall71
        (goto (reg continue))
        after-lambda59
        (assign val (const *unassigned*))
        (assign argl (op list) (reg val))
        (assign val (const *unassigned*))
        (assign argl (op cons) (reg val) (reg argl)) ;argl: (*unassigned* *unassigned*)
        (test (op primitive-procedure?) (reg proc))
        (branch (label primitive-branch66))
        compiled-branch67
        (assign val (op compiled-procedure-entry) (reg proc)) ;val: entry58
        (goto (reg val))
        primitive-branch66
        (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
        (goto (reg continue))
        after-call68
        after-lambda57
        (assign val (const 6))          ;val: 6
        (assign argl (op list) (reg val)) ;argl: (6)
        (assign val (const 5))          ;val: 5
        (assign argl (op cons) (reg val) (reg argl)) ;argl: (5 6)
        (test (op primitive-procedure?) (reg proc)) ;no
        (branch (label primitive-branch69))
        compiled-branch70
        (assign continue (label after-call71)) ;continue: aftercall71
        (assign val (op compiled-procedure-entry) (reg proc)) ;val: entry56
        (goto (reg val))
        primitive-branch69
        (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
        after-call71                    ;val 14
        ))

期待通りに内部定義を吐き出してlambdaでunassignedとして受け取り，
bodyで実際の値（手続き）にset!している．