SICP 読み (267) 5.2 レジスタ計算機での計算

意識を失なう前に色々検討。

問題 5.15

最初は advance-pc かと思ったんですが、goto とか branch からは呼ばれない。それなら make-* で inst-ctr みたいなソレを increase かのぅ、とも思ったのですが面倒スギ。で、リストを睨んでいた所 make-new-machine の start メセジを受ける部分に解があると見た。ってーか execute か。
これでイケるのかどうかは微妙ながらも試験を検討してとりあえず以下のソレをでっち上げた。

(use gauche.test)

(add-load-path ".")
(load "ch5-regsim")

(test-start "5.15")

(test-section "fact")
(let ((m (make-machine '(n continue val)
		       (list (list '= =)
			     (list '- -)
			     (list '* *))
		       '(controller
			 (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))))
  (set-register-contents! m 'n 1)
  (start m)
  (test* "inst-ctr" 5 (m 'get-inst-ctr))
  )

(test-end)

2 とか 3 とかヤラないと、なんですが (以下略
で、make-new-machine 限定で修正なソレが以下。

(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
	(inst-ctr 0) ;; 5.15
        (the-instruction-sequence '()))
    (let ((the-ops
           (list (list 'initialize-stack
                       (lambda () (stack 'initialize)))
                 ;;**next for monitored stack (as in section 5.2.4)
                 ;;  -- comment out if not wanted
                 (list 'print-stack-statistics
                       (lambda () (stack 'print-statistics)))))
          (register-table
           (list (list 'pc pc) (list 'flag flag))))
      (define (init-inst-ctr) ;; 5.15
	(set! inst-ctr 0))    ;; 5.15
      (define (get-inst-ctr)  ;; 5.15
	inst-ctr)             ;; 5.15
      (define (allocate-register name)
        (if (assoc name register-table)
            (error "Multiply defined register: " name)
            (set! register-table
                  (cons (list name (make-register name))
                        register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
              (cadr val)
              (error "Unknown register:" name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (begin
                ((instruction-execution-proc (car insts)))
		(set! inst-ctr (+ inst-ctr 1)) ;; 5.15
                (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
	      ((eq? message 'init-inst-ctr) (init-inst-ctr))
	      ((eq? message 'get-inst-ctr) (get-inst-ctr))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

1 な試験にはパス。わははは的。branch をカウントするのがわからず、微妙にハマりましたが、追加の試験が以下。

(test-section "fact")
(let ((m (make-machine '(n continue val)
		       (list (list '= =)
			     (list '- -)
			     (list '* *))
		       '(controller
			 (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))))
  (set-register-contents! m 'n 1)
  (start m)
  (test* "inst-ctr" 5 (m 'get-inst-ctr))

  (m 'init-inst-ctr)
  (set-register-contents! m 'n 2)
  (start m)
  (test* "inst-ctr" 16 (m 'get-inst-ctr))

  (m 'init-inst-ctr)
  (set-register-contents! m 'n 3)
  (start m)
  (test* "inst-ctr" 27 (m 'get-inst-ctr))

  (m 'init-inst-ctr)
  (set-register-contents! m 'n 4)
  (start m)
  (test* "inst-ctr" 38 (m 'get-inst-ctr))
  )

楽できたのでちょっと嬉しい。このまま調子に乗って次もヤるかも。