Serendip

Web Studio

問題5.18

make-register 手続きをレジスタのトレースを行うように修正する。
問題5.16の命令トレースの場合と似たような処理となる。

(define (make-register name)
  (let ((contents '*unassigned*)
        (register-trace-flag #f))
       (define (set-register-trace flag)
         (set! register-trace-flag flag))
       (define (dispatch message)
         (cond ((eq? message 'get)
                (if register-trace-flag
                    (print "get register [" name "]: " contents))
                contents)
               ((eq? message 'set)
                (lambda (value)
                        (if register-trace-flag
                            (print "set register [" name "]: " contents " to " value))
                        (set! contents value)))
               ((eq? message 'trace-on) (set-register-trace #t))
               ((eq? message 'trace-off) (set-register-trace #f))
               (else
                 (error "Unknown request -- REGISTER" message))))
       dispatch))

(define (set-register-trace-flag machine register-name flag)
  ((get-register machine register-name) flag))

図5.11の階乗計算機でトレースを試してみる。

(define fact-machine
  (make-machine
    '(continue val n)
    (list (list '= =) (list '- -) (list '* *))
    '(start
       (assign continue (label fact-done))
  fact-loop
    (test (op =) (reg n) (const 1))
    (branch (label base-case))
    (save continue)
    (save n)
    (assign n (op -) (reg n) (const 1))
    (assign continue (label after-fact))
    (goto (label fact-loop))
  after-fact
    (restore n)
    (restore continue)
    (assign val (op *) (reg n) (reg val))
    (goto (reg continue))
  base-case
    (assign val (const 1))
    (goto (reg continue))
  fact-done)))

(fact-machine 'trace-on)
(set-register-trace-flag fact-machine 'n 'trace-on)
(set-register-trace-flag fact-machine 'val 'trace-on)
(set-register-contents! fact-machine 'n 3)
(start fact-machine)
(get-register-contents fact-machine 'val)

実行結果

gosh> set register [n]: *unassigned* to 3
done
gosh> label: start, instruction: (label start)
label: start, instruction: (assign continue (label fact-done))
label: fact-loop, instruction: (label fact-loop)
get register [n]: 3
label: fact-loop, instruction: (test (op =) (reg n) (const 1))
label: fact-loop, instruction: (branch (label base-case))
label: fact-loop, instruction: (save continue)
get register [n]: 3
label: fact-loop, instruction: (save n)
get register [n]: 3
set register [n]: 3 to 2
label: fact-loop, instruction: (assign n (op -) (reg n) (const 1))
label: fact-loop, instruction: (assign continue (label after-fact))
label: fact-loop, instruction: (goto (label fact-loop))
label: fact-loop, instruction: (label fact-loop)
get register [n]: 2
label: fact-loop, instruction: (test (op =) (reg n) (const 1))
label: fact-loop, instruction: (branch (label base-case))
label: fact-loop, instruction: (save continue)
get register [n]: 2
label: fact-loop, instruction: (save n)
get register [n]: 2
set register [n]: 2 to 1
label: fact-loop, instruction: (assign n (op -) (reg n) (const 1))
label: fact-loop, instruction: (assign continue (label after-fact))
label: fact-loop, instruction: (goto (label fact-loop))
label: fact-loop, instruction: (label fact-loop)
get register [n]: 1
label: fact-loop, instruction: (test (op =) (reg n) (const 1))
label: fact-loop, instruction: (branch (label base-case))
label: base-case, instruction: (label base-case)
set register [val]: *unassigned* to 1
label: base-case, instruction: (assign val (const 1))
label: base-case, instruction: (goto (reg continue))
label: after-fact, instruction: (label after-fact)
set register [n]: 1 to 2
label: after-fact, instruction: (restore n)
label: after-fact, instruction: (restore continue)
get register [n]: 2
get register [val]: 1
set register [val]: 1 to 2
label: after-fact, instruction: (assign val (op *) (reg n) (reg val))
label: after-fact, instruction: (goto (reg continue))
label: after-fact, instruction: (label after-fact)
set register [n]: 2 to 3
label: after-fact, instruction: (restore n)
label: after-fact, instruction: (restore continue)
get register [n]: 3
get register [val]: 2
set register [val]: 2 to 6
label: after-fact, instruction: (assign val (op *) (reg n) (reg val))
label: after-fact, instruction: (goto (reg continue))
label: fact-done, instruction: (label fact-done)
done
gosh> get register [val]: 6
6

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

posted with amazlet at 08.11.07

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

Amazon.co.jp で詳細を見る