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

ええと、問題 5.11 の c. の要求を控えとく。

レジスタ毎にスタックを確保
initialize-stack で全ての stack を初期化

これを材料に実装を検討。
うーん。関連するであろう手続きも控えてみる。

(define (make-machine register-names ops controller-text)
  (let ((machine (make-new-machine)))
    (for-each (lambda (register-name)
                ((machine 'allocate-register) register-name))
              register-names)
    ((machine 'install-operations) ops)    
    ((machine 'install-instruction-sequence)
     (assemble controller-text machine))
    machine))

上記の手続きでレジスタを確保した後で initialize-stack すれば良いのかな。でも make-new-machine 先頭にて stack をローカルに確保していらっしゃる。
allocate-register 手続きの中でレジスタ名な stack を作れば良いのだろうか。ざっくりベースでこんな感じ??

先頭の let で (stack-table '()) を確保
allocate-register でレジスタ名な stack を作成
stack-table に ('名前スタック) なリストを cons で追加

後は

initialize-stack
make-save と make-resotre

を修正で良いのかなぁ。machine に lookup な手続きの追加も必要か。今から試験の検討をぼちぼちヤる予定ですが、微妙に DRY 違反な感じもするなぁ。register-table に stack も追加した方が良いのかなぁ。そしたら既存な手続きへの影響も大きそげ。

つづき

以下の

(define (get-register machine reg-name)
  ((machine 'get-register) reg-name))

と lookup-register を上手にナニしてやれば良さげな感じかも。でも get-stack な手続きの定義は必要か。

実装的にこんな感じ

(define (get-register machine reg-name)
  ((machine 'get-register) 'reg reg-name))
(define (get-stack machine reg-name)
  ((machine 'get-register) 'stack reg-name))

でこう

      (define (lookup-register sw name)
        (let ((val (assoc name register-table)))
          (if val
	      (if (eq? sw 'reg)
		  (cadr val)
		  (caddr val))
              (error "Unknown register:" name))))

やんのと get-* を以下にしておいて

(define (get-register machine reg-name)
  ((machine 'get-register) #t reg-name))
(define (get-stack machine reg-name)
  ((machine 'get-register) #f reg-name))

こう評価するのは

      (define (lookup-register sw name)
        (let ((val (assoc name register-table)))
          (if val
	      (if (sw)
		  (cadr val)
		  (caddr val))
              (error "Unknown register:" name))))

どっちが良いのかなぁ。可読性的には前者か。でも前者だと cond で判定して 'reg でも 'stack でも無い時の保険が必要??ヤリすぎと言えばそうかも。
しかしここまでヤッといてナチュラル間違いをカマしてたら笑うな (笑えん

試験

まず何から確認すりゃ良いやら。試験項目箇条書きにするより手続き書いた方が早いな。とゆー事で以下。

(use gauche.test)

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

(test-start "5.2.1")

(test-section "make-new-machine")
(let ((m (make-new-machine)))
  (for-each (lambda (register-name)
	      ((m 'allocate-register) register-name))
	    '(a b))

  (test* "register a allocated" 
	 '*unassigned* 
	 (get-contents (get-register m 'a)))
  (test* "register b allocated" 
	 '*unassigned* 
	 (get-contents (get-register m 'b)))

  (test* "stack a allocated" #t (not (null? (get-stack m 'a))))
  (test* "stack b allocated" #t (not (null? (get-stack m 'b))))

  (test* "stack a is null" *test-error* ((get-stack m 'a) 'pop))
  (test* "stack b is null" *test-error* ((get-stack m 'b) 'pop))

  (let ((push-a-thunk (make-save '(save a)
				 m
				 ((m 'get-register) 'pc)))
	(pop-a-thunk (make-restore '(restore a)
				   m
				   ((m 'get-register) 'pc)))
	(posh-b-thunk (make-save '(save b)
				 m
				 ((m 'get-register) 'pc)))
	(pop-b-thunk (make-restore '(restore b)
				   m
				   ((m 'get-register) 'pc)))
	(test-init (lambda ()
		     (set-contents! (get-register m 'a) 1)
		     (set-contents! (get-register m 'b) 2)
		     (set-contents! (get-register m 'pc) '(() (gcd-done ())))
		     (push-a-thunk)
		     (set-contents! (get-register m 'pc) '(() (gcd-done ())))
		     (push-b-thunk)
		     (set-contents! (get-register m 'a) 9)
		     (set-contents! (get-register m 'b) 8)

		     (test* "a" 9 (get-contents (get-register m 'a)))
		     (test* "b" 8 (get-contents (get-register m 'b))))))

    (test-init)
    (set-contents! (get-register m 'pc) '(() (gcd-done ())))
    (pop-b-thunk)
    (test* "pop b" 2 (get-contents (get-register m 'b)))

    (set-contents! (get-register m 'pc) '(() (gcd-done ())))
    (pop-a-thunk)
    (test* "pop a" 1 (get-contents (get-register m 'a)))

    (test* "stack a is null" *test-error* (pop-a-thunk))
    (test* "stack b is null" *test-error* (pop-b-thunk))

    (test-init)
    (set-contents! (get-register m 'pc) '(() (gcd-done ())))
    (pop-a-thunk)
    (test* "pop a" 1 (get-contents (get-register m 'a)))

    (set-contents! (get-register m 'pc) '(() (gcd-done ())))
    (pop-b-thunk)
    (test* "pop b" 2 (get-contents (get-register m 'b)))

    (test* "stack a is null" *test-error* (pop-a-thunk))
    (test* "stack b is null" *test-error* (pop-b-thunk))
    )
  )

(test-end)

なんか微妙。これだけで良い訳ゃ無いように思うのですが。あといくつか気づきを控えておいて後は帰宅後にトライ、とゆー事で。

(machine 'stack) なメソドは不要になる
update-insts! 以降の stack に関わる処理も不要
make-save, make-restore 関連な試験も修正が必要