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