2016/02/09
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
))