SICP演習問題5.18

夏休みだけに、ちょっと子供日記風に今日の天気を書いてみる。

今日は久しぶりに太陽さんに会いました。太陽さんが出てきたのでとってもとっても暑いです。ぼくは冬の太陽さんは大好きだけど、夏の太陽さんはきらいです。

僕の本心です。
早く夏よ去れ〜

ということで，それではSICP5.18です．

今回はレジスタをtraceせよとのこと．基本的には，5.16の命令トレースと同じ．

(define (make-register name)
  (let ((contents '*unassigned*)
        (trace? #f))
    (define (print-reg before-value value) ;; ex5.18
      (if trace?
          (print "reg-name: " name " before: " before-value " set: " value)))
    (define (dispatch message)
      (cond [(eq? message 'get) contents]
            [(eq? message 'set)
             (lambda (value) ;; ex5.18
               (let ((before-val contents))
                 (set! contents value)
                 (print-reg before-val value)))]
            [(eq? message 'trace-on) (set! trace? #t)]
            [(eq? message 'trace-off) (set! trace? #f)]
            [else
             (error "Unknown request -- REGISTER" message)]))
    dispatch))

(define (trace-on-register machine register-name) ;; ex5.18
  ((get-register machine register-name) 'trace-on))

(define (trace-off-register machine register-name) ;; ex5.18
  ((get-register machine register-name) 'trace-off))

実行

(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)
(trace-on expt-machine)
(trace-on-register expt-machine 'val)
(trace-on-register expt-machine 'n)
(start expt-machine)
(get-register-contents expt-machine 'val)

結果

見た目の悪さはご勘弁を．

gosh> instruction: (assign continue (label expt-done))
instruction: (test (op =) (reg n) (const 0))
instruction: (branch (label return))
instruction: (save continue)
instruction: (assign n (op -) (reg n) (const 1))
reg-name: n before: 3 set: 2
instruction: (assign continue (label after-expt))
instruction: (goto (label expt-loop))
instruction: (test (op =) (reg n) (const 0))
instruction: (branch (label return))
instruction: (save continue)
instruction: (assign n (op -) (reg n) (const 1))
reg-name: n before: 2 set: 1
instruction: (assign continue (label after-expt))
instruction: (goto (label expt-loop))
instruction: (test (op =) (reg n) (const 0))
instruction: (branch (label return))
instruction: (save continue)
instruction: (assign n (op -) (reg n) (const 1))
reg-name: n before: 1 set: 0
instruction: (assign continue (label after-expt))
instruction: (goto (label expt-loop))
instruction: (test (op =) (reg n) (const 0))
instruction: (branch (label return))
instruction: (assign val (const 1))
reg-name: val before: *unassigned* set: 1
instruction: (goto (reg continue))
instruction: (restore continue)
instruction: (assign val (op *) (reg b) (reg val))
reg-name: val before: 1 set: 2
instruction: (goto (reg continue))
instruction: (restore continue)
instruction: (assign val (op *) (reg b) (reg val))
reg-name: val before: 2 set: 4
instruction: (goto (reg continue))
instruction: (restore continue)
instruction: (assign val (op *) (reg b) (reg val))
reg-name: val before: 4 set: 8
instruction: (goto (reg continue))
done
gosh> 8