SICP 読み (246) 5.2 レジスタ計算機での計算
assemble は試験で動作が確認したい。てコトは machine か。make-new-machine が戻すオブジェクトの属性でアクセス可能なのは
- pc
- flag
- stack
- the-ops
あたりのナニ。でも machine があれば assemble できる。ただ assemble が戻すのはとても微妙なリストのはずなんですが。
gdgd 言ってないで試験書くか。
ってコトでとりあえず書いてみたのが以下。微妙。
("make-new-machine"
("machine"
(let ((m (make-new-machine)))
(assert-equal '*unassigned* (((m 'get-register) 'pc) 'get))
(assert-equal '*unassigned* (get-contents ((m 'get-register) 'pc)))
(assert-equal '*unassigned* (((m 'get-register) 'flag) 'get))
(assert-equal '*unassigned* (get-contents ((m 'get-register) 'flag)))
)
)
)とりあえず、make-machine なソレを手動でヤッてみて中身確認してみるか。
(define gcd-machine
(make-machine
'(a b t)
(list (list 'rem remainder) (list '= =))
'(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)))make-machine は以下の手続きなんで
(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))こんなカンジでしょうか。
("hand make-machine"
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(assert-equal '*unassigned* (get-contents ((m 'get-register) 'a)))
(assert-equal '*unassigned* (get-contents ((m 'get-register) 'b)))
(assert-equal '*unassigned* (get-contents ((m 'get-register) 't)))
(assert-error (lambda () ((m 'stack) 'pop)))
(assert-error (lambda () (pop (m 'stack))))
(assert-equal 'initialize-stack (car (car (m 'operations))))
(assert-equal 'print-stack-statistics (car (cadr (m 'operations))))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(assert-equal 'rem (car (caddr (m 'operations))))
(assert-equal '= (car (cadddr (m 'operations))))
)
)assemble のあたりをどう確認していくか、が問題。あと make-* なソレ達をどう試験したものやら。どっちかというと make-* の方が先な気もしています。
続
make-* から見ていく事に。make-* は基本的に手続きを戻してて、update-insts! において insts なリスト要素の cdr にセットされているはず。てー事は戻った手続きは基本的には thunk のようなので呼び出して結果を見てみりゃ良いのか。
とりあえず make-assign から着手。5.1.5 節によれば assign の様式は以下な模様。
(assign
(reg )) (assign
(const )) (assign
(op ) ... ) (assign
(label ))
うーん。label がどういった形なのか、ですが
(label-name (以降の命令列))
になっているという理解なんだけど、これは先に試験で確認しておいた方が良さげ。ってか labels って machine の中にリストがあるって思ってたらそうではなかった。assemble 中にそのラベルを参照する命令がある時に、という事になるのか。
assemble の中の処理を微妙に変えて試験してみる、というのは手かも。
("label"
(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)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
((m 'install-operations) (list (list 'rem remainder) (list '= =)))
(extract-labels l
(lambda (insts labels)
(assert-equal 'test-b (car (car labels)))
(assert-equal '(((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))))
(cdr (car labels)))
(assert-equal 'gcd-done (car (cadr labels)))
(assert-equal '() (cdr (cadr labels)))
))
)
)これはこれは。最初 test-b なラベルの cdr に格納されているリストが意味不明でしたが、extract-labels でいっこづつ cons してる上に assemble した手続きを格納するための領域があるんだったよ、と。
((test (op =) (reg b) (const 0)) ())
みたいな感じ。で、これがリストになってるんで (以下略) ってコトですか。で、何やってるんだったか、というと 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))))
(ope)
(assert-equal 1 (get-contents ((m 'get-register) 'b)))
)
)
)
)駄目。
Error occurred in (assign <register-name> (reg <register-name>)) *** ERROR: pair required, but got *unassigned*
って叱られる。make-assign が吐き出す手続きは
(lambda () ; execution procedure for assign
(set-contents! target (value-proc))
(advance-pc pc)))))な形で最後に pc を先に進める形になっているんですが、上記試験の machine は空の pc しか持っていない事が原因であると思われます。無理矢理セットしてやるか。
("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)))
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(let ((ope (make-assign '(assign b (reg a)) m '() (m 'operations)
((m 'get-register) 'pc))))
(ope)
(assert-equal 1 (get-contents ((m 'get-register) 'b)))
)
)
)
)手続き引用が重複しとりますが勘弁して下さい。無理矢理 pc に
(() (gcd-done ()))
なリストを設定して試験パス。無理矢理すぎませんか、というツッコミはスルーで以降を検討してみる事に。てーか先に make-primitive-exp とか make-operation-exp とかの動作の確認が先かなぁ、と言いつつエントリ投入。
続々
という事でまず、make-primitive-exp から試験確認実施。作業がフォークし杉とゆー話もありますが、ログとってるから戻り先は大丈夫ッス。
で、試験ですがこの手続きも thunk を戻します。
("make-primitive"
("constant"
(let ((m (make-new-machine)))
(let ((ope (make-primitive-exp '(const 2) m '())))
(assert-equal 2 (ope))
)
)
)
("label"
(let ((m (make-new-machine)))
(let ((ope (make-primitive-exp '(label gcd-done) m '((gcd-done . ())))))
(assert-equal '() (ope))
(assert-error (lambda () (make-primitive-exp '(label test)
m
'())))
)
)
)
("register"
(let ((m (make-new-machine)))
(for-each (lambda (register-name)
((m 'allocate-register) register-name))
'(a b t))
(set-contents! ((m 'get-register) 'a) 1)
(let ((ope (make-primitive-exp '(reg a) m '())))
(assert-equal 1 (ope))
(assert-error (lambda () (make-primitive-exp '(reg c)
m
'())))
)
)
)
)で、make-primitive-exp な試験検討中に make-assign な試験のラベルな部分に不備を発見。ラベルのリスト要素は
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done . ())))
みたいな形になってないと駄目な模様。make-assign はどうして試験パスしたのかはよく分かりませんが、中身まで見てる訳ではなかったはず。あるいは以下が make-operation-exp な試験。渡す式を普通の scheme の (+ 1 2 3) みたいな式を渡して叱られた。
("make-operation-exp"
("+"
(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) 3)
(set-contents! ((m 'get-register) 'b) 2)
(let ((ope1 (make-operation-exp '((ope +) (const 1) (const 2))
m
'()
(m 'operations)))
(ope2 (make-operation-exp '((ope +) (const 1)
(const 2)
(const 3)
(const 4)
(const 5))
m
'()
(m 'operations)))
(ope3 (make-operation-exp '((ope +) (reg a) (reg b))
m
'()
(m 'operations))))
(assert-equal 3 (ope1))
(assert-equal 15 (ope2))
(assert-equal 5 (ope3))
(assert-error (lambda () (make-operation-exp '((ope *)
(const 2)
(const 3))
m
'())))
(assert-error (lambda () (make-operation-exp '((ope +)
(reg c)
(reg d))
m
'())))
)
)
)
)一応試験できているみたいですが lookup-prim も以下に。
("lookup-prim"
("lookup-prim"
(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 () (lookup-prim '* (m 'operations))))
(assert-equal 2 (apply (lookup-prim '+ (m 'operations)) '(1 1)))
)
)
)なんかてきとーにヤッツケちゃってる感満点だなぁ。ただ、これで make-assign 方面に戻れるはず。
