SICP 問題 5.11-c

各レジスタがスタックを持つようにしてpopやpushはそのスタックを使用するように修正する．

;; make-registerがstackを持つ
(define (make-register name)
  (let ((contents '*unassaigned*)
        (stack (make-stack)))     ;;(make-stack)
    (define (dispatch message)
      (cond ((eq? message 'get) contents)
            ((eq? message 'set)
             (lambda (value) (set! contents value)))
            ((eq? message 'pop)
             (let ((val (stack 'pop)))
               ((dispatch 'set) val)))
            ((eq? message 'push)
             ((stack 'push) contents))
            ((eq? message 'initialize)
             (stack 'initialize))
            (else
             (error "Unknown request -- REGISTER" message))))
    dispatch))


;; make-new-machineはstackを持たなくなった．
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (the-instruction-sequence '()))
    (let ((register-table
           (list (list 'pc pc) (list 'flag flag))))
      (let ((the-ops                    ;すべてのregisterに対してstackを初期化する手続きを入れる
             (list (list 'initialize-stack
                         (lambda ()
                           (for-each (lambda (stack) (stack 'initialize))
                                     register-table))))))
        ;; registerをregiter-tableに登録する．
        (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)
        ;; registerの値をregister-tableから見つける．
        (define (lookup-register name)
          (let ((val (assoc name register-table)))
            (if val
                (cadr val)
                (error "Unknown register: " name))))
        ;; pc内に保存された手続きを実行する
        (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) ;the-instruction-sequenceをpcに保存してexecute
                 (set-contents! pc the-instruction-sequence)
                 (execute))
                ((eq? message 'install-instruction-sequence) ;the-instruction-sequenceにseqを登録
                 (lambda (seq) (set! the-instruction-sequence seq)))
                ((eq? message 'allocate-register) allocate-register)
                ((eq? message 'get-register) lookup-register)
                ((eq? message 'install-operations) ;新しいopをthe-opsに追加
                 (lambda (ops) (set! the-ops (append the-ops ops))))
                ((eq? message 'stack) stack)
                ((eq? message 'operations) the-ops)
                (else (error "Unknown request -- MACHINE" message))))
        dispatch))))

(define (make-execution-procedure inst labels machine ;引数からstackを削除
                                  pc flag ops)
  (cond ((eq? (car inst) 'assign)
         (make-assign inst machine labels ops pc))
        ((eq? (car inst) 'test)
         (make-test inst machine labels ops flag pc))
        ((eq? (car inst) 'branch)
         (make-branch inst machine labels flag pc))
        ((eq? (car inst) 'goto)
         (make-goto inst machine labels pc))
        ((eq? (car inst) 'save)
         (make-save inst machine pc))   ;引数からstackを削除
        ((eq? (car inst) 'restore)
         (make-restore inst machine pc))  ;引数からstackを削除
        ((eq? (car inst) 'perform)
         (make-perform inst machine labels ops pc))
        (else (error "Unknown instruction type -- ASSEMBLE" inst))))

(define (update-insts! insts labels machine)
  (let ((pc (get-register machine 'pc))
        (flag (get-register machine 'flag))
        (ops (machine 'operations)))
    (for-each
     (lambda (inst)
       (set-instruction-execution-proc!
        inst
        (make-execution-procedure
         (instruction-text inst) labels machine
         pc flag ops)))
     insts)))

(define (make-save inst machine pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (reg 'push)
      (advance-pc pc))))

(define (make-restore inst machine pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (reg 'pop)
      (advance-pc pc))))

test. 5.11-bと同じくfib-machine2で動けばよく，fib-machineでは正しい答えが返らない．

(define fib-machine2
  (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-machine2 'n 10)
done
gosh> (start fib-machine2)
done
gosh> (get-register-contents fib-machine2 'val)
55

gosh> (set-register-contents! fib-machine 'n 10)
done
gosh> (start fib-machine)
*** ERROR: Empty stack -- POP
Stack Trace:
_______________________________________
  0  (stack 'pop)
        At line 1770 of "(standard input)"
  1  (reg 'pop)
        At line 1906 of "(standard input)"
  2  ((instruction-execution-proc (car insts)))
        At line 1810 of "(standard input)"
  3  (eval expr env)
        At line 179 of "/usr/local/Cellar/gauche/0.9.4/share/gauche-0.9/0.9.4/lib/gauche/interactive.scm"