SICP 読み (268) 5.2 レジスタ計算機での計算
新規でエントリ投入。
問題 5.16
trace-on と trace-off は machine が受けとる、と限定して検討。これって試験を作るのが微妙だな。5.15 をコピーして作ってみる。
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (inst-ctr 0) ;; 5.15 (trace #f) ;; 5.16 (the-instruction-sequence '())) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))) ;;**next for monitored stack (as in section 5.2.4) ;; -- comment out if not wanted (list 'print-stack-statistics (lambda () (stack 'print-statistics))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (init-inst-ctr) ;; 5.15 (set! inst-ctr 0)) ;; 5.15 (define (get-inst-ctr) ;; 5.15 inst-ctr) ;; 5.15 (define (trace-on) (set! trace #t)) ;; 5.16 (define (trace-off) (set! trace #f)) ;; 5.16 (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined 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)))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin (if trace ;; 5.16 (begin ;; 5.16 (display (instruction-text (car insts))) ;; 5.16 (newline))) ;; 5.16 ((instruction-execution-proc (car insts))) (set! inst-ctr (+ inst-ctr 1)) ;; 5.15 (execute))))) (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 (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'init-inst-ctr) (init-inst-ctr)) ((eq? message 'get-inst-ctr) (get-inst-ctr)) ((eq? message 'trace-on) (trace-on)) ((eq? message 'trace-off) (trace-off)) (else (error "Unknown request -- MACHINE" message)))) dispatch)))
単体試験はこのままでは微妙なので gosh で試してみます。
gosh> (add-load-path ".") ("." "/usr/share/gauche/site/lib" "/usr/share/gauche/0.8.8/lib") gosh> (load "ch5-regsim") #t gosh> (define m (make-machine '(n continue val) (list (list '= =) (list '- -) (list '* *)) '(controller (assign continue (label fact-done)) fact-loop (test (op =) (reg n) (const 1)) (branch (label base-case)) (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) after-fact (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) base-case (assign val (const 1)) (goto (reg continue)) fact-done))) m gosh> (set-register-contents! m 'n 1) done gosh> (m 'start) done gosh> (get-register-contents m 'n) 1 gosh> (set-register-contents! m 'n 1) done gosh> (m 'trace-on) #t gosh> (m 'start) (assign continue (label fact-done)) (test (op =) (reg n) (const 1)) (branch (label base-case)) (assign val (const 1)) (goto (reg continue)) done gosh> (get-register-contents m 'n) 1 gosh> (set-register-contents! m 'n 2) done gosh> (m 'start) (assign continue (label fact-done)) (test (op =) (reg n) (const 1)) (branch (label base-case)) (save continue) (save n) (assign n (op -) (reg n) (const 1)) (assign continue (label after-fact)) (goto (label fact-loop)) (test (op =) (reg n) (const 1)) (branch (label base-case)) (assign val (const 1)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) done gosh> (set-register-contents! m 'n 2) done gosh> (m 'start) done gosh> (get-register-contents m 'n) 2
次までエントリできるかどうか微妙。最近日中忙しいんで晩勝負です。
追記
コピペのミスなのかなぁ。(m 'trace-off) が抜けてるんですが ...