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

This procedure has a couple of problems. First, you can't have more than one break-point in any label. Because assoc will only find the first one. The other problem is with cancel-breakpoint. Because it uses cons to accumulate the labels, the elements in the labels lists will change order each time you cancel a break-point. And if more than one breakpoint was placed in this label (which would not work because of the first problem), then it will now break at another point of the execution. The solution in: https://github.com/spacemanaki/sicp/blob/master/ch5/ex-5.19-breakpoints.scm does not have these issues.