sicp-ex-5.19



<< Previous exercise (5.18) | Index | Next exercise (5.20) >>


meteorgan

  ;; using a list to contain break points, every element in the list   
  ;; is a pair containing the label and line.  the code changed   
  ;; had been marked.  
  (define (make-new-machine)  
   (let ((pc (make-register 'pc))  
             (flag (make-register 'flag))  
             (stack (make-stack))  
             (the-instruction-sequence '())  
             (instruction-number 0)  
             (trace-on false)  
             (labels '())                                            ;; ***  
             (current-label '*unassigned*)             ;; ***  
             (current-line 0)                                    ;; ***  
             (breakpoint-line 0)                              ;; ***  
             (break-on true))                                   ;; ****  
    (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 (print-instruction-number)  
     (display (list "current instruction number is: " instruction-number))  
     (set! instruction-number 0)  
     (newline))  
     (define (allocate-register name)  
          (if (assoc name register-table)  
              (error "Multiply defined register: " 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)  
                   (begin  
                    (allocate-register name)  
                    (lookup-register name)))))  
     (define (execute)  
          (let ((insts (get-contents pc)))  
           (if (null? insts)  
               'done  
                   (begin                                                 ;; ***  
                    (if (and (not (null? (instruction-label (car insts))))  
                                 (assoc (instruction-label (car insts)) labels))  
                        (begin  
                             (set! current-label (instruction-label (car insts)))  
                             (set! breakpoint-line (cdr (assoc current-label labels)))  
                             (set! current-line 0)))  
                    (set! current-line (+ current-line 1))  
                    (if (and (= current-line breakpoint-line) break-on)  
                        (begin   
                             (set! break-on false)  
                         (display (list "breakpoint here" current-label current-line)))  
                        (begin  
                             (if trace-on  
                                  (begin  
                                   (display (instruction-text (car insts)))  
                           (newline)))  
                             (set! break-on true)                                    ;; ***  
                         ((instruction-execution-proc (car insts)))  
                         (set! instruction-number (+ instruction-number 1))  
                         (execute)))))))  
          (define (cancel-breakpoint label)                                 ;; ***  
           (define (delete-label acc-labels orig-labels)  
            (cond ((null? orig-labels)  
                           (error "the label is not in the machine -- CANCEL-REAKPOINT" label))  
                  ((eq? (caar orig-labels) label) (append acc-labels (cdr orig-labels)))  
                      (else (delete-label (cons (car orig-labels) acc-labels) (cdr orig-labels)))))  
           (set! labels (delete-label '() labels)))  
          (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 'trace-on) (set! trace-on true))  
                     ((eq? message 'trace-off) (set! trace-on false))  
                     ((eq? message 'get-register) lookup-register)  
                     ((eq? message 'install-operations)  
                          (lambda (ops) (set! the-ops (append the-ops ops))))  
                     ((eq? message 'instruction-number) print-instruction-number)  
                     ((eq? message 'stack) stack)  
                     ((eq? message 'operations) the-ops)  
                     ((eq? message 'set-breakpoint)                           ;; ***  
                          (lambda (label n) (set! labels (cons (cons label n) labels))))  
                     ((eq? message 'cancel-breakpoint)                     ;; ***  
                          (lambda (label) (cancel-breakpoint label)))  
                     ((eq? message 'cancel-all-breakpoint) (set! labels '()))  
                     ((eq? message 'process-machine) (execute))     ;; ***  
                     (else (error "Unkown request -- MACHINE" message))))  
          dispatch)))  
    
  (define (set-breakpoint machine label n)  
   ((machine 'set-breakpoint) label n))  
  (define (cancel-breakpoint machine label)  
   ((machine 'cancel-breakpoint) label))  
  (define (cancel-all-breakpoint machine)  
   (machine 'cancel-all-breakpoint))  
  (define (process-machine machine)  
   (machine 'process-machine))  
  
 Another solution at: 
 https://github.com/spacemanaki/sicp/blob/master/ch5/ex-5.19-breakpoints.scm 

I think the above procedure will function well with only one breakpoint, but there might be some bug when implement it with more that one breakpoint.

 ... 
 (if (and (not (null? (instruction-label (car insts))))  
          (assoc (instruction-label (car insts)) labels))  
     (begin  
       (set! current-label (instruction-label (car insts)))  
       (set! breakpoint-line (cdr (assoc current-label labels)))  
       (set! current-line 0)))  
 ... 

the (set! breakpoint-line (cdr (assoc current-label labels))) here will cause some bug if there are two breakpoints with same label in the labels (labels are used to store breakpoints here). Apparently, the front one in the labels will be calculated first. But actually both of them should be calculated simultaneously.

The second situation is that if two breakpoints are interleaved. For example, if breakpoint one is set up to break when the procedure meet label "A" after 100 steps, and breakpoint two to label "B" after 50 steps. It will be alright if label "B" is not in the 100 steps after label "A". But if it is in, the above procedure will just cover the counting current-line and breakpoint-line, reset the current-line to 0 and breakpoint-line to 50, which means process won't be broke for breakepoint one (A, 100).