SICP 問題 5.44

基本手続きの名前を含む式の正しいコードを翻訳するため，翻訳時環境を調べるようにする．

  (cond ((self-evaluating? exp)
         (compile-self-evaluating exp target linkage))
        ((variable? exp)
         (compile-variable exp target linkage ct-env))
        ((quoted? exp) (compile-quoted exp target linkage))
        ((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)
         (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 ct-env)           ;ct-envも渡して翻訳時環境に上書きされていないか調べる
         (compile-open-code exp target linkage ct-env))
        ((application? exp)
         (compile-application exp target linkage ct-env))
        (else
         (error "Unknown expression type -- COMPILE" exp))))

(define (not-overwrite? op ct-env)
  (let ((address (find-variable op ct-env )))
    (eq? address 'not-found)))

(define (open-code? exp ct-env)
  (and (memq (car exp) '(= * - +))
       (not-overwrite? (car exp) ct-env)))

test

((env)
 (val)
 ((assign val (op make-compiled-procedure) (label entry14) (reg env))
  (goto (label after-lambda15))
  entry14
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (+ * a b x y)) (reg argl) (reg env))
  (assign proc (op lexical-address-lookup) (const (0 0)) (const ((+ * a b x y)))) ;;ここで+を探すのにct-envの中身から探しているので成功.open-codeになっていない．
  (save continue)
  (save proc)
  (assign proc (op lexical-address-lookup) (const (0 1)) (const ((+ * a b x y))))
  (assign val (op lexical-address-lookup) (const (0 5)) (const ((+ * a b x y))))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (0 3)) (const ((+ * a b x y))))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch19))
  compiled-branch20
  (assign continue (label after-call21))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch19
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call21
  (assign argl (op list) (reg val))
  (save argl)
  (assign proc (op lexical-address-lookup) (const (0 1)) (const ((+ * a b x y))))
  (assign val (op lexical-address-lookup) (const (0 4)) (const ((+ * a b x y))))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (0 2)) (const ((+ * a b x y))))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch16))
  compiled-branch17
  (assign continue (label after-call18))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch16
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  after-call18
  (restore argl)
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch22))
  compiled-branch23
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
  primitive-branch22
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
  after-call24
  after-lambda15
  ))