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