guile18/ice-9/debugging/traps.scm

   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 ;;;
   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.
  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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  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)
  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)
  33   #:export (tc:type
  34             tc:continuation
  35             tc:expression
  36             tc:return-value
  37             tc:stack
  38             tc:frame
  39             tc:depth
  40             tc:real-depth
  41             tc:exit-depth
  42             tc:fired-traps
  43             ;; Interface for users of <trap> subclasses defined in
  44             ;; this module.
  45             add-trapped-stack-id!
  46             remove-trapped-stack-id!
  47             <procedure-trap>
  48             <exit-trap>
  49             <entry-trap>
  50             <apply-trap>
  51             <step-trap>
  52             <source-trap>
  53             <location-trap>
  54             install-trap
  55             uninstall-trap
  56             all-traps
  57             get-trap
  58             list-traps
  59             trap-ordering
  60             behaviour-ordering
  61             throw->trap-context
  62             on-lazy-handler-dispatch
  63             ;; Interface for authors of new <trap> subclasses.
  64             <trap-context>
  65             <trap>
  66             trap->behaviour
  67             trap-runnable?
  68             install-apply-frame-trap
  69             install-breakpoint-trap
  70             install-enter-frame-trap
  71             install-exit-frame-trap
  72             install-trace-trap
  73             uninstall-apply-frame-trap
  74             uninstall-breakpoint-trap
  75             uninstall-enter-frame-trap
  76             uninstall-exit-frame-trap
  77             uninstall-trace-trap
  78             frame->source-position
  79             frame-file-name
  80             without-traps
  81             guile-trap-features)
  82   #:re-export (make)
  83   #:export-syntax (trap-here))
  84
  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)
  88
  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))))
  93
  94 ;;; The current low level traps interface is as follows.
  95 ;;;
  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.
 101 ;;;
 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)'.
 106 ;;;
 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
 111 ;;; passed are:
 112 ;;;
 113 ;;; - the symbol 'apply-frame
 114 ;;;
 115 ;;; - a continuation or debug object describing the current stack
 116 ;;;
 117 ;;; - a boolean indicating whether the application is tail-recursive.
 118 ;;;
 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:
 124 ;;;
 125 ;;; - the symbol 'enter-frame
 126 ;;;
 127 ;;; - a continuation or debug object describing the current stack
 128 ;;;
 129 ;;; - a boolean indicating whether the application is tail-recursive.
 130 ;;;
 131 ;;; - an unmemoized copy of the expression to be evaluated.
 132 ;;;
 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:
 138 ;;;
 139 ;;; - the symbol 'enter-frame
 140 ;;;
 141 ;;; - a continuation or debug object describing the current stack.
 142 ;;;
 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:
 152 ;;;
 153 ;;; - the symbol 'exit-frame
 154 ;;;
 155 ;;; - a continuation or debug object describing the current stack
 156 ;;;
 157 ;;; - the result of the evaluation or application.
 158
 159 ;;; {Trap Context}
 160 ;;;
 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:
 164 ;;;
 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
 168 ;;;
 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.
 172 ;;;
 173 ;;; It also allows us - where very carefully documented! - to pass
 174 ;;; information from one behaviour procedure to another.
 175
 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,
 180   ;; #:error.
 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
 189   ;; evaluation trap.
 190   (expression #:getter tc:expression
 191               #:init-keyword #:expression
 192               #:init-value #f)
 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
 197                 #:init-value #f)
 198   ;; The list of trap objects which fired in this trap context.
 199   (fired-traps #:getter tc:fired-traps
 200                #:init-value '())
 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
 203   ;; have an effect.
 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))
 215
 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)
 220         stack)))
 221
 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)
 227         frame)))
 228
 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)
 233         depth)))
 234
 235 (define-method (tc:real-depth (ctx <trap-context>))
 236   (or (slot-ref ctx 'real-depth)
 237       (let* ((stack (tc:stack ctx))
 238              (real-depth (apply +
 239                                 (map (lambda (i)
 240                                        (if (frame-real? (stack-ref stack i))
 241                                            1
 242                                            0))
 243                                      (iota (tc:depth ctx))))))
 244         (slot-set! ctx 'real-depth real-depth)
 245         real-depth)))
 246
 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
 254                                                            (- depth
 255                                                               exit-depth))))
 256                                exit-depth
 257                                (loop (- exit-depth 1))))))
 258         (slot-set! ctx 'exit-depth exit-depth)
 259         exit-depth)))
 260
 261 ;;; {Stack IDs}
 262 ;;;
 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.
 266
 267 (define trapped-stack-ids (list #t))
 268 (define all-stack-ids-trapped? #t)
 269
 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
 275 it twice."
 276   (set! trapped-stack-ids (cons id trapped-stack-ids))
 277   (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
 278
 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)))
 283
 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
 287   ;; false.
 288   (or all-stack-ids-trapped?
 289       (memq (stack-id cont) trapped-stack-ids)))
 290
 291 ;;; {Global State}
 292 ;;;
 293 ;;; Variables tracking registered handlers, relevant procedures, and
 294 ;;; what's turned on as regards the evaluator's debugging options.
 295
 296 (define enter-frame-traps '())
 297 (define apply-frame-traps '())
 298 (define exit-frame-traps '())
 299 (define breakpoint-traps '())
 300 (define trace-traps '())
 301
 302 (define (non-null? hook)
 303   (not (null? hook)))
 304
 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)
 311
 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)))
 317                      (and l
 318                           (not (null? (cdr l)))
 319                           (cadr 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)))
 333       (lambda ()
 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
 340                               (or need-trace
 341                                   need-breakpoints
 342                                   need-enter-frame
 343                                   need-apply-frame
 344                                   need-exit-frame
 345                                   save-debug))
 346           (debug-set-boolean! 'trace
 347                               (or need-trace
 348                                   save-trace))
 349           (debug-set-boolean! 'breakpoints
 350                               (or need-breakpoints
 351                                   save-breakpoints))
 352           (trap-set-boolean! 'enter-frame
 353                              (or need-enter-frame
 354                                  save-enter-frame))
 355           (trap-set-boolean! 'apply-frame
 356                              (or need-apply-frame
 357                                  save-apply-frame))
 358           (trap-set-boolean! 'exit-frame
 359                              (or need-exit-frame
 360                                  save-exit-frame))
 361           (trap-set! enter-frame-handler
 362                      (cond ((or need-breakpoints
 363                                 need-enter-frame)
 364                             enter-frame-handler)
 365                            (else save-enter-frame-handler)))
 366           (trap-set! apply-frame-handler
 367                      (cond ((or need-trace
 368                                 need-apply-frame)
 369                             apply-frame-handler)
 370                            (else save-apply-frame-handler)))
 371           (trap-set! exit-frame-handler
 372                      (cond ((or need-exit-frame)
 373                             exit-frame-handler)
 374                            (else save-exit-frame-handler))))
 375         ;;(write (evaluator-traps-interface))
 376         *unspecified*))))
 377
 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>
 385                              #:type #:evaluation
 386                              #:continuation cont
 387                              #:expression (if application-entry?
 388                                               #f
 389                                               (cadr args)))))
 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?
 395                        enter-frame-traps
 396                        (append enter-frame-traps breakpoint-traps))
 397                    trap-context)
 398         (slot-ref trap-context 'handler-return-value))))
 399
 400 (define (apply-frame-handler key cont tail?)
 401   (if (trap-here? cont)
 402       (let ((trap-context (make <trap-context>
 403                             #:type #:application
 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))))
 408
 409 (define (exit-frame-handler key cont retval)
 410   (if (trap-here? cont)
 411       (let ((trap-context (make <trap-context>
 412                             #:type #:return
 413                             #:continuation cont
 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))))
 420
 421 (define-macro (trap-installer trap-list)
 422   `(lambda (trap)
 423      (set! ,trap-list (cons trap ,trap-list))
 424      (set-debug-and-trap-options)))
 425
 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))
 431
 432 (define-macro (trap-uninstaller trap-list)
 433   `(lambda (trap)
 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)))
 438
 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))
 444
 445 (define trap-ordering (make-object-property))
 446 (define behaviour-ordering (make-object-property))
 447
 448 (define (run-traps traps trap-context)
 449   (let ((behaviours (apply append
 450                            (map (lambda (trap)
 451                                   (trap->behaviour trap trap-context))
 452                                 (sort traps
 453                                       (lambda (t1 t2)
 454                                         (< (or (trap-ordering t1) 0)
 455                                            (or (trap-ordering t2) 0))))))))
 456     (for-each (lambda (proc)
 457                 (proc trap-context))
 458               (sort (delete-duplicates behaviours)
 459                     (lambda (b1 b2)
 460                     (< (or (behaviour-ordering b1) 0)
 461                        (or (behaviour-ordering b2) 0)))))))
 462
 463 ;;; {Pseudo-Traps for Non-Trap Events}
 464
 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.
 469
 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.
 476
 477 (define default-default-lazy-handler default-lazy-handler)
 478
 479 (define (throw->trap-context key args . stack-args)
 480   (let ((ctx (make <trap-context>
 481                #:type #:error
 482                #:continuation #f
 483                #:return-value (cons key args))))
 484     (slot-set! ctx 'stack
 485                (let ((caller-stack (and (= (length stack-args) 1)
 486                                         (car stack-args))))
 487                  (if (stack? caller-stack)
 488                      caller-stack
 489                      (apply make-stack #t stack-args))))
 490     ctx))
 491
 492 (define (on-lazy-handler-dispatch behaviour . ignored-keys)
 493   (set! default-lazy-handler
 494         (if behaviour
 495             (lambda (key . args)
 496               (or (memq key ignored-keys)
 497                   (behaviour (throw->trap-context key
 498                                                   args
 499                                                   lazy-handler-dispatch)))
 500               (apply default-default-lazy-handler key args))
 501             default-default-lazy-handler)))
 502
 503 ;;; {Trap Classes}
 504
 505 ;;; Class: <trap>
 506 ;;;
 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).
 513   (number)
 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
 530   ;; trap's behaviour.
 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))
 547
 548 (define last-assigned-trap-number 0)
 549 (define all-traps (make-weak-value-hash-table 7))
 550
 551 (define-method (initialize (trap <trap>) initargs)
 552   (next-method)
 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)))))
 561
 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
 566
 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))
 571
 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))
 576
 577 ;;; uniquify-behaviour
 578 ;;;
 579 ;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
 580 (define (uniquify-behaviour behaviour)
 581   (lambda (trap-context)
 582     (behaviour trap-context)))
 583
 584 ;;; trap->behaviour
 585 ;;;
 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>))
 590   (if (and
 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)))
 598          (or (not condition)
 599              ((condition))))
 600        ;; Check for a skip count.
 601        (let ((skip-count (slot-ref trap 'skip-count)))
 602          (if (zero? skip-count)
 603              #t
 604              (begin
 605                (slot-set! trap 'skip-count (- skip-count 1))
 606                #f))))
 607       ;; All checks passed, so we will return the contents of this
 608       ;; trap's behaviour slot.
 609       (begin
 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
 615         ;; fired here.
 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)))
 622       '()))
 623
 624 ;;; Class: <procedure-trap>
 625 ;;;
 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
 634              #:slot-ref
 635              (lambda (trap)
 636                (vector-ref (slot-ref trap 'procedure-wv) 0))
 637              #:slot-set!
 638              (lambda (trap proc)
 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)))))
 642   (procedure-wv))
 643
 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)
 647   (next-method)
 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 '())))))
 657
 658 (define procedure-trace-count (make-object-property))
 659
 660 (define-method (install-trap (trap <procedure-trap>))
 661   (next-method)
 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))
 667
 668 (define-method (uninstall-trap (trap <procedure-trap>))
 669   (next-method)
 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))
 676
 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))))
 681
 682 ;;; Class: <exit-trap>
 683 ;;;
 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))
 689
 690 (define-method (install-trap (trap <exit-trap>))
 691   (next-method)
 692   (install-exit-frame-trap trap))
 693
 694 (define-method (uninstall-trap (trap <exit-trap>))
 695   (next-method)
 696   (uninstall-exit-frame-trap trap))
 697
 698 (define-method (trap-runnable? (trap <exit-trap>)
 699                                (trap-context <trap-context>))
 700   (<= (tc:exit-depth trap-context)
 701       (slot-ref trap 'depth)))
 702
 703 ;;; Class: <entry-trap>
 704 ;;;
 705 ;;; An installed instance of <entry-trap> triggers on any frame entry.
 706 (define-class <entry-trap> (<trap>))
 707
 708 (define-method (install-trap (trap <entry-trap>))
 709   (next-method)
 710   (install-enter-frame-trap trap))
 711
 712 (define-method (uninstall-trap (trap <entry-trap>))
 713   (next-method)
 714   (uninstall-enter-frame-trap trap))
 715
 716 (define-method (trap-runnable? (trap <entry-trap>)
 717                                (trap-context <trap-context>))
 718   #t)
 719
 720 ;;; Class: <apply-trap>
 721 ;;;
 722 ;;; An installed instance of <apply-trap> triggers on any procedure
 723 ;;; application.
 724 (define-class <apply-trap> (<trap>))
 725
 726 (define-method (install-trap (trap <apply-trap>))
 727   (next-method)
 728   (install-apply-frame-trap trap))
 729
 730 (define-method (uninstall-trap (trap <apply-trap>))
 731   (next-method)
 732   (uninstall-apply-frame-trap trap))
 733
 734 (define-method (trap-runnable? (trap <apply-trap>)
 735                                (trap-context <trap-context>))
 736   #t)
 737
 738 ;;; Class: <step-trap>
 739 ;;;
 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))
 751
 752 (define-method (initialize (trap <step-trap>) initargs)
 753   (next-method)
 754   (slot-set! trap 'depth (slot-ref trap 'exit-depth)))
 755
 756 (define-method (install-trap (trap <step-trap>))
 757   (next-method)
 758   (install-enter-frame-trap trap)
 759   (install-apply-frame-trap trap))
 760
 761 (define-method (uninstall-trap (trap <step-trap>))
 762   (next-method)
 763   (uninstall-enter-frame-trap trap)
 764   (uninstall-apply-frame-trap trap))
 765
 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)
 773            (next-method)
 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.
 777            (begin
 778              (slot-set! trap 'exit-depth #f)
 779              #t))
 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.
 789              (begin
 790                (slot-set! trap 'exit-depth (tc:depth trap-context))
 791                (slot-set! trap 'depth (tc:depth trap-context))
 792                #t)))))
 793
 794 (define (frame->source-position frame)
 795   (let ((source (if (frame-procedure? frame)
 796                     (or (frame-source frame)
 797                         (let ((proc (frame-procedure frame)))
 798                           (and proc
 799                                (procedure? proc)
 800                                (procedure-source proc))))
 801                     (frame-source frame))))
 802     (and source
 803          (string? (source-property source 'filename))
 804          (list (source-property source 'filename)
 805                (source-property source 'line)
 806                (source-property source 'column)))))
 807
 808 (define (frame-file-name frame)
 809   (cond ((frame->source-position frame) => car)
 810         (else #f)))
 811
 812 ;;; Class: <source-trap>
 813 ;;;
 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
 820   ;; code.
 821   (expression #:init-keyword #:expression
 822               #:allocation #:virtual
 823               #:slot-ref
 824               (lambda (trap)
 825                 (vector-ref (slot-ref trap 'expression-wv) 0))
 826               #:slot-set!
 827               (lambda (trap expr)
 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)))))
 831   (expression-wv)
 832   ;; source property slots - for internal use only
 833   (filename)
 834   (line)
 835   (column))
 836
 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)
 841   (next-method)
 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 '())))))
 860
 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))
 865
 866 (define-method (install-trap (trap <source-trap>))
 867   (next-method)
 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))
 873
 874 (define-method (uninstall-trap (trap <source-trap>))
 875   (next-method)
 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))
 882
 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))))
 888         (and trap-location
 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))))))
 892
 893 ;; (trap-here EXPRESSION . OPTIONS)
 894 (define trap-here
 895   (procedure->memoizing-macro
 896    (lambda (expr env)
 897      (let ((trap (apply make
 898                         <source-trap>
 899                         #:expression expr
 900                         (local-eval `(list ,@(cddr expr))
 901                                     env))))
 902        (install-trap trap)
 903        (set-car! expr 'begin)
 904        (set-cdr! (cdr expr) '())
 905        expr))))
 906
 907 ;;; Class: <location-trap>
 908 ;;;
 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
 913   ;; trap in.
 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
 919   (compiled-regexp))
 920
 921 (define-method (initialize (trap <location-trap>) initargs)
 922   (next-method)
 923   (slot-set! trap 'compiled-regexp
 924              (make-regexp (slot-ref trap 'file-regexp))))
 925
 926 (define-method (install-trap (trap <location-trap>))
 927   (next-method)
 928   (install-enter-frame-trap trap))
 929
 930 (define-method (uninstall-trap (trap <location-trap>))
 931   (next-method)
 932   (uninstall-enter-frame-trap trap))
 933
 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))))
 943
 944 ;;; {Misc Trap Utilities}
 945
 946 (define (get-trap number)
 947   (hash-ref all-traps number))
 948
 949 (define (list-traps)
 950   (for-each describe
 951             (map cdr (sort (hash-fold acons '() all-traps)
 952                            (lambda (x y) (< (car x) (car y)))))))
 953
 954 ;;; {Volatile Traps}
 955 ;;;
 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
 961 ;;; lists.
 962
 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))
 966
 967 ;; A guardian that tells us when a volatile target is no longer
 968 ;; accessible.
 969 (define volatile-target-guardian (make-guardian))
 970
 971 ;; An after GC hook that checks for newly inaccessible targets.
 972 (add-hook! after-gc-hook
 973            (lambda ()
 974              (trc 'after-gc-hook)
 975              (let loop ((target (volatile-target-guardian)))
 976                (if target
 977                    ;; We have a target which is now inaccessible.  Get
 978                    ;; the list of traps installed on it.
 979                    (begin
 980                      (trc 'after-gc-hook "got target")
 981                      ;; Uninstall all the traps that are installed on
 982                      ;; this target.
 983                      (for-each (lambda (trap)
 984                                  (trc 'after-gc-hook "got trap")
 985                                  ;; If the trap is still installed,
 986                                  ;; uninstall it.
 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)
 992                                         =>
 993                                         (lambda (proc)
 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)))))))
 999
1000 (define (without-traps thunk)
1001   (with-traps (lambda ()
1002                 (trap-disable 'traps)
1003                 (thunk))))
1004
1005 (define guile-trap-features
1006   ;; Helper procedure, to test whether a specific possible Guile
1007   ;; feature is supported.
1008   (let ((supported?
1009          (lambda (test-feature)
1010            (case test-feature
1011              ((tweaking)
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))))))
1020              (else
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)))))))
1033
1034 ;; Make sure that traps are enabled.
1035 (trap-enable 'traps)
1036
1037 ;;; (ice-9 debugging traps) ends here.