1 ;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
3 ;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
4 ;;; Copyright (C) 2005 Neil Jerram
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 2.1 of the License, or (at your option) any later version.
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.
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
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.
26 (define-module (ice-9 debugging traps)
27 #:use-module (ice-9 regex)
28 #:use-module (oop goops)
29 #:use-module (oop goops describe)
30 #:use-module (ice-9 debugging trc)
31 #:use-module (srfi srfi-1)
32 #:use-module (srfi srfi-2)
43 ;; Interface for users of <trap> subclasses defined in
46 remove-trapped-stack-id!
62 on-lazy-handler-dispatch
63 ;; Interface for authors of new <trap> subclasses.
68 install-apply-frame-trap
69 install-breakpoint-trap
70 install-enter-frame-trap
71 install-exit-frame-trap
73 uninstall-apply-frame-trap
74 uninstall-breakpoint-trap
75 uninstall-enter-frame-trap
76 uninstall-exit-frame-trap
78 frame->source-position
83 #:export-syntax (trap-here))
85 ;; How to debug the debugging infrastructure, when needed. Grep for
86 ;; "(trc " to find other symbols that can be passed to trc-add.
87 ;; (trc-add 'after-gc-hook)
89 ;; In Guile 1.7 onwards, weak-vector and friends are provided by the
90 ;; (ice-9 weak-vector) module.
91 (cond ((string>=? (version) "1.7")
92 (use-modules (ice-9 weak-vector))))
94 ;;; The current low level traps interface is as follows.
96 ;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
97 ;;; by the `traps' setting of `(evaluator-traps-interface)' but also
98 ;;; (and more relevant in most cases) by the `with-traps' procedure.
99 ;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
100 ;;; its thunk parameter.
102 ;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
103 ;;; for the duration of the call, to avoid nasty recursive trapping
104 ;;; loops. If a trap handler knows what it is doing, it can override
105 ;;; this by `(trap-enable traps)'.
107 ;;; The apply-frame handler is called when Guile is about to perform
108 ;;; an application if EITHER the `apply-frame' evaluator trap option
109 ;;; is set, OR the `trace' debug option is set and the procedure to
110 ;;; apply has its `trace' procedure property set. The arguments
113 ;;; - the symbol 'apply-frame
115 ;;; - a continuation or debug object describing the current stack
117 ;;; - a boolean indicating whether the application is tail-recursive.
119 ;;; The enter-frame handler is called when the evaluator begins a new
120 ;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
121 ;;; is set, OR the `breakpoints' debug option is set and the code to
122 ;;; be evaluated has its `breakpoint' source property set. The
123 ;;; arguments passed are:
125 ;;; - the symbol 'enter-frame
127 ;;; - a continuation or debug object describing the current stack
129 ;;; - a boolean indicating whether the application is tail-recursive.
131 ;;; - an unmemoized copy of the expression to be evaluated.
133 ;;; If the `enter-frame' evaluator trap option is set, the enter-frame
134 ;;; handler is also called when about to perform an application in
135 ;;; SCM_APPLY, immediately before possibly calling the apply-frame
136 ;;; handler. (I don't totally understand this.) In this case, the
137 ;;; arguments passed are:
139 ;;; - the symbol 'enter-frame
141 ;;; - a continuation or debug object describing the current stack.
143 ;;; The exit-frame handler is called when Guile exits an evaluation
144 ;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
145 ;;; EITHER the `exit-frame' evaluator trap option is set, OR the
146 ;;; `trace' debug option is set and the frame is marked as having been
147 ;;; traced. The frame will be marked as having been traced if the
148 ;;; apply-frame handler was called for this frame. (This is trickier
149 ;;; than it sounds because of tail recursion: the same debug frame
150 ;;; could have been used for multiple applications, only some of which
151 ;;; were traced - I think.) The arguments passed are:
153 ;;; - the symbol 'exit-frame
155 ;;; - a continuation or debug object describing the current stack
157 ;;; - the result of the evaluation or application.
161 ;;; A trap context is a GOOPS object that encapsulates all the useful
162 ;;; information about a particular trap. Encapsulating this
163 ;;; information in a single object also allows us:
165 ;;; - to defer the calculation of information that is time-consuming
166 ;;; to calculate, such as the stack, and to cache such information so
167 ;;; that it is only ever calculated once per trap
169 ;;; - to pass all interesting information to trap behaviour procedures
170 ;;; in a single parameter, which (i) is convenient and (ii) makes for
171 ;;; a more future-proof interface.
173 ;;; It also allows us - where very carefully documented! - to pass
174 ;;; information from one behaviour procedure to another.
176 (define-class <trap-context> ()
177 ;; Information provided directly by the trap calls from the
178 ;; evaluator. The "type" slot holds a keyword indicating the type
179 ;; of the trap: one of #:evaluation, #:application, #:return,
181 (type #:getter tc:type
182 #:init-keyword #:type)
183 ;; The "continuation" slot holds the continuation (or debug object,
184 ;; if "cheap" traps are enabled, which is the default) at the point
185 ;; of the trap. For an error trap it is #f.
186 (continuation #:getter tc:continuation
187 #:init-keyword #:continuation)
188 ;; The "expression" slot holds the source code expression, for an
190 (expression #:getter tc:expression
191 #:init-keyword #:expression
193 ;; The "return-value" slot holds the return value, for a return
194 ;; trap, or the error args, for an error trap.
195 (return-value #:getter tc:return-value
196 #:init-keyword #:return-value
198 ;; The list of trap objects which fired in this trap context.
199 (fired-traps #:getter tc:fired-traps
201 ;; The set of symbols which, if one of them is set in the CAR of the
202 ;; handler-return-value slot, will cause the CDR of that slot to
204 (handler-return-syms #:init-value '())
205 ;; The value which the trap handler should return to the evaluator.
206 (handler-return-value #:init-value #f)
207 ;; Calculated and cached information. "stack" is the stack
208 ;; (computed from the continuation (or debug object) by make-stack,
209 ;; or else (in the case of an error trap) by (make-stack #t ...).
210 (stack #:init-value #f)
211 (frame #:init-value #f)
212 (depth #:init-value #f)
213 (real-depth #:init-value #f)
214 (exit-depth #:init-value #f))
216 (define-method (tc:stack (ctx <trap-context>))
217 (or (slot-ref ctx 'stack)
218 (let ((stack (make-stack (tc:continuation ctx))))
219 (slot-set! ctx 'stack stack)
222 (define-method (tc:frame (ctx <trap-context>))
223 (or (slot-ref ctx 'frame)
224 (let ((frame (cond ((tc:continuation ctx) => last-stack-frame)
225 (else (stack-ref (tc:stack ctx) 0)))))
226 (slot-set! ctx 'frame frame)
229 (define-method (tc:depth (ctx <trap-context>))
230 (or (slot-ref ctx 'depth)
231 (let ((depth (stack-length (tc:stack ctx))))
232 (slot-set! ctx 'depth depth)
235 (define-method (tc:real-depth (ctx <trap-context>))
236 (or (slot-ref ctx 'real-depth)
237 (let* ((stack (tc:stack ctx))
240 (if (frame-real? (stack-ref stack i))
243 (iota (tc:depth ctx))))))
244 (slot-set! ctx 'real-depth real-depth)
247 (define-method (tc:exit-depth (ctx <trap-context>))
248 (or (slot-ref ctx 'exit-depth)
249 (let* ((stack (tc:stack ctx))
250 (depth (tc:depth ctx))
251 (exit-depth (let loop ((exit-depth depth))
252 (if (or (zero? exit-depth)
253 (frame-real? (stack-ref stack
257 (loop (- exit-depth 1))))))
258 (slot-set! ctx 'exit-depth exit-depth)
263 ;;; Mechanism for limiting trapping to contexts whose stack ID matches
264 ;;; one of a registered set. The default is for traps to fire
265 ;;; regardless of stack ID.
267 (define trapped-stack-ids (list #t))
268 (define all-stack-ids-trapped? #t)
270 (define (add-trapped-stack-id! id)
271 "Add ID to the set of stack ids for which traps are active.
272 If `#t' is in this set, traps are active regardless of stack context.
273 To remove ID again, use `remove-trapped-stack-id!'. If you add the
274 same ID twice using `add-trapped-stack-id!', you will need to remove
276 (set! trapped-stack-ids (cons id trapped-stack-ids))
277 (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
279 (define (remove-trapped-stack-id! id)
280 "Remove ID from the set of stack ids for which traps are active."
281 (set! trapped-stack-ids (delq1! id trapped-stack-ids))
282 (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
284 (define (trap-here? cont)
285 ;; Return true if the stack id of the specified continuation (or
286 ;; debug object) is in the set that we should trap for; otherwise
288 (or all-stack-ids-trapped?
289 (memq (stack-id cont) trapped-stack-ids)))
293 ;;; Variables tracking registered handlers, relevant procedures, and
294 ;;; what's turned on as regards the evaluator's debugging options.
296 (define enter-frame-traps '())
297 (define apply-frame-traps '())
298 (define exit-frame-traps '())
299 (define breakpoint-traps '())
300 (define trace-traps '())
302 (define (non-null? hook)
305 ;; The low level frame handlers must all be initialized to something
306 ;; harmless. Otherwise we hit a problem immediately when trying to
307 ;; enable one of these handlers.
308 (trap-set! enter-frame-handler noop)
309 (trap-set! apply-frame-handler noop)
310 (trap-set! exit-frame-handler noop)
312 (define set-debug-and-trap-options
313 (let ((dopts (debug-options))
314 (topts (evaluator-traps-interface))
315 (setting (lambda (key opts)
316 (let ((l (memq key opts)))
318 (not (null? (cdr l)))
320 (debug-set-boolean! (lambda (key value)
321 ((if value debug-enable debug-disable) key)))
322 (trap-set-boolean! (lambda (key value)
323 ((if value trap-enable trap-disable) key))))
324 (let ((save-debug (memq 'debug dopts))
325 (save-trace (memq 'trace dopts))
326 (save-breakpoints (memq 'breakpoints dopts))
327 (save-enter-frame (memq 'enter-frame topts))
328 (save-apply-frame (memq 'apply-frame topts))
329 (save-exit-frame (memq 'exit-frame topts))
330 (save-enter-frame-handler (setting 'enter-frame-handler topts))
331 (save-apply-frame-handler (setting 'apply-frame-handler topts))
332 (save-exit-frame-handler (setting 'exit-frame-handler topts)))
334 (let ((need-trace (non-null? trace-traps))
335 (need-breakpoints (non-null? breakpoint-traps))
336 (need-enter-frame (non-null? enter-frame-traps))
337 (need-apply-frame (non-null? apply-frame-traps))
338 (need-exit-frame (non-null? exit-frame-traps)))
339 (debug-set-boolean! 'debug
346 (debug-set-boolean! 'trace
349 (debug-set-boolean! 'breakpoints
352 (trap-set-boolean! 'enter-frame
355 (trap-set-boolean! 'apply-frame
358 (trap-set-boolean! 'exit-frame
361 (trap-set! enter-frame-handler
362 (cond ((or need-breakpoints
365 (else save-enter-frame-handler)))
366 (trap-set! apply-frame-handler
367 (cond ((or need-trace
370 (else save-apply-frame-handler)))
371 (trap-set! exit-frame-handler
372 (cond ((or need-exit-frame)
374 (else save-exit-frame-handler))))
375 ;;(write (evaluator-traps-interface))
378 (define (enter-frame-handler key cont . args)
379 ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
380 ;; unmemoized copy of the source expression. For an application
381 ;; entry, ARGS is empty.
382 (if (trap-here? cont)
383 (let* ((application-entry? (null? args))
384 (trap-context (make <trap-context>
387 #:expression (if application-entry?
390 (trc 'enter-frame-handler)
391 (if (and (not application-entry?)
392 (memq 'tweaking guile-trap-features))
393 (slot-set! trap-context 'handler-return-syms '(instead)))
394 (run-traps (if application-entry?
396 (append enter-frame-traps breakpoint-traps))
398 (slot-ref trap-context 'handler-return-value))))
400 (define (apply-frame-handler key cont tail?)
401 (if (trap-here? cont)
402 (let ((trap-context (make <trap-context>
404 #:continuation cont)))
405 (trc 'apply-frame-handler tail?)
406 (run-traps (append apply-frame-traps trace-traps) trap-context)
407 (slot-ref trap-context 'handler-return-value))))
409 (define (exit-frame-handler key cont retval)
410 (if (trap-here? cont)
411 (let ((trap-context (make <trap-context>
414 #:return-value retval)))
415 (trc 'exit-frame-handler retval (tc:depth trap-context))
416 (if (memq 'tweaking guile-trap-features)
417 (slot-set! trap-context 'handler-return-syms '(instead)))
418 (run-traps exit-frame-traps trap-context)
419 (slot-ref trap-context 'handler-return-value))))
421 (define-macro (trap-installer trap-list)
423 (set! ,trap-list (cons trap ,trap-list))
424 (set-debug-and-trap-options)))
426 (define install-enter-frame-trap (trap-installer enter-frame-traps))
427 (define install-apply-frame-trap (trap-installer apply-frame-traps))
428 (define install-exit-frame-trap (trap-installer exit-frame-traps))
429 (define install-breakpoint-trap (trap-installer breakpoint-traps))
430 (define install-trace-trap (trap-installer trace-traps))
432 (define-macro (trap-uninstaller trap-list)
434 (or (memq trap ,trap-list)
435 (error "Trap list does not include the specified trap"))
436 (set! ,trap-list (delq1! trap ,trap-list))
437 (set-debug-and-trap-options)))
439 (define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps))
440 (define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps))
441 (define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps))
442 (define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps))
443 (define uninstall-trace-trap (trap-uninstaller trace-traps))
445 (define trap-ordering (make-object-property))
446 (define behaviour-ordering (make-object-property))
448 (define (run-traps traps trap-context)
449 (let ((behaviours (apply append
451 (trap->behaviour trap trap-context))
454 (< (or (trap-ordering t1) 0)
455 (or (trap-ordering t2) 0))))))))
456 (for-each (lambda (proc)
458 (sort (delete-duplicates behaviours)
460 (< (or (behaviour-ordering b1) 0)
461 (or (behaviour-ordering b2) 0)))))))
463 ;;; {Pseudo-Traps for Non-Trap Events}
465 ;;; Once there is a body of code to do with responding to (debugging,
466 ;;; tracing, etc.) traps, it makes sense to be able to leverage that
467 ;;; same code for certain events that are trap-like, but not actually
468 ;;; traps in the sense of the calls made by libguile's evaluator.
470 ;;; The main example of this is when an error is signalled. Guile
471 ;;; doesn't yet have a 100% reliable way of hooking into errors, but
472 ;;; in practice most errors go through a lazy-catch whose handler is
473 ;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn
474 ;;; calls default-lazy-handler. So we can present most errors as
475 ;;; pseudo-traps by modifying default-lazy-handler.
477 (define default-default-lazy-handler default-lazy-handler)
479 (define (throw->trap-context key args . stack-args)
480 (let ((ctx (make <trap-context>
483 #:return-value (cons key args))))
484 (slot-set! ctx 'stack
485 (let ((caller-stack (and (= (length stack-args) 1)
487 (if (stack? caller-stack)
489 (apply make-stack #t stack-args))))
492 (define (on-lazy-handler-dispatch behaviour . ignored-keys)
493 (set! default-lazy-handler
496 (or (memq key ignored-keys)
497 (behaviour (throw->trap-context key
499 lazy-handler-dispatch)))
500 (apply default-default-lazy-handler key args))
501 default-default-lazy-handler)))
507 ;;; <trap> is the base class for traps. Any actual trap should be an
508 ;;; instance of a class derived from <trap>, not of <trap> itself,
509 ;;; because there is no base class method for the install-trap,
510 ;;; trap-runnable? and uninstall-trap GFs.
511 (define-class <trap> ()
512 ;; "number" slot: the number of this trap (assigned automatically).
514 ;; "installed" slot: whether this trap is installed.
515 (installed #:init-value #f)
516 ;; "condition" slot: if non-#f, this is a thunk which is called when
517 ;; the trap fires, to determine whether trap processing should
518 ;; proceed any further.
519 (condition #:init-value #f #:init-keyword #:condition)
520 ;; "skip-count" slot: a count of valid (after "condition"
521 ;; processing) firings of this trap to skip.
522 (skip-count #:init-value 0 #:init-keyword #:skip-count)
523 ;; "single-shot" slot: if non-#f, this trap is removed after it has
524 ;; successfully fired (after "condition" and "skip-count"
525 ;; processing) for the first time.
526 (single-shot #:init-value #f #:init-keyword #:single-shot)
527 ;; "behaviour" slot: procedure or list of procedures to call
528 ;; (passing the trap context as parameter) if we finally decide
529 ;; (after "condition" and "skip-count" processing) to run this
531 (behaviour #:init-value '() #:init-keyword #:behaviour)
532 ;; "repeat-identical-behaviour" slot: normally, if multiple <trap>
533 ;; objects are triggered by the same low level trap, and they
534 ;; request the same behaviour, it's only useful to do that behaviour
535 ;; once (per low level trap); so by default multiple requests for
536 ;; the same behaviour are coalesced. If this slot is non-#f, the
537 ;; contents of the "behaviour" slot are uniquified so that they
538 ;; avoid being coalesced in this way.
539 (repeat-identical-behaviour #:init-value #f
540 #:init-keyword #:repeat-identical-behaviour)
541 ;; "observer" slot: this is a procedure that is called with one
542 ;; EVENT argument when the trap status changes in certain
543 ;; interesting ways, currently the following. (1) When the trap is
544 ;; uninstalled because of the target becoming inaccessible; EVENT in
545 ;; this case is 'target-gone.
546 (observer #:init-value #f #:init-keyword #:observer))
548 (define last-assigned-trap-number 0)
549 (define all-traps (make-weak-value-hash-table 7))
551 (define-method (initialize (trap <trap>) initargs)
553 ;; Assign a trap number, and store in the hash of all traps.
554 (set! last-assigned-trap-number (+ last-assigned-trap-number 1))
555 (slot-set! trap 'number last-assigned-trap-number)
556 (hash-set! all-traps last-assigned-trap-number trap)
557 ;; Listify the behaviour slot, if not a list already.
558 (let ((behaviour (slot-ref trap 'behaviour)))
559 (if (procedure? behaviour)
560 (slot-set! trap 'behaviour (list behaviour)))))
562 (define-generic install-trap) ; provided mostly by subclasses
563 (define-generic uninstall-trap) ; provided mostly by subclasses
564 (define-generic trap->behaviour) ; provided by <trap>
565 (define-generic trap-runnable?) ; provided by subclasses
567 (define-method (install-trap (trap <trap>))
568 (if (slot-ref trap 'installed)
569 (error "Trap is already installed"))
570 (slot-set! trap 'installed #t))
572 (define-method (uninstall-trap (trap <trap>))
573 (or (slot-ref trap 'installed)
574 (error "Trap is not installed"))
575 (slot-set! trap 'installed #f))
577 ;;; uniquify-behaviour
579 ;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
580 (define (uniquify-behaviour behaviour)
581 (lambda (trap-context)
582 (behaviour trap-context)))
586 ;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of
587 ;;; behaviour procs to call with TRAP-CONTEXT as a parameter.
588 ;;; Otherwise return the empty list.
589 (define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>))
591 ;; Check that the trap is runnable. Runnability is implemented
592 ;; by the subclass and allows us to check, for example, that
593 ;; the procedure being applied in an apply-frame trap matches
594 ;; this trap's procedure.
595 (trap-runnable? trap trap-context)
596 ;; Check the additional condition, if specified.
597 (let ((condition (slot-ref trap 'condition)))
600 ;; Check for a skip count.
601 (let ((skip-count (slot-ref trap 'skip-count)))
602 (if (zero? skip-count)
605 (slot-set! trap 'skip-count (- skip-count 1))
607 ;; All checks passed, so we will return the contents of this
608 ;; trap's behaviour slot.
610 ;; First, though, remove this trap if its single-shot slot
611 ;; indicates that it should fire only once.
612 (if (slot-ref trap 'single-shot)
613 (uninstall-trap trap))
614 ;; Add this trap object to the context's list of traps which
616 (slot-set! trap-context 'fired-traps
617 (cons trap (tc:fired-traps trap-context)))
618 ;; Return trap behaviour, uniquified if necessary.
619 (if (slot-ref trap 'repeat-identical-behaviour)
620 (map uniquify-behaviour (slot-ref trap 'behaviour))
621 (slot-ref trap 'behaviour)))
624 ;;; Class: <procedure-trap>
626 ;;; An installed instance of <procedure-trap> triggers on invocation
627 ;;; of a specific procedure.
628 (define-class <procedure-trap> (<trap>)
629 ;; "procedure" slot: the procedure to trap on. This is implemented
630 ;; virtually, using the following weak vector slot, so as to avoid
631 ;; this trap preventing the GC of the target procedure.
632 (procedure #:init-keyword #:procedure
633 #:allocation #:virtual
636 (vector-ref (slot-ref trap 'procedure-wv) 0))
639 (if (slot-bound? trap 'procedure-wv)
640 (vector-set! (slot-ref trap 'procedure-wv) 0 proc)
641 (slot-set! trap 'procedure-wv (weak-vector proc)))))
644 ;; Customization of the initialize method: set up to handle what
645 ;; should happen when the procedure is GC'd.
646 (define-method (initialize (trap <procedure-trap>) initargs)
648 (let* ((proc (slot-ref trap 'procedure))
649 (existing-traps (volatile-target-traps proc)))
650 ;; If this is the target's first trap, give the target procedure
651 ;; to the volatile-target-guardian, so we can find out if it
652 ;; becomes inaccessible.
653 (or existing-traps (volatile-target-guardian proc))
654 ;; Add this trap to the target procedure's list of traps.
655 (set! (volatile-target-traps proc)
656 (cons trap (or existing-traps '())))))
658 (define procedure-trace-count (make-object-property))
660 (define-method (install-trap (trap <procedure-trap>))
662 (let* ((proc (slot-ref trap 'procedure))
663 (trace-count (or (procedure-trace-count proc) 0)))
664 (set-procedure-property! proc 'trace #t)
665 (set! (procedure-trace-count proc) (+ trace-count 1)))
666 (install-trace-trap trap))
668 (define-method (uninstall-trap (trap <procedure-trap>))
670 (let* ((proc (slot-ref trap 'procedure))
671 (trace-count (or (procedure-trace-count proc) 0)))
672 (if (= trace-count 1)
673 (set-procedure-property! proc 'trace #f))
674 (set! (procedure-trace-count proc) (- trace-count 1)))
675 (uninstall-trace-trap trap))
677 (define-method (trap-runnable? (trap <procedure-trap>)
678 (trap-context <trap-context>))
679 (eq? (slot-ref trap 'procedure)
680 (frame-procedure (tc:frame trap-context))))
682 ;;; Class: <exit-trap>
684 ;;; An installed instance of <exit-trap> triggers on stack frame exit
685 ;;; past a specified stack depth.
686 (define-class <exit-trap> (<trap>)
687 ;; "depth" slot: the reference depth for the trap.
688 (depth #:init-keyword #:depth))
690 (define-method (install-trap (trap <exit-trap>))
692 (install-exit-frame-trap trap))
694 (define-method (uninstall-trap (trap <exit-trap>))
696 (uninstall-exit-frame-trap trap))
698 (define-method (trap-runnable? (trap <exit-trap>)
699 (trap-context <trap-context>))
700 (<= (tc:exit-depth trap-context)
701 (slot-ref trap 'depth)))
703 ;;; Class: <entry-trap>
705 ;;; An installed instance of <entry-trap> triggers on any frame entry.
706 (define-class <entry-trap> (<trap>))
708 (define-method (install-trap (trap <entry-trap>))
710 (install-enter-frame-trap trap))
712 (define-method (uninstall-trap (trap <entry-trap>))
714 (uninstall-enter-frame-trap trap))
716 (define-method (trap-runnable? (trap <entry-trap>)
717 (trap-context <trap-context>))
720 ;;; Class: <apply-trap>
722 ;;; An installed instance of <apply-trap> triggers on any procedure
724 (define-class <apply-trap> (<trap>))
726 (define-method (install-trap (trap <apply-trap>))
728 (install-apply-frame-trap trap))
730 (define-method (uninstall-trap (trap <apply-trap>))
732 (uninstall-apply-frame-trap trap))
734 (define-method (trap-runnable? (trap <apply-trap>)
735 (trap-context <trap-context>))
738 ;;; Class: <step-trap>
740 ;;; An installed instance of <step-trap> triggers on the next frame
741 ;;; entry, exit or application, optionally with source location inside
742 ;;; a specified file.
743 (define-class <step-trap> (<exit-trap>)
744 ;; "file-name" slot: if non-#f, indicates that this trap should
745 ;; trigger only for steps in source code from the specified file.
746 (file-name #:init-value #f #:init-keyword #:file-name)
747 ;; "exit-depth" slot: when non-#f, indicates that the next step may
748 ;; be a frame exit past this depth; otherwise, indicates that the
749 ;; next step must be an application or a frame entry.
750 (exit-depth #:init-value #f #:init-keyword #:exit-depth))
752 (define-method (initialize (trap <step-trap>) initargs)
754 (slot-set! trap 'depth (slot-ref trap 'exit-depth)))
756 (define-method (install-trap (trap <step-trap>))
758 (install-enter-frame-trap trap)
759 (install-apply-frame-trap trap))
761 (define-method (uninstall-trap (trap <step-trap>))
763 (uninstall-enter-frame-trap trap)
764 (uninstall-apply-frame-trap trap))
766 (define-method (trap-runnable? (trap <step-trap>)
767 (trap-context <trap-context>))
768 (if (eq? (tc:type trap-context) #:return)
769 ;; We're in the context of an exit-frame trap. Trap should only
770 ;; be run if exit-depth is set and this exit-frame has returned
771 ;; past the set depth.
772 (and (slot-ref trap 'exit-depth)
774 ;; OK to run the trap here, but we should first reset the
775 ;; exit-depth slot to indicate that the step after this one
776 ;; must be an application or frame entry.
778 (slot-set! trap 'exit-depth #f)
780 ;; We're in the context of an application or frame entry trap.
781 ;; Check whether trap is limited to a specified file.
782 (let ((file-name (slot-ref trap 'file-name)))
783 (and (or (not file-name)
784 (equal? (frame-file-name (tc:frame trap-context)) file-name))
785 ;; Trap should run here, but we should also set exit-depth to
786 ;; the current stack length, so that - if we don't stop at any
787 ;; other steps first - the next step shows the return value of
788 ;; the current application or evaluation.
790 (slot-set! trap 'exit-depth (tc:depth trap-context))
791 (slot-set! trap 'depth (tc:depth trap-context))
794 (define (frame->source-position frame)
795 (let ((source (if (frame-procedure? frame)
796 (or (frame-source frame)
797 (let ((proc (frame-procedure frame)))
800 (procedure-source proc))))
801 (frame-source frame))))
803 (string? (source-property source 'filename))
804 (list (source-property source 'filename)
805 (source-property source 'line)
806 (source-property source 'column)))))
808 (define (frame-file-name frame)
809 (cond ((frame->source-position frame) => car)
812 ;;; Class: <source-trap>
814 ;;; An installed instance of <source-trap> triggers upon evaluation of
815 ;;; a specified source expression.
816 (define-class <source-trap> (<trap>)
817 ;; "expression" slot: the expression to trap on. This is
818 ;; implemented virtually, using the following weak vector slot, so
819 ;; as to avoid this trap preventing the GC of the target source
821 (expression #:init-keyword #:expression
822 #:allocation #:virtual
825 (vector-ref (slot-ref trap 'expression-wv) 0))
828 (if (slot-bound? trap 'expression-wv)
829 (vector-set! (slot-ref trap 'expression-wv) 0 expr)
830 (slot-set! trap 'expression-wv (weak-vector expr)))))
832 ;; source property slots - for internal use only
837 ;; Customization of the initialize method: get and save the
838 ;; expression's source properties, or signal an error if it doesn't
839 ;; have the necessary properties.
840 (define-method (initialize (trap <source-trap>) initargs)
842 (let* ((expr (slot-ref trap 'expression))
843 (filename (source-property expr 'filename))
844 (line (source-property expr 'line))
845 (column (source-property expr 'column))
846 (existing-traps (volatile-target-traps expr)))
847 (or (and filename line column)
848 (error "Specified source does not have the necessary properties"
849 filename line column))
850 (slot-set! trap 'filename filename)
851 (slot-set! trap 'line line)
852 (slot-set! trap 'column column)
853 ;; If this is the target's first trap, give the target expression
854 ;; to the volatile-target-guardian, so we can find out if it
855 ;; becomes inaccessible.
856 (or existing-traps (volatile-target-guardian expr))
857 ;; Add this trap to the target expression's list of traps.
858 (set! (volatile-target-traps expr)
859 (cons trap (or existing-traps '())))))
861 ;; Just in case more than one trap is installed on the same source
862 ;; expression ... so that we can still get the setting and resetting
863 ;; of the 'breakpoint source property correct.
864 (define source-breakpoint-count (make-object-property))
866 (define-method (install-trap (trap <source-trap>))
868 (let* ((expr (slot-ref trap 'expression))
869 (breakpoint-count (or (source-breakpoint-count expr) 0)))
870 (set-source-property! expr 'breakpoint #t)
871 (set! (source-breakpoint-count expr) (+ breakpoint-count 1)))
872 (install-breakpoint-trap trap))
874 (define-method (uninstall-trap (trap <source-trap>))
876 (let* ((expr (slot-ref trap 'expression))
877 (breakpoint-count (or (source-breakpoint-count expr) 0)))
878 (if (= breakpoint-count 1)
879 (set-source-property! expr 'breakpoint #f))
880 (set! (source-breakpoint-count expr) (- breakpoint-count 1)))
881 (uninstall-breakpoint-trap trap))
883 (define-method (trap-runnable? (trap <source-trap>)
884 (trap-context <trap-context>))
885 (or (eq? (slot-ref trap 'expression)
886 (tc:expression trap-context))
887 (let ((trap-location (frame->source-position (tc:frame trap-context))))
889 (string=? (car trap-location) (slot-ref trap 'filename))
890 (= (cadr trap-location) (slot-ref trap 'line))
891 (= (caddr trap-location) (slot-ref trap 'column))))))
893 ;; (trap-here EXPRESSION . OPTIONS)
895 (procedure->memoizing-macro
897 (let ((trap (apply make
900 (local-eval `(list ,@(cddr expr))
903 (set-car! expr 'begin)
904 (set-cdr! (cdr expr) '())
907 ;;; Class: <location-trap>
909 ;;; An installed instance of <location-trap> triggers on entry to a
910 ;;; frame with a more-or-less precisely specified source location.
911 (define-class <location-trap> (<trap>)
912 ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to
914 (file-regexp #:init-keyword #:file-regexp)
915 ;; "line" and "column" slots: position to trap at (0-based).
916 (line #:init-value #f #:init-keyword #:line)
917 (column #:init-value #f #:init-keyword #:column)
918 ;; "compiled-regexp" slot - self explanatory, internal use only
921 (define-method (initialize (trap <location-trap>) initargs)
923 (slot-set! trap 'compiled-regexp
924 (make-regexp (slot-ref trap 'file-regexp))))
926 (define-method (install-trap (trap <location-trap>))
928 (install-enter-frame-trap trap))
930 (define-method (uninstall-trap (trap <location-trap>))
932 (uninstall-enter-frame-trap trap))
934 (define-method (trap-runnable? (trap <location-trap>)
935 (trap-context <trap-context>))
936 (and-let* ((trap-location (frame->source-position (tc:frame trap-context)))
937 (tcline (cadr trap-location))
938 (tccolumn (caddr trap-location)))
939 (and (= tcline (slot-ref trap 'line))
940 (= tccolumn (slot-ref trap 'column))
941 (regexp-exec (slot-ref trap 'compiled-regexp)
942 (car trap-location) 0))))
944 ;;; {Misc Trap Utilities}
946 (define (get-trap number)
947 (hash-ref all-traps number))
951 (map cdr (sort (hash-fold acons '() all-traps)
952 (lambda (x y) (< (car x) (car y)))))))
956 ;;; Some traps are associated with Scheme objects that are likely to
957 ;;; be GC'd, such as procedures and read expressions. When those
958 ;;; objects are GC'd, we want to allow their traps to evaporate as
959 ;;; well, or at least not to prevent them from doing so because they
960 ;;; are (now pointlessly) included on the various installed trap
963 ;; An object property that maps each volatile target to the list of
964 ;; traps that are installed on it.
965 (define volatile-target-traps (make-object-property))
967 ;; A guardian that tells us when a volatile target is no longer
969 (define volatile-target-guardian (make-guardian))
971 ;; An after GC hook that checks for newly inaccessible targets.
972 (add-hook! after-gc-hook
975 (let loop ((target (volatile-target-guardian)))
977 ;; We have a target which is now inaccessible. Get
978 ;; the list of traps installed on it.
980 (trc 'after-gc-hook "got target")
981 ;; Uninstall all the traps that are installed on
983 (for-each (lambda (trap)
984 (trc 'after-gc-hook "got trap")
985 ;; If the trap is still installed,
987 (if (slot-ref trap 'installed)
988 (uninstall-trap trap))
989 ;; If the trap has an observer, tell
990 ;; it that the target has gone.
991 (cond ((slot-ref trap 'observer)
994 (trc 'after-gc-hook "call obs")
995 (proc 'target-gone)))))
996 (or (volatile-target-traps target) '()))
997 ;; Check for any more inaccessible targets.
998 (loop (volatile-target-guardian)))))))
1000 (define (without-traps thunk)
1001 (with-traps (lambda ()
1002 (trap-disable 'traps)
1005 (define guile-trap-features
1006 ;; Helper procedure, to test whether a specific possible Guile
1007 ;; feature is supported.
1009 (lambda (test-feature)
1012 ;; Tweaking is supported if the description of the cheap
1013 ;; traps option includes the word "obsolete", or if the
1014 ;; option isn't there any more.
1015 (and (string>=? (version) "1.7")
1016 (let ((cheap-opt-desc
1017 (assq 'cheap (debug-options-interface 'help))))
1018 (or (not cheap-opt-desc)
1019 (string-match "obsolete" (caddr cheap-opt-desc))))))
1021 (error "Unexpected feature name:" test-feature))))))
1022 ;; Compile the list of actually supported features from all
1023 ;; possible features.
1024 (let loop ((possible-features '(tweaking))
1025 (actual-features '()))
1026 (if (null? possible-features)
1027 (reverse! actual-features)
1028 (let ((test-feature (car possible-features)))
1029 (loop (cdr possible-features)
1030 (if (supported? test-feature)
1031 (cons test-feature actual-features)
1032 actual-features)))))))
1034 ;; Make sure that traps are enabled.
1035 (trap-enable 'traps)
1037 ;;; (ice-9 debugging traps) ends here.