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