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

なんか体調悪い。へろへろで帰宅。メシ喰って端末に火を入れた。試験にパスしない件ですが、評価器はきちんと動いてるはずだし、make-execution-procedure では make-test な戻りをそのまま戻しているだけ、という事で悪さをしてるのはツールかも、と思い (ナチュラルなボケをカマしている可能性も大、と思い) つつ gauche.test で試験を書いてみました。
以下が試しに作成してみた試験。

(use gauche.test)

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

(test-start "make-execution-procedure test")

(test-section "assign")
(let ((m (make-new-machine)))
  (for-each (lambda (register-name)
	      ((m 'allocate-register) register-name))
	    '(a b t))
  ((m 'install-operations) (list (list 'rem remainder) (list '= =)))
  (set-contents! ((m 'get-register) 'a) 1)
  (test* "a is 1" 1 (get-contents ((m 'get-register) 'a)))
  (let ((thunk (make-execution-procedure
		'(assign b (reg a))
		'()
		m
		((m 'get-register) 'pc)
		((m 'get-register) 'flag)
		(m 'stack)
		(m 'operations))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "b is 1" 1 (get-contents ((m 'get-register) 'b)))
    )
  )

(test-section "test (1)")
(let ((m (make-new-machine)))
  (for-each (lambda (register-name)
	      ((m 'allocate-register) register-name))
	    '(a b t))
  ((m 'install-operations) (list (list 'rem remainder) (list '= =)))
  (let ((thunk (make-test '(test (op =) (const 1) (const 1))
			  m
			  '()
			  (m 'operations)
			  ((m 'get-register) 'flag)
			  ((m 'get-register) 'pc))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "true" #t (get-contents ((m 'get-register) 'flag)))
    )
  )

(test-section "test (2)")
(let ((m (make-new-machine)))
  (for-each (lambda (register-name)
	      ((m 'allocate-register) register-name))
	    '(a b t))
  ((m 'install-operations) (list (list 'rem remainder) (list '= =)))
  (let ((thunk (make-execution-procedure
		'(test (op =) (const 1) (const 1))
		'()
		m
		((m 'get-register) 'pc)
		((m 'get-register) 'flag)
		(m 'stack)
		(m 'operations))))
    (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
    (thunk)
    (test* "true" #t (get-contents ((m 'get-register) 'flag)))
    )
  )

結果はパス。

$ gosh test-ch5-regsim.scm 
Testing make-execution-procedure test ...                        
<assign>-----------------------------------------------------------------------
test a is 1, expects 1 ==> ok
test b is 1, expects 1 ==> ok
<test (1)>---------------------------------------------------------------------
test true, expects #t ==> ok
<test (2)>---------------------------------------------------------------------
test true, expects #t ==> ok
$

gaunit が、というよりは使い方が悪いのかなぁ。とりあえず、問題 5.10 な試験が書ければ追記予定。

続

という事でなんとなく元気になりかけたので頑張ってみた。ちなみに (252) なエントリで書いてる n-branch (この名前微妙) な試験はダウト。バグってる (n-branch を使ってない) のに気がつかなんだ。gauche.test で書いた試験が以下。

(use gauche.test)

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

(test-start "Exercise 5.10. test")

(test-section "error")
(test* "non label" *test-error* (make-n-branch '(branch (reg a)) '() '() '()))

(test-section "flag is #f")
(let ((m (make-new-machine))
      (l '(test-b
	   (test (op =) (reg b) (const 0))
	   (branch (label gcd-done))
	   (assign t (op rem) (reg a) (reg b))
	   (assign a (reg b))
	   (assign b (reg t))
	   (goto (label test-b))
	   gcd-done)))
  (extract-labels 
   l
   (lambda (insts labels)
     (set-contents! ((m 'get-register) 'flag) #f)
     (let ((thunk (make-execution-procedure
		   '(n-branch (label test-b))
		   labels
		   m
		   ((m 'get-register) 'pc)
		   ((m 'get-register) 'flag)
		   (m 'stack)
		   (m 'operations))))
       (thunk)
       (test* "jmp to test-b"
	      '(test (op =) (reg b) (const 0))
	      (car (car (get-contents ((m 'get-register) 'pc)))))))))

(test-section "flag is #t")
(let ((m (make-new-machine))
      (l '(test-b
	   (test (op =) (reg b) (const 0))
	   (branch (label gcd-done))
	   (assign t (op rem) (reg a) (reg b))
	   (assign a (reg b))
	   (assign b (reg t))
	   (goto (label test-b))
	   gcd-done)))
  (extract-labels 
   l
   (lambda (insts labels)
     (set-contents! ((m 'get-register) 'flag) #t)
     (set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
     (let ((thunk (make-execution-procedure
		   '(n-branch (label test-b))
		   labels
		   m
		   ((m 'get-register) 'pc)
		   ((m 'get-register) 'flag)
		   (m 'stack)
		   (m 'operations))))
       (thunk)
       (test* "jmp to last"
	      'gcd-done
	      (car (car (get-contents ((m 'get-register) 'pc)))))))))

(test-end)

てーか、ぱっと見で分かりにくい試験だなあ、と。(何
一応試験にはパスしております。

$ gosh test-5.10.scm 
Testing Exercise 5.10. test ...                                  
<error>------------------------------------------------------------------------
test non label, expects #<error> ==> ok
<flag is #f>-------------------------------------------------------------------
test jmp to test-b, expects (test (op =) (reg b) (const 0)) ==> ok
<flag is #t>-------------------------------------------------------------------
test jmp to last, expects gcd-done ==> ok
passed.

次あたりからハードルが格段に上がる。