sicp-ex-5.19

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 
  
 (codybartfast: This may have moved to: 
 https://github.com/michiakig/sicp/blob/master/ch5/ex-5.19-breakpoints.scm)

poly

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

aos

I ended up using a 2-D association list as my breakpoint table. The first key is the label, the second key is the line number, and the third key is whether it is on or off. Setting a breakpoint adds (or modifies) the breakpoint in the table to on, canceling turns it off. Unsetting all BPs just resets the table completely.

In this way you can interleave breakpoints to your heart's desire.

codybartfast

I took a different approach and updated the instruction object to indicate if we should break on that instruction and which records the original label & offset. At runtime the machine then just checks if the instruction is marked as a breakpoint.

;; The breakpoint-controller provides procedures for modifying instructions:

  (define (make-breakpoint-controller labels)
    (define (set label offset)
      (set-instruction-break!
       (list-ref (lookup-label labels label) offset)
       #t (cons label offset)))
    (define (cancel label offset)
      (set-instruction-break!
       (list-ref (lookup-label labels label) offset) #f '()))
    (define (cancel-all)
      (map
       (lambda (label)
         (map
          (lambda (inst)
            (set-instruction-break! inst #f '()))
          (filter
           (lambda (inst) (not (symbol? inst)))
           (cdr label))))
       labels))
    (define (dispatch message)
      (cond
        ((eq? message 'set) set)
        ((eq? message 'cancel) cancel)
        ((eq? message 'cancel-all) cancel-all)))
    dispatch)

;; And in the machine:

  (define (execute-proceed check-break)
    (let ((insts (get-contents pc)))
      (cond ((null? insts)
              ...
            ((and check-break (instruction-break? (car insts)))
             (let ((desc  (instruction-break-desc (car insts))))
               (display \"--break--:  label: \")
               (display (car desc))
               (display \" offset: \")
               (display (cdr desc))
               (newline)
               'stopped))
            (else    ;; normal execution
             (write-trace (instruction-text (car insts)))
             ((instruction-execution-proc (car insts)))
             (set! inst-count (+ inst-count 1))
             (execute)))))
  (define (proceed) (execute-proceed #false))
  (define (execute) (execute-proceed #true))

;; full code on github:
;; https://github.com/codybartfast/sicp/blob/master/chapter5/exercise-5.19.scm
;; https://github.com/codybartfast/sicp/blob/master/chapter5/machine-19.scm

revc

 (define (make-stack) 
   (let ((s '()) 
         (number-pushes 0) 
         (max-depth 0) 
         (current-depth 0)) 
     (define (push x) 
       (set! s (cons x s)) 
       (set! number-pushes (+ 1 number-pushes)) 
       (set! current-depth (+ 1 current-depth)) 
       (set! max-depth (max current-depth max-depth))) 
     (define (pop) 
       (if (null? s) 
           (error "Empty stack -- POP" 'pop) 
           (let ((top (car s))) 
             (set! s (cdr s)) 
             (set! current-depth (- current-depth 1)) 
             top))) 
      
     (define (initialize) 
       (set! s '()) 
       (set! number-pushes 0) 
       (set! max-depth 0) 
       (set! current-depth 0) 
       'done) 
     (define (print-statistics) 
       (newline) 
       (for-each display (list "total-pushes: " number-pushes 
                               "\n" 
                               "maximum-depth: " max-depth 
                               "\n" 
                               ))) 
      
     (define (dispatch message) 
       (cond ((eq? message 'push) push) 
             ((eq? message 'pop) (pop)) 
             ((eq? message 'initialize) (initialize)) 
             ((eq? message 'print-statistics) 
              (print-statistics)) 
             (else 
              (error "Unknown request -- STACK" message)))) 
     dispatch)) 
  
 (define input-prompt ";;; Factorial-Machine input:") 
 (define output-prompt ";;; Factorial-Machine output:") 
  
 (define (prompt-for-input string) 
   (newline) (newline) (display string) (newline)) 
  
 (define (announce-output string) 
   (newline) (display string) (newline)) 
  
  
 (define (lookup-insts labels insts) 
   (let ((val (assoc insts labels))) 
     (if val 
         (cdr val) 
         #f))) 
        
  
  
 (define (assemble controller-text machine) 
   (extract-labels controller-text 
                   (lambda (insts labels) 
                     (update-insts! insts labels machine) 
                     ((machine 'install-instruction-labels) labels) 
                     insts))) 
  
  
 (define (make-register name labels) 
   (let ((contents '*unassigned*) 
         (trace-switch #f)) 
      
     (define (print-information value) 
       (display "register ") 
       (display name) 
        
       (display " :") 
       (if (pair? contents) 
           (if (lookup-insts labels contents) 
               (display (lookup-insts labels contents)) 
               (display (list (instruction-text (car contents)) '...))) 
           (display contents)) 
        
       (display " >>> ") 
       (if (pair? value) 
           (if (lookup-insts labels value) 
               (display (lookup-insts labels value)) 
               (display (list (instruction-text (car value)) '...))) 
           (display value)) 
        
       (newline)) 
      
     (define (dispatch message) 
       (cond ((eq? message 'get) contents) 
             ((eq? message 'set) 
              (lambda (value) 
                (if trace-switch (print-information value)) 
                (set! contents value))) 
             ((eq? message 'trace-on) (set! trace-switch #t)) 
             ((eq? message 'trace-off) (set! trace-switch #f)) 
             (else 
              (error "Unknown request -- REGISTER" message)))) 
     dispatch)) 
  
  
 (define (make-new-machine) 
   (let* ((stack (make-stack)) 
          (the-instruction-sequence '()) 
          (the-instruction-insts '((*DUMMY* . *HEAD*))) 
          (the-instruction-labels '((*DUMMY* . *HEAD*))) 
          (the-breakpoints '()) 
          (flag (make-register 'flag the-instruction-insts)) 
          (pc (make-register 'pc the-instruction-insts)) 
          (trace-switch #f)) 
     (let ((the-ops 
            (list (list 'initialize-stack 
                        (lambda () (stack 'initialize))) 
                  ;;**next for monitored stack (as in section 5.2.4) 
                  ;;  -- comment out if not wanted 
                  (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 register: " name) 
             (set! register-table 
                   (cons (list name (make-register name the-instruction-insts))  ;** 
                         register-table))) 
         'register-allocated) 
       (define (lookup-register name) 
         (let ((val (assoc name register-table))) 
           (if val 
               (cadr val) 
               (error "Unknown register:" name)))) 
  
       (define (print-trace insts) 
         (let ((label (lookup-insts the-instruction-insts insts))) 
           (if label 
               (begin 
                 (display "label:\t") 
                 (display label) 
                 (newline)))) 
          
         (display "instruction:\t") 
         (display (instruction-text (car insts))) 
         (newline)) 
  
       (define (proceed) 
         (let ((insts (get-contents pc))) 
           (if (null? insts) 
               'done 
               (begin 
                 (if trace-switch 
                     (print-trace insts)) 
                 ((instruction-execution-proc (car insts))) 
                 (execute))))) 
        
       (define (execute) 
         (let ((insts (get-contents pc))) 
           (if (or (null? insts) (member insts the-breakpoints)) 
               'done 
               (begin 
                 (if trace-switch 
                     (print-trace insts)) 
                 ((instruction-execution-proc (car insts))) 
                 (execute))))) 
  
       (define (install-instruction-labels labels) 
         (set-cdr! the-instruction-insts 
                   (map (lambda (x) (cons (cdr x) (car x))) 
                        labels)) 
         (set-cdr! the-instruction-labels labels)) 
  
       (define (set-breakpoint label n) 
         (set! the-breakpoints 
               (cons (list-tail (lookup-label the-instruction-labels label) n) 
                     the-breakpoints))) 
  
       (define (cancel-breakpoint label n) 
         (set! the-breakpoints 
               (remove (list-tail (lookup-label the-instruction-labels label) n) 
                       the-breakpoints))) 
  
       (define (cancel-all-breakpoints) 
         (set! the-breakpoints '())) 
        
       (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 'install-instruction-labels) ;** 
                install-instruction-labels) 
               ((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 'trace-on) (set! trace-switch #t)) 
               ((eq? message 'trace-off) (set! trace-switch #f)) 
               ((eq? message 'register-trace-off) 
                (lambda (r) ((lookup-register r) 'trace-off))) 
               ((eq? message 'register-trace-on) 
                (lambda (r) ((lookup-register r) 'trace-on))) 
                
               ((eq? message 'set-breakpoint) set-breakpoint) 
               ((eq? message 'cancel-breakpoint) cancel-breakpoint) 
               ((eq? message 'cancel-all-breakpoints) (cancel-all-breakpoints)) 
               ((eq? message 'proceed-machine) (proceed)) 
               (else (error "Unknown request -- MACHINE" message)))) 
       dispatch))) 
  
 (define factorial-machine 
   (make-machine 
    '(continue n val) 
    (list (list '= =) (list '* *) (list '- -)) 
    '( 
      (perform (op initialize-stack)) 
      (assign continue (label factorial-done)) 
  
      factorial-loop 
      (test (op =) (reg n) (const 0)) 
      (branch (label base-case)) 
      (test (op =) (reg n) (const 1)) 
      (branch (label base-case)) 
      (save continue) 
      (save n) 
      (assign continue (label after-factorial)) 
      (assign n (op -) (reg n) (const 1)) 
      (goto (label factorial-loop)) 
      after-factorial 
       
      (restore n) 
      (restore continue) 
      (assign val (op *) (reg val) (reg n)) 
      (goto (reg continue)) 
  
       
      base-case 
      (assign val (const 1)) 
      (goto (reg continue)) 
  
       
      factorial-done 
      (perform (op print-stack-statistics)) 
      ))) 
  
  
 (define (register-trace-off machine) 
   (display "which register?\n") 
   (let ((r (read))) 
     ((machine 'register-trace-off) r) 
     (display "disable trace of ") 
     (display r) 
     (newline) 
     (driver-loop))) 
  
 (define (register-trace-on machine) 
   (display "which register?\n") 
   (let ((r (read))) 
     ((machine 'register-trace-on) r) 
     (display "enable trace of ") 
     (display r) 
     (newline) 
     (driver-loop))) 
  
 (define (breakpoint-setter machine) 
   (display "which label?\n") 
   (let ((label (read))) 
     (display "which position?\n") 
     (let ((n (read))) 
       (set-breakpoint machine label n) 
       (driver-loop)))) 
  
 (define (breakpoint-canceler machine) 
   (display "which label?\n") 
   (let ((label (read))) 
     (display "which position?\n") 
     (let ((n (read))) 
       (cancel-breakpoint machine label n) 
       (driver-loop)))) 
  
 (define (driver-loop) 
   (prompt-for-input input-prompt) 
   (let ((n (read))) 
     (announce-output output-prompt) 
     (cond [(eq? n 'quit) (display "goodbye\n")] 
           [(eq? n 'trace-on) (factorial-machine 'trace-on) (display "enable trace\n") (driver-loop)] 
           [(eq? n 'trace-off) (factorial-machine 'trace-off) (display "disable trace\n") (driver-loop)] 
           [(eq? n 'r-trace-off) (register-trace-off factorial-machine)] 
           [(eq? n 'r-trace-on) (register-trace-on factorial-machine)] 
           [(eq? n 'set-bp) (breakpoint-setter factorial-machine)] 
           [(eq? n 'cancel-bp) (breakpoint-canceler factorial-machine)] 
           [(eq? n 'cancel-abp) (cancel-all-breakpoints factorial-machine) (driver-loop)] 
           [(eq? n 'proceed) (proceed-machine factorial-machine) (driver-loop)] 
           [(integer? n) 
            (set-register-contents! factorial-machine 'n n) 
            (start factorial-machine) 
            (display "value: ") 
            (display (get-register-contents factorial-machine 'val)) 
            (newline) 
            (driver-loop)] 
           [else (display "Unknown input, try again!\n") (driver-loop)]))) 
  
 (define (set-breakpoint machine label n) 
   ((machine 'set-breakpoint) label n)) 
  
 (define (cancel-breakpoint machine label n) 
   ((machine 'cancel-breakpoint) label n)) 
  
 (define (cancel-all-breakpoints machine) 
   (machine 'cancel-all-breakpoints)) 
  
 (define (proceed-machine machine) 
   (machine 'proceed-machine)) 
  
 ;;;;;;;;;;;;;test;;;;;;;;;;;;;;;;; 
  
  
 ;;; Factorial-Machine input: 
 trace-on 
  
 ;;; Factorial-Machine output: 
 enable trace 
  
  
 ;;; Factorial-Machine input: 
 r-trace-on 
  
 ;;; Factorial-Machine output: 
 which register? 
 continue 
 enable trace of continue 
  
  
 ;;; Factorial-Machine input: 
 2 
  
 ;;; Factorial-Machine output: 
 instruction:    (perform (op initialize-stack)) 
 instruction:    (assign continue (label factorial-done)) 
 register continue :*unassigned* >>> factorial-done 
 label:  factorial-loop 
 instruction:    (test (op =) (reg n) (const 0)) 
 instruction:    (branch (label base-case)) 
 instruction:    (test (op =) (reg n) (const 1)) 
 instruction:    (branch (label base-case)) 
 instruction:    (save continue) 
 instruction:    (save n) 
 instruction:    (assign continue (label after-factorial)) 
 register continue :factorial-done >>> after-factorial 
 instruction:    (assign n (op -) (reg n) (const 1)) 
 instruction:    (goto (label factorial-loop)) 
 label:  factorial-loop 
 instruction:    (test (op =) (reg n) (const 0)) 
 instruction:    (branch (label base-case)) 
 instruction:    (test (op =) (reg n) (const 1)) 
 instruction:    (branch (label base-case)) 
 label:  base-case 
 instruction:    (assign val (const 1)) 
 instruction:    (goto (reg continue)) 
 label:  after-factorial 
 instruction:    (restore n) 
 instruction:    (restore continue) 
 register continue :after-factorial >>> factorial-done 
 instruction:    (assign val (op *) (reg val) (reg n)) 
 instruction:    (goto (reg continue)) 
 label:  factorial-done 
 instruction:    (perform (op print-stack-statistics)) 
  
 total-pushes: 2 
 maximum-depth: 2 
 value: 2 
  
  
 ;;; Factorial-Machine input: 
 set-bp 
  
 ;;; Factorial-Machine output: 
 which label? 
 factorial-done 
 which position? 
 0 
  
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; Factorial-Machine output: 
 instruction:    (perform (op initialize-stack)) 
 instruction:    (assign continue (label factorial-done)) 
 register continue :factorial-done >>> factorial-done 
 label:  factorial-loop 
 instruction:    (test (op =) (reg n) (const 0)) 
 instruction:    (branch (label base-case)) 
 instruction:    (test (op =) (reg n) (const 1)) 
 instruction:    (branch (label base-case)) 
 label:  base-case 
 instruction:    (assign val (const 1)) 
 instruction:    (goto (reg continue)) 
 value: 1 
  
  
 ;;; Factorial-Machine input: 
 proceed 
  
 ;;; Factorial-Machine output: 
 label:  factorial-done 
 instruction:    (perform (op print-stack-statistics)) 
  
 total-pushes: 0 
 maximum-depth: 0 
  
  
 ;;; Factorial-Machine input: 
 set-bp 
  
 ;;; Factorial-Machine output: 
 which label? 
 base-case 
 which position? 
 0 
  
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; Factorial-Machine output: 
 instruction:    (perform (op initialize-stack)) 
 instruction:    (assign continue (label factorial-done)) 
 register continue :factorial-done >>> factorial-done 
 label:  factorial-loop 
 instruction:    (test (op =) (reg n) (const 0)) 
 instruction:    (branch (label base-case)) 
 instruction:    (test (op =) (reg n) (const 1)) 
 instruction:    (branch (label base-case)) 
 value: 1 
  
  
 ;;; Factorial-Machine input: 
 proceed 
  
 ;;; Factorial-Machine output: 
 label:  base-case 
 instruction:    (assign val (const 1)) 
 instruction:    (goto (reg continue)) 
  
  
 ;;; Factorial-Machine input: 
 proceed 
  
 ;;; Factorial-Machine output: 
 label:  factorial-done 
 instruction:    (perform (op print-stack-statistics)) 
  
 total-pushes: 0 
 maximum-depth: 0 
  
  
 ;;; Factorial-Machine input: 
 cancel-bp 
  
 ;;; Factorial-Machine output: 
 which label? 
 factorial-done 
 which position? 
 0 
  
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; Factorial-Machine output: 
 instruction:    (perform (op initialize-stack)) 
 instruction:    (assign continue (label factorial-done)) 
 register continue :factorial-done >>> factorial-done 
 label:  factorial-loop 
 instruction:    (test (op =) (reg n) (const 0)) 
 instruction:    (branch (label base-case)) 
 instruction:    (test (op =) (reg n) (const 1)) 
 instruction:    (branch (label base-case)) 
 value: 1 
  
  
 ;;; Factorial-Machine input: 
 proceed 
  
 ;;; Factorial-Machine output: 
 label:  base-case 
 instruction:    (assign val (const 1)) 
 instruction:    (goto (reg continue)) 
 label:  factorial-done 
 instruction:    (perform (op print-stack-statistics)) 
  
 total-pushes: 0 
 maximum-depth: 0 
  
  
 ;;; Factorial-Machine input: 
 cancel-abp 
  
 ;;; Factorial-Machine output: 
  
  
 ;;; Factorial-Machine input: 
 1 
  
 ;;; Factorial-Machine output: 
 instruction:    (perform (op initialize-stack)) 
 instruction:    (assign continue (label factorial-done)) 
 register continue :factorial-done >>> factorial-done 
 label:  factorial-loop 
 instruction:    (test (op =) (reg n) (const 0)) 
 instruction:    (branch (label base-case)) 
 instruction:    (test (op =) (reg n) (const 1)) 
 instruction:    (branch (label base-case)) 
 label:  base-case 
 instruction:    (assign val (const 1)) 
 instruction:    (goto (reg continue)) 
 label:  factorial-done 
 instruction:    (perform (op print-stack-statistics)) 
  
 total-pushes: 0 
 maximum-depth: 0 
 value: 1 
  
  
 ;;; Factorial-Machine input: 
 quit 
  
 ;;; Factorial-Machine output: 
 goodbye

baby

A quite enjoyable and satisfying exercise. After thinking for sometime before coding, I decided to modify the representation of an instruction - specifically, I have decided to make it an object as well, with message passing mechanism.

(define (instruction-object)
  (let ((text '*unassigned*)
        (proc '*unassigned*)
        (label '*unassigned*)
        (breakpoint #f))
    (define (dispatch message)
      (cond ((eq? message 'set-text)
             (lambda (ins)
               (set! text ins)))
            ((eq? message 'set-proc)
             (lambda (p)
               (set! proc p)))
            ((eq? message 'set-label)
             (lambda (l)
               (set! label l)))
            ((eq? message 'set-breakpoint)
             (set! breakpoint #t))
            ((eq? message 'clear-breakpoint)
             (set! breakpoint #f))
            ((eq? message 'get-text) text)
            ((eq? message 'get-proc) proc)
            ((eq? message 'get-label) label)
            ((eq? message 'break?) breakpoint)
            (else
             (error "Unknown request: INSTRUCTION" message))))
    dispatch))

(define (make-instruction text)
  (let ((obj (instruction-object)))
    ((obj 'set-text) text)
    obj))
(define (instruction-text inst)
  (inst 'get-text))
(define (instruction-execution-proc inst)
  (inst 'get-proc))
(define (set-instruction-execution-proc! inst proc)
  ((inst 'set-proc) proc))
(define (set-instruction-label label inst)
  ((inst 'set-label) label))
(define (instruction-label inst)
  (inst 'get-label))
(define (should-break? inst)
  (inst 'break?))
(define (set-break inst) (inst 'set-breakpoint))
(define (clear-break inst) (inst 'clear-breakpoint))

I have modified the machine model to store the labels as well. I was wondering so much as to how I could iterate through instructions of a label, only to realize it was in plain slight.

(define (assemble controller-text machine)
  (extract-labels
   controller-text
   ; 5.19
   (lambda (insts labels)
     ((machine 'store-labels) labels)
     (update-insts! insts labels machine)
     insts)))

Here are the functions asked for:

(define (set-breakpoint machine label n)
  (define (insert-break insts n i)
    (cond ((null? insts)
           'done)
          ((= n i)
           (set-break (car insts)))
          (else
           (insert-break (cdr insts) n (+ i 1)))))
  (insert-break (lookup-label (machine 'get-labels) label)
                n
                1))

(define (cancel-breakpoint machine label n)
  (define (remove-break insts n i)
    (cond ((null? insts)
           'done)
          ((= n i)
           (clear-break (car insts)))
          (else
           (remove-break (cdr insts) n (+ i 1)))))
  (remove-break (lookup-label (machine 'get-labels) label)
                n
                1))

(define (cancel-all-breakpoints machine)
  (for-each
   (lambda (label)
     (for-each (lambda (inst) (clear-break inst)) (cdr label)))
   (machine 'get-labels)))

I realized later that by storing breakpoint information at every instruction, a stepper would be trivial by setting breakpoint as #t at every instruction.

The execute procedure is modified as follows:

(define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
              'done
              (if (not (break? (car insts)))
                  (begin
                    (if should-trace?
                        (print-trace (car insts)))
                    ((instruction-execution-proc (car insts)))
                    (set! executed-instructions-count
                          (+ 1 executed-instructions-count))
                    (execute))))))

(define (break? inst)
        (if paused?
            (begin
              (set! paused? #f)
              paused?)
            (if (should-break? inst)
                (begin
                  (set! paused? #t)
                  (display "Execution paused at: ")
                  (display (instruction-text inst))
                  (newline)
                  paused?)
                paused?)))

Perhaps my design has a flaw, but I had to use another boolean in the machine state - paused?. When the simulation is stopped, my proceed function just calls execute again without resetting the program counter. However it won't move forward because it will hit the same instruction and break again. So my paused? variable is used as a flag to see if the program has already been broken; if yes, then proceed forward. Else this is a fresh breakpoint and must be invoked.