Commit | Line | Data |
---|---|---|
8ee7506b NJ |
1 | ;;;; (ice-9 debugger breakpoints) -- general breakpoints interface |
2 | ||
3 | ;;; Copyright (C) 2002 Free Software Foundation, Inc. | |
4 | ;;; | |
73be1d9e MV |
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 | |
8ee7506b NJ |
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. |