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

練習問題に着手。

問題 5.9

最初は make-assign らへんで、とか思っていたのですが op な式で label な要素を却下となると、make-operation-exp でチェックした方が良さげ。

(define (make-operation-exp exp machine labels operations)
  (let ((op (lookup-prim (operation-exp-op exp) operations))
        (aprocs
         (map (lambda (e)
		(if (label-exp? e)
		    (error "cannot place label element -- ASSEMBLE" e)
		    (make-primitive-exp e machine labels)))
              (operation-exp-operands exp))))
    (lambda ()
      (apply op (map (lambda (p) (p)) aprocs)))))

みたいな感じになるでしょうか。試験は make-opration-exp なテストに assert-error を入れただけなので略。って本来なら op 指定可能な命令は全部試験すべきなのでしょうか。UT とゆー意味では、上記手続きの試験ができてれば OK なんでしょうが ...

問題 5.10

branch の逆を作ってみる事に。flag レジスタが偽だったら jmp てのは楽ちんそう。(を
様式としては

(n-branch (label ))

みたいな感じ。解析な手続きは以下で良いはず。

(define (make-n-branch inst machine labels flag pc)
  (let ((dest (branch-dest inst)))
    (if (label-exp? dest)
        (let ((insts
               (lookup-label labels (label-exp-label dest))))
          (lambda ()
            (if (not (get-contents flag))
                (set-contents! pc insts)
                (advance-pc pc))))
        (error "Bad BRANCH instruction -- ASSEMBLE" inst))))

すごいテキトーだなぁ。他に修正が必要なのは

• make-execution-procedure

くらい??
# ってコイツの試験書いてないな (とほほ

むむ、新たな構文の追加や修正は 5.2.3 なソレ達に閉じてるんですか。凄いな。試験も書くのが楽だな。

  ("make-n-branch"
   ("error"
    (assert-error (lambda () (make-n-branch '(branch (reg a)) '() '() '())))
    )

   ("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-n-branch '(branch (label test-b))
				     m
				     labels
				     ((m 'get-register) 'flag)
				     ((m 'get-register) 'pc))))
	   (thunk)
	   (assert-equal '(test (op =) (reg b) (const 0))
			 (car (car (get-contents ((m 'get-register) 'pc)))))
	   )
	 ))
      )
    )


   ("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-n-branch '(branch (label test-b))
				     m
				     labels
				     ((m 'get-register) 'flag)
				     ((m 'get-register) 'pc))))
	   (thunk)
	   (assert-equal 'gcd-done
			 (car (car (get-contents ((m 'get-register) 'pc)))))
	   )
	 ))
      )
    )
   )

あと、make-execution-procedure の試験も書いとくか。と言いつつ test な試験を書いていた所、以下のようなメセジを出力して異常終了。

Error occurred in test
*** ERROR: invalid application: (#<<test> 0x83fb788>)

試験は以下。(一部のみ)

   ("test"
    (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)
        (assert-true (get-contents ((m 'get-register) 'flag)))
        )
      )
    )

thunk を動かすトコロで上記メセジが出ている模様。原因不明。ちなみに make-test を直接呼び出すと動きます。

   ("test"
    (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))))
;      (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 ())))
;	(assert-equal 'a thunk)
        (thunk)
        (assert-true (get-contents ((m 'get-register) 'flag)))
        )
      )
    )

何故なんだ。問題解決してませんが、ログ投入。ちなみに make-assign な試験は以下の形なんですが、正常に動いてたりします。ワケワカんねぇ。

   ("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)
      (assert-equal 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)
        (assert-equal 1 (get-contents ((m 'get-register) 'b)))
        )
      )
    )