SICP 問題 5.17
トレースログにラベルネームをつける.
extract-labelsでlabelを見つけた時に('label labe-name)の形でinsts, labels両方に登録する.
make-new-machineでtracing-labelを作り,そこに現在のラベルを登録する.
*1の実行形式はそのまま(advanced-pc pc)でpcをすすめるだけ.
後はexecuteを調整する
(define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (if (assoc next-inst labels) (error "The same label name is used to indicate two different location " label-name) ;; ここでlabelは('label . next-inst)の形でinstsに登録 (let ((insts (cons (list (list 'label next-inst)) insts))) (receive insts (cons (make-label-entry next-inst insts) labels)))) (receive (cons (make-instruction next-inst) insts) labels))))))) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (the-instruction-counter 0) (tracing-flag (lambda (inst) #f)) (tracing-label 'global)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))) (list 'print-stack-statistics (lambda () (stack 'print-statistics))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (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) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (error "Unknown register: " name)))) (define (execute trace) (let ((insts (get-contents pc))) (cond ((null? insts) 'done) (else ((instruction-execution-proc (car insts))) (cond ((label-exp? (caar insts)) (set! tracing-label (cdaar insts))) (else (set! the-instruction-counter (+ 1 the-instruction-counter)) (trace (caar insts)))) (execute trace))))) (define (trace-on) (set! tracing-flag (lambda (inst) (display tracing-label) (display " : ") (display inst) (newline))) 'trace-on) (define (trace-off) (set! tracing-flag (lambda (inst) #f)) 'trace-off) (define (initialize-counter) (set! instruction-counter 0)) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute tracing-flag)) ((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 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'get-counter) the-instruction-counter) ((eq? message 'initilize-counter) (initilize-counter)) ((eq? message 'trace-on) (trace-on)) ((eq? message 'trace-off) (trace-off)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (make-execution-procedure inst labels machine pc flag stack 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 stack pc)) ((eq? (car inst) 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (make-perform inst machine labels ops pc)) ((eq? (car inst) 'label) (lambda () (advance-pc pc))) (else (error "Unknown instruction type -- ASSEMBLE" inst))))
test
(define fib-machine (make-machine '(n val continue) (list (list '< <) (list '- -) (list '+ +)) '(start (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 (assign n (op print-stack-statistics))))) gosh> (set-register-contents! fib-machine 'n 3) done gosh> (fib-machine 'trace-on) trace-on gosh> (start fib-machine) (start) : (assign continue (label fib-done)) (fib-loop) : (test (op <) (reg n) (const 2)) (fib-loop) : (branch (label immediate-answer)) (fib-loop) : (save continue) (fib-loop) : (assign continue (label afterfib-n-1)) (fib-loop) : (save n) (fib-loop) : (assign n (op -) (reg n) (const 1)) (fib-loop) : (goto (label fib-loop)) (fib-loop) : (test (op <) (reg n) (const 2)) (fib-loop) : (branch (label immediate-answer)) (fib-loop) : (save continue) (fib-loop) : (assign continue (label afterfib-n-1)) (fib-loop) : (save n) (fib-loop) : (assign n (op -) (reg n) (const 1)) (fib-loop) : (goto (label fib-loop)) (fib-loop) : (test (op <) (reg n) (const 2)) (fib-loop) : (branch (label immediate-answer)) (immediate-answer) : (assign val (reg n)) (immediate-answer) : (goto (reg continue)) (afterfib-n-1) : (restore n) (afterfib-n-1) : (assign n (op -) (reg n) (const 2)) (afterfib-n-1) : (assign continue (label afterfib-n-2)) (afterfib-n-1) : (save val) (afterfib-n-1) : (goto (label fib-loop)) (fib-loop) : (test (op <) (reg n) (const 2)) (fib-loop) : (branch (label immediate-answer)) (immediate-answer) : (assign val (reg n)) (immediate-answer) : (goto (reg continue)) (afterfib-n-2) : (assign n (reg val)) (afterfib-n-2) : (restore val) (afterfib-n-2) : (restore continue) (afterfib-n-2) : (assign val (op +) (reg val) (reg n)) (afterfib-n-2) : (goto (reg continue)) (afterfib-n-1) : (restore n) (afterfib-n-1) : (assign n (op -) (reg n) (const 2)) (afterfib-n-1) : (assign continue (label afterfib-n-2)) (afterfib-n-1) : (save val) (afterfib-n-1) : (goto (label fib-loop)) (fib-loop) : (test (op <) (reg n) (const 2)) (fib-loop) : (branch (label immediate-answer)) (immediate-answer) : (assign val (reg n)) (immediate-answer) : (goto (reg continue)) (afterfib-n-2) : (assign n (reg val)) (afterfib-n-2) : (restore val) (afterfib-n-2) : (restore continue) (afterfib-n-2) : (assign val (op +) (reg val) (reg n)) (afterfib-n-2) : (goto (reg continue)) (total-pushes = 6 maximum-depth = 4)(fib-done) : (assign n (op print-stack-statistics)) done
*1:'label label-name