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