Serendip

Web Studio

問題5.47

元の翻訳系では翻訳した手続きが合成手続き（解釈される手続き）を呼び出せない。

$ gosh
gosh> (load "./ece4compiler.scm")
#t
(compile-and-go
  '(begin
     (define (g x) (+ x 10))
     (define (f x) (g x))))

(total-pushes = 0 max-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1) ; <= 翻訳した手続き g を呼び出す

(total-pushes = 5 max-depth = 3)
;;; EC-Eval value:
11

;;; EC-Eval input:
(define (g x) (+ x 20)) ; <= 合成手続きを定義する

(total-pushes = 3 max-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1) ; <= 合成手続き g の呼び出しに失敗する
*** ERROR: pair required, but got x
Stack Trace:
_______________________________________
  0  (instruction-execution-proc (car insts))
        At line 129 of "./register_machine.scm"
  1  (instruction-execution-proc (car insts))
        At line 129 of "./register_machine.scm"
gosh>

compile-proc-appl と同様の条件分岐を追加する。
compound-apply に移動するために continue を退避させる。

(define (compile-procedure-call target linkage)
  (let ((primitive-branch (make-label 'primitive-branch))
        (compiled-branch (make-label 'compiled-branch))
        (after-call (make-label 'after-call)))
       (let ((compiled-linkage
               (if (eq? linkage 'next) after-call linkage)))
            (append-instruction-sequences
              (make-instruction-sequence '(proc) '()
                                         `((test (op primitive-procedure?) (reg proc))
                                           (branch (label ,primitive-branch))))
              (make-instruction-sequence '(proc) '()
                                         `((test (op compiled-procedure?) (reg proc))
                                           (branch (label ,compiled-branch))))
              (parallel-instruction-sequences
                (cond ((and (eq? target 'val) (not (eq? compiled-linkage 'return)))
                       (make-instruction-sequence '(proc)all-regs
                                                  `((assign continue (label ,compiled-linkage))
                                                    (save continue)
                                                    (goto (reg compapp)))))
                      ((and (not (eq? target 'val))
                            (not (eq? compiled-linkage 'return)))
                       (let ((proc-return (make-label 'proc-return)))
                            (make-instruction-sequence '(proc) all-regs
                                                       `((assign continue (label ,proc-return))
                                                         (save continue)
                                                         (goto (reg compapp))
                                                         ,proc-return
                                                         (assign ,target (reg val))
                                                         (goto (label ,compiled-linkage))))))
                      ((and (eq? target 'val) (eq? compiled-linkage 'return))
                       (make-instruction-sequence '(proc continue) all-regs
                                                  '((save continue)
                                                    (goto (reg compapp)))))
                      ((and (not (eq? target 'val)) (eq? compiled-linkage 'return))
                       (error "return linkage, target not val -- COMPILE"
                              target)))
                (parallel-instruction-sequences
                  (append-instruction-sequences
                    compiled-branch
                    (compile-proc-appl target compiled-linkage))
                  (append-instruction-sequences
                    primitive-branch
                    (end-with-linkage linkage
                                      (make-instruction-sequence '(proc argl)
                                                                 (list target)
                                                                 `((assign ,target
                                                                           (op apply-primitive-procedure)
                                                                           (reg proc)
                                                                           (reg argl))))))))
                after-call))))

compapp レジスタの追加と初期化コードを加える。

(define eceval
  (make-machine
    '(exp env val proc argl continue unev compapp)
    eceval-operations
    '(
        (assign compapp (label compound-apply))
        (branch (label external-entry)) ; flag が設定してあれば分岐する
      read-eval-print-loop
      ;; 省略

実行結果

$ gosh
gosh> (load "./ece4compiler.scm")
#t
(compile-and-go
  '(begin
     (define (g x) (+ x 10))
     (define (f x) (g x))))

(total-pushes = 0 max-depth = 0)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1) ; <= 翻訳した手続き g を呼び出す

(total-pushes = 5 max-depth = 3)
;;; EC-Eval value:
11

;;; EC-Eval input:
(define (g x) (+ x 20)) ; <= 合成手続きを定義する

(total-pushes = 3 max-depth = 3)
;;; EC-Eval value:
ok

;;; EC-Eval input:
(f 1) ; <= 合成手続き g を呼び出す

(total-pushes = 14 max-depth = 5)
;;; EC-Eval value:
21

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

posted with amazlet at 08.11.07

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

Amazon.co.jp で詳細を見る