Serendip

Web Studio

問題5.42

(define (compile exp target linkage ct-env)
  ;; 省略
        ((variable? exp)
         (compile-variable exp target linkage ct-env))
  ;; 省略
        (else
          (error "Unknown expression type -- COMPILE" exp))))

(define (compile-variable exp target linkage ct-env)
  (let ((addr (find-variable exp ct-env)))
       (end-with-linkage
         linkage
         (make-instruction-sequence
           '(env)
           (list target)
           (if (eq? addr 'not-found)
               `((assign ,target
                         (op lookup-variable-value)
                         (const ,exp)
                         (reg env)))
               `((assign ,target
                         (op lexical-address-lookup)
                         (const ,addr)
                         (reg env))))))))

(define (compile-assingment exp target linkage ct-env)
  (let ((var (assignment-variable exp))
        (get-value-code
          (compile (assignment-value exp) 'val 'next ct-env)))
       (let ((addr (find-variable var ct-env)))
            (end-with-linkage
              linkage
              (preserving
                '(env)
                get-value-code
                (make-instruction-sequence
                  '(env val)
                  (list target)
                  (if (eq? addr 'not-found)
                      `((perform (op set-variable-value!)
                                 (const ,var)
                                 (reg val)
                                 (reg env))
                        (assign ,target (const ok)))
                      `((perform (op lexical-address-set!)
                                 (const ,addr)
                                 (reg val)
                                 (reg env))
                            (assign ,target (const ok))))))))))

以下の入れ子の lambda 式でテストしてみる。

(parse-compiled-code
  (compile
    '(lambda (x y)
             (lambda (a b)
                     (+
                       (+ x a)
                       (* y b)
                       (set! x a)
                       (set! z b))))
    'val
    'next
    '()))

実行結果

(env)
(val)
  (assign val (op make-compiled-procedure) (label entry1) (reg env))
  (goto (label after-lambda2))
entry1
  (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 entry3) (reg env))
  (goto (reg continue))
entry3
  (assign env (op compiled-procedure-env) (reg proc))
  (assign env (op extend-environment) (const (a b)) (reg argl) (reg env))
  (assign proc (op lookup-variable-value) (const +) (reg env))
  (save continue)
  (save proc)
  (assign val (op lexical-address-lookup) (const (0 1)) (reg env))
  (perform (op set-variable-value!) (const z) (reg val) (reg env))
  (assign val (const ok))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (0 0)) (reg env))
  (perform (op lexical-address-set!) (const (1 0)) (reg val) (reg env))
  (assign val (const ok))
  (assign argl (op cons) (reg val) (reg argl))
  (save env)
  (save argl)
  (assign proc (op lookup-variable-value) (const *) (reg env))
  (assign val (op lexical-address-lookup) (const (0 1)) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (1 1)) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch8))
compiled-branch9
  (assign continue (label after-call10))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch8
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call10
  (restore argl)
  (assign argl (op cons) (reg val) (reg argl))
  (restore env)
  (save argl)
  (assign proc (op lookup-variable-value) (const +) (reg env))
  (assign val (op lexical-address-lookup) (const (0 0)) (reg env))
  (assign argl (op list) (reg val))
  (assign val (op lexical-address-lookup) (const (1 0)) (reg env))
  (assign argl (op cons) (reg val) (reg argl))
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch5))
compiled-branch6
  (assign continue (label after-call7))
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch5
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
after-call7
  (restore argl)
  (assign argl (op cons) (reg val) (reg argl))
  (restore proc)
  (restore continue)
  (test (op primitive-procedure?) (reg proc))
  (branch (label primitive-branch11))
compiled-branch12
  (assign val (op compiled-procedure-entry) (reg proc))
  (goto (reg val))
primitive-branch11
  (assign val (op apply-primitive-procedure) (reg proc) (reg argl))
  (goto (reg continue))
after-call13
after-lambda4
after-lambda2

計算機プログラムの構造と解釈

posted with amazlet at 08.11.07

ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 6542

Amazon.co.jp で詳細を見る