path: root/module/ice-9/debugging/traps.scm

;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface

;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; This module provides an abstraction around Guile's low level trap
;;; handler interface; its aim is to make the low level trap mechanism
;;; shareable between the debugger and other applications, and to
;;; insulate the rest of the debugger code a bit from changes that may
;;; occur in the low level trap interface in future.

(define-module (ice-9 debugging traps)
  #:use-module (ice-9 regex)
  #:use-module (oop goops)
  #:use-module (oop goops describe)
  #:use-module (ice-9 debugging trc)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:export (tc:type
            tc:continuation
            tc:expression
            tc:return-value
            tc:stack
            tc:frame
            tc:depth
            tc:real-depth
            tc:exit-depth
	    tc:fired-traps
	    ;; Interface for users of <trap> subclasses defined in
	    ;; this module.
            add-trapped-stack-id!
	    remove-trapped-stack-id!
	    <procedure-trap>
	    <exit-trap>
	    <entry-trap>
	    <apply-trap>
	    <step-trap>
	    <source-trap>
	    <location-trap>
	    install-trap
	    uninstall-trap
            all-traps
            get-trap
	    list-traps
	    trap-ordering
            behaviour-ordering
	    throw->trap-context
	    on-pre-unwind-handler-dispatch
	    ;; Interface for authors of new <trap> subclasses.
	    <trap-context>
	    <trap>
	    trap->behaviour
	    trap-runnable?
	    install-apply-frame-trap
	    install-breakpoint-trap
	    install-enter-frame-trap
	    install-exit-frame-trap
	    install-trace-trap
	    uninstall-apply-frame-trap
	    uninstall-breakpoint-trap
	    uninstall-enter-frame-trap
	    uninstall-exit-frame-trap
	    uninstall-trace-trap
	    frame->source-position
	    frame-file-name
	    without-traps
            guile-trap-features)
  #:re-export (make)
  #:export-syntax (trap-here))

;; How to debug the debugging infrastructure, when needed.  Grep for
;; "(trc " to find other symbols that can be passed to trc-add.
;; (trc-add 'after-gc-hook)

;; In Guile 1.7 onwards, weak-vector and friends are provided by the
;; (ice-9 weak-vector) module.
(cond ((string>=? (version) "1.7")
       (use-modules (ice-9 weak-vector))))

;;; The current low level traps interface is as follows.
;;;
;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
;;; by the `traps' setting of `(evaluator-traps-interface)' but also
;;; (and more relevant in most cases) by the `with-traps' procedure.
;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
;;; its thunk parameter.
;;;
;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
;;; for the duration of the call, to avoid nasty recursive trapping
;;; loops.  If a trap handler knows what it is doing, it can override
;;; this by `(trap-enable traps)'.
;;;
;;; The apply-frame handler is called when Guile is about to perform
;;; an application if EITHER the `apply-frame' evaluator trap option
;;; is set, OR the `trace' debug option is set and the procedure to
;;; apply has its `trace' procedure property set.  The arguments
;;; passed are:
;;;
;;; - the symbol 'apply-frame
;;;
;;; - a continuation or debug object describing the current stack
;;;
;;; - a boolean indicating whether the application is tail-recursive.
;;;
;;; The enter-frame handler is called when the evaluator begins a new
;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
;;; is set, OR the `breakpoints' debug option is set and the code to
;;; be evaluated has its `breakpoint' source property set.  The
;;; arguments passed are:
;;;
;;; - the symbol 'enter-frame
;;;
;;; - a continuation or debug object describing the current stack
;;;
;;; - a boolean indicating whether the application is tail-recursive.
;;;
;;; - an unmemoized copy of the expression to be evaluated.
;;;
;;; If the `enter-frame' evaluator trap option is set, the enter-frame
;;; handler is also called when about to perform an application in
;;; SCM_APPLY, immediately before possibly calling the apply-frame
;;; handler.  (I don't totally understand this.)  In this case, the
;;; arguments passed are:
;;;
;;; - the symbol 'enter-frame
;;;
;;; - a continuation or debug object describing the current stack.
;;;
;;; The exit-frame handler is called when Guile exits an evaluation
;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
;;; EITHER the `exit-frame' evaluator trap option is set, OR the
;;; `trace' debug option is set and the frame is marked as having been
;;; traced.  The frame will be marked as having been traced if the
;;; apply-frame handler was called for this frame.  (This is trickier
;;; than it sounds because of tail recursion: the same debug frame
;;; could have been used for multiple applications, only some of which
;;; were traced - I think.)  The arguments passed are:
;;;
;;; - the symbol 'exit-frame
;;;
;;; - a continuation or debug object describing the current stack
;;;
;;; - the result of the evaluation or application.

;;; {Trap Context}
;;;
;;; A trap context is a GOOPS object that encapsulates all the useful
;;; information about a particular trap.  Encapsulating this
;;; information in a single object also allows us:
;;;
;;; - to defer the calculation of information that is time-consuming
;;; to calculate, such as the stack, and to cache such information so
;;; that it is only ever calculated once per trap
;;;
;;; - to pass all interesting information to trap behaviour procedures
;;; in a single parameter, which (i) is convenient and (ii) makes for
;;; a more future-proof interface.
;;;
;;; It also allows us - where very carefully documented! - to pass
;;; information from one behaviour procedure to another.

(define-class <trap-context> ()
  ;; Information provided directly by the trap calls from the
  ;; evaluator.  The "type" slot holds a keyword indicating the type
  ;; of the trap: one of #:evaluation, #:application, #:return,
  ;; #:error.
  (type #:getter tc:type
        #:init-keyword #:type)
  ;; The "continuation" slot holds the continuation (or debug object,
  ;; if "cheap" traps are enabled, which is the default) at the point
  ;; of the trap.  For an error trap it is #f.
  (continuation #:getter tc:continuation
                #:init-keyword #:continuation)
  ;; The "expression" slot holds the source code expression, for an
  ;; evaluation trap.
  (expression #:getter tc:expression
              #:init-keyword #:expression
              #:init-value #f)
  ;; The "return-value" slot holds the return value, for a return
  ;; trap, or the error args, for an error trap.
  (return-value #:getter tc:return-value
                #:init-keyword #:return-value
                #:init-value #f)
  ;; The list of trap objects which fired in this trap context.
  (fired-traps #:getter tc:fired-traps
	       #:init-value '())
  ;; The set of symbols which, if one of them is set in the CAR of the
  ;; handler-return-value slot, will cause the CDR of that slot to
  ;; have an effect.
  (handler-return-syms #:init-value '())
  ;; The value which the trap handler should return to the evaluator.
  (handler-return-value #:init-value #f)
  ;; Calculated and cached information.  "stack" is the stack
  ;; (computed from the continuation (or debug object) by make-stack,
  ;; or else (in the case of an error trap) by (make-stack #t ...).
  (stack #:init-value #f)
  (frame #:init-value #f)
  (depth #:init-value #f)
  (real-depth #:init-value #f)
  (exit-depth #:init-value #f))

(define-method (tc:stack (ctx <trap-context>))
  (or (slot-ref ctx 'stack)
      (let ((stack (make-stack (tc:continuation ctx))))
        (slot-set! ctx 'stack stack)
        stack)))

(define-method (tc:frame (ctx <trap-context>))
  (or (slot-ref ctx 'frame)
      (let ((frame (cond ((tc:continuation ctx) => last-stack-frame)
			 (else (stack-ref (tc:stack ctx) 0)))))
        (slot-set! ctx 'frame frame)
        frame)))

(define-method (tc:depth (ctx <trap-context>))
  (or (slot-ref ctx 'depth)
      (let ((depth (stack-length (tc:stack ctx))))
        (slot-set! ctx 'depth depth)
        depth)))

(define-method (tc:real-depth (ctx <trap-context>))
  (or (slot-ref ctx 'real-depth)
      (let* ((stack (tc:stack ctx))
	     (real-depth (apply +
				(map (lambda (i)
				       (if (frame-real? (stack-ref stack i))
					   1
					   0))
				     (iota (tc:depth ctx))))))
        (slot-set! ctx 'real-depth real-depth)
        real-depth)))

(define-method (tc:exit-depth (ctx <trap-context>))
  (or (slot-ref ctx 'exit-depth)
      (let* ((stack (tc:stack ctx))
	     (depth (tc:depth ctx))
	     (exit-depth (let loop ((exit-depth depth))
			   (if (or (zero? exit-depth)
				   (frame-real? (stack-ref stack
							   (- depth
							      exit-depth))))
			       exit-depth
			       (loop (- exit-depth 1))))))
	(slot-set! ctx 'exit-depth exit-depth)
        exit-depth)))

;;; {Stack IDs}
;;;
;;; Mechanism for limiting trapping to contexts whose stack ID matches
;;; one of a registered set.  The default is for traps to fire
;;; regardless of stack ID.

(define trapped-stack-ids (list #t))
(define all-stack-ids-trapped? #t)

(define (add-trapped-stack-id! id)
  "Add ID to the set of stack ids for which traps are active.
If `#t' is in this set, traps are active regardless of stack context.
To remove ID again, use `remove-trapped-stack-id!'.  If you add the
same ID twice using `add-trapped-stack-id!', you will need to remove
it twice."
  (set! trapped-stack-ids (cons id trapped-stack-ids))
  (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))

(define (remove-trapped-stack-id! id)
  "Remove ID from the set of stack ids for which traps are active."
  (set! trapped-stack-ids (delq1! id trapped-stack-ids))
  (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))

(define (trap-here? cont)
  ;; Return true if the stack id of the specified continuation (or
  ;; debug object) is in the set that we should trap for; otherwise
  ;; false.
  (or all-stack-ids-trapped?
      (memq (stack-id cont) trapped-stack-ids)))

;;; {Global State}
;;;
;;; Variables tracking registered handlers, relevant procedures, and
;;; what's turned on as regards the evaluator's debugging options.

(define enter-frame-traps '())
(define apply-frame-traps '())
(define exit-frame-traps '())
(define breakpoint-traps '())
(define trace-traps '())

(define (non-null? hook)
  (not (null? hook)))

;; The low level frame handlers must all be initialized to something
;; harmless.  Otherwise we hit a problem immediately when trying to
;; enable one of these handlers.
(trap-set! enter-frame-handler noop)
(trap-set! apply-frame-handler noop)
(trap-set! exit-frame-handler noop)

(define set-debug-and-trap-options
  (let ((dopts (debug-options))
	(topts (evaluator-traps-interface))
	(setting (lambda (key opts)
		   (let ((l (memq key opts)))
		     (and l
			  (not (null? (cdr l)))
			  (cadr l)))))
	(debug-set-boolean! (lambda (key value)
			      ((if value debug-enable debug-disable) key)))
	(trap-set-boolean! (lambda (key value)
			     ((if value trap-enable trap-disable) key))))
    (let ((save-debug (memq 'debug dopts))
	  (save-trace (memq 'trace dopts))
	  (save-breakpoints (memq 'breakpoints dopts))
	  (save-enter-frame (memq 'enter-frame topts))
	  (save-apply-frame (memq 'apply-frame topts))
	  (save-exit-frame (memq 'exit-frame topts))
	  (save-enter-frame-handler (setting 'enter-frame-handler topts))
	  (save-apply-frame-handler (setting 'apply-frame-handler topts))
	  (save-exit-frame-handler (setting 'exit-frame-handler topts)))
      (lambda ()
	(let ((need-trace (non-null? trace-traps))
	      (need-breakpoints (non-null? breakpoint-traps))
	      (need-enter-frame (non-null? enter-frame-traps))
	      (need-apply-frame (non-null? apply-frame-traps))
	      (need-exit-frame (non-null? exit-frame-traps)))
	  (debug-set-boolean! 'debug
			      (or need-trace
				  need-breakpoints
				  need-enter-frame
				  need-apply-frame
				  need-exit-frame
				  save-debug))
	  (debug-set-boolean! 'trace
			      (or need-trace
				  save-trace))
	  (debug-set-boolean! 'breakpoints
			      (or need-breakpoints
				  save-breakpoints))
	  (trap-set-boolean! 'enter-frame
			     (or need-enter-frame
				 save-enter-frame))
	  (trap-set-boolean! 'apply-frame
			     (or need-apply-frame
				 save-apply-frame))
	  (trap-set-boolean! 'exit-frame
			     (or need-exit-frame
				 save-exit-frame))
	  (trap-set! enter-frame-handler
		     (cond ((or need-breakpoints
				need-enter-frame)
			    enter-frame-handler)
			   (else save-enter-frame-handler)))
	  (trap-set! apply-frame-handler
		     (cond ((or need-trace
				need-apply-frame)
			    apply-frame-handler)
			   (else save-apply-frame-handler)))
	  (trap-set! exit-frame-handler
		     (cond ((or need-exit-frame)
			    exit-frame-handler)
			   (else save-exit-frame-handler))))
	;;(write (evaluator-traps-interface))
	*unspecified*))))

(define (enter-frame-handler key cont . args)
  ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
  ;; unmemoized copy of the source expression.  For an application
  ;; entry, ARGS is empty.
  (if (trap-here? cont)
      (let* ((application-entry? (null? args))
             (trap-context (make <trap-context>
                             #:type #:evaluation
                             #:continuation cont
                             #:expression (if application-entry?
                                              #f
                                              (cadr args)))))
	(trc 'enter-frame-handler)
	(if (and (not application-entry?)
                 (memq 'tweaking guile-trap-features))
	    (slot-set! trap-context 'handler-return-syms '(instead)))
        (run-traps (if application-entry?
		       enter-frame-traps
		       (append enter-frame-traps breakpoint-traps))
		   trap-context)
	(slot-ref trap-context 'handler-return-value))))

(define (apply-frame-handler key cont tail?)
  (if (trap-here? cont)
      (let ((trap-context (make <trap-context>
                            #:type #:application
                            #:continuation cont)))
	(trc 'apply-frame-handler tail?)
        (run-traps (append apply-frame-traps trace-traps) trap-context)
	(slot-ref trap-context 'handler-return-value))))

(define (exit-frame-handler key cont retval)
  (if (trap-here? cont)
      (let ((trap-context (make <trap-context>
                            #:type #:return
                            #:continuation cont
                            #:return-value retval)))
	(trc 'exit-frame-handler retval (tc:depth trap-context))
	(if (memq 'tweaking guile-trap-features)
            (slot-set! trap-context 'handler-return-syms '(instead)))
        (run-traps exit-frame-traps trap-context)
	(slot-ref trap-context 'handler-return-value))))

(define-macro (trap-installer trap-list)
  `(lambda (trap)
     (set! ,trap-list (cons trap ,trap-list))
     (set-debug-and-trap-options)))

(define install-enter-frame-trap (trap-installer enter-frame-traps))
(define install-apply-frame-trap (trap-installer apply-frame-traps))
(define install-exit-frame-trap (trap-installer exit-frame-traps))
(define install-breakpoint-trap (trap-installer breakpoint-traps))
(define install-trace-trap (trap-installer trace-traps))

(define-macro (trap-uninstaller trap-list)
  `(lambda (trap)
     (or (memq trap ,trap-list)
         (error "Trap list does not include the specified trap"))
     (set! ,trap-list (delq1! trap ,trap-list))
     (set-debug-and-trap-options)))

(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps))
(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps))
(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps))
(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps))
(define uninstall-trace-trap (trap-uninstaller trace-traps))

(define trap-ordering (make-object-property))
(define behaviour-ordering (make-object-property))

(define (run-traps traps trap-context)
  (let ((behaviours (apply append
			   (map (lambda (trap)
				  (trap->behaviour trap trap-context))
				(sort traps
				      (lambda (t1 t2)
					(< (or (trap-ordering t1) 0)
					   (or (trap-ordering t2) 0))))))))
    (for-each (lambda (proc)
		(proc trap-context))
	      (sort (delete-duplicates behaviours)
		    (lambda (b1 b2)
                    (< (or (behaviour-ordering b1) 0)
                       (or (behaviour-ordering b2) 0)))))))

;;; {Pseudo-Traps for Non-Trap Events}

;;; Once there is a body of code to do with responding to (debugging,
;;; tracing, etc.) traps, it makes sense to be able to leverage that
;;; same code for certain events that are trap-like, but not actually
;;; traps in the sense of the calls made by libguile's evaluator.

;;; The main example of this is when an error is signalled. Guile
;;; doesn't yet have a 100% reliable way of hooking into errors, but in
;;; practice most errors go through a catch whose pre-unwind handler is
;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in
;;; turn calls default-pre-unwind-handler. So we can present most errors
;;; as pseudo-traps by modifying default-pre-unwind-handler.

(define default-default-pre-unwind-handler default-pre-unwind-handler)

(define (throw->trap-context key args . stack-args)
  (let ((ctx (make <trap-context>
	       #:type #:error
	       #:continuation #f
	       #:return-value (cons key args))))
    (slot-set! ctx 'stack
	       (let ((caller-stack (and (= (length stack-args) 1)
					(car stack-args))))
		 (if (stack? caller-stack)
		     caller-stack
		     (apply make-stack #t stack-args))))
    ctx))

(define (on-pre-unwind-handler-dispatch behaviour . ignored-keys)
  (set! default-pre-unwind-handler
	(if behaviour
	    (lambda (key . args)
	      (or (memq key ignored-keys)
		  (behaviour (throw->trap-context key
						  args
						  pre-unwind-handler-dispatch)))
	      (apply default-default-pre-unwind-handler key args))
	    default-default-pre-unwind-handler)))

;;; {Trap Classes}

;;; Class: <trap>
;;;
;;; <trap> is the base class for traps.  Any actual trap should be an
;;; instance of a class derived from <trap>, not of <trap> itself,
;;; because there is no base class method for the install-trap,
;;; trap-runnable? and uninstall-trap GFs.
(define-class <trap> ()
  ;; "number" slot: the number of this trap (assigned automatically).
  (number)
  ;; "installed" slot: whether this trap is installed.
  (installed #:init-value #f)
  ;; "condition" slot: if non-#f, this is a thunk which is called when
  ;; the trap fires, to determine whether trap processing should
  ;; proceed any further.
  (condition #:init-value #f #:init-keyword #:condition)
  ;; "skip-count" slot: a count of valid (after "condition"
  ;; processing) firings of this trap to skip.
  (skip-count #:init-value 0 #:init-keyword #:skip-count)
  ;; "single-shot" slot: if non-#f, this trap is removed after it has
  ;; successfully fired (after "condition" and "skip-count"
  ;; processing) for the first time.
  (single-shot #:init-value #f #:init-keyword #:single-shot)
  ;; "behaviour" slot: procedure or list of procedures to call
  ;; (passing the trap context as parameter) if we finally decide
  ;; (after "condition" and "skip-count" processing) to run this
  ;; trap's behaviour.
  (behaviour #:init-value '() #:init-keyword #:behaviour)
  ;; "repeat-identical-behaviour" slot: normally, if multiple <trap>
  ;; objects are triggered by the same low level trap, and they
  ;; request the same behaviour, it's only useful to do that behaviour
  ;; once (per low level trap); so by default multiple requests for
  ;; the same behaviour are coalesced.  If this slot is non-#f, the
  ;; contents of the "behaviour" slot are uniquified so that they
  ;; avoid being coalesced in this way.
  (repeat-identical-behaviour #:init-value #f
			      #:init-keyword #:repeat-identical-behaviour)
  ;; "observer" slot: this is a procedure that is called with one
  ;; EVENT argument when the trap status changes in certain
  ;; interesting ways, currently the following.  (1) When the trap is
  ;; uninstalled because of the target becoming inaccessible; EVENT in
  ;; this case is 'target-gone.
  (observer #:init-value #f #:init-keyword #:observer))

(define last-assigned-trap-number 0)
(define all-traps (make-weak-value-hash-table 7))

(define-method (initialize (trap <trap>) initargs)
  (next-method)
  ;; Assign a trap number, and store in the hash of all traps.
  (set! last-assigned-trap-number (+ last-assigned-trap-number 1))
  (slot-set! trap 'number last-assigned-trap-number)
  (hash-set! all-traps last-assigned-trap-number trap)
  ;; Listify the behaviour slot, if not a list already.
  (let ((behaviour (slot-ref trap 'behaviour)))
    (if (procedure? behaviour)
	(slot-set! trap 'behaviour (list behaviour)))))

(define-generic install-trap)		; provided mostly by subclasses
(define-generic uninstall-trap)		; provided mostly by subclasses
(define-generic trap->behaviour)	; provided by <trap>
(define-generic trap-runnable?)		; provided by subclasses

(define-method (install-trap (trap <trap>))
  (if (slot-ref trap 'installed)
      (error "Trap is already installed"))
  (slot-set! trap 'installed #t))

(define-method (uninstall-trap (trap <trap>))
  (or (slot-ref trap 'installed)
      (error "Trap is not installed"))
  (slot-set! trap 'installed #f))

;;; uniquify-behaviour
;;;
;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
(define (uniquify-behaviour behaviour)
  (lambda (trap-context)
    (behaviour trap-context)))

;;; trap->behaviour
;;;
;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of
;;; behaviour procs to call with TRAP-CONTEXT as a parameter.
;;; Otherwise return the empty list.
(define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>))
  (if (and
       ;; Check that the trap is runnable.  Runnability is implemented
       ;; by the subclass and allows us to check, for example, that
       ;; the procedure being applied in an apply-frame trap matches
       ;; this trap's procedure.
       (trap-runnable? trap trap-context)
       ;; Check the additional condition, if specified.
       (let ((condition (slot-ref trap 'condition)))
	 (or (not condition)
	     ((condition))))
       ;; Check for a skip count.
       (let ((skip-count (slot-ref trap 'skip-count)))
	 (if (zero? skip-count)
	     #t
	     (begin
	       (slot-set! trap 'skip-count (- skip-count 1))
	       #f))))
      ;; All checks passed, so we will return the contents of this
      ;; trap's behaviour slot.
      (begin
	;; First, though, remove this trap if its single-shot slot
	;; indicates that it should fire only once.
	(if (slot-ref trap 'single-shot)
	    (uninstall-trap trap))
	;; Add this trap object to the context's list of traps which
	;; fired here.
	(slot-set! trap-context 'fired-traps
		   (cons trap (tc:fired-traps trap-context)))
	;; Return trap behaviour, uniquified if necessary.
	(if (slot-ref trap 'repeat-identical-behaviour)
	    (map uniquify-behaviour (slot-ref trap 'behaviour))
	    (slot-ref trap 'behaviour)))
      '()))

;;; Class: <procedure-trap>
;;;
;;; An installed instance of <procedure-trap> triggers on invocation
;;; of a specific procedure.
(define-class <procedure-trap> (<trap>)
  ;; "procedure" slot: the procedure to trap on.  This is implemented
  ;; virtually, using the following weak vector slot, so as to avoid
  ;; this trap preventing the GC of the target procedure.
  (procedure #:init-keyword #:procedure
	     #:allocation #:virtual
	     #:slot-ref
	     (lambda (trap)
	       (vector-ref (slot-ref trap 'procedure-wv) 0))
	     #:slot-set!
	     (lambda (trap proc)
	       (if (slot-bound? trap 'procedure-wv)
		   (vector-set! (slot-ref trap 'procedure-wv) 0 proc)
		   (slot-set! trap 'procedure-wv (weak-vector proc)))))
  (procedure-wv))

;; Customization of the initialize method: set up to handle what
;; should happen when the procedure is GC'd.
(define-method (initialize (trap <procedure-trap>) initargs)
  (next-method)
  (let* ((proc (slot-ref trap 'procedure))
	 (existing-traps (volatile-target-traps proc)))
    ;; If this is the target's first trap, give the target procedure
    ;; to the volatile-target-guardian, so we can find out if it
    ;; becomes inaccessible.
    (or existing-traps (volatile-target-guardian proc))
    ;; Add this trap to the target procedure's list of traps.
    (set! (volatile-target-traps proc)
	  (cons trap (or existing-traps '())))))

(define procedure-trace-count (make-object-property))

(define-method (install-trap (trap <procedure-trap>))
  (next-method)
  (let* ((proc (slot-ref trap 'procedure))
         (trace-count (or (procedure-trace-count proc) 0)))
    (set-procedure-property! proc 'trace #t)
    (set! (procedure-trace-count proc) (+ trace-count 1)))
  (install-trace-trap trap))

(define-method (uninstall-trap (trap <procedure-trap>))
  (next-method)
  (let* ((proc (slot-ref trap 'procedure))
         (trace-count (or (procedure-trace-count proc) 0)))
    (if (= trace-count 1)
        (set-procedure-property! proc 'trace #f))
    (set! (procedure-trace-count proc) (- trace-count 1)))
  (uninstall-trace-trap trap))

(define-method (trap-runnable? (trap <procedure-trap>)
			       (trap-context <trap-context>))
  (eq? (slot-ref trap 'procedure)
       (frame-procedure (tc:frame trap-context))))

;;; Class: <exit-trap>
;;;
;;; An installed instance of <exit-trap> triggers on stack frame exit
;;; past a specified stack depth.
(define-class <exit-trap> (<trap>)
  ;; "depth" slot: the reference depth for the trap.
  (depth #:init-keyword #:depth))

(define-method (install-trap (trap <exit-trap>))
  (next-method)
  (install-exit-frame-trap trap))

(define-method (uninstall-trap (trap <exit-trap>))
  (next-method)
  (uninstall-exit-frame-trap trap))

(define-method (trap-runnable? (trap <exit-trap>)
			       (trap-context <trap-context>))
  (<= (tc:exit-depth trap-context)
      (slot-ref trap 'depth)))

;;; Class: <entry-trap>
;;;
;;; An installed instance of <entry-trap> triggers on any frame entry.
(define-class <entry-trap> (<trap>))

(define-method (install-trap (trap <entry-trap>))
  (next-method)
  (install-enter-frame-trap trap))

(define-method (uninstall-trap (trap <entry-trap>))
  (next-method)
  (uninstall-enter-frame-trap trap))

(define-method (trap-runnable? (trap <entry-trap>)
			       (trap-context <trap-context>))
  #t)

;;; Class: <apply-trap>
;;;
;;; An installed instance of <apply-trap> triggers on any procedure
;;; application.
(define-class <apply-trap> (<trap>))

(define-method (install-trap (trap <apply-trap>))
  (next-method)
  (install-apply-frame-trap trap))

(define-method (uninstall-trap (trap <apply-trap>))
  (next-method)
  (uninstall-apply-frame-trap trap))

(define-method (trap-runnable? (trap <apply-trap>)
			       (trap-context <trap-context>))
  #t)

;;; Class: <step-trap>
;;;
;;; An installed instance of <step-trap> triggers on the next frame
;;; entry, exit or application, optionally with source location inside
;;; a specified file.
(define-class <step-trap> (<exit-trap>)
  ;; "file-name" slot: if non-#f, indicates that this trap should
  ;; trigger only for steps in source code from the specified file.
  (file-name #:init-value #f #:init-keyword #:file-name)
  ;; "exit-depth" slot: when non-#f, indicates that the next step may
  ;; be a frame exit past this depth; otherwise, indicates that the
  ;; next step must be an application or a frame entry.
  (exit-depth #:init-value #f #:init-keyword #:exit-depth))

(define-method (initialize (trap <step-trap>) initargs)
  (next-method)
  (slot-set! trap 'depth (slot-ref trap 'exit-depth)))

(define-method (install-trap (trap <step-trap>))
  (next-method)
  (install-enter-frame-trap trap)
  (install-apply-frame-trap trap))

(define-method (uninstall-trap (trap <step-trap>))
  (next-method)
  (uninstall-enter-frame-trap trap)
  (uninstall-apply-frame-trap trap))

(define-method (trap-runnable? (trap <step-trap>)
			       (trap-context <trap-context>))
  (if (eq? (tc:type trap-context) #:return)
      ;; We're in the context of an exit-frame trap.  Trap should only
      ;; be run if exit-depth is set and this exit-frame has returned
      ;; past the set depth.
      (and (slot-ref trap 'exit-depth)
	   (next-method)
	   ;; OK to run the trap here, but we should first reset the
	   ;; exit-depth slot to indicate that the step after this one
	   ;; must be an application or frame entry.
	   (begin
	     (slot-set! trap 'exit-depth #f)
	     #t))
      ;; We're in the context of an application or frame entry trap.
      ;; Check whether trap is limited to a specified file.
      (let ((file-name (slot-ref trap 'file-name)))
	(and (or (not file-name)
		 (equal? (frame-file-name (tc:frame trap-context)) file-name))
	     ;; Trap should run here, but we should also set exit-depth to
	     ;; the current stack length, so that - if we don't stop at any
	     ;; other steps first - the next step shows the return value of
	     ;; the current application or evaluation.
	     (begin
	       (slot-set! trap 'exit-depth (tc:depth trap-context))
	       (slot-set! trap 'depth (tc:depth trap-context))
	       #t)))))

(define (frame->source-position frame)
  (let ((source (if (frame-procedure? frame)
		    (or (frame-source frame)
			(let ((proc (frame-procedure frame)))
			  (and proc
			       (procedure? proc)
			       (procedure-source proc))))
		    (frame-source frame))))
    (and source
	 (string? (source-property source 'filename))
	 (list (source-property source 'filename)
	       (source-property source 'line)
	       (source-property source 'column)))))

(define (frame-file-name frame)
  (cond ((frame->source-position frame) => car)
	(else #f)))

;;; Class: <source-trap>
;;;
;;; An installed instance of <source-trap> triggers upon evaluation of
;;; a specified source expression.
(define-class <source-trap> (<trap>)
  ;; "expression" slot: the expression to trap on.  This is
  ;; implemented virtually, using the following weak vector slot, so
  ;; as to avoid this trap preventing the GC of the target source
  ;; code.
  (expression #:init-keyword #:expression
	      #:allocation #:virtual
	      #:slot-ref
	      (lambda (trap)
		(vector-ref (slot-ref trap 'expression-wv) 0))
	      #:slot-set!
	      (lambda (trap expr)
		(if (slot-bound? trap 'expression-wv)
		    (vector-set! (slot-ref trap 'expression-wv) 0 expr)
		    (slot-set! trap 'expression-wv (weak-vector expr)))))
  (expression-wv)
  ;; source property slots - for internal use only
  (filename)
  (line)
  (column))

;; Customization of the initialize method: get and save the
;; expression's source properties, or signal an error if it doesn't
;; have the necessary properties.
(define-method (initialize (trap <source-trap>) initargs)
  (next-method)
  (let* ((expr (slot-ref trap 'expression))
	 (filename (source-property expr 'filename))
         (line (source-property expr 'line))
         (column (source-property expr 'column))
	 (existing-traps (volatile-target-traps expr)))
    (or (and filename line column)
        (error "Specified source does not have the necessary properties"
               filename line column))
    (slot-set! trap 'filename filename)
    (slot-set! trap 'line line)
    (slot-set! trap 'column column)
    ;; If this is the target's first trap, give the target expression
    ;; to the volatile-target-guardian, so we can find out if it
    ;; becomes inaccessible.
    (or existing-traps (volatile-target-guardian expr))
    ;; Add this trap to the target expression's list of traps.
    (set! (volatile-target-traps expr)
	  (cons trap (or existing-traps '())))))

;; Just in case more than one trap is installed on the same source
;; expression ... so that we can still get the setting and resetting
;; of the 'breakpoint source property correct.
(define source-breakpoint-count (make-object-property))

(define-method (install-trap (trap <source-trap>))
  (next-method)
  (let* ((expr (slot-ref trap 'expression))
         (breakpoint-count (or (source-breakpoint-count expr) 0)))
    (set-source-property! expr 'breakpoint #t)
    (set! (source-breakpoint-count expr) (+ breakpoint-count 1)))
  (install-breakpoint-trap trap))

(define-method (uninstall-trap (trap <source-trap>))
  (next-method)
  (let* ((expr (slot-ref trap 'expression))
         (breakpoint-count (or (source-breakpoint-count expr) 0)))
    (if (= breakpoint-count 1)
        (set-source-property! expr 'breakpoint #f))
    (set! (source-breakpoint-count expr) (- breakpoint-count 1)))
  (uninstall-breakpoint-trap trap))

(define-method (trap-runnable? (trap <source-trap>)
			       (trap-context <trap-context>))
  (or (eq? (slot-ref trap 'expression)
           (tc:expression trap-context))
      (let ((trap-location (frame->source-position (tc:frame trap-context))))
        (and trap-location
             (string=? (car trap-location) (slot-ref trap 'filename))
             (= (cadr trap-location) (slot-ref trap 'line))
             (= (caddr trap-location) (slot-ref trap 'column))))))

;; (trap-here EXPRESSION . OPTIONS)
(define trap-here
  (procedure->memoizing-macro
   (lambda (expr env)
     (let ((trap (apply make
                        <source-trap>
                        #:expression expr
                        (local-eval `(list ,@(cddr expr))
                                    env))))
       (install-trap trap)
       (set-car! expr 'begin)
       (set-cdr! (cdr expr) '())
       expr))))

;;; Class: <location-trap>
;;;
;;; An installed instance of <location-trap> triggers on entry to a
;;; frame with a more-or-less precisely specified source location.
(define-class <location-trap> (<trap>)
  ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to
  ;; trap in.
  (file-regexp #:init-keyword #:file-regexp)
  ;; "line" and "column" slots: position to trap at (0-based).
  (line #:init-value #f #:init-keyword #:line)
  (column #:init-value #f #:init-keyword #:column)
  ;; "compiled-regexp" slot - self explanatory, internal use only
  (compiled-regexp))

(define-method (initialize (trap <location-trap>) initargs)
  (next-method)
  (slot-set! trap 'compiled-regexp
             (make-regexp (slot-ref trap 'file-regexp))))

(define-method (install-trap (trap <location-trap>))
  (next-method)
  (install-enter-frame-trap trap))

(define-method (uninstall-trap (trap <location-trap>))
  (next-method)
  (uninstall-enter-frame-trap trap))

(define-method (trap-runnable? (trap <location-trap>)
			       (trap-context <trap-context>))
  (and-let* ((trap-location (frame->source-position (tc:frame trap-context)))
	     (tcline (cadr trap-location))
	     (tccolumn (caddr trap-location)))
    (and (= tcline (slot-ref trap 'line))
	 (= tccolumn (slot-ref trap 'column))
         (regexp-exec (slot-ref trap 'compiled-regexp)
		      (car trap-location) 0))))

;;; {Misc Trap Utilities}

(define (get-trap number)
  (hash-ref all-traps number))

(define (list-traps)
  (for-each describe
	    (map cdr (sort (hash-fold acons '() all-traps)
			   (lambda (x y) (< (car x) (car y)))))))

;;; {Volatile Traps}
;;;
;;; Some traps are associated with Scheme objects that are likely to
;;; be GC'd, such as procedures and read expressions.  When those
;;; objects are GC'd, we want to allow their traps to evaporate as
;;; well, or at least not to prevent them from doing so because they
;;; are (now pointlessly) included on the various installed trap
;;; lists.

;; An object property that maps each volatile target to the list of
;; traps that are installed on it.
(define volatile-target-traps (make-object-property))

;; A guardian that tells us when a volatile target is no longer
;; accessible.
(define volatile-target-guardian (make-guardian))

;; An after GC hook that checks for newly inaccessible targets.
(add-hook! after-gc-hook
	   (lambda ()
	     (trc 'after-gc-hook)
	     (let loop ((target (volatile-target-guardian)))
	       (if target
                   ;; We have a target which is now inaccessible.  Get
                   ;; the list of traps installed on it.
		   (begin
		     (trc 'after-gc-hook "got target")
		     ;; Uninstall all the traps that are installed on
		     ;; this target.
		     (for-each (lambda (trap)
				 (trc 'after-gc-hook "got trap")
				 ;; If the trap is still installed,
				 ;; uninstall it.
				 (if (slot-ref trap 'installed)
				     (uninstall-trap trap))
				 ;; If the trap has an observer, tell
				 ;; it that the target has gone.
				 (cond ((slot-ref trap 'observer)
					=>
					(lambda (proc)
					  (trc 'after-gc-hook "call obs")
					  (proc 'target-gone)))))
			       (or (volatile-target-traps target) '()))
                     ;; Check for any more inaccessible targets.
		     (loop (volatile-target-guardian)))))))

(define (without-traps thunk)
  (with-traps (lambda ()
		(trap-disable 'traps)
		(thunk))))

(define guile-trap-features
  ;; Helper procedure, to test whether a specific possible Guile
  ;; feature is supported.
  (let ((supported?
         (lambda (test-feature)
           (case test-feature
             ((tweaking)
              ;; Tweaking is supported if the description of the cheap
              ;; traps option includes the word "obsolete", or if the
              ;; option isn't there any more.
              (and (string>=? (version) "1.7")
                   (let ((cheap-opt-desc
                          (assq 'cheap (debug-options-interface 'help))))
                     (or (not cheap-opt-desc)
                         (string-match "obsolete" (caddr cheap-opt-desc))))))
             (else
              (error "Unexpected feature name:" test-feature))))))
    ;; Compile the list of actually supported features from all
    ;; possible features.
    (let loop ((possible-features '(tweaking))
               (actual-features '()))
      (if (null? possible-features)
          (reverse! actual-features)
          (let ((test-feature (car possible-features)))
            (loop (cdr possible-features)
                  (if (supported? test-feature)
                      (cons test-feature actual-features)
                      actual-features)))))))

;; Make sure that traps are enabled.
(trap-enable 'traps)

;;; (ice-9 debugging traps) ends here.