さっき書いたエントリでは,脱出するところが不自然だったことに気付き修正した.
今回の問題はcall/ccを使えば簡単にできる.使っていいのかな?まぁいっか.
問題5.17をベースに今回の問題を解く.5.17はlabelをinstructionに付随させるものなので,その性質を使う.というか,むしろ,この問題のための問題だったのか?
今回追加するものと修正するものは...と思ったが結構多いので,そのまま貼り付けます.
簡単に方針を書きます.
まず,breakpointのデータ構造は
((break1 . 1) (break2 . 2)...)
のような連想リストにする.これをbreakpoint-pairsとする.
また,同じラベルの中で,instructionの数を数えておく.この数をinst-count-for-labelとする.
(この2つはどちらもmake-new-machineの内部変数)
で,breakするかどうかは
- instに付随しているlabelを確認する
- (assoc label breakpoint-pairs)で#fでなければ
- assocで得られたpairのcdrがinst-count-for-labelと等しいか確認する
- 3が真なら,breakする
breakをどうやって実現するかというと,breakpointという変数を用意しておき,
(call/cc (lambda (break) (set! breakpoint break) (after-break))
を実行する.(after-break)はmake-new-machineの外に出るための,継続.
breakしたあとは,(execute)の最後に脱出すればよいことに気が付いた.
set-breakpointによって,breakpointをセットしたり,cancel-breakpointによって,breakpointを消すには,当然breakpoint-pairsをいじくればいい.
まずは,make-new-machineを載せる.
相当長くなってます...
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-count 0) ;; exercise 5.15 (trace? #f) ;; exercise 5.16 (label #f) ;; exercise5.17 (breakpoint #f) (breakpoint-pairs '()) (inst-count-for-label 0)) (let ((the-operations (list (list 'initialize-stack (lambda () (stack 'initialize))) (list 'print-stack-statistics (lambda () (stack 'print-statistics))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply define register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register: " name)))) ;; exercise5.19 ====================================== (define (set-breakpoint label n) (if (not (null? breakpoint-pairs)) (set-cdr! breakpoint-pairs (list (cons label n))) (set! breakpoint-pairs (list (cons label n)))) (print "set-breakpoint")) (define (search-breakpoint label n) (let ((pair (assoc label breakpoint-pairs))) (if pair (if (eq? n (cdr pair)) pair #f) #f))) (define (cancel-breakpoint label n) (let ((cancel-pair (cons label n))) (set! breakpoint-pairs (map (lambda (pair) (if (equal? pair cancel-pair) '() pair)) breakpoint-pairs)) (print "cancel-pair: "cancel-pair " breakpoint-pairs: " breakpoint-pairs))) (define (cancel-all-breakpoints) (set! breakpoint-pairs '()) (set! breakpoint #f) 'done) ;; ================================================== (define (execute) (let ((val (call/cc (lambda (after-break) (let ((instructions (get-contents pc))) (if (null? instructions) 'done (begin (if (not (eq? (caaar instructions) 'label)) ;; check-label-tag (begin (inc! inst-count-for-label) (instruction-count-up) (print-trace (caar instructions))) (begin (set! inst-count-for-label 0) (set! label (cadr (caar instructions))))) (let ((break-pair (search-breakpoint label inst-count-for-label))) (if break-pair (call/cc (lambda (break) (set! breakpoint break) (after-break 'break))))) ((instruction-execution-proc (car instructions))) (execute)))))))) val)) (define (print-trace trace) ;; exercise 5.16 (if trace? (print "label: " label " instruction: " trace))) (define (print-stack-statistics) ;; exercise 5.14 (stack 'print-statistics)) (define (instruction-count-up) ;; exercise 5.15 (set! instruction-count (+ instruction-count 1))) (define (print-inst-count) ;; exercise 5.15 (let ((x instruction-count)) (set! instruction-count 0) (print "instruction-count: " x))) (define (trace-on) ;; exercise 5.16 (set! trace? #t)) (define (trace-off) ;; exercise 5.16 (set! trace? #f)) (define (dispatch message) (cond [(eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)] [(eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))] [(eq? message 'allocate-register) allocate-register] [(eq? message 'get-register) lookup-register] [(eq? message 'install-operations) (lambda (operations) (set! the-operations (append the-operations operations)))] [(eq? message 'stack) stack] [(eq? message 'print-stack) (print-stack-statistics)] ;; exercise 5.14 [(eq? message 'inst-count-init) (instruction-count-init)] ;; exercise 5.15 [(eq? message 'print-inst-count) (print-inst-count)] ;; exercise 5.15 [(eq? message 'trace-on) (trace-on)] ;; exercise 5.16 [(eq? message 'trace-off) (trace-off)] ;; exercise 5.16 [(eq? message 'set-label) set-label] ;; exercise 5.17 [(eq? message 'set-breakpoint) set-breakpoint] ;; exercise5.19 [(eq? message 'proceed-machine) (breakpoint)] ;; exercise5 5.19 [(eq? message 'cancel-breakpoint) cancel-breakpoint] ;; exercise5.19 [(eq? message 'cancel-all-breakpoints) (cancel-all-breakpoints)] ;;exercise5.19 [(eq? message 'operations) the-operations] [else (error "Unknown request -- MACHINE" message)])) dispatch)))
これらのインターフェイスを使うための定義は,
(define (set-breakpoint machine label n) ((machine 'set-breakpoint) label n)) (define (proceed-machine machine) (machine 'proceed-machine)) (define (cancel-breakpoint machine label n) ((machine 'cancel-breakpoint) label n)) (define (cancel-all-breakpoints machine) (machine 'cancel-all-breakpoints))
また,make-new-machineから脱出するための定義は
(define after-break '()) (define (break-proc) (call/cc (lambda (break) (set! after-break break))) #f) (break-proc)
一度break-procを実行しておかなければならない.
実行
(define expt-machine (make-machine '(b n val continue) (list (list '= =) (list '- -) (list '* *)) '((assign continue (label expt-done)) expt-loop (test (op =) (reg n) (const 0)) (branch (label return)) (save continue) (assign n (op -) (reg n) (const 1)) (assign continue (label after-expt)) (goto (label expt-loop)) after-expt (restore continue) (assign val (op *) (reg b) (reg val)) (goto (reg continue)) return (assign val (const 1)) (goto (reg continue)) expt-done))) (set-register-contents! expt-machine 'b 2) (set-register-contents! expt-machine 'n 3) (set-breakpoint expt-machine 'return 2) (start expt-machine) ;; gosh> expt-machine ;; gosh> done ;; gosh> done ;; gosh> set-breakpoint ;; #<undef> ;; gosh> break
(最後のIO-ERRORはなぜおきるかは不明...とりあえず結果には問題ないので,続ける.)
これでvalを確認すると,
(get-register-contents expt-machine 'val) ;=> 1
無事にbreakできている.
保存していた継続を呼び出す
(proceed-machine expt-machine) ;=> done (get-register-contents expt-machine 'val) ;=> 8
無事に再開される.2つでもできるし, cancel-breakpointもできることを確認.
(cancel-breakpoint expt-machine 'return 2) ;=> cancel-pair: (return . 2) breakpoint-pairs: (()) ;=> #<undef>
外側の継続を呼び出したときになぜIOERRORがでるのか...上のコードでコメントアウトしているerror関数を使う方法でももちろんmake-new-machineを脱出できるけれど...errorでもないのにerrorは使いたくない.
このエラーの原因はいまだにわからない.