-;;;; (ice-9 debugger trap-hooks) -- abstraction of libguile's traps interface
-
-;;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;;
-;; 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 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 debugger trap-hooks)
- #:use-module (ice-9 debugger trc)
- #:export (add-trapped-stack-id!
- remove-trapped-stack-id!
- before-apply-frame-hook
- before-enter-frame-hook
- before-exit-frame-hook
- after-apply-frame-hook
- after-enter-frame-hook
- after-exit-frame-hook
- add-apply-frame-hook!
- add-breakpoint-hook!
- add-enter-frame-hook!
- add-exit-frame-hook!
- add-trace-hook!
- remove-apply-frame-hook!
- remove-breakpoint-hook!
- remove-enter-frame-hook!
- remove-exit-frame-hook!
- remove-trace-hook!
- debug-hook-membership))
-
-;;; 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 possible 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.
-
-;;; {Stack IDs}
-;;;
-;;; Mechanism for limiting trapping to contexts whose stack ID matches
-;;; one of a registered set. The default set up is to limit trapping
-;;; to events in the contexts of the Guile REPL and of file loading.
-
-(define trapped-stack-ids (list 'repl-stack 'load-stack))
-(define all-stack-ids-trapped? #f)
-
-(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 before-enter-frame-hook (make-hook 3))
-(define enter-frame-hook (make-hook))
-(define breakpoint-hook (make-hook))
-(define after-enter-frame-hook (make-hook))
-
-(define before-exit-frame-hook (make-hook 2))
-(define exit-frame-hook (make-hook))
-(define after-exit-frame-hook (make-hook))
-
-(define before-apply-frame-hook (make-hook 2))
-(define apply-frame-hook (make-hook))
-(define trace-hook (make-hook))
-(define after-apply-frame-hook (make-hook))
-
-(define (hook-not-empty? hook)
- (not (hook-empty? hook)))
-
-(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 (hook-not-empty? trace-hook))
- (need-breakpoints (hook-not-empty? breakpoint-hook))
- (need-enter-frame (hook-not-empty? enter-frame-hook))
- (need-apply-frame (hook-not-empty? apply-frame-hook))
- (need-exit-frame (hook-not-empty? exit-frame-hook)))
- (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)))
- (trc 'enter-frame-handler)
- (if application-entry?
- (run-hook before-enter-frame-hook cont #f #f)
- (run-hook before-enter-frame-hook cont (car args) (cadr args)))
- (run-hook enter-frame-hook)
- (or application-entry?
- (run-hook breakpoint-hook))
- (run-hook after-enter-frame-hook))))
-
-(define (exit-frame-handler key cont retval)
- (if (trap-here? cont)
- (begin
- (trc 'exit-frame-handler retval (stack-length (make-stack cont)))
- (run-hook before-exit-frame-hook cont retval)
- (run-hook exit-frame-hook)
- (run-hook after-exit-frame-hook))))
-
-(define (apply-frame-handler key cont tail?)
- (if (trap-here? cont)
- (begin
- (trc 'apply-frame-handler tail?)
- (run-hook before-apply-frame-hook cont tail?)
- (run-hook apply-frame-hook)
- (run-hook trace-hook)
- (run-hook after-apply-frame-hook))))
-
-(define-public (add-enter-frame-hook! proc)
- (add-hook! enter-frame-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (add-breakpoint-hook! proc)
- (add-hook! breakpoint-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (add-exit-frame-hook! proc)
- (add-hook! exit-frame-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (add-apply-frame-hook! proc)
- (add-hook! apply-frame-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (add-trace-hook! proc)
- (add-hook! trace-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (remove-enter-frame-hook! proc)
- (remove-hook! enter-frame-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (remove-breakpoint-hook! proc)
- (remove-hook! breakpoint-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (remove-exit-frame-hook! proc)
- (remove-hook! exit-frame-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (remove-apply-frame-hook! proc)
- (remove-hook! apply-frame-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (remove-trace-hook! proc)
- (remove-hook! trace-hook proc)
- (set-debug-and-trap-options))
-
-(define-public (debug-hook-membership)
- (for-each (lambda (name+hook)
- (format #t "~A:\n" (car name+hook))
- (for-each (lambda (proc)
- (format #t " ~S\n" proc))
- (hook->list (cdr name+hook))))
- `((before-enter-frame-hook . ,before-enter-frame-hook)
- (enter-frame-hook . ,enter-frame-hook )
- (breakpoint-hook . ,breakpoint-hook )
- (after-enter-frame-hook . ,after-enter-frame-hook )
- (before-exit-frame-hook . ,before-exit-frame-hook )
- (exit-frame-hook . ,exit-frame-hook )
- (after-exit-frame-hook . ,after-exit-frame-hook )
- (before-apply-frame-hook . ,before-apply-frame-hook)
- (apply-frame-hook . ,apply-frame-hook )
- (trace-hook . ,trace-hook )
- (after-apply-frame-hook . ,after-apply-frame-hook ))))
-
-;;; (ice-9 debugger trap-hooks) ends here.
HCoop / bpt / guile.git / blobdiff