ice-9/debugger/breakpoints.scm

   1 ;;;; (ice-9 debugger breakpoints) -- general breakpoints interface
   2
   3 ;;; Copyright (C) 2002 Free Software Foundation, Inc.
   4 ;;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18
  19 (define-module (ice-9 debugger breakpoints)
  20   #:use-module (ice-9 debugger behaviour)
  21   #:use-module (ice-9 format)
  22   #:use-module (oop goops)
  23   #:export (;; For <breakpoint> subclass implementations.
  24             <breakpoint>
  25             register-breakpoint-subclass
  26             ;; For application use and subclass implementations.
  27             bp-number
  28             bp-enabled?
  29             bp-behaviour
  30             bp-run
  31             bp-message
  32             bp-delete!
  33             bp-describe
  34             break!
  35             trace!
  36             trace-subtree!
  37             set-breakpoint!
  38             get-breakpoint
  39             describe-breakpoint
  40             disable-breakpoint!
  41             enable-breakpoint!
  42             delete-breakpoint!
  43             all-breakpoints
  44             describe-all-breakpoints))
  45
  46 ;;; {Breakpoints -- General Properties and Behaviour}
  47
  48 ;;; Generics with names beginning `bp-' all take a single breakpoint
  49 ;;; argument (i.e. an instance of a subclass of <breakpoint>).
  50
  51 (define-generic bp-number)              ; implemented
  52 (define-generic bp-enabled?)            ; implemented
  53 (define-generic bp-behaviour)           ; implemented
  54 (define-generic bp-run)                 ; implemented
  55 (define-generic bp-message)             ; virtual
  56 (define-generic bp-delete!)             ; virtual
  57 (define-generic bp-describe)            ; implemented
  58
  59 ;;; The following all take arguments that describe (in whatever way
  60 ;;; the various subclasses support) a breakpoint location.  The
  61 ;;; <breakpoint> implementations of `break!' and `trace!' just call
  62 ;;; `set-breakpoint!' specifying the `debug-here' and `trace-here'
  63 ;;; behaviours respectively.
  64
  65 (define-generic set-breakpoint!)        ; semi-virtual
  66 (define-generic get-breakpoint)         ; semi-virtual
  67
  68 ;;; Common base class for breakpoints.
  69
  70 (define-class <breakpoint> ()
  71
  72   ;; Breakpoint number.
  73   (number #:accessor bp-number
  74           #:init-thunk (let ((count 0))
  75                          (lambda ()
  76                            (set! count (+ count 1))
  77                            count)))
  78
  79   ;; Whether this breakpoint is currently enabled.
  80   (enabled? #:accessor bp-enabled?
  81             #:init-value #t)
  82
  83   ;; Breakpoint behaviour, either a list of behaviour indicators, or a
  84   ;; thunk that, when called, returns such a list.
  85   (behaviour #:accessor bp-behaviour
  86              #:init-value '()))
  87
  88 ;;; Registration of <breakpoint> subclasses.  The only current reason
  89 ;;; for this is so that we can provide `all-breakpoints'.
  90
  91 (define subclass-registrations '())
  92
  93 (define (register-breakpoint-subclass class list-thunk)
  94   ;; LIST-THUNK should be a thunk that returns a list containing all
  95   ;; current breakpoints of the corresponding class.
  96   (set! subclass-registrations
  97         (assq-set! subclass-registrations class list-thunk)))
  98
  99 (define (all-breakpoints)
 100   (sort (apply append
 101                (map (lambda (list-thunk) (list-thunk))
 102                     (map cdr subclass-registrations)))
 103         (lambda (bp1 bp2)
 104           (< (bp-number bp1) (bp-number bp2)))))
 105
 106 (define (describe-all-breakpoints)
 107   (for-each (lambda (bp)
 108               (bp-describe bp #t))
 109             (all-breakpoints)))
 110
 111 (define-method (get-breakpoint (number <integer>))
 112   (let loop ((bps (all-breakpoints)))
 113     (if (null? bps)
 114         #f
 115         (let* ((bp (car bps))
 116                (bp-num (bp-number bp)))
 117           (cond ((= bp-num number) bp)
 118                 ((> bp-num number) #f)
 119                 (else (loop (cdr bps))))))))
 120
 121 (define (make-breakpoint-command proc)
 122   (lambda args
 123     (let ((bp (apply get-breakpoint args)))
 124       (if bp
 125           (proc bp)
 126           (display "Breakpoint not found\n")))))
 127
 128 (define describe-breakpoint
 129   (make-breakpoint-command (lambda (bp)
 130                              (bp-describe bp #t))))
 131
 132 (define disable-breakpoint!
 133   (make-breakpoint-command (lambda (bp)
 134                              (set! (bp-enabled? bp) #f)
 135                              (bp-describe bp #t))))
 136
 137 (define enable-breakpoint!
 138   (make-breakpoint-command (lambda (bp)
 139                              (set! (bp-enabled? bp) #t)
 140                              (bp-describe bp #t))))
 141
 142 (define delete-breakpoint!
 143   (make-breakpoint-command bp-delete!))
 144
 145 (define-method (set-breakpoint! behaviour (number <integer>))
 146   (let ((bp (get-breakpoint number)))
 147     (if bp
 148         (begin
 149           (set! (bp-behaviour bp) behaviour)
 150           (bp-describe bp #t))
 151         (display "No such breakpoint\n"))))
 152
 153 ;;; `bp-run' is what trap hook functions should call when they
 154 ;;; establish that the program is at a breakpoint location.
 155
 156 (define-method (bp-run (bp <breakpoint>))
 157   ;; Only do anything if the breakpoint is enabled.
 158   (add-debug-entry-message (bp-message bp "Hit breakpoint" #f))
 159   (if (bp-enabled? bp)
 160       ;; Get behaviour for this breakpoint.
 161       (let ((behaviour (bp-behaviour bp)))
 162         ;; Behaviour should be a thunk or a list of thunks.
 163         (cond ((thunk? behaviour)
 164                (behaviour))
 165               ((list? behaviour)
 166                (for-each (lambda (thunk) (thunk)) behaviour))
 167               (else
 168                (bp-message bp "Bad behaviour for breakpoint" #t)))
 169 ;       (if (thunk? behaviour)
 170 ;           (set! behaviour (behaviour)))
 171 ;       ;; If not a list, wrap as a list.
 172 ;       (or (list? behaviour)
 173 ;           (set! behaviour (list behaviour)))
 174 ;       ;; If behaviour indicates tracing, do so.
 175 ;       (if (memq #:trace behaviour)
 176 ;           (trace-here))
 177 ;       ;; If behaviour indicates a thunk to be run when we exit the
 178 ;       ;; current frame, register it.
 179 ;       (let ((at-exit (memq #:at-exit behaviour)))
 180 ;         (if (and at-exit (not (null? (cdr at-exit))))
 181 ;             (set-at-exit (cadr at-exit))))
 182 ;       ;; If behaviour indicates interactive debugging, set flag that
 183 ;       ;; will cause us to enter the debugger.
 184 ;       (if (memq #:debug behaviour)
 185 ;           (begin
 186 ;             (bp-message "Hit breakpoint" bp)
 187 ;             (debug-here)))
 188         )))
 189
 190 ;;; `break! ...' is just shorthand for `set-breakpoint! debug-here ...'.
 191
 192 (define (break! . args)
 193   (apply set-breakpoint! debug-here args))
 194
 195 ;;; Similarly `trace! ...' and `set-breakpoint! trace-here ...'.
 196
 197 (define (trace! . args)
 198   (apply set-breakpoint! trace-here args))
 199
 200 ;;; And so on.
 201
 202 (define (trace-subtree! . args)
 203   (apply set-breakpoint! trace-subtree args))
 204
 205 ;;; `bp-describe' is expected to be overridden/extended by subclasses,
 206 ;;; but subclass implementations may want to leverage this
 207 ;;; implementation by beginning with `(next-method)'.
 208
 209 (define-method (bp-describe (bp <breakpoint>) port)
 210   (bp-message bp "Breakpoint" port)
 211   (format port "\tenabled? = ~S\n" (bp-enabled? bp))
 212   (format port "\tbehaviour = ~S\n" (bp-behaviour bp))
 213   *unspecified*)
 214
 215 ;;; (ice-9 debugger breakpoints) ends here.