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

調子悪い。知恵熱かなぁ。熱っぽい感じ。
make-assign な試験から再開してますが微妙。とりあえずエントリ投入してみる。
やっぱ知恵熱かも。pc なソレでハマった。以下の試験、let の中で pc に微妙なソレをセットしてますが、不適切な場所で初期化していたようです。
最初は以下のような形でしたが、試験にパスしない。というか、make-assign が戻す手続き自体が_pair が欲しいが () かよ_という文句を言って異常終了。知恵熱状態なのでワケワカ、なナニでした。(とほほ

   ("(assign <register-name> (op <operation-name>) <input1> ... <inputn>)"
    (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) 'pc) '(() (gcd-done ())))
      ;; (assign b (op rem) (reg a) (label gcd-done)) ??

      (let ((ope (make-assign '(assign a (op +) (reg t) (reg b))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 't) 3)
	(set-contents! ((m 'get-register) 'b) 2)
	(assert-equal 3 (get-contents ((m 'get-register) 't)))
	(assert-equal 2 (get-contents ((m 'get-register) 'b)))
	(assert-equal '*unassigned* (get-contents ((m 'get-register) 'a)))
	(ope)
	(assert-equal 5 (get-contents ((m 'get-register) 'a)))
	)

      (let ((ope (make-assign '(assign a (op rem) (reg a) (const 2))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'a) 3)
	(ope)
	(assert-equal 1 (get-contents ((m 'get-register) 'a)))
	)

      (let ((ope (make-assign '(assign a (op +) (const 1) (const 2) (const 3))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(ope)
	(assert-equal 6 (get-contents ((m 'get-register) 'a)))
	)

      (assert-error (lambda () (make-assign '(assign d (op =) (reg a) (reg b))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (op *) (reg a) (reg b))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (op rem) (reg d) (reg b))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (op rem) (reg a) (reg d))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      )
    )

分かりにくいですが、pc をセットしてるのは一箇所だけ。let を抜けたらリセットされる、という手前勝手な理解でどハマリ。
以下に make-assign 関連の試験を貼っておきますが、確認不足である可能性は非常に高いと言わざるを得ません (とほほほ

  ("make-assign"
   ("(assign <register-name> (reg <register-name>))"
    (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)
      (assert-equal 1 (get-contents ((m 'get-register) 'a)))
      (let ((ope (make-assign '(assign b (reg a)) m '() (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
	(ope)
	(assert-equal 1 (get-contents ((m 'get-register) 'b)))
	)
      (assert-error (lambda () (make-assign '(assign c (reg a))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (reg c))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      )
    )

   ("(assign <register-name> (const <constant-value>))"
    (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 '= =)))
      (assert-error (lambda () (make-assign '(assign c (const 1))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (let ((ope (make-assign '(assign b (const 1))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
	(ope)
	(assert-equal 1 (get-contents ((m 'get-register) 'b)))
	)
      )
    )

   ("(assign <register-name> (label <label-name>))"
    (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 ((ope (make-assign '(assign b (label gcd-done))
			      m
			      '((gcd-done . ()))
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
	(ope)
	(assert-equal '() (get-contents ((m 'get-register) 'b)))
	(assert-error (lambda () (make-assign '(assign d (label gcd-done))
					      m
					      '((gcd-done . ()))
					      (m 'operations)
					      ((m 'get-register) 'pc))))
	)

      (assert-error (lambda () (make-assign '(assign b (label x))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      )
    )

   ("(assign <register-name> (op <operation-name>) <input1> ... <inputn>)"
    (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 '+ +)))
      ;; (assign b (op rem) (reg a) (label gcd-done)) ??

      (let ((ope (make-assign '(assign a (op +) (reg t) (reg b))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
	(set-contents! ((m 'get-register) 't) 3)
	(set-contents! ((m 'get-register) 'b) 2)
	(assert-equal 3 (get-contents ((m 'get-register) 't)))
	(assert-equal 2 (get-contents ((m 'get-register) 'b)))
	(assert-equal '*unassigned* (get-contents ((m 'get-register) 'a)))
	(ope)
	(assert-equal 5 (get-contents ((m 'get-register) 'a)))
	)

      (let ((ope (make-assign '(assign a (op rem) (reg a) (const 2))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
	(set-contents! ((m 'get-register) 'a) 3)
	(ope)
	(assert-equal 1 (get-contents ((m 'get-register) 'a)))
	)

      (let ((ope (make-assign '(assign a (op +) (const 1) (const 2) (const 3))
			      m
			      '()
			      (m 'operations)
			      ((m 'get-register) 'pc))))
	(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
	(ope)
	(assert-equal 6 (get-contents ((m 'get-register) 'a)))
	)

      (assert-error (lambda () (make-assign '(assign d (op =) (reg a) (reg b))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (op *) (reg a) (reg b))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (op rem) (reg d) (reg b))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      (assert-error (lambda () (make-assign '(assign b (op rem) (reg a) (reg d))
					    m
					    '()
					    (m 'operations)
					    ((m 'get-register) 'pc))))
      )
    )
   )

明日も厄日だったらヘコむなぁ。
UT 完了の先は随分向こうな上に、練習問題のハードルがでーじ高そげ。