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))