Serendip

Web Studio

問題5.17

make-new-machine に label 変数を追加する。
instruction リストに 'label が存在する場合は advance-pc で次の命令へと進める。
execute で instruction リストの car が 'label かどうかをチェックし、'label の場合は label 変数に値をセットし、'label でない場合は instruction-count 変数をインクリメントする。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        ;; 省略
        (label '()) ;; ex5.17
        (the-instruction-sequence '()))
        ;; 省略
            (define (execute)
              (let ((insts (get-contents pc)))
                   (if (null? insts)
                       'done
                       (begin
                         ((instruction-execution-proc (car insts)))
                         (if (not (eq? (caaar insts) 'label)) ;; ex5.17
                             (set! instruction-count (+ 1 instruction-count))
                             (set! label (cadr (caar insts))))
                         (if instruction-trace-flag
                             (print "label: " label ", instruction: " (caar insts)))
                         (execute)))))
        ;; 省略
            dispatch)))

(define (extract-labels text receive)
  (if (null? text)
      (receive '() '())
      (extract-labels (cdr text)
                      (lambda (insts labels)
                              (let ((next-inst (car text)))
                                   (if (symbol? next-inst)
                                       (if (assoc next-inst labels)
                                           (error "Multiply defined label: " next-inst)
                                           (let ((insts
                                                   (cons (list (list 'label next-inst)) insts))) ;; ex5.17
                                                (receive insts
                                                         (cons (make-label-entry next-inst
                                                                                 insts)
                                                               labels))))
                                       (receive (cons (make-instruction next-inst)
                                                      insts)
                                                labels)))))))

(define (make-execution-procedure inst labels machine
                                  pc flag stack ops)
  ;; 省略
        ((eq? (car inst) 'label) ;; ex5.17
         (lambda () (advance-pc pc)))
        (else (error "Unknown instruction type -- ASSEMBLE"
                     inst))))

図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-contents! fact-machine 'n 3)
(start fact-machine)
(get-register-contents fact-machine 'val)

実行結果

gosh> label: start, instruction: (label start)
label: start, instruction: (assign continue (label fact-done))
label: fact-loop, instruction: (label fact-loop)
label: fact-loop, instruction: (test (op =) (reg n) (const 1))
label: fact-loop, instruction: (branch (label base-case))
label: fact-loop, instruction: (save continue)
label: fact-loop, instruction: (save n)
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)
label: fact-loop, instruction: (test (op =) (reg n) (const 1))
label: fact-loop, instruction: (branch (label base-case))
label: fact-loop, instruction: (save continue)
label: fact-loop, instruction: (save n)
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)
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)
label: base-case, instruction: (assign val (const 1))
label: base-case, instruction: (goto (reg continue))
label: after-fact, instruction: (label after-fact)
label: after-fact, instruction: (restore n)
label: after-fact, instruction: (restore continue)
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)
label: after-fact, instruction: (restore n)
label: after-fact, instruction: (restore continue)
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> 6

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

posted with amazlet at 08.11.07

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

Amazon.co.jp で詳細を見る