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) が抜けてるんですが ...