SICP 問題 5.16
命令トレースを出来るようにする.
executeがtraceフラグを引数に取り,trace-onなら命令を印字し,trace-offなら#fを返す.
(define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (the-instruction-counter 0) (tracing-flag (lambda (inst) #f))) (let ((the-ops (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 defined rgister: " 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)))) ;; tracing-flagを引数に取るようにする. (define (execute trace) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin (set! the-instruction-counter (+ 1 the-instruction-counter)) (trace (caar insts)) ;trace-onならここで命令を印字.offなら#fを返す. ((instruction-execution-proc (car insts))) (execute trace))))) (define (trace-on) (set! tracing-flag (lambda (inst) (display inst) (newline))) 'trace-on) (define (trace-off) (set! tracing-flag (lambda (inst) #f)) 'trace-off) (define (initialize-counter) (set! instruction-counter 0)) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute tracing-flag)) ((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 'get-counter) the-instruction-counter) ((eq? message 'initilize-counter) (initilize-counter)) ((eq? message 'trace-on) (trace-on)) ((eq? message 'trace-off) (trace-off)) (else (error "Unknown request -- MACHINE" message)))) dispatch)))
test
gosh> (fact-machine 'trace-on) trace-on gosh> (set-register-contents! fact-machine 'n 10) done gosh> (start fact-machine) (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)) (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)) (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)) (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)) (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)) (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)) (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)) (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)) (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)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) (restore n) (restore continue) (assign val (op *) (reg n) (reg val)) (goto (reg continue)) done