SICP 問題 5.19
ラベルから何番目の命令の直前にブレークポイントを入れられるようにする.
実装した手続きのテストはREPLで試したが,テストの記述は省略.
(define (set-breakpoint machine label n) ((machine 'set-breakpoint) label n)) (define (proceed-machine machine) (machine 'proceed)) (define (cancel-breakpoint machine label n) ((machine 'cancel-breakpoint) label n)) (define (cancel-all-breakpoints machine) (machine 'cancel-all-breakpoints)) (define (trace-on machine) (machine 'trace-on)) (define (trace-off machine) (machine 'trace-off)) (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) (breakpoint '()) ;連想リストのリスト (label-number 1)) (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) ((check-breakpoint breakpoint) (format "break! ~s: ~s" tracing-label label-number)) (else ((instruction-execution-proc (car insts))) (cond ((label-exp? (caar insts)) (set! tracing-label (cadaar insts)) (set! label-number 1)) (else (set! the-instruction-counter (+ 1 the-instruction-counter)) (set! label-number (+ 1 label-number)) (trace (caar insts)))) (execute trace))))) (define (proceed) (let ((insts (get-contents pc))) ((instruction-execution-proc (car insts))) (cond ((label-exp? (caar insts)) (set! tracing-label (cdaar insts)) (set! label-number 1)) (else (set! the-instruction-counter (+ 1 the-instruction-counter)) (set! label-number (+ 1 label-number)) (tracing-flag (caar insts)))) (execute tracing-flag))) (define (cancel-breakpoint label n) (set! breakpoint (remove (cons label n) breakpoint))) (define (remove x lis) (cond ((null? lis) (error "Cannot find in breakpoint" x)) ((equal? x (car lis)) (cdr lis)) (else (cons (car lis) (remove x (cdr lis)))))) (define (cancel-all-breakpoints) (set! breakpoint '())) ;; breakpointを引数に取り,再帰で一致するものがないか調べる. (define (check-breakpoint breakpoint) (cond ((null? breakpoint) #f) ((eq? (caar breakpoint) tracing-label) (cond ((eq? (cdar breakpoint) label-number) #t) (else (check-breakpoint (cdr breakpoint))))) (else (check-breakpoint (cdr breakpoint))))) (define (set-breakpoint label n) (set! breakpoint (cons (cons label n) breakpoint))) (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)) ((eq? message 'set-breakpoint) set-breakpoint) ((eq? message 'proceed) (proceed)) ((eq? message 'cancel-breakpoint) cancel-breakpoint) ((eq? message 'cancel-all-breakpoints) (cancel-all-breakpoints)) (else (error "Unknown request -- MACHINE" message)))) dispatch)))