(wat-aro)

無職から有職者にランクアップしました

SICP 問題 5.11-b

;;; stackに退避するときにレジスタを指定しておき,そのレジスタにresotre出来るように修正する.
(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (let ((val (pop stack)))
        ;; valのcarにregisterが入っているので呼び出し側のregと比較し#fならエラーを返す
        (cond ((eq? reg (car val))
               (set-contents! reg (cdr val))
               (advance-pc pc))
              (else
               (error "RESTORE require the same register as save, but" reg)))))))

(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    (lambda ()
      (push stack (cons reg (get-contents reg))) ;regも一緒にconsする.
      (advance-pc pc))))

ex5.11-aで作ったfib-machineでテスト.これは失敗してほしい.

(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
     (restore n)
     (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 10)
done
gosh> (start fib-machine)
*** ERROR: operation - is not defined between (#<closure (make-register dispatch)> ((restore n) . #<closure (make-restore make-restore)>) ((assign n (op -) (reg n) (const 2)) . #<closure (make-assign make-assign)>) ((assign continue (label afterfib-n-2)) . #<closure (make-assign make-assign)>) ((save val) . #<closure (make-save make-save)>) ((goto (label fib-loop)) . #<closure (make-goto make-goto)>) ((restore n) . #<closure (make-restore make-restore)>) ((restore continue) . #<closure (make-restore make-restore)>) ((assign val (op +) (reg val) (reg n)) . #<closure (make-assign make-assign)>) ((goto (reg continue)) . #<closure (make-goto make-goto)>) ((assign val (reg n)) . #<closure (make-assign make-assign)>) ((goto (reg continue)) . #<closure (make-goto make-goto)>)) and 2
Stack Trace:
_______________________________________
  0  (value-proc)
        At line 341 of "/Users//work/scheme/SICP/5.2.scm"
  1  (set-contents! target (value-proc))
        At line 341 of "/Users//work/scheme/SICP/5.2.scm"
  2  ((instruction-execution-proc (car insts)))
        At line 444 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"

ex5.06で作ったfib-machine2.これは成功してほしい.

(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 n)
     (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