SICP 問題 5.13

make-machineでレジスタのリストを登録するのではなく，
命令の中で初めてassignされるときにレジスタを登録するように変更する．
make-machineとmake-new-machineの変更だけですむ．

;;; register-namesを削除
(define (make-machine ops controller-text)
  (let ((machine (make-new-machine)))
    ((machine 'install-operations) ops)
    (let ((insts (assemble controller-text machine)))
      ((machine 'install-instruction-sequence) (car insts))
      ((machine 'install-instruction-types) (cadr insts))
      ((machine 'install-label-registers) (caddr insts))
      ((machine 'install-saved-registers) (cadddr insts))
      ((machine 'install-register-sources) (car (cddddr insts)))
      machine)))

;;; lookupで見つからなければallocateで登録．
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (the-instruction-sequence '())
        (the-instruction-types '())
        (the-label-registers '())
        (the-saved-registers '())
        (the-register-sources '()))
    (let ((register-table
           (list (list 'pc pc) (list 'flag flag))))
      (let ((the-ops
             (list (list 'initialize-stack
                         (lambda ()
                           (for-each (lambda (stack) (stack 'initialize))
                                     register-table))))))
        (define (allocate-register name)
          (if (assoc name register-table)
              (error "Multiply defined rgister: " name)
              ;; 登録した後にそのレジスタを返す
              (let ((reg (make-register name)))
                   (set! register-table
                         (cons (list name reg)
                               register-table))
                   reg)))
        (define (lookup-register name)
          (let ((val (assoc name register-table)))
            (if val
                (cadr val)
                (allocate-register name)))) ;; 見つからなければ新たに登録する．
        (define (execute)
          (let ((insts (get-contents pc)))
            (if (null? insts)
                'done
                (begin
                  ((instruction-execution-proc (car insts)))
                  (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 'operations) the-ops)
                ((eq? message 'install-instruction-types)
                 (lambda (types) (set! the-instruction-types types)))
                ((eq? message 'install-label-registers)
                 (lambda (regs) (set! the-label-registers regs)))
                ((eq? message 'install-saved-registers)
                 (lambda (saved) (set! the-saved-registers saved)))
                ((eq? message 'install-register-sources)
                 (lambda (sources) (set! the-register-sources sources)))
                ((eq? message 'instruction-types) the-instruction-types)
                ((eq? message 'label-registers) the-label-registers)
                ((eq? message 'saved-registers) the-saved-registers)
                ((eq? message 'register-sources) the-register-sources)
                (else (error "Unknown request -- MACHINE" message))))
        dispatch))))

test

(define fib-machine
  (make-machine
   ;; '(n val continue)
   (list (list '< <) (list '- -) (list '+ +))
   '(controller
     (assign continue (label fib-done))
     fib-loop
     (test (op <) (reg n) (const 2))
     (branch (label immediate-answer))
     (save continue)
     (assign continue (label afterfib-n-1))
     (save n)
     (assign n (op -) (reg n) (const 1))
     (goto (label fib-loop))
     afterfib-n-1
     (restore n)
     (assign n (op -) (reg n) (const 2))
     (assign continue (label afterfib-n-2))
     (save val)
     (goto (label fib-loop))
     afterfib-n-2
     (assign n (reg val))
     (restore val)
     (restore continue)
     (assign val
             (op +) (reg val) (reg n))
     (goto (reg continue))
     immediate-answer
     (assign val (reg n))
     (goto (reg continue))
     fib-done)))

gosh> (set-register-contents! fib-machine 'n 20)
done
gosh> (start fib-machine)
done
gosh> (get-register-contents fib-machine 'val)
6765