SICP 読み (249) 5.2 レジスタ計算機での計算
追記するのは微妙みたいなので新たにエントリ起こす。make-test の次は make-branch からです。
make-branch
手続きの定義は以下。
(define (make-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 (get-contents flag)
(set-contents! pc insts)
(advance-pc pc))))
(error "Bad BRANCH instruction -- ASSEMBLE" inst))))flag が真なら pc レジスタを書き換える、という操作で jmp を実装してます。何と申し上げれば良いか分かりませんが凄いな。でも試験書くの面倒だなぁ。extract-labels に渡す手続きの中に assert を書いてしまうか。
ええと、branch な構文は
(branch (label
))
との事。でっち上がったのが以下の試験。微妙スギ。
("make-branch"
("error"
(assert-error (lambda () (make-branch '(branch (reg a)) '() '() '())))
)
("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)
(let ((thunk (make-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 #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)
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(let ((thunk (make-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)))))
)
))
)
)
)OK ってコトで次に進む。
make-goto
手続きの定義は以下。
(define (make-goto inst machine labels pc)
(let ((dest (goto-dest inst)))
(cond ((label-exp? dest)
(let ((insts
(lookup-label labels
(label-exp-label dest))))
(lambda () (set-contents! pc insts))))
((register-exp? dest)
(let ((reg
(get-register machine
(register-exp-reg dest))))
(lambda ()
(set-contents! pc (get-contents reg)))))
(else (error "Bad GOTO instruction -- ASSEMBLE"
inst)))))なんか長いな。そうか、goto はラベルとレジスタが指定可能なのか。
(goto (label
)) (goto (reg
))
これも branch 式な試験が必要かなぁ。あそこまでせんでも良いように思うんですが。と言いつつ以下の試験をでっち上げたら
Error occurred in label *** ERROR: unbound variable: false
って叱られた。
("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)))
(extract-labels
l
(lambda (insts labels)
(let ((thunk (make-goto '(goto test-b) m labels ((m 'get-register) 'pc))))
(thunk)
(assert-equal '(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'pc)))))
)
)
)
)
)goto の構文が違うのは良いんですが、false って何だよ、と。で、ch5-regsim.scm を false で grep したらあるでないの。探してみると tagged-list? でした。
; from 4.1
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))パクッたナニを使ってると駄目ですねぇ。(を
あるいは register な試験にて正常に lookup できぬ、という不具合が発現。
Error occurred in register *** ERROR: Unknown register: (reg a)
こんなコトしてるし (とほほ
(ope (make-assign '(assign (reg a) (label test-b)) m labels (m 'operations) ((m 'get-register) 'pc))))
紆余曲折を経て、一応以下の試験にパスしている模様。
("make-goto"
("error"
(assert-error (lambda () (make-goto '(goto (op =))
'()
'()
'())))
(assert-error (lambda () (make-goto '(goto (const 2))
'()
'()
'())))
)
("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)))
(extract-labels
l
(lambda (insts labels)
(let ((thunk (make-goto '(goto (label test-b)) m labels ((m 'get-register) 'pc))))
(thunk)
(assert-equal '(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'pc)))))
)
)
)
)
)
("register"
(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))
(extract-labels
l
(lambda (insts labels)
(let ((thunk (make-goto '(goto (reg a)) m labels ((m 'get-register) 'pc)))
(ope (make-assign '(assign a (label test-b))
m
labels
(m 'operations)
((m 'get-register) 'pc))))
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(ope)
(thunk)
(assert-equal '(test (op =) (reg b) (const 0))
(car (car (get-contents ((m 'get-register) 'pc)))))
)
)
)
)
)
)段々試験が微妙になってる気がしてきた。無理矢理通してる感満点な感じ。
make-save
スタック操作は試験が楽そげ。手続きの定義は以下。
(define (make-save inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
(lambda ()
(push stack (get-contents reg))
(advance-pc pc))))save の様式は以下ですか。
(save <register-name>)
これもレジスタの名前を直接記述か。stack の中身が直接見れないんだよなぁ。面倒臭いなぁ。このあたりまで来たら手続きオブジェクトの中身をなんたら、みたいなコトができるようになってたかたのですが、さすがに SICP にはそんなコトは書いていないのか。(何
試験としては push して次、という動作が確認できてれば OK かなぁ。
("make-save"
("make-save"
(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 ((thunk (make-save '(save a)
m
(m 'stack)
((m 'get-register) 'pc))))
(assert-error (lambda () ((m 'stack) 'pop)))
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(thunk)
(assert-equal '() (cadr (car (get-contents ((m 'get-register) 'pc)))))
(assert-equal 1 ((m 'stack) 'pop))
(assert-error (lambda () ((m 'stack) 'pop)))
)
)
)
)なんと言えば良いか分かりませんが、pc の確認あたりがとても微妙。
make-restore
微妙と言いつつどんどん行く。make-restore の定義は以下。
(define (make-restore inst machine stack pc)
(let ((reg (get-register machine
(stack-inst-reg-name inst))))
(lambda ()
(set-contents! reg (pop stack))
(advance-pc pc))))あるいは restore の様式は以下。
(restore
)
で、make-save な試験をパクッて作成した試験が以下。
("make-restore"
("make-restore"
(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 ((push-thunk (make-save '(save a)
m
(m 'stack)
((m 'get-register) 'pc)))
(pop-thunk (make-restore '(restore b)
m
(m 'stack)
((m 'get-register) 'pc))))
(assert-error (lambda () ((m 'stack) 'pop)))
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(push-thunk)
(assert-equal '() (cadr (car (get-contents ((m 'get-register) 'pc)))))
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(pop-thunk)
(assert-equal 1 (get-contents ((m 'get-register) 'b)))
(assert-error (lambda () ((m 'stack) 'pop)))
)
)
)
)一応パスはしております。残るは make-perform です。
make-perform
手続きの定義は以下。
(define (make-perform inst machine labels operations pc)
(let ((action (perform-action inst)))
(if (operation-exp? action)
(let ((action-proc
(make-operation-exp
action machine labels operations)))
(lambda ()
(action-proc)
(advance-pc pc)))
(error "Bad PERFORM instruction -- ASSEMBLE" inst))))様式は以下との事。
(perform (op
) ... )
むむ。どうやって試験したものやら、悩ましひ。こんなの書いて途中で止めてたり。
("make-perform"
(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-perform '(perform (op +) (const 1) (const 2) (const 3))
m
'()
(m 'operations)
((m 'get-register) 'pc))))
(set-contents! ((m 'get-register) 'pc) '(() (gcd-done ())))
(thunk)
;; cannot assert
)
)
)確認できねぇじゃんかよ、みたいな。一応 make-operation-exp で確認してますのでスルーで勘弁して下さい (誰
