summaryrefslogtreecommitdiff
path: root/module/ice-9/debugging
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-11-01 12:44:21 +0100
committerAndy Wingo <wingo@pobox.com>2008-11-01 12:44:21 +0100
commit00d04892052f345a844c967adbe77c258896c1e7 (patch)
tree6e99b35f9d7d6ac1fe7b452bcad96cfb20f055b8 /module/ice-9/debugging
parent5192c9e89bc18e5f6b33741aceed66bf28d56823 (diff)
downloadguile-00d04892052f345a844c967adbe77c258896c1e7.tar.gz
move ice-9/ and oop/ under module/
Moved ice-9/ and oop/ under module/, with the idea being that we have only scheme under module/. Adjusted configure.in and Makefile.am appropriately. Put oop/ at the end of the compilation order.
Diffstat (limited to 'module/ice-9/debugging')
-rw-r--r--module/ice-9/debugging/Makefile.am33
-rw-r--r--module/ice-9/debugging/breakpoints.scm415
-rw-r--r--module/ice-9/debugging/example-fns.scm17
-rw-r--r--module/ice-9/debugging/ice-9-debugger-extensions.scm172
-rw-r--r--module/ice-9/debugging/load-hooks.scm33
-rw-r--r--module/ice-9/debugging/steps.scm106
-rw-r--r--module/ice-9/debugging/trace.scm157
-rwxr-xr-xmodule/ice-9/debugging/traps.scm1037
-rw-r--r--module/ice-9/debugging/trc.scm63
9 files changed, 2033 insertions, 0 deletions
diff --git a/module/ice-9/debugging/Makefile.am b/module/ice-9/debugging/Makefile.am
new file mode 100644
index 000000000..5fbe9c6de
--- /dev/null
+++ b/module/ice-9/debugging/Makefile.am
@@ -0,0 +1,33 @@
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2006 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE is free software; you can redistribute it and/or modify
+## it under the terms of the GNU General Public License as
+## published by the Free Software Foundation; either version 2, or
+## (at your option) any later version.
+##
+## GUILE 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 General Public License for more details.
+##
+## You should have received a copy of the GNU General Public
+## License along with GUILE; see the file COPYING. If not, write
+## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+## Floor, Boston, MA 02110-1301 USA
+
+AUTOMAKE_OPTIONS = gnu
+
+# These should be installed and distributed.
+ice9_debugging_sources = breakpoints.scm example-fns.scm \
+ ice-9-debugger-extensions.scm load-hooks.scm \
+ steps.scm trace.scm traps.scm trc.scm
+
+subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging
+subpkgdata_DATA = $(ice9_debugging_sources)
+TAGS_FILES = $(subpkgdata_DATA)
+
+EXTRA_DIST = $(ice9_debugging_sources)
diff --git a/module/ice-9/debugging/breakpoints.scm b/module/ice-9/debugging/breakpoints.scm
new file mode 100644
index 000000000..132746f17
--- /dev/null
+++ b/module/ice-9/debugging/breakpoints.scm
@@ -0,0 +1,415 @@
+;;;; (ice-9 debugging breakpoints) -- practical breakpoints
+
+;;; 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 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 a practical interface for setting and
+;;; manipulating breakpoints.
+
+(define-module (ice-9 debugging breakpoints)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 ls)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 regex)
+ #:use-module (oop goops)
+ #:use-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugging traps)
+ #:use-module (ice-9 debugging trc)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:export (break-in
+ break-at
+ default-breakpoint-behaviour
+ delete-breakpoint
+ for-each-breakpoint
+ setup-before-load
+ setup-after-load
+ setup-after-read
+ setup-after-eval))
+
+;; If the running Guile does not provide before- and after- load hooks
+;; itself, install them using the (ice-9 debugging load-hooks) module.
+(or (defined? 'after-load-hook)
+ (begin
+ (use-modules (ice-9 debugging load-hooks))
+ (install-load-hooks)))
+
+;; Getter/setter for default breakpoint behaviour.
+(define default-breakpoint-behaviour
+ (let ((behaviour debug-trap))
+ (make-procedure-with-setter
+ ;; Getter: return current default behaviour.
+ (lambda ()
+ behaviour)
+ ;; Setter: set default behaviour to given procedure.
+ (lambda (new-behaviour)
+ (set! behaviour new-behaviour)))))
+
+;; Base class for breakpoints. (We don't need to use GOOPS to
+;; represent breakpoints, but it's a nice way to describe a composite
+;; object.)
+(define-class <breakpoint> ()
+ ;; This breakpoint's trap options, which include its behaviour.
+ (trap-options #:init-keyword #:trap-options)
+ ;; All the traps relating to this breakpoint.
+ (traps #:init-value '())
+ ;; Observer. This is a procedure that is called when the breakpoint
+ ;; trap list changes.
+ (observer #:init-value #f))
+
+;; Noop base class definitions of all the possible setup methods.
+(define-method (setup-before-load (bp <breakpoint>) filename)
+ *unspecified*)
+(define-method (setup-after-load (bp <breakpoint>) filename)
+ *unspecified*)
+(define-method (setup-after-read (bp <breakpoint>) x)
+ *unspecified*)
+(define-method (setup-after-eval (bp <breakpoint>) filename)
+ *unspecified*)
+
+;; Call the breakpoint's observer, if it has one.
+(define-method (call-observer (bp <breakpoint>))
+ (cond ((slot-ref bp 'observer)
+ =>
+ (lambda (proc)
+ (proc)))))
+
+;; Delete a breakpoint.
+(define (delete-breakpoint bp)
+ ;; Remove this breakpoint from the global list.
+ (set! breakpoints (delq! bp breakpoints))
+ ;; Uninstall and discard all its traps.
+ (for-each uninstall-trap (slot-ref bp 'traps))
+ (slot-set! bp 'traps '()))
+
+;; Class for `break-in' breakpoints.
+(define-class <break-in> (<breakpoint>)
+ ;; The name of the procedure to break in.
+ (procedure-name #:init-keyword #:procedure-name)
+ ;; The name of the module or file that the procedure is defined in.
+ ;; A module name is a list of symbols that exactly names the
+ ;; relevant module. A file name is a string, which can in fact be
+ ;; any substring of the relevant full file name.
+ (module-or-file-name #:init-keyword #:module-or-file-name))
+
+;; Class for `break-at' breakpoints.
+(define-class <break-at> (<breakpoint>)
+ ;; The name of the file to break in. This is a string, which can in
+ ;; fact be any substring of the relevant full file name.
+ (file-name #:init-keyword #:file-name)
+ ;; Line and column number to break at.
+ (line #:init-keyword #:line)
+ (column #:init-keyword #:column))
+
+;; Global list of non-deleted breakpoints.
+(define breakpoints '())
+
+;; Add to the above list.
+(define-method (add-to-global-breakpoint-list (bp <breakpoint>))
+ (set! breakpoints (append! breakpoints (list bp))))
+
+;; break-in: create a `break-in' breakpoint.
+(define (break-in procedure-name . options)
+ ;; Sort out the optional args.
+ (let* ((module-or-file-name+options
+ (cond ((and (not (null? options))
+ (or (string? (car options))
+ (list? (car options))))
+ options)
+ (else
+ (cons (module-name (current-module)) options))))
+ (module-or-file-name (car module-or-file-name+options))
+ (trap-options (cdr module-or-file-name+options))
+ ;; Create the new breakpoint object.
+ (bp (make <break-in>
+ #:procedure-name procedure-name
+ #:module-or-file-name module-or-file-name
+ #:trap-options (if (memq #:behaviour trap-options)
+ trap-options
+ (cons* #:behaviour
+ (default-breakpoint-behaviour)
+ trap-options)))))
+ ;; Add it to the global breakpoint list.
+ (add-to-global-breakpoint-list bp)
+ ;; Set the new breakpoint, if possible, in already loaded code.
+ (set-in-existing-code bp)
+ ;; Return the breakpoint object to our caller.
+ bp))
+
+;; break-at: create a `break-at' breakpoint.
+(define (break-at file-name line column . trap-options)
+ ;; Create the new breakpoint object.
+ (let* ((bp (make <break-at>
+ #:file-name file-name
+ #:line line
+ #:column column
+ #:trap-options (if (memq #:behaviour trap-options)
+ trap-options
+ (cons* #:behaviour
+ (default-breakpoint-behaviour)
+ trap-options)))))
+ ;; Add it to the global breakpoint list.
+ (add-to-global-breakpoint-list bp)
+ ;; Set the new breakpoint, if possible, in already loaded code.
+ (set-in-existing-code bp)
+ ;; Return the breakpoint object to our caller.
+ bp))
+
+;; Set a `break-in' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-in>))
+ ;; Get the module or file name that was specified for this
+ ;; breakpoint.
+ (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+ ;; Handling is simpler for a module name.
+ (cond ((list? module-or-file-name)
+ ;; See if the named module exists yet.
+ (let ((m (module-if-already-loaded module-or-file-name)))
+ (maybe-break-in-module-proc m bp)))
+ ((string? module-or-file-name)
+ ;; Try all loaded modules.
+ (or-map (lambda (m)
+ (maybe-break-in-module-proc m bp))
+ (all-loaded-modules)))
+ (else
+ (error "Bad module-or-file-name:" module-or-file-name)))))
+
+(define (make-observer bp trap)
+ (lambda (event)
+ (trap-target-gone bp trap)))
+
+;; Set a `break-at' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-at>) . code)
+ ;; Procedure to install a source trap on each expression that we
+ ;; find matching this breakpoint.
+ (define (install-source-trap x)
+ (or (or-map (lambda (trap)
+ (and (is-a? trap <source-trap>)
+ (eq? (slot-ref trap 'expression) x)))
+ (slot-ref bp 'traps))
+ (let ((trap (apply make <source-trap>
+ #:expression x
+ (slot-ref bp 'trap-options))))
+ (slot-set! trap 'observer (make-observer bp trap))
+ (install-trap trap)
+ (trc 'install-source-trap (object-address trap) (object-address x))
+ (trap-installed bp trap #t))))
+ ;; Scan the source whash, and install a trap on all code matching
+ ;; this breakpoint.
+ (trc 'set-in-existing-code (length code))
+ (if (null? code)
+ (scan-source-whash (slot-ref bp 'file-name)
+ (slot-ref bp 'line)
+ (slot-ref bp 'column)
+ install-source-trap)
+ (scan-code (car code)
+ (slot-ref bp 'file-name)
+ (slot-ref bp 'line)
+ (slot-ref bp 'column)
+ install-source-trap)))
+
+;; Temporary implementation of scan-source-whash - this _really_ needs
+;; to be implemented in C.
+(define (scan-source-whash file-name line column proc)
+ ;; Procedure to call for each source expression in the whash.
+ (define (folder x props acc)
+ (if (and (= line (source-property x 'line))
+ (= column (source-property x 'column))
+ (let ((fn (source-property x 'filename)))
+ (trc 'scan-source-whash fn)
+ (and (string? fn)
+ (string-contains fn file-name))))
+ (proc x)))
+ ;; Tracing.
+ (trc 'scan-source-whash file-name line column)
+ ;; Apply this procedure to the whash.
+ (hash-fold folder 0 source-whash))
+
+(define (scan-code x file-name line column proc)
+ (trc 'scan-code file-name line column)
+ (if (pair? x)
+ (begin
+ (if (and (eq? line (source-property x 'line))
+ (eq? column (source-property x 'column))
+ (let ((fn (source-property x 'filename)))
+ (trc 'scan-code fn)
+ (and (string? fn)
+ (string-contains fn file-name))))
+ (proc x))
+ (scan-code (car x) file-name line column proc)
+ (scan-code (cdr x) file-name line column proc))))
+
+;; If a module named MODULE-NAME has been loaded, return its module
+;; object; otherwise return #f.
+(define (module-if-already-loaded module-name)
+ (nested-ref the-root-module (append '(app modules) module-name)))
+
+;; Construct and return a list of all loaded modules.
+(define (all-loaded-modules)
+ ;; This is the list that accumulates known modules. It has to be
+ ;; defined outside the following functions, and accumulated using
+ ;; set!, so as to avoid infinite loops - because of the fact that
+ ;; all non-pure modules have a variable `app'.
+ (define known-modules '())
+ ;; Return an alist of submodules of the given PARENT-MODULE-NAME.
+ ;; Each element of the alist is (NAME . MODULE), where NAME is the
+ ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and
+ ;; MODULE is the module object. By a "submodule of a parent
+ ;; module", we mean any module value that is bound to a symbol in
+ ;; the parent module, and which is not an interface module.
+ (define (direct-submodules parent-module-name)
+ (filter (lambda (name+value)
+ (and (module? (cdr name+value))
+ (not (eq? (module-kind (cdr name+value)) 'interface))))
+ (map (lambda (name)
+ (cons name (local-ref (append parent-module-name
+ (list name)))))
+ (cdar (lls parent-module-name)))))
+ ;; Add all submodules (direct and indirect) of the module named
+ ;; PARENT-MODULE-NAME to `known-modules', if not already there.
+ (define (add-submodules-of parent-module-name)
+ (let ((ds (direct-submodules parent-module-name)))
+ (for-each
+ (lambda (name+module)
+ (or (memq (cdr name+module) known-modules)
+ (begin
+ (set! known-modules (cons (cdr name+module) known-modules))
+ (add-submodules-of (append parent-module-name
+ (list (car name+module)))))))
+ ds)))
+ ;; Add submodules recursively, starting from the root of all
+ ;; modules.
+ (add-submodules-of '(app modules))
+ ;; Return the result.
+ known-modules)
+
+;; Before-load setup for `break-at' breakpoints.
+(define-method (setup-before-load (bp <break-at>) filename)
+ (let ((trap (apply make <location-trap>
+ #:file-regexp (regexp-quote (slot-ref bp 'file-name))
+ #:line (slot-ref bp 'line)
+ #:column (slot-ref bp 'column)
+ (slot-ref bp 'trap-options))))
+ (install-trap trap)
+ (trap-installed bp trap #f)
+ (letrec ((uninstaller
+ (lambda (file-name)
+ (uninstall-trap trap)
+ (remove-hook! after-load-hook uninstaller))))
+ (add-hook! after-load-hook uninstaller))))
+
+;; After-load setup for `break-in' breakpoints.
+(define-method (setup-after-load (bp <break-in>) filename)
+ ;; Get the module that the loaded file created or was loaded into,
+ ;; and the module or file name that were specified for this
+ ;; breakpoint.
+ (let ((m (current-module))
+ (module-or-file-name (slot-ref bp 'module-or-file-name)))
+ ;; Decide whether the breakpoint spec matches this load.
+ (if (or (and (string? module-or-file-name)
+ (string-contains filename module-or-file-name))
+ (and (list? module-or-file-name)
+ (equal? (module-name (current-module)) module-or-file-name)))
+ ;; It does, so try to install the breakpoint.
+ (maybe-break-in-module-proc m bp))))
+
+;; After-load setup for `break-at' breakpoints.
+(define-method (setup-after-load (bp <break-at>) filename)
+ (if (string-contains filename (slot-ref bp 'file-name))
+ (set-in-existing-code bp)))
+
+(define (maybe-break-in-module-proc m bp)
+ "If module M defines a procedure matching the specification of
+breakpoint BP, install a trap on it."
+ (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f)))
+ (if (and proc
+ (procedure? proc)
+ (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+ (if (string? module-or-file-name)
+ (source-file-matches (procedure-source proc)
+ module-or-file-name)
+ #t))
+ (not (or-map (lambda (trap)
+ (and (is-a? trap <procedure-trap>)
+ (eq? (slot-ref trap 'procedure) proc)))
+ (slot-ref bp 'traps))))
+ ;; There is, so install a <procedure-trap> on it.
+ (letrec ((trap (apply make <procedure-trap>
+ #:procedure proc
+ (slot-ref bp 'trap-options))))
+ (slot-set! trap 'observer (make-observer bp trap))
+ (install-trap trap)
+ (trap-installed bp trap #t)
+ ;; Tell caller that we installed a trap.
+ #t)
+ ;; Tell caller that we did not install a trap.
+ #f)))
+
+;; After-read setup for `break-at' breakpoints.
+(define-method (setup-after-read (bp <break-at>) x)
+ (set-in-existing-code bp x))
+
+;; Common code for associating a newly created and installed trap with
+;; a breakpoint object.
+(define (trap-installed bp trap record?)
+ (if record?
+ ;; Remember this trap in the breakpoint object.
+ (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap))))
+ ;; Update the breakpoint status.
+ (call-observer bp))
+
+;; Common code for handling when the target of one of a breakpoint's
+;; traps is being GC'd.
+(define (trap-target-gone bp trap)
+ (trc 'trap-target-gone (object-address trap))
+ ;; Remove this trap from the breakpoint's list.
+ (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps)))
+ ;; Update the breakpoint status.
+ (call-observer bp))
+
+(define (source-file-matches source file-name)
+ "Return #t if any of the expressions in SOURCE have a 'filename
+source property that includes FILE-NAME; otherwise return #f."
+ (and (pair? source)
+ (or (let ((source-file-name (source-property source 'filename)))
+ (and source-file-name
+ (string? source-file-name)
+ (string-contains source-file-name file-name)))
+ (let loop ((source source))
+ (and (pair? source)
+ (or (source-file-matches (car source) file-name)
+ (loop (cdr source))))))))
+
+;; Install load hook functions.
+(add-hook! before-load-hook
+ (lambda (fn)
+ (for-each-breakpoint setup-before-load fn)))
+
+(add-hook! after-load-hook
+ (lambda (fn)
+ (for-each-breakpoint setup-after-load fn)))
+
+;;; Apply generic function GF to each breakpoint, passing the
+;;; breakpoint object and ARGS as args on each call.
+(define (for-each-breakpoint gf . args)
+ (for-each (lambda (bp)
+ (apply gf bp args))
+ breakpoints))
+
+;; Make sure that recording of source positions is enabled. Without
+;; this break-at breakpoints will obviously not work.
+(read-enable 'positions)
+
+;;; (ice-9 debugging breakpoints) ends here.
diff --git a/module/ice-9/debugging/example-fns.scm b/module/ice-9/debugging/example-fns.scm
new file mode 100644
index 000000000..30d412f00
--- /dev/null
+++ b/module/ice-9/debugging/example-fns.scm
@@ -0,0 +1,17 @@
+(define-module (ice-9 debugging example-fns)
+ #:export (fact1 fact2 facti))
+
+(define (fact1 n)
+ (if (= n 0)
+ 1
+ (* n (fact1 (- n 1)))))
+
+(define (facti n a)
+ (if (= n 0)
+ a
+ (facti (- n 1) (* a n))))
+
+(define (fact2 n)
+ (facti n 1))
+
+; Test: (fact2 3)
diff --git a/module/ice-9/debugging/ice-9-debugger-extensions.scm b/module/ice-9/debugging/ice-9-debugger-extensions.scm
new file mode 100644
index 000000000..a8b8c970e
--- /dev/null
+++ b/module/ice-9/debugging/ice-9-debugger-extensions.scm
@@ -0,0 +1,172 @@
+
+(define-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugger))
+
+;;; Upgrade the debugger state object so that it can carry a flag
+;;; indicating whether the debugging session is continuable.
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger state))
+ (define-module (ice-9 debugger state)))
+ (else
+ (define-module (ice-9 debugger))))
+
+(set! state-rtd (make-record-type "debugger-state" '(stack index flags)))
+(set! state? (record-predicate state-rtd))
+(set! make-state
+ (let ((make-state-internal (record-constructor state-rtd
+ '(stack index flags))))
+ (lambda (stack index . flags)
+ (make-state-internal stack index flags))))
+(set! state-stack (record-accessor state-rtd 'stack))
+(set! state-index (record-accessor state-rtd 'index))
+
+(define state-flags (record-accessor state-rtd 'flags))
+
+;;; Add commands that (ice-9 debugger) doesn't currently have, for
+;;; continuing or single stepping program execution.
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger command-loop))
+ (define-module (ice-9 debugger command-loop)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 debugger state)
+ #:use-module (ice-9 debugging traps))
+ (define new-define-command define-command)
+ (set! define-command
+ (lambda (name argument-template documentation procedure)
+ (new-define-command name argument-template procedure))))
+ (else
+ (define-module (ice-9 debugger))))
+
+(use-modules (ice-9 debugging steps))
+
+(define (assert-continuable state)
+ ;; Check that debugger is in a state where `continuing' makes sense.
+ ;; If not, signal an error.
+ (or (memq #:continuable (state-flags state))
+ (user-error "This debug session is not continuable.")))
+
+(define (debugger:continue state)
+ "Tell the program being debugged to continue running. (In fact this is
+the same as the @code{quit} command, because it exits the debugger
+command loop and so allows whatever code it was that invoked the
+debugger to continue.)"
+ (assert-continuable state)
+ (throw 'exit-debugger))
+
+(define (debugger:finish state)
+ "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+ (assert-continuable state)
+ (at-exit (- (stack-length (state-stack state))
+ (state-index state))
+ (list trace-trap debug-trap))
+ (debugger:continue state))
+
+(define (debugger:step state n)
+ "Tell the debugged program to do @var{n} more steps from its current
+position. One @dfn{step} means executing until the next frame entry
+or exit of any kind. @var{n} defaults to 1."
+ (assert-continuable state)
+ (at-step debug-trap (or n 1))
+ (debugger:continue state))
+
+(define (debugger:next state n)
+ "Tell the debugged program to do @var{n} more steps from its current
+position, but only counting frame entries and exits where the
+corresponding source code comes from the same file as the current
+stack frame. (See @ref{Step Traps} for the details of how this
+works.) If the current stack frame has no source code, the effect of
+this command is the same as of @code{step}. @var{n} defaults to 1."
+ (assert-continuable state)
+ (at-step debug-trap
+ (or n 1)
+ (frame-file-name (stack-ref (state-stack state)
+ (state-index state)))
+ (if (memq #:return (state-flags state))
+ #f
+ (- (stack-length (state-stack state)) (state-index state))))
+ (debugger:continue state))
+
+(define-command "continue" '()
+ "Continue program execution."
+ debugger:continue)
+
+(define-command "finish" '()
+ "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+ debugger:finish)
+
+(define-command "step" '('optional exact-integer)
+ "Continue until entry to @var{n}th next frame."
+ debugger:step)
+
+(define-command "next" '('optional exact-integer)
+ "Continue until entry to @var{n}th next frame in same file."
+ debugger:next)
+
+;;; Export a couple of procedures for use by (ice-9 debugging trace).
+
+(cond ((string>=? (version) "1.7"))
+ (else
+ (define-module (ice-9 debugger))
+ (export write-frame-short/expression
+ write-frame-short/application)))
+
+;;; Provide a `debug-trap' entry point in (ice-9 debugger). This is
+;;; designed so that it can be called to explore the stack at a
+;;; breakpoint, and to single step from the breakpoint.
+
+(define-module (ice-9 debugger))
+
+(use-modules (ice-9 debugging traps))
+
+(define *not-yet-introduced* #t)
+
+(cond ((string>=? (version) "1.7"))
+ (else
+ (define (debugger-command-loop state)
+ (read-and-dispatch-commands state (current-input-port)))))
+
+(define-public (debug-trap trap-context)
+ "Invoke the Guile debugger to explore the stack at the specified @var{trap}."
+ (start-stack 'debugger
+ (let* ((stack (tc:stack trap-context))
+ (flags1 (let ((trap-type (tc:type trap-context)))
+ (case trap-type
+ ((#:return #:error)
+ (list trap-type
+ (tc:return-value trap-context)))
+ (else
+ (list trap-type)))))
+ (flags (if (tc:continuation trap-context)
+ (cons #:continuable flags1)
+ flags1))
+ (state (apply make-state stack 0 flags)))
+ (if *not-yet-introduced*
+ (let ((ssize (stack-length stack)))
+ (display "This is the Guile debugger -- for help, type `help'.\n")
+ (set! *not-yet-introduced* #f)
+ (if (= ssize 1)
+ (display "There is 1 frame on the stack.\n\n")
+ (format #t "There are ~A frames on the stack.\n\n" ssize))))
+ (write-state-short-with-source-location state)
+ (debugger-command-loop state))))
+
+(define write-state-short-with-source-location
+ (cond ((string>=? (version) "1.7")
+ write-state-short)
+ (else
+ (lambda (state)
+ (let* ((frame (stack-ref (state-stack state) (state-index state)))
+ (source (frame-source frame))
+ (position (and source (source-position source))))
+ (format #t "Frame ~A at " (frame-number frame))
+ (if position
+ (display-position position)
+ (display "unknown source location"))
+ (newline)
+ (write-char #\tab)
+ (write-frame-short frame)
+ (newline))))))
diff --git a/module/ice-9/debugging/load-hooks.scm b/module/ice-9/debugging/load-hooks.scm
new file mode 100644
index 000000000..fb869ed23
--- /dev/null
+++ b/module/ice-9/debugging/load-hooks.scm
@@ -0,0 +1,33 @@
+
+(define-module (ice-9 debugging load-hooks)
+ #:export (before-load-hook
+ after-load-hook
+ install-load-hooks
+ uninstall-load-hooks))
+
+;; real-primitive-load: holds the real (C-implemented) definition of
+;; primitive-load, when the load hooks are installed.
+(define real-primitive-load #f)
+
+;; The load hooks themselves. These are called with one argument, the
+;; name of the file concerned.
+(define before-load-hook (make-hook 1))
+(define after-load-hook (make-hook 1))
+
+;; primitive-load-with-hooks: our new definition for primitive-load.
+(define (primitive-load-with-hooks filename)
+ (run-hook before-load-hook filename)
+ (real-primitive-load filename)
+ (run-hook after-load-hook filename))
+
+(define (install-load-hooks)
+ (if real-primitive-load
+ (error "load hooks are already installed"))
+ (set! real-primitive-load primitive-load)
+ (set! primitive-load primitive-load-with-hooks))
+
+(define (uninstall-load-hooks)
+ (or real-primitive-load
+ (error "load hooks are not installed"))
+ (set! primitive-load real-primitive-load)
+ (set! real-primitive-load #f))
diff --git a/module/ice-9/debugging/steps.scm b/module/ice-9/debugging/steps.scm
new file mode 100644
index 000000000..fedbc6a32
--- /dev/null
+++ b/module/ice-9/debugging/steps.scm
@@ -0,0 +1,106 @@
+;;;; (ice-9 debugging steps) -- stepping through code from the debugger
+
+;;; Copyright (C) 2002, 2004 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
+
+(define-module (ice-9 debugging steps)
+ #:use-module (ice-9 debugging traps)
+ #:use-module (ice-9 and-let-star)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 optargs)
+ #:export (at-exit
+ at-entry
+ at-apply
+ at-step
+ at-next))
+
+;;; at-exit DEPTH BEHAVIOUR
+;;;
+;;; Install a behaviour to run when we exit the current frame.
+
+(define (at-exit depth behaviour)
+ (install-trap (make <exit-trap>
+ #:depth depth
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;;; at-entry BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next frame
+;;; entry. COUNT defaults to 1.
+
+(define* (at-entry behaviour #:optional (count 1))
+ (install-trap (make <entry-trap>
+ #:skip-count (- count 1)
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;;; at-apply BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next
+;;; application. COUNT defaults to 1.
+
+(define* (at-apply behaviour #:optional (count 1))
+ (install-trap (make <apply-trap>
+ #:skip-count (- count 1)
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]]
+;;;
+;;; Install BEHAVIOUR to run on the COUNT'th next application, frame
+;;; entry or frame exit. COUNT defaults to 1. If FILENAME is
+;;; specified and not #f, only frames that begin in the named file are
+;;; counted.
+
+(define* (at-step behaviour #:optional (count 1) filename (depth 1000))
+ (install-trap (make <step-trap>
+ #:file-name filename
+ #:exit-depth depth
+ #:skip-count (- count 1)
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;; (or count (set! count 1))
+;; (letrec ((proc (lambda (trap-context)
+;; ;; Behaviour whenever we enter or exit a frame.
+;; (set! count (- count 1))
+;; (if (= count 0)
+;; (begin
+;; (remove-enter-frame-hook! step)
+;; (remove-apply-frame-hook! step)
+;; (behaviour trap-context)))))
+;; (step (lambda (trap-context)
+;; ;; Behaviour on frame entry: both execute the above
+;; ;; and install it as an exit hook.
+;; (if (or (not filename)
+;; (equal? (frame-file-name (tc:frame trap-context))
+;; filename))
+;; (begin
+;; (proc trap-context)
+;; (at-exit (tc:depth trap-context) proc))))))
+;; (at-exit depth proc)
+;; (add-enter-frame-hook! step)
+;; (add-apply-frame-hook! step)))
+
+;;; at-next BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next frame
+;;; entry in the same source file as the current location. COUNT
+;;; defaults to 1. If the current location has no filename, fall back
+;;; silently to `at-entry' behaviour.
+
+;;; (ice-9 debugging steps) ends here.
diff --git a/module/ice-9/debugging/trace.scm b/module/ice-9/debugging/trace.scm
new file mode 100644
index 000000000..ad3015ddf
--- /dev/null
+++ b/module/ice-9/debugging/trace.scm
@@ -0,0 +1,157 @@
+;;;; (ice-9 debugging trace) -- breakpoint trace behaviour
+
+;;; 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
+
+(define-module (ice-9 debugging trace)
+ #:use-module (ice-9 debug)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugging steps)
+ #:use-module (ice-9 debugging traps)
+ #:export (trace-trap
+ trace-port
+ set-trace-layout
+ trace/pid
+ trace/stack-id
+ trace/stack-depth
+ trace/stack-real-depth
+ trace/stack
+ trace/source-file-name
+ trace/source-line
+ trace/source-column
+ trace/source
+ trace/type
+ trace/real?
+ trace/info
+ trace-at-exit
+ trace-until-exit))
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger utils))))
+
+(define trace-format-string #f)
+(define trace-arg-procs #f)
+
+(define (set-trace-layout format-string . arg-procs)
+ (set! trace-format-string format-string)
+ (set! trace-arg-procs arg-procs))
+
+(define (trace/pid trap-context)
+ (getpid))
+
+(define (trace/stack-id trap-context)
+ (stack-id (tc:stack trap-context)))
+
+(define (trace/stack-depth trap-context)
+ (tc:depth trap-context))
+
+(define (trace/stack-real-depth trap-context)
+ (tc:real-depth trap-context))
+
+(define (trace/stack trap-context)
+ (format #f "~a:~a+~a"
+ (stack-id (tc:stack trap-context))
+ (tc:real-depth trap-context)
+ (- (tc:depth trap-context) (tc:real-depth trap-context))))
+
+(define (trace/source-file-name trap-context)
+ (cond ((frame->source-position (tc:frame trap-context)) => car)
+ (else "")))
+
+(define (trace/source-line trap-context)
+ (cond ((frame->source-position (tc:frame trap-context)) => cadr)
+ (else 0)))
+
+(define (trace/source-column trap-context)
+ (cond ((frame->source-position (tc:frame trap-context)) => caddr)
+ (else 0)))
+
+(define (trace/source trap-context)
+ (cond ((frame->source-position (tc:frame trap-context))
+ =>
+ (lambda (pos)
+ (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
+ (else "")))
+
+(define (trace/type trap-context)
+ (case (tc:type trap-context)
+ ((#:application) "APP")
+ ((#:evaluation) "EVA")
+ ((#:return) "RET")
+ ((#:error) "ERR")
+ (else "???")))
+
+(define (trace/real? trap-context)
+ (if (frame-real? (tc:frame trap-context)) " " "t"))
+
+(define (trace/info trap-context)
+ (with-output-to-string
+ (lambda ()
+ (if (memq (tc:type trap-context) '(#:application #:evaluation))
+ ((if (tc:expression trap-context)
+ write-frame-short/expression
+ write-frame-short/application) (tc:frame trap-context))
+ (begin
+ (display "=>")
+ (write (tc:return-value trap-context)))))))
+
+(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info)
+
+;;; trace-trap
+;;;
+;;; Trace the current location, and install a hook to trace the return
+;;; value when we exit the current frame.
+
+(define (trace-trap trap-context)
+ (apply format
+ (trace-port)
+ trace-format-string
+ (map (lambda (arg-proc)
+ (arg-proc trap-context))
+ trace-arg-procs)))
+
+(set! (behaviour-ordering trace-trap) 50)
+
+;;; trace-port
+;;;
+;;; The port to which trace information is printed.
+
+(define trace-port
+ (let ((port (current-output-port)))
+ (make-procedure-with-setter
+ (lambda () port)
+ (lambda (new) (set! port new)))))
+
+;;; trace-at-exit
+;;;
+;;; Trace return value on exit from the current frame.
+
+(define (trace-at-exit trap-context)
+ (at-exit (tc:depth trap-context) trace-trap))
+
+;;; trace-until-exit
+;;;
+;;; Trace absolutely everything until exit from the current frame.
+
+(define (trace-until-exit trap-context)
+ (let ((step-trap (make <step-trap> #:behaviour trace-trap)))
+ (install-trap step-trap)
+ (at-exit (tc:depth trap-context)
+ (lambda (trap-context)
+ (uninstall-trap step-trap)))))
+
+;;; (ice-9 debugging trace) ends here.
diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm
new file mode 100755
index 000000000..080d7bc31
--- /dev/null
+++ b/module/ice-9/debugging/traps.scm
@@ -0,0 +1,1037 @@
+;;;; (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 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 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-lazy-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 lazy-catch whose handler is
+;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn
+;;; calls default-lazy-handler. So we can present most errors as
+;;; pseudo-traps by modifying default-lazy-handler.
+
+(define default-default-lazy-handler default-lazy-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-lazy-handler-dispatch behaviour . ignored-keys)
+ (set! default-lazy-handler
+ (if behaviour
+ (lambda (key . args)
+ (or (memq key ignored-keys)
+ (behaviour (throw->trap-context key
+ args
+ lazy-handler-dispatch)))
+ (apply default-default-lazy-handler key args))
+ default-default-lazy-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.
diff --git a/module/ice-9/debugging/trc.scm b/module/ice-9/debugging/trc.scm
new file mode 100644
index 000000000..9e95d7e5c
--- /dev/null
+++ b/module/ice-9/debugging/trc.scm
@@ -0,0 +1,63 @@
+;;;; (ice-9 debugging trc) -- tracing for Guile debugger code
+
+;;; Copyright (C) 2002, 2004 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
+
+(define-module (ice-9 debugging trc)
+ #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
+
+(define *syms* #f)
+
+(define (trc-set! syms)
+ (set! *syms* syms))
+
+(define (trc-syms . syms)
+ (trc-set! syms))
+
+(define (trc-all)
+ (trc-set! #f))
+
+(define (trc-none)
+ (trc-set! '()))
+
+(define (trc-add sym)
+ (trc-set! (cons sym *syms*)))
+
+(define (trc-remove sym)
+ (trc-set! (delq1! sym *syms*)))
+
+(define (trc sym . args)
+ (if (or (not *syms*)
+ (memq sym *syms*))
+ (let ((port (trc-port)))
+ (write sym port)
+ (display ":" port)
+ (for-each (lambda (arg)
+ (display " " port)
+ (write arg port))
+ args)
+ (newline port))))
+
+(define trc-port
+ (let ((port (current-error-port)))
+ (make-procedure-with-setter
+ (lambda () port)
+ (lambda (p) (set! port p)))))
+
+;; Default to no tracing.
+(trc-none)
+
+;;; (ice-9 debugging trc) ends here.