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

まだシミュレータ関連の手続きを全部把握できてません。ちょっと時間をかけて試験しながらシバキ回してみる事にしてみます。

register

とりあえず make-machine は置いとく事にしてレジスタから。

#!/usr/bin/env gosh

(use test.unit)
(require "ch5-regsim")

(define-test-suite "5.2.1"

  ("register"
   ("make & get"
    (let ((reg (make-register 'a)))
      (assert-error (lambda () (reg 'xxx)))
      (assert-equal '*unassigned* (reg 'get))
      (assert-equal '*unassigned* (get-contents reg))
      )
    )

   ("get & set"
    (let ((reg (make-register 'a)))
      ((reg 'set) 1)
      (assert-equal 1 (reg 'get))
      (assert-equal 1 (get-contents reg))
      (set-contents! reg 2)
      (assert-equal 2 (reg 'get))
      (assert-equal 2 (get-contents reg))
      )
    )
   )
  )

以降は追加された差分のみをサラします。このあたりは全然ハードル低くてむしろヤッツケ仕事の範疇。

stack

次、行きます。

  ("stack"
   ("make & pop"
    (let ((s (make-stack)))
      (assert-error (lambda () (s 'pop)))
      )
    )

   ("push & pop"
    (let ((s (make-stack)))
      ((s 'push) 1)
      (assert-equal 1 (s 'pop))
      (assert-error (lambda () (s 'pop)))
      ((s 'push) 2)
      ((s 'push) 1)
      (assert-equal 1 (s 'pop))
      (assert-equal 2 (s 'pop))
      (assert-error (lambda () (s 'pop)))
      )
    )

   ("initialize"
    (let ((s (make-stack)))
      ((s 'push) 1)
      (s 'initialize)
      (assert-error (lambda () (s 'pop)))
      )
    )

   ("push & pop (2)"
    (let ((s (make-stack)))
      (push s 1)
      (push s 2)
      (assert-equal 2 (pop s))
      (assert-equal 1 (pop s))
      (assert-error (lambda () (pop s)))
      )
    )
   )

そろそろ手続きオブジェクトの内部状態を確認する仕掛けが (以下略
そりゃええが、ここらあたりから早くも UT 微妙になってる予感。make-new-machine も現時点ではスルーした方が良さげ。てーか低水準 (??) なソレ達の試験をまず確認すべきかな。

selector & constructor

とゆー事で基本な手続きをざくっと確認。

  ("selector & constructor"
   ("make-instruction"
    (assert-equal '(1) (make-instruction 1))
    )

   ("instruction-text"
    (assert-equal 1 (instruction-text '(1 2)))
    )

   ("instruction-execution-proc"
    (assert-equal 2 (instruction-execution-proc '(1 . 2)))
    )

   ("set-instruction-execution-proc!"
    (let ((l '(cons 1 '())))
      (set-instruction-execution-proc! l 1)
      (assert-equal 1 (cdr l))
      )
    )

   ("make-label-entry"
    (assert-equal '(1 . 2) (make-label-entry 1 2))
    )

   ("lookup-label"
    (let ((labels (cons (make-label-entry 1 2)
			'())))
      (assert-error (lambda () (lookup-label labels 3)))
      (assert-equal 2 (lookup-label labels 1)) ;; return cdr
      )
    )

   ("assign-reg-name"
    (let ((l1 '(assign n (op -) (reg n) (const 1)))
	  (l2 '(assign continue (label afterfib-n-1))))
      (assert-equal 'n (assign-reg-name l1))
      (assert-equal 'continue (assign-reg-name l2))
      )
    )

   ("assign-value-exp"
    (let ((l1 '(assign n (op -) (reg n) (const 1)))
	  (l2 '(assign continue (label afterfib-n-1))))
      (assert-equal '((op -) (reg n) (const 1)) (assign-value-exp l1))
      (assert-equal '((label afterfib-n-1)) (assign-value-exp l2))
      )
    )

   ("operation-exp?"
    (let ((l1 '(assign n (op -) (reg n) (const 1)))
	  (l2 '(assign continue (label afterfib-n-1))))
      (assert-true (operation-exp? (assign-value-exp l1)))
      (assert-false (operation-exp? (assign-value-exp l2)))
      )
    )

   ("operation-exp-op"
    (let ((l1 '(assign n (op -) (reg n) (const 1))))
      (assert-equal '- (operation-exp-op (assign-value-exp l1)))
      )
    )

   ("operation-exp-operands"
    (let ((l1 '(assign n (op -) (reg n) (const 1))))
      (assert-equal '((reg n) (const 1))
		    (operation-exp-operands (assign-value-exp l1)))
      )
    )

   ("test-condition"
    (let ((l '(test (op <) (reg n) (const 2))))
      (assert-equal '((op <) (reg n) (const 2)) (test-condition l))
      (assert-true (operation-exp? (test-condition l)))
      )
    )

   ("register-exp?"
    (assert-true (register-exp? '(reg n)))
    (assert-false (register-exp? '(const 1)))
    (assert-false (register-exp? '(label afterfib-n-1)))
    )

   ("register-exp-reg"
    (assert-equal 'n (register-exp-reg '(reg n)))
    )

   ("constant-exp?"
    (assert-true (constant-exp? '(const 1)))
    (assert-false (constant-exp? '(reg n)))
    (assert-false (constant-exp? '(label afterfib-n-1)))
    )

   ("constant-exp-value"
    (assert-equal 1 (constant-exp-value '(const 1)))
    )

   ("label-exp?"
    (assert-true (label-exp? '(label afterfib-n-1)))
    (assert-false (label-exp? '(reg n)))
    (assert-false (label-exp? '(const 1)))
    )

   ("label-exp-label"
    (assert-equal 'afterfib-n-1 (label-exp-label '(label afterfib-n-1)))
    )

   ("branch-dest"
    (let ((l '(branch (label immediate-answer))))
      (assert-equal '(label immediate-answer) (branch-dest l))
      (assert-true (label-exp? (branch-dest l)))
      )
    )

   ("goto-dest"
    (let ((l '(goto (reg continue))))
      (assert-equal '(reg continue) (goto-dest l))
      )
    )

   ("stack-inst-reg-name"
    (let ((l1 '(save val))
	  (l2 '(restore val)))
      (assert-equal 'val (stack-inst-reg-name l1))
      (assert-equal 'val (stack-inst-reg-name l2))
      )
    )

   ("perform-action"
    (let ((l1 '(perform (op print) (reg a))))
      (assert-equal '((op print) (reg a)) (perform-action l1))
      )
    )
   )

上記を手掛かりに残りの試験をできたらヤリますが、今日はもう駄目かも。(を
とりあえずエントリ投入。元気があれば、なんですが、どこからヤレば良いのか微妙だなぁ。