2016/02/09
SICP 問題 5.42
compile-variableとcompile-assignmentを文面アドレスを使った検索に対応
(define (compile-variable exp target linkage ct-env)
(let ((address (find-variable exp ct-env)))
(end-with-linkage
linkage
(if (eq? address 'not-found)
(make-instruction-sequence
'(env) (list target)
;; targetなら変更しても問題ないので一時的に帯域環境を入れる
`((assign ,target (op get-global-environment))
(assign ,target
(op lookup-variable-value)
(const ,exp)
(reg ,target))))
(make-instruction-sequence
'() (list target)
`((assign ,target
(op lexical-address-lookup)
(const ,address)
(reg env))))))))
(define (compile-assignment exp target linkage ct-env)
(let ((var (assignment-variable exp))
(get-value-code ;valを求めるための命令.
(compile (assignment-value exp) 'val 'next ct-env)))
(let ((address (find-variable var ct-env)))
(end-with-linkage
linkage
(append-instruction-sequences
get-value-code ;代入する値を求め,valに代入される.seq1
;; valに代入された値をvarに代入する.seq2
(if (eq? address 'not-found)
(make-instruction-sequence
'(env val)
(list target)
;; 一度targetにglobal-environmentを代入してからsetする
`((assign target (op get-global-environment))
(perform (op set-variable-value!)
(const ,var)
(reg val)
(reg ,target))
(assign ,target (const ok))))
(make-instruction-sequence
'(env val)
(list target)
`((perform (op lexical-address-set!)
(const ,address)
(reg val)
(reg env))
(assign ,target (const ok))))))))))
test
このschemeの式自体はバグってる.
ただし,test自体は出来るのでそのまま
gosh> (compile
'(lambda (x y)
(lambda (a b)
(+
(+ x a)
(* y b)
(set! x a) ;; +の中でset!してるので 'okが返ってバグる
(set! z b))))
'val
'next
'())
((env)
(val)
((assign val (op make-compiled-procedure) (label entry24) (reg env))
(goto (label after-lambda25))
entry24
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (x y)) (reg argl) (reg env))
(assign val (op make-compiled-procedure) (label entry26) (reg env))
(goto (reg continue))
entry26
(assign env (op compiled-procedure-env) (reg proc))
(assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
(assign arg1 (op lexical-address-lookup) (const (1 0)) (const ((a b) (x y))))
(assign arg2 (op lexical-address-lookup) (const (0 0)) (const ((a b) (x y))))
(assign arg1 (op +) (reg arg1) (reg arg2))
(save arg1)
(assign arg1 (op lexical-address-lookup) (const (1 1)) (const ((a b) (x y))))
(assign arg2 (op lexical-address-lookup) (const (0 1)) (const ((a b) (x y))))
(assign arg2 (op *) (reg arg1) (reg arg2))
(restore arg1)
(assign arg1 (op +) (reg arg1) (reg arg2))
(assign val (op lexical-address-lookup) (const (0 0)) (const ((a b) (x y))))
(perform (op lexical-address-set!) (const (1 0)) (reg val) (const ((a b) (x y))))
(assign arg2 (const ok)) ;; arg2 = ok
(assign arg1 (op +) (reg arg1) (reg arg2)) ;; (+ arg1 ok)なのでバグる
(assign val (op lexical-address-lookup) (const (0 1)) (const ((a b) (x y))))
(assign env (op get-global-environment))
(perform (op set-variable-value!) (const z) (reg val) (reg env))
(assign arg2 (const ok))
(assin val (op +) (reg arg1) (reg arg2))
(goto (reg continue))
after-lambda27
after-lambda25))