Commit | Line | Data |
---|---|---|
8746959c NJ |
1 | ;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface |
2 | ||
3 | ;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc. | |
4 | ;;; Copyright (C) 2005 Neil Jerram | |
5 | ;;; | |
53befeb7 NJ |
6 | ;;;; This library is free software; you can redistribute it and/or |
7 | ;;;; modify it under the terms of the GNU Lesser General Public | |
8 | ;;;; License as published by the Free Software Foundation; either | |
9 | ;;;; version 3 of the License, or (at your option) any later version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free Software | |
18 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
8746959c NJ |
19 | |
20 | ;;; This module provides an abstraction around Guile's low level trap | |
21 | ;;; handler interface; its aim is to make the low level trap mechanism | |
22 | ;;; shareable between the debugger and other applications, and to | |
23 | ;;; insulate the rest of the debugger code a bit from changes that may | |
24 | ;;; occur in the low level trap interface in future. | |
25 | ||
26 | (define-module (ice-9 debugging traps) | |
27 | #:use-module (ice-9 regex) | |
ba5f8bf4 | 28 | #:use-module (ice-9 weak-vector) |
8746959c NJ |
29 | #:use-module (oop goops) |
30 | #:use-module (oop goops describe) | |
31 | #:use-module (ice-9 debugging trc) | |
32 | #:use-module (srfi srfi-1) | |
33 | #:use-module (srfi srfi-2) | |
34 | #:export (tc:type | |
35 | tc:continuation | |
36 | tc:expression | |
37 | tc:return-value | |
38 | tc:stack | |
39 | tc:frame | |
40 | tc:depth | |
41 | tc:real-depth | |
42 | tc:exit-depth | |
43 | tc:fired-traps | |
44 | ;; Interface for users of <trap> subclasses defined in | |
45 | ;; this module. | |
46 | add-trapped-stack-id! | |
47 | remove-trapped-stack-id! | |
48 | <procedure-trap> | |
49 | <exit-trap> | |
50 | <entry-trap> | |
51 | <apply-trap> | |
52 | <step-trap> | |
53 | <source-trap> | |
54 | <location-trap> | |
55 | install-trap | |
56 | uninstall-trap | |
57 | all-traps | |
58 | get-trap | |
59 | list-traps | |
60 | trap-ordering | |
61 | behaviour-ordering | |
62 | throw->trap-context | |
9f0e9918 | 63 | on-pre-unwind-handler-dispatch |
8746959c NJ |
64 | ;; Interface for authors of new <trap> subclasses. |
65 | <trap-context> | |
66 | <trap> | |
67 | trap->behaviour | |
68 | trap-runnable? | |
69 | install-apply-frame-trap | |
70 | install-breakpoint-trap | |
71 | install-enter-frame-trap | |
72 | install-exit-frame-trap | |
73 | install-trace-trap | |
74 | uninstall-apply-frame-trap | |
75 | uninstall-breakpoint-trap | |
76 | uninstall-enter-frame-trap | |
77 | uninstall-exit-frame-trap | |
78 | uninstall-trace-trap | |
79 | frame->source-position | |
80 | frame-file-name | |
81 | without-traps | |
82 | guile-trap-features) | |
83 | #:re-export (make) | |
84 | #:export-syntax (trap-here)) | |
85 | ||
86 | ;; How to debug the debugging infrastructure, when needed. Grep for | |
87 | ;; "(trc " to find other symbols that can be passed to trc-add. | |
88 | ;; (trc-add 'after-gc-hook) | |
89 | ||
8746959c NJ |
90 | ;;; The current low level traps interface is as follows. |
91 | ;;; | |
92 | ;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled | |
93 | ;;; by the `traps' setting of `(evaluator-traps-interface)' but also | |
94 | ;;; (and more relevant in most cases) by the `with-traps' procedure. | |
95 | ;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of | |
96 | ;;; its thunk parameter. | |
97 | ;;; | |
98 | ;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0 | |
99 | ;;; for the duration of the call, to avoid nasty recursive trapping | |
100 | ;;; loops. If a trap handler knows what it is doing, it can override | |
101 | ;;; this by `(trap-enable traps)'. | |
102 | ;;; | |
103 | ;;; The apply-frame handler is called when Guile is about to perform | |
104 | ;;; an application if EITHER the `apply-frame' evaluator trap option | |
105 | ;;; is set, OR the `trace' debug option is set and the procedure to | |
106 | ;;; apply has its `trace' procedure property set. The arguments | |
107 | ;;; passed are: | |
108 | ;;; | |
109 | ;;; - the symbol 'apply-frame | |
110 | ;;; | |
111 | ;;; - a continuation or debug object describing the current stack | |
112 | ;;; | |
113 | ;;; - a boolean indicating whether the application is tail-recursive. | |
114 | ;;; | |
115 | ;;; The enter-frame handler is called when the evaluator begins a new | |
116 | ;;; evaluation frame if EITHER the `enter-frame' evaluator trap option | |
117 | ;;; is set, OR the `breakpoints' debug option is set and the code to | |
118 | ;;; be evaluated has its `breakpoint' source property set. The | |
119 | ;;; arguments passed are: | |
120 | ;;; | |
121 | ;;; - the symbol 'enter-frame | |
122 | ;;; | |
123 | ;;; - a continuation or debug object describing the current stack | |
124 | ;;; | |
125 | ;;; - a boolean indicating whether the application is tail-recursive. | |
126 | ;;; | |
127 | ;;; - an unmemoized copy of the expression to be evaluated. | |
128 | ;;; | |
129 | ;;; If the `enter-frame' evaluator trap option is set, the enter-frame | |
130 | ;;; handler is also called when about to perform an application in | |
131 | ;;; SCM_APPLY, immediately before possibly calling the apply-frame | |
132 | ;;; handler. (I don't totally understand this.) In this case, the | |
133 | ;;; arguments passed are: | |
134 | ;;; | |
135 | ;;; - the symbol 'enter-frame | |
136 | ;;; | |
137 | ;;; - a continuation or debug object describing the current stack. | |
138 | ;;; | |
139 | ;;; The exit-frame handler is called when Guile exits an evaluation | |
140 | ;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if | |
141 | ;;; EITHER the `exit-frame' evaluator trap option is set, OR the | |
142 | ;;; `trace' debug option is set and the frame is marked as having been | |
143 | ;;; traced. The frame will be marked as having been traced if the | |
144 | ;;; apply-frame handler was called for this frame. (This is trickier | |
145 | ;;; than it sounds because of tail recursion: the same debug frame | |
146 | ;;; could have been used for multiple applications, only some of which | |
147 | ;;; were traced - I think.) The arguments passed are: | |
148 | ;;; | |
149 | ;;; - the symbol 'exit-frame | |
150 | ;;; | |
151 | ;;; - a continuation or debug object describing the current stack | |
152 | ;;; | |
153 | ;;; - the result of the evaluation or application. | |
154 | ||
155 | ;;; {Trap Context} | |
156 | ;;; | |
157 | ;;; A trap context is a GOOPS object that encapsulates all the useful | |
158 | ;;; information about a particular trap. Encapsulating this | |
159 | ;;; information in a single object also allows us: | |
160 | ;;; | |
161 | ;;; - to defer the calculation of information that is time-consuming | |
162 | ;;; to calculate, such as the stack, and to cache such information so | |
163 | ;;; that it is only ever calculated once per trap | |
164 | ;;; | |
165 | ;;; - to pass all interesting information to trap behaviour procedures | |
166 | ;;; in a single parameter, which (i) is convenient and (ii) makes for | |
167 | ;;; a more future-proof interface. | |
168 | ;;; | |
169 | ;;; It also allows us - where very carefully documented! - to pass | |
170 | ;;; information from one behaviour procedure to another. | |
171 | ||
172 | (define-class <trap-context> () | |
173 | ;; Information provided directly by the trap calls from the | |
174 | ;; evaluator. The "type" slot holds a keyword indicating the type | |
175 | ;; of the trap: one of #:evaluation, #:application, #:return, | |
176 | ;; #:error. | |
177 | (type #:getter tc:type | |
178 | #:init-keyword #:type) | |
179 | ;; The "continuation" slot holds the continuation (or debug object, | |
180 | ;; if "cheap" traps are enabled, which is the default) at the point | |
181 | ;; of the trap. For an error trap it is #f. | |
182 | (continuation #:getter tc:continuation | |
183 | #:init-keyword #:continuation) | |
184 | ;; The "expression" slot holds the source code expression, for an | |
185 | ;; evaluation trap. | |
186 | (expression #:getter tc:expression | |
187 | #:init-keyword #:expression | |
188 | #:init-value #f) | |
189 | ;; The "return-value" slot holds the return value, for a return | |
190 | ;; trap, or the error args, for an error trap. | |
191 | (return-value #:getter tc:return-value | |
192 | #:init-keyword #:return-value | |
193 | #:init-value #f) | |
194 | ;; The list of trap objects which fired in this trap context. | |
195 | (fired-traps #:getter tc:fired-traps | |
196 | #:init-value '()) | |
197 | ;; The set of symbols which, if one of them is set in the CAR of the | |
198 | ;; handler-return-value slot, will cause the CDR of that slot to | |
199 | ;; have an effect. | |
200 | (handler-return-syms #:init-value '()) | |
201 | ;; The value which the trap handler should return to the evaluator. | |
202 | (handler-return-value #:init-value #f) | |
203 | ;; Calculated and cached information. "stack" is the stack | |
204 | ;; (computed from the continuation (or debug object) by make-stack, | |
205 | ;; or else (in the case of an error trap) by (make-stack #t ...). | |
206 | (stack #:init-value #f) | |
207 | (frame #:init-value #f) | |
208 | (depth #:init-value #f) | |
209 | (real-depth #:init-value #f) | |
210 | (exit-depth #:init-value #f)) | |
211 | ||
212 | (define-method (tc:stack (ctx <trap-context>)) | |
213 | (or (slot-ref ctx 'stack) | |
214 | (let ((stack (make-stack (tc:continuation ctx)))) | |
215 | (slot-set! ctx 'stack stack) | |
216 | stack))) | |
217 | ||
218 | (define-method (tc:frame (ctx <trap-context>)) | |
219 | (or (slot-ref ctx 'frame) | |
220 | (let ((frame (cond ((tc:continuation ctx) => last-stack-frame) | |
221 | (else (stack-ref (tc:stack ctx) 0))))) | |
222 | (slot-set! ctx 'frame frame) | |
223 | frame))) | |
224 | ||
225 | (define-method (tc:depth (ctx <trap-context>)) | |
226 | (or (slot-ref ctx 'depth) | |
227 | (let ((depth (stack-length (tc:stack ctx)))) | |
228 | (slot-set! ctx 'depth depth) | |
229 | depth))) | |
230 | ||
231 | (define-method (tc:real-depth (ctx <trap-context>)) | |
232 | (or (slot-ref ctx 'real-depth) | |
233 | (let* ((stack (tc:stack ctx)) | |
234 | (real-depth (apply + | |
235 | (map (lambda (i) | |
236 | (if (frame-real? (stack-ref stack i)) | |
237 | 1 | |
238 | 0)) | |
239 | (iota (tc:depth ctx)))))) | |
240 | (slot-set! ctx 'real-depth real-depth) | |
241 | real-depth))) | |
242 | ||
243 | (define-method (tc:exit-depth (ctx <trap-context>)) | |
244 | (or (slot-ref ctx 'exit-depth) | |
245 | (let* ((stack (tc:stack ctx)) | |
246 | (depth (tc:depth ctx)) | |
247 | (exit-depth (let loop ((exit-depth depth)) | |
248 | (if (or (zero? exit-depth) | |
249 | (frame-real? (stack-ref stack | |
250 | (- depth | |
251 | exit-depth)))) | |
252 | exit-depth | |
253 | (loop (- exit-depth 1)))))) | |
254 | (slot-set! ctx 'exit-depth exit-depth) | |
255 | exit-depth))) | |
256 | ||
257 | ;;; {Stack IDs} | |
258 | ;;; | |
259 | ;;; Mechanism for limiting trapping to contexts whose stack ID matches | |
260 | ;;; one of a registered set. The default is for traps to fire | |
261 | ;;; regardless of stack ID. | |
262 | ||
263 | (define trapped-stack-ids (list #t)) | |
264 | (define all-stack-ids-trapped? #t) | |
265 | ||
266 | (define (add-trapped-stack-id! id) | |
267 | "Add ID to the set of stack ids for which traps are active. | |
268 | If `#t' is in this set, traps are active regardless of stack context. | |
269 | To remove ID again, use `remove-trapped-stack-id!'. If you add the | |
270 | same ID twice using `add-trapped-stack-id!', you will need to remove | |
271 | it twice." | |
272 | (set! trapped-stack-ids (cons id trapped-stack-ids)) | |
273 | (set! all-stack-ids-trapped? (memq #t trapped-stack-ids))) | |
274 | ||
275 | (define (remove-trapped-stack-id! id) | |
276 | "Remove ID from the set of stack ids for which traps are active." | |
277 | (set! trapped-stack-ids (delq1! id trapped-stack-ids)) | |
278 | (set! all-stack-ids-trapped? (memq #t trapped-stack-ids))) | |
279 | ||
280 | (define (trap-here? cont) | |
281 | ;; Return true if the stack id of the specified continuation (or | |
282 | ;; debug object) is in the set that we should trap for; otherwise | |
283 | ;; false. | |
284 | (or all-stack-ids-trapped? | |
285 | (memq (stack-id cont) trapped-stack-ids))) | |
286 | ||
287 | ;;; {Global State} | |
288 | ;;; | |
289 | ;;; Variables tracking registered handlers, relevant procedures, and | |
290 | ;;; what's turned on as regards the evaluator's debugging options. | |
291 | ||
292 | (define enter-frame-traps '()) | |
293 | (define apply-frame-traps '()) | |
294 | (define exit-frame-traps '()) | |
295 | (define breakpoint-traps '()) | |
296 | (define trace-traps '()) | |
297 | ||
298 | (define (non-null? hook) | |
299 | (not (null? hook))) | |
300 | ||
301 | ;; The low level frame handlers must all be initialized to something | |
302 | ;; harmless. Otherwise we hit a problem immediately when trying to | |
303 | ;; enable one of these handlers. | |
304 | (trap-set! enter-frame-handler noop) | |
305 | (trap-set! apply-frame-handler noop) | |
306 | (trap-set! exit-frame-handler noop) | |
307 | ||
308 | (define set-debug-and-trap-options | |
309 | (let ((dopts (debug-options)) | |
310 | (topts (evaluator-traps-interface)) | |
311 | (setting (lambda (key opts) | |
312 | (let ((l (memq key opts))) | |
313 | (and l | |
314 | (not (null? (cdr l))) | |
315 | (cadr l))))) | |
316 | (debug-set-boolean! (lambda (key value) | |
317 | ((if value debug-enable debug-disable) key))) | |
318 | (trap-set-boolean! (lambda (key value) | |
319 | ((if value trap-enable trap-disable) key)))) | |
320 | (let ((save-debug (memq 'debug dopts)) | |
321 | (save-trace (memq 'trace dopts)) | |
322 | (save-breakpoints (memq 'breakpoints dopts)) | |
323 | (save-enter-frame (memq 'enter-frame topts)) | |
324 | (save-apply-frame (memq 'apply-frame topts)) | |
325 | (save-exit-frame (memq 'exit-frame topts)) | |
326 | (save-enter-frame-handler (setting 'enter-frame-handler topts)) | |
327 | (save-apply-frame-handler (setting 'apply-frame-handler topts)) | |
328 | (save-exit-frame-handler (setting 'exit-frame-handler topts))) | |
329 | (lambda () | |
330 | (let ((need-trace (non-null? trace-traps)) | |
331 | (need-breakpoints (non-null? breakpoint-traps)) | |
332 | (need-enter-frame (non-null? enter-frame-traps)) | |
333 | (need-apply-frame (non-null? apply-frame-traps)) | |
334 | (need-exit-frame (non-null? exit-frame-traps))) | |
335 | (debug-set-boolean! 'debug | |
336 | (or need-trace | |
337 | need-breakpoints | |
338 | need-enter-frame | |
339 | need-apply-frame | |
340 | need-exit-frame | |
341 | save-debug)) | |
342 | (debug-set-boolean! 'trace | |
343 | (or need-trace | |
344 | save-trace)) | |
345 | (debug-set-boolean! 'breakpoints | |
346 | (or need-breakpoints | |
347 | save-breakpoints)) | |
348 | (trap-set-boolean! 'enter-frame | |
349 | (or need-enter-frame | |
350 | save-enter-frame)) | |
351 | (trap-set-boolean! 'apply-frame | |
352 | (or need-apply-frame | |
353 | save-apply-frame)) | |
354 | (trap-set-boolean! 'exit-frame | |
355 | (or need-exit-frame | |
356 | save-exit-frame)) | |
357 | (trap-set! enter-frame-handler | |
358 | (cond ((or need-breakpoints | |
359 | need-enter-frame) | |
360 | enter-frame-handler) | |
361 | (else save-enter-frame-handler))) | |
362 | (trap-set! apply-frame-handler | |
363 | (cond ((or need-trace | |
364 | need-apply-frame) | |
365 | apply-frame-handler) | |
366 | (else save-apply-frame-handler))) | |
367 | (trap-set! exit-frame-handler | |
368 | (cond ((or need-exit-frame) | |
369 | exit-frame-handler) | |
370 | (else save-exit-frame-handler)))) | |
371 | ;;(write (evaluator-traps-interface)) | |
372 | *unspecified*)))) | |
373 | ||
374 | (define (enter-frame-handler key cont . args) | |
375 | ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an | |
376 | ;; unmemoized copy of the source expression. For an application | |
377 | ;; entry, ARGS is empty. | |
378 | (if (trap-here? cont) | |
379 | (let* ((application-entry? (null? args)) | |
380 | (trap-context (make <trap-context> | |
381 | #:type #:evaluation | |
382 | #:continuation cont | |
383 | #:expression (if application-entry? | |
384 | #f | |
385 | (cadr args))))) | |
386 | (trc 'enter-frame-handler) | |
387 | (if (and (not application-entry?) | |
388 | (memq 'tweaking guile-trap-features)) | |
389 | (slot-set! trap-context 'handler-return-syms '(instead))) | |
390 | (run-traps (if application-entry? | |
391 | enter-frame-traps | |
392 | (append enter-frame-traps breakpoint-traps)) | |
393 | trap-context) | |
394 | (slot-ref trap-context 'handler-return-value)))) | |
395 | ||
396 | (define (apply-frame-handler key cont tail?) | |
397 | (if (trap-here? cont) | |
398 | (let ((trap-context (make <trap-context> | |
399 | #:type #:application | |
400 | #:continuation cont))) | |
401 | (trc 'apply-frame-handler tail?) | |
402 | (run-traps (append apply-frame-traps trace-traps) trap-context) | |
403 | (slot-ref trap-context 'handler-return-value)))) | |
404 | ||
405 | (define (exit-frame-handler key cont retval) | |
406 | (if (trap-here? cont) | |
407 | (let ((trap-context (make <trap-context> | |
408 | #:type #:return | |
409 | #:continuation cont | |
410 | #:return-value retval))) | |
411 | (trc 'exit-frame-handler retval (tc:depth trap-context)) | |
412 | (if (memq 'tweaking guile-trap-features) | |
413 | (slot-set! trap-context 'handler-return-syms '(instead))) | |
414 | (run-traps exit-frame-traps trap-context) | |
415 | (slot-ref trap-context 'handler-return-value)))) | |
416 | ||
417 | (define-macro (trap-installer trap-list) | |
418 | `(lambda (trap) | |
419 | (set! ,trap-list (cons trap ,trap-list)) | |
420 | (set-debug-and-trap-options))) | |
421 | ||
422 | (define install-enter-frame-trap (trap-installer enter-frame-traps)) | |
423 | (define install-apply-frame-trap (trap-installer apply-frame-traps)) | |
424 | (define install-exit-frame-trap (trap-installer exit-frame-traps)) | |
425 | (define install-breakpoint-trap (trap-installer breakpoint-traps)) | |
426 | (define install-trace-trap (trap-installer trace-traps)) | |
427 | ||
428 | (define-macro (trap-uninstaller trap-list) | |
429 | `(lambda (trap) | |
430 | (or (memq trap ,trap-list) | |
431 | (error "Trap list does not include the specified trap")) | |
432 | (set! ,trap-list (delq1! trap ,trap-list)) | |
433 | (set-debug-and-trap-options))) | |
434 | ||
435 | (define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps)) | |
436 | (define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps)) | |
437 | (define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps)) | |
438 | (define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps)) | |
439 | (define uninstall-trace-trap (trap-uninstaller trace-traps)) | |
440 | ||
441 | (define trap-ordering (make-object-property)) | |
442 | (define behaviour-ordering (make-object-property)) | |
443 | ||
444 | (define (run-traps traps trap-context) | |
445 | (let ((behaviours (apply append | |
446 | (map (lambda (trap) | |
447 | (trap->behaviour trap trap-context)) | |
448 | (sort traps | |
449 | (lambda (t1 t2) | |
450 | (< (or (trap-ordering t1) 0) | |
451 | (or (trap-ordering t2) 0)))))))) | |
452 | (for-each (lambda (proc) | |
453 | (proc trap-context)) | |
454 | (sort (delete-duplicates behaviours) | |
455 | (lambda (b1 b2) | |
456 | (< (or (behaviour-ordering b1) 0) | |
457 | (or (behaviour-ordering b2) 0))))))) | |
458 | ||
459 | ;;; {Pseudo-Traps for Non-Trap Events} | |
460 | ||
461 | ;;; Once there is a body of code to do with responding to (debugging, | |
462 | ;;; tracing, etc.) traps, it makes sense to be able to leverage that | |
463 | ;;; same code for certain events that are trap-like, but not actually | |
464 | ;;; traps in the sense of the calls made by libguile's evaluator. | |
465 | ||
9f0e9918 AW |
466 | ;;; The main example of this is when an error is signalled. Guile |
467 | ;;; doesn't yet have a 100% reliable way of hooking into errors, but in | |
468 | ;;; practice most errors go through a catch whose pre-unwind handler is | |
469 | ;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in | |
470 | ;;; turn calls default-pre-unwind-handler. So we can present most errors | |
471 | ;;; as pseudo-traps by modifying default-pre-unwind-handler. | |
8746959c | 472 | |
9f0e9918 | 473 | (define default-default-pre-unwind-handler default-pre-unwind-handler) |
8746959c NJ |
474 | |
475 | (define (throw->trap-context key args . stack-args) | |
476 | (let ((ctx (make <trap-context> | |
477 | #:type #:error | |
478 | #:continuation #f | |
479 | #:return-value (cons key args)))) | |
480 | (slot-set! ctx 'stack | |
481 | (let ((caller-stack (and (= (length stack-args) 1) | |
482 | (car stack-args)))) | |
483 | (if (stack? caller-stack) | |
484 | caller-stack | |
485 | (apply make-stack #t stack-args)))) | |
486 | ctx)) | |
487 | ||
9f0e9918 AW |
488 | (define (on-pre-unwind-handler-dispatch behaviour . ignored-keys) |
489 | (set! default-pre-unwind-handler | |
8746959c NJ |
490 | (if behaviour |
491 | (lambda (key . args) | |
492 | (or (memq key ignored-keys) | |
493 | (behaviour (throw->trap-context key | |
494 | args | |
9f0e9918 AW |
495 | pre-unwind-handler-dispatch))) |
496 | (apply default-default-pre-unwind-handler key args)) | |
497 | default-default-pre-unwind-handler))) | |
8746959c NJ |
498 | |
499 | ;;; {Trap Classes} | |
500 | ||
501 | ;;; Class: <trap> | |
502 | ;;; | |
503 | ;;; <trap> is the base class for traps. Any actual trap should be an | |
504 | ;;; instance of a class derived from <trap>, not of <trap> itself, | |
505 | ;;; because there is no base class method for the install-trap, | |
506 | ;;; trap-runnable? and uninstall-trap GFs. | |
507 | (define-class <trap> () | |
508 | ;; "number" slot: the number of this trap (assigned automatically). | |
509 | (number) | |
510 | ;; "installed" slot: whether this trap is installed. | |
511 | (installed #:init-value #f) | |
512 | ;; "condition" slot: if non-#f, this is a thunk which is called when | |
513 | ;; the trap fires, to determine whether trap processing should | |
514 | ;; proceed any further. | |
515 | (condition #:init-value #f #:init-keyword #:condition) | |
516 | ;; "skip-count" slot: a count of valid (after "condition" | |
517 | ;; processing) firings of this trap to skip. | |
518 | (skip-count #:init-value 0 #:init-keyword #:skip-count) | |
519 | ;; "single-shot" slot: if non-#f, this trap is removed after it has | |
520 | ;; successfully fired (after "condition" and "skip-count" | |
521 | ;; processing) for the first time. | |
522 | (single-shot #:init-value #f #:init-keyword #:single-shot) | |
523 | ;; "behaviour" slot: procedure or list of procedures to call | |
524 | ;; (passing the trap context as parameter) if we finally decide | |
525 | ;; (after "condition" and "skip-count" processing) to run this | |
526 | ;; trap's behaviour. | |
527 | (behaviour #:init-value '() #:init-keyword #:behaviour) | |
528 | ;; "repeat-identical-behaviour" slot: normally, if multiple <trap> | |
529 | ;; objects are triggered by the same low level trap, and they | |
530 | ;; request the same behaviour, it's only useful to do that behaviour | |
531 | ;; once (per low level trap); so by default multiple requests for | |
532 | ;; the same behaviour are coalesced. If this slot is non-#f, the | |
533 | ;; contents of the "behaviour" slot are uniquified so that they | |
534 | ;; avoid being coalesced in this way. | |
535 | (repeat-identical-behaviour #:init-value #f | |
536 | #:init-keyword #:repeat-identical-behaviour) | |
537 | ;; "observer" slot: this is a procedure that is called with one | |
538 | ;; EVENT argument when the trap status changes in certain | |
539 | ;; interesting ways, currently the following. (1) When the trap is | |
540 | ;; uninstalled because of the target becoming inaccessible; EVENT in | |
541 | ;; this case is 'target-gone. | |
542 | (observer #:init-value #f #:init-keyword #:observer)) | |
543 | ||
544 | (define last-assigned-trap-number 0) | |
545 | (define all-traps (make-weak-value-hash-table 7)) | |
546 | ||
547 | (define-method (initialize (trap <trap>) initargs) | |
548 | (next-method) | |
549 | ;; Assign a trap number, and store in the hash of all traps. | |
550 | (set! last-assigned-trap-number (+ last-assigned-trap-number 1)) | |
551 | (slot-set! trap 'number last-assigned-trap-number) | |
552 | (hash-set! all-traps last-assigned-trap-number trap) | |
553 | ;; Listify the behaviour slot, if not a list already. | |
554 | (let ((behaviour (slot-ref trap 'behaviour))) | |
555 | (if (procedure? behaviour) | |
556 | (slot-set! trap 'behaviour (list behaviour))))) | |
557 | ||
558 | (define-generic install-trap) ; provided mostly by subclasses | |
559 | (define-generic uninstall-trap) ; provided mostly by subclasses | |
560 | (define-generic trap->behaviour) ; provided by <trap> | |
561 | (define-generic trap-runnable?) ; provided by subclasses | |
562 | ||
563 | (define-method (install-trap (trap <trap>)) | |
564 | (if (slot-ref trap 'installed) | |
565 | (error "Trap is already installed")) | |
566 | (slot-set! trap 'installed #t)) | |
567 | ||
568 | (define-method (uninstall-trap (trap <trap>)) | |
569 | (or (slot-ref trap 'installed) | |
570 | (error "Trap is not installed")) | |
571 | (slot-set! trap 'installed #f)) | |
572 | ||
573 | ;;; uniquify-behaviour | |
574 | ;;; | |
575 | ;;; Uniquify BEHAVIOUR by wrapping it in a new lambda. | |
576 | (define (uniquify-behaviour behaviour) | |
577 | (lambda (trap-context) | |
578 | (behaviour trap-context))) | |
579 | ||
580 | ;;; trap->behaviour | |
581 | ;;; | |
582 | ;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of | |
583 | ;;; behaviour procs to call with TRAP-CONTEXT as a parameter. | |
584 | ;;; Otherwise return the empty list. | |
585 | (define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>)) | |
586 | (if (and | |
587 | ;; Check that the trap is runnable. Runnability is implemented | |
588 | ;; by the subclass and allows us to check, for example, that | |
589 | ;; the procedure being applied in an apply-frame trap matches | |
590 | ;; this trap's procedure. | |
591 | (trap-runnable? trap trap-context) | |
592 | ;; Check the additional condition, if specified. | |
593 | (let ((condition (slot-ref trap 'condition))) | |
594 | (or (not condition) | |
595 | ((condition)))) | |
596 | ;; Check for a skip count. | |
597 | (let ((skip-count (slot-ref trap 'skip-count))) | |
598 | (if (zero? skip-count) | |
599 | #t | |
600 | (begin | |
601 | (slot-set! trap 'skip-count (- skip-count 1)) | |
602 | #f)))) | |
603 | ;; All checks passed, so we will return the contents of this | |
604 | ;; trap's behaviour slot. | |
605 | (begin | |
606 | ;; First, though, remove this trap if its single-shot slot | |
607 | ;; indicates that it should fire only once. | |
608 | (if (slot-ref trap 'single-shot) | |
609 | (uninstall-trap trap)) | |
610 | ;; Add this trap object to the context's list of traps which | |
611 | ;; fired here. | |
612 | (slot-set! trap-context 'fired-traps | |
613 | (cons trap (tc:fired-traps trap-context))) | |
614 | ;; Return trap behaviour, uniquified if necessary. | |
615 | (if (slot-ref trap 'repeat-identical-behaviour) | |
616 | (map uniquify-behaviour (slot-ref trap 'behaviour)) | |
617 | (slot-ref trap 'behaviour))) | |
618 | '())) | |
619 | ||
620 | ;;; Class: <procedure-trap> | |
621 | ;;; | |
622 | ;;; An installed instance of <procedure-trap> triggers on invocation | |
623 | ;;; of a specific procedure. | |
624 | (define-class <procedure-trap> (<trap>) | |
625 | ;; "procedure" slot: the procedure to trap on. This is implemented | |
626 | ;; virtually, using the following weak vector slot, so as to avoid | |
627 | ;; this trap preventing the GC of the target procedure. | |
628 | (procedure #:init-keyword #:procedure | |
629 | #:allocation #:virtual | |
630 | #:slot-ref | |
631 | (lambda (trap) | |
632 | (vector-ref (slot-ref trap 'procedure-wv) 0)) | |
633 | #:slot-set! | |
634 | (lambda (trap proc) | |
635 | (if (slot-bound? trap 'procedure-wv) | |
636 | (vector-set! (slot-ref trap 'procedure-wv) 0 proc) | |
637 | (slot-set! trap 'procedure-wv (weak-vector proc))))) | |
638 | (procedure-wv)) | |
639 | ||
640 | ;; Customization of the initialize method: set up to handle what | |
641 | ;; should happen when the procedure is GC'd. | |
642 | (define-method (initialize (trap <procedure-trap>) initargs) | |
643 | (next-method) | |
644 | (let* ((proc (slot-ref trap 'procedure)) | |
645 | (existing-traps (volatile-target-traps proc))) | |
646 | ;; If this is the target's first trap, give the target procedure | |
647 | ;; to the volatile-target-guardian, so we can find out if it | |
648 | ;; becomes inaccessible. | |
649 | (or existing-traps (volatile-target-guardian proc)) | |
650 | ;; Add this trap to the target procedure's list of traps. | |
651 | (set! (volatile-target-traps proc) | |
652 | (cons trap (or existing-traps '()))))) | |
653 | ||
654 | (define procedure-trace-count (make-object-property)) | |
655 | ||
656 | (define-method (install-trap (trap <procedure-trap>)) | |
657 | (next-method) | |
658 | (let* ((proc (slot-ref trap 'procedure)) | |
659 | (trace-count (or (procedure-trace-count proc) 0))) | |
660 | (set-procedure-property! proc 'trace #t) | |
661 | (set! (procedure-trace-count proc) (+ trace-count 1))) | |
662 | (install-trace-trap trap)) | |
663 | ||
664 | (define-method (uninstall-trap (trap <procedure-trap>)) | |
665 | (next-method) | |
666 | (let* ((proc (slot-ref trap 'procedure)) | |
667 | (trace-count (or (procedure-trace-count proc) 0))) | |
668 | (if (= trace-count 1) | |
669 | (set-procedure-property! proc 'trace #f)) | |
670 | (set! (procedure-trace-count proc) (- trace-count 1))) | |
671 | (uninstall-trace-trap trap)) | |
672 | ||
673 | (define-method (trap-runnable? (trap <procedure-trap>) | |
674 | (trap-context <trap-context>)) | |
675 | (eq? (slot-ref trap 'procedure) | |
676 | (frame-procedure (tc:frame trap-context)))) | |
677 | ||
678 | ;;; Class: <exit-trap> | |
679 | ;;; | |
680 | ;;; An installed instance of <exit-trap> triggers on stack frame exit | |
681 | ;;; past a specified stack depth. | |
682 | (define-class <exit-trap> (<trap>) | |
683 | ;; "depth" slot: the reference depth for the trap. | |
684 | (depth #:init-keyword #:depth)) | |
685 | ||
686 | (define-method (install-trap (trap <exit-trap>)) | |
687 | (next-method) | |
688 | (install-exit-frame-trap trap)) | |
689 | ||
690 | (define-method (uninstall-trap (trap <exit-trap>)) | |
691 | (next-method) | |
692 | (uninstall-exit-frame-trap trap)) | |
693 | ||
694 | (define-method (trap-runnable? (trap <exit-trap>) | |
695 | (trap-context <trap-context>)) | |
696 | (<= (tc:exit-depth trap-context) | |
697 | (slot-ref trap 'depth))) | |
698 | ||
699 | ;;; Class: <entry-trap> | |
700 | ;;; | |
701 | ;;; An installed instance of <entry-trap> triggers on any frame entry. | |
702 | (define-class <entry-trap> (<trap>)) | |
703 | ||
704 | (define-method (install-trap (trap <entry-trap>)) | |
705 | (next-method) | |
706 | (install-enter-frame-trap trap)) | |
707 | ||
708 | (define-method (uninstall-trap (trap <entry-trap>)) | |
709 | (next-method) | |
710 | (uninstall-enter-frame-trap trap)) | |
711 | ||
712 | (define-method (trap-runnable? (trap <entry-trap>) | |
713 | (trap-context <trap-context>)) | |
714 | #t) | |
715 | ||
716 | ;;; Class: <apply-trap> | |
717 | ;;; | |
718 | ;;; An installed instance of <apply-trap> triggers on any procedure | |
719 | ;;; application. | |
720 | (define-class <apply-trap> (<trap>)) | |
721 | ||
722 | (define-method (install-trap (trap <apply-trap>)) | |
723 | (next-method) | |
724 | (install-apply-frame-trap trap)) | |
725 | ||
726 | (define-method (uninstall-trap (trap <apply-trap>)) | |
727 | (next-method) | |
728 | (uninstall-apply-frame-trap trap)) | |
729 | ||
730 | (define-method (trap-runnable? (trap <apply-trap>) | |
731 | (trap-context <trap-context>)) | |
732 | #t) | |
733 | ||
734 | ;;; Class: <step-trap> | |
735 | ;;; | |
736 | ;;; An installed instance of <step-trap> triggers on the next frame | |
737 | ;;; entry, exit or application, optionally with source location inside | |
738 | ;;; a specified file. | |
739 | (define-class <step-trap> (<exit-trap>) | |
740 | ;; "file-name" slot: if non-#f, indicates that this trap should | |
741 | ;; trigger only for steps in source code from the specified file. | |
742 | (file-name #:init-value #f #:init-keyword #:file-name) | |
743 | ;; "exit-depth" slot: when non-#f, indicates that the next step may | |
744 | ;; be a frame exit past this depth; otherwise, indicates that the | |
745 | ;; next step must be an application or a frame entry. | |
746 | (exit-depth #:init-value #f #:init-keyword #:exit-depth)) | |
747 | ||
748 | (define-method (initialize (trap <step-trap>) initargs) | |
749 | (next-method) | |
750 | (slot-set! trap 'depth (slot-ref trap 'exit-depth))) | |
751 | ||
752 | (define-method (install-trap (trap <step-trap>)) | |
753 | (next-method) | |
754 | (install-enter-frame-trap trap) | |
755 | (install-apply-frame-trap trap)) | |
756 | ||
757 | (define-method (uninstall-trap (trap <step-trap>)) | |
758 | (next-method) | |
759 | (uninstall-enter-frame-trap trap) | |
760 | (uninstall-apply-frame-trap trap)) | |
761 | ||
762 | (define-method (trap-runnable? (trap <step-trap>) | |
763 | (trap-context <trap-context>)) | |
764 | (if (eq? (tc:type trap-context) #:return) | |
765 | ;; We're in the context of an exit-frame trap. Trap should only | |
766 | ;; be run if exit-depth is set and this exit-frame has returned | |
767 | ;; past the set depth. | |
768 | (and (slot-ref trap 'exit-depth) | |
769 | (next-method) | |
770 | ;; OK to run the trap here, but we should first reset the | |
771 | ;; exit-depth slot to indicate that the step after this one | |
772 | ;; must be an application or frame entry. | |
773 | (begin | |
774 | (slot-set! trap 'exit-depth #f) | |
775 | #t)) | |
776 | ;; We're in the context of an application or frame entry trap. | |
777 | ;; Check whether trap is limited to a specified file. | |
778 | (let ((file-name (slot-ref trap 'file-name))) | |
779 | (and (or (not file-name) | |
780 | (equal? (frame-file-name (tc:frame trap-context)) file-name)) | |
781 | ;; Trap should run here, but we should also set exit-depth to | |
782 | ;; the current stack length, so that - if we don't stop at any | |
783 | ;; other steps first - the next step shows the return value of | |
784 | ;; the current application or evaluation. | |
785 | (begin | |
786 | (slot-set! trap 'exit-depth (tc:depth trap-context)) | |
787 | (slot-set! trap 'depth (tc:depth trap-context)) | |
788 | #t))))) | |
789 | ||
790 | (define (frame->source-position frame) | |
791 | (let ((source (if (frame-procedure? frame) | |
792 | (or (frame-source frame) | |
793 | (let ((proc (frame-procedure frame))) | |
794 | (and proc | |
795 | (procedure? proc) | |
796 | (procedure-source proc)))) | |
797 | (frame-source frame)))) | |
798 | (and source | |
799 | (string? (source-property source 'filename)) | |
800 | (list (source-property source 'filename) | |
801 | (source-property source 'line) | |
802 | (source-property source 'column))))) | |
803 | ||
804 | (define (frame-file-name frame) | |
805 | (cond ((frame->source-position frame) => car) | |
806 | (else #f))) | |
807 | ||
808 | ;;; Class: <source-trap> | |
809 | ;;; | |
810 | ;;; An installed instance of <source-trap> triggers upon evaluation of | |
811 | ;;; a specified source expression. | |
812 | (define-class <source-trap> (<trap>) | |
813 | ;; "expression" slot: the expression to trap on. This is | |
814 | ;; implemented virtually, using the following weak vector slot, so | |
815 | ;; as to avoid this trap preventing the GC of the target source | |
816 | ;; code. | |
817 | (expression #:init-keyword #:expression | |
818 | #:allocation #:virtual | |
819 | #:slot-ref | |
820 | (lambda (trap) | |
821 | (vector-ref (slot-ref trap 'expression-wv) 0)) | |
822 | #:slot-set! | |
823 | (lambda (trap expr) | |
824 | (if (slot-bound? trap 'expression-wv) | |
825 | (vector-set! (slot-ref trap 'expression-wv) 0 expr) | |
826 | (slot-set! trap 'expression-wv (weak-vector expr))))) | |
827 | (expression-wv) | |
828 | ;; source property slots - for internal use only | |
829 | (filename) | |
830 | (line) | |
831 | (column)) | |
832 | ||
833 | ;; Customization of the initialize method: get and save the | |
834 | ;; expression's source properties, or signal an error if it doesn't | |
835 | ;; have the necessary properties. | |
836 | (define-method (initialize (trap <source-trap>) initargs) | |
837 | (next-method) | |
838 | (let* ((expr (slot-ref trap 'expression)) | |
839 | (filename (source-property expr 'filename)) | |
840 | (line (source-property expr 'line)) | |
841 | (column (source-property expr 'column)) | |
842 | (existing-traps (volatile-target-traps expr))) | |
843 | (or (and filename line column) | |
844 | (error "Specified source does not have the necessary properties" | |
845 | filename line column)) | |
846 | (slot-set! trap 'filename filename) | |
847 | (slot-set! trap 'line line) | |
848 | (slot-set! trap 'column column) | |
849 | ;; If this is the target's first trap, give the target expression | |
850 | ;; to the volatile-target-guardian, so we can find out if it | |
851 | ;; becomes inaccessible. | |
852 | (or existing-traps (volatile-target-guardian expr)) | |
853 | ;; Add this trap to the target expression's list of traps. | |
854 | (set! (volatile-target-traps expr) | |
855 | (cons trap (or existing-traps '()))))) | |
856 | ||
857 | ;; Just in case more than one trap is installed on the same source | |
858 | ;; expression ... so that we can still get the setting and resetting | |
859 | ;; of the 'breakpoint source property correct. | |
860 | (define source-breakpoint-count (make-object-property)) | |
861 | ||
862 | (define-method (install-trap (trap <source-trap>)) | |
863 | (next-method) | |
864 | (let* ((expr (slot-ref trap 'expression)) | |
865 | (breakpoint-count (or (source-breakpoint-count expr) 0))) | |
866 | (set-source-property! expr 'breakpoint #t) | |
867 | (set! (source-breakpoint-count expr) (+ breakpoint-count 1))) | |
868 | (install-breakpoint-trap trap)) | |
869 | ||
870 | (define-method (uninstall-trap (trap <source-trap>)) | |
871 | (next-method) | |
872 | (let* ((expr (slot-ref trap 'expression)) | |
873 | (breakpoint-count (or (source-breakpoint-count expr) 0))) | |
874 | (if (= breakpoint-count 1) | |
875 | (set-source-property! expr 'breakpoint #f)) | |
876 | (set! (source-breakpoint-count expr) (- breakpoint-count 1))) | |
877 | (uninstall-breakpoint-trap trap)) | |
878 | ||
879 | (define-method (trap-runnable? (trap <source-trap>) | |
880 | (trap-context <trap-context>)) | |
881 | (or (eq? (slot-ref trap 'expression) | |
882 | (tc:expression trap-context)) | |
883 | (let ((trap-location (frame->source-position (tc:frame trap-context)))) | |
884 | (and trap-location | |
885 | (string=? (car trap-location) (slot-ref trap 'filename)) | |
886 | (= (cadr trap-location) (slot-ref trap 'line)) | |
887 | (= (caddr trap-location) (slot-ref trap 'column)))))) | |
888 | ||
889 | ;; (trap-here EXPRESSION . OPTIONS) | |
890 | (define trap-here | |
891 | (procedure->memoizing-macro | |
892 | (lambda (expr env) | |
893 | (let ((trap (apply make | |
894 | <source-trap> | |
895 | #:expression expr | |
896 | (local-eval `(list ,@(cddr expr)) | |
897 | env)))) | |
898 | (install-trap trap) | |
899 | (set-car! expr 'begin) | |
900 | (set-cdr! (cdr expr) '()) | |
901 | expr)))) | |
902 | ||
903 | ;;; Class: <location-trap> | |
904 | ;;; | |
905 | ;;; An installed instance of <location-trap> triggers on entry to a | |
906 | ;;; frame with a more-or-less precisely specified source location. | |
907 | (define-class <location-trap> (<trap>) | |
908 | ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to | |
909 | ;; trap in. | |
910 | (file-regexp #:init-keyword #:file-regexp) | |
911 | ;; "line" and "column" slots: position to trap at (0-based). | |
912 | (line #:init-value #f #:init-keyword #:line) | |
913 | (column #:init-value #f #:init-keyword #:column) | |
914 | ;; "compiled-regexp" slot - self explanatory, internal use only | |
915 | (compiled-regexp)) | |
916 | ||
917 | (define-method (initialize (trap <location-trap>) initargs) | |
918 | (next-method) | |
919 | (slot-set! trap 'compiled-regexp | |
920 | (make-regexp (slot-ref trap 'file-regexp)))) | |
921 | ||
922 | (define-method (install-trap (trap <location-trap>)) | |
923 | (next-method) | |
924 | (install-enter-frame-trap trap)) | |
925 | ||
926 | (define-method (uninstall-trap (trap <location-trap>)) | |
927 | (next-method) | |
928 | (uninstall-enter-frame-trap trap)) | |
929 | ||
930 | (define-method (trap-runnable? (trap <location-trap>) | |
931 | (trap-context <trap-context>)) | |
932 | (and-let* ((trap-location (frame->source-position (tc:frame trap-context))) | |
933 | (tcline (cadr trap-location)) | |
934 | (tccolumn (caddr trap-location))) | |
935 | (and (= tcline (slot-ref trap 'line)) | |
936 | (= tccolumn (slot-ref trap 'column)) | |
937 | (regexp-exec (slot-ref trap 'compiled-regexp) | |
938 | (car trap-location) 0)))) | |
939 | ||
940 | ;;; {Misc Trap Utilities} | |
941 | ||
942 | (define (get-trap number) | |
943 | (hash-ref all-traps number)) | |
944 | ||
945 | (define (list-traps) | |
946 | (for-each describe | |
947 | (map cdr (sort (hash-fold acons '() all-traps) | |
948 | (lambda (x y) (< (car x) (car y))))))) | |
949 | ||
950 | ;;; {Volatile Traps} | |
951 | ;;; | |
952 | ;;; Some traps are associated with Scheme objects that are likely to | |
953 | ;;; be GC'd, such as procedures and read expressions. When those | |
954 | ;;; objects are GC'd, we want to allow their traps to evaporate as | |
955 | ;;; well, or at least not to prevent them from doing so because they | |
956 | ;;; are (now pointlessly) included on the various installed trap | |
957 | ;;; lists. | |
958 | ||
959 | ;; An object property that maps each volatile target to the list of | |
960 | ;; traps that are installed on it. | |
961 | (define volatile-target-traps (make-object-property)) | |
962 | ||
963 | ;; A guardian that tells us when a volatile target is no longer | |
964 | ;; accessible. | |
965 | (define volatile-target-guardian (make-guardian)) | |
966 | ||
967 | ;; An after GC hook that checks for newly inaccessible targets. | |
968 | (add-hook! after-gc-hook | |
969 | (lambda () | |
970 | (trc 'after-gc-hook) | |
971 | (let loop ((target (volatile-target-guardian))) | |
972 | (if target | |
973 | ;; We have a target which is now inaccessible. Get | |
974 | ;; the list of traps installed on it. | |
975 | (begin | |
976 | (trc 'after-gc-hook "got target") | |
977 | ;; Uninstall all the traps that are installed on | |
978 | ;; this target. | |
979 | (for-each (lambda (trap) | |
980 | (trc 'after-gc-hook "got trap") | |
981 | ;; If the trap is still installed, | |
982 | ;; uninstall it. | |
983 | (if (slot-ref trap 'installed) | |
984 | (uninstall-trap trap)) | |
985 | ;; If the trap has an observer, tell | |
986 | ;; it that the target has gone. | |
987 | (cond ((slot-ref trap 'observer) | |
988 | => | |
989 | (lambda (proc) | |
990 | (trc 'after-gc-hook "call obs") | |
991 | (proc 'target-gone))))) | |
992 | (or (volatile-target-traps target) '())) | |
993 | ;; Check for any more inaccessible targets. | |
994 | (loop (volatile-target-guardian))))))) | |
995 | ||
996 | (define (without-traps thunk) | |
997 | (with-traps (lambda () | |
998 | (trap-disable 'traps) | |
999 | (thunk)))) | |
1000 | ||
ba5f8bf4 | 1001 | (define guile-trap-features '(tweaking)) |
8746959c NJ |
1002 | |
1003 | ;; Make sure that traps are enabled. | |
1004 | (trap-enable 'traps) | |
1005 | ||
1006 | ;;; (ice-9 debugging traps) ends here. |