mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Remove everything to do with GDS Breakpoints

Browse source 
(which I now regard as an unsuccesful experiment)

This commit makes all affected files the same in master as they are in branch_release-1-8.

* doc/ref/api-debug.texi (Breakpoints): Removed.

* doc/ref/scheme-using.texi (GDS Introduction, GDS Getting Started,
  Displaying the Scheme Stack): Remove mentions of breakpoints.
  (Setting Specific Breakpoints, Setting GDS-managed Breakpoints,
  Setting and Managing Breakpoints, Listing and Deleting Breakpoints,
  Moving and Losing Breakpoints): Removed.

* emacs/gds-scheme.el (gds-bufferless-breakpoints,
  gds-bpdef:behaviour, gds-bpdef:type, gds-bpdef:file-name,
  gds-bpdef:proc-name, gds-bpdef:lc, gds-breakpoint-number,
  gds-breakpoint-buffers, gds-breakpoint-programming,
  gds-breakpoint-cache, gds-breakpoint-face,
  gds-breakpoints-file-name, gds-delete-lost-breakpoints,
  gds-bpdefs-cache, gds-read-breakpoints-file, gds-adopt-breakpoints,
  gds-adopt-breakpoint, gds-make-breakpoint-overlay,
  gds-send-breakpoint-to-client, gds-default-breakpoint-type,
  gds-set-breakpoint, gds-defun-name-region,
  gds-breakpoint-overlays-at, gds-write-breakpoints-file,
  gds-fold-breakpoints, gds-delete-breakpoints, gds-delete-breakpoint,
  gds-breakpoint-at-point, gds-union, gds-user-selected-breakpoint,
  gds-describe-breakpoints, gds-describe-breakpoint,
  gds-after-save-update-breakpoints, gds-breakpoint-map): Removed.
  (gds-nondebug-protocol): Removed handling for `breakpoint' and
  `get-breakpoints'.

* emacs/gds.el (gds-scheme-first-load): Removed.

* ice-9/debugging/Makefile.am (ice9_debugging_sources): Removed
  breakpoints.scm and load-hooks.scm.

* ice-9/debugging/breakpoints.scm: Removed.

* ice-9/debugging/load-hooks.scm: Removed.

* ice-9/gds-client.scm (handle-nondebug-protocol): Remove everything
  to do with breakpoints.
  (breakpoints, set-gds-breakpoints): Removed.
  (run-utility): Call `connect-to-gds' instead of `set-gds-breakpoints'.
This commit is contained in:
Neil Jerram 2008-12-09 23:56:51 +00:00
parent e00634774a
commit 69986e21d3
8 changed files with 26 additions and 1371 deletions
Download patch file Download diff file Expand all files Collapse all files

134
doc/ref/api-debug.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -19,7 +19,6 @@ infrastructure that builds on top of those calls.
* Evaluation Model:: Evaluation and the Scheme stack. * Evaluation Model:: Evaluation and the Scheme stack.
* Debug on Error:: Debugging when an error occurs. * Debug on Error:: Debugging when an error occurs.
* Traps:: * Traps::
* Breakpoints::
* Debugging Examples:: * Debugging Examples::
@end menu @end menu
@ -1691,137 +1690,6 @@ if there isn't one.
@end deffn @end deffn
@node Breakpoints
@subsection Breakpoints
While they are an important piece of infrastructure, and directly
usable in some scenarios, traps are still too low level to meet some
of the requirements of interactive development.
A common scenario is that a newly written procedure is not working
properly, and so you'd like to be able to step or trace through its
code to find out why. Ideally this should be possible from the IDE
and without having to modify the source code. There are two problems
with using traps directly in this scenario.
@enumerate
@item
They are too detailed: constructing and installing a trap requires you
to say what kind of trap you want and to specify fairly low level
options for it, whereas what you really want is just to say ``break
here using the most efficient means possible.''
@item
The most efficient kinds of trap --- that is, @code{<procedure-trap>}
and @code{<source-trap>} --- can only be specified and installed
@emph{after} the code that they refer to has been loaded. This is an
inconvenient detail for the user to deal with, and in some
applications it might be very difficult to insert an instruction to
install the required trap in between when the code is loaded and when
the procedure concerned is first called. It would be better to be
able to tell Guile about the requirement upfront, and for it to deal
with installing the trap when possible.
@end enumerate
We solve these problems by introducing breakpoints. A breakpoint is
something which says ``I want to break at location X, or in procedure
P --- just make it happen'', and can be set regardless of whether the
relevant code has already been loaded. Breakpoints use traps to do
their work, but that is a detail that the user will usually not have
to care about.
Breakpoints are provided by a combination of Scheme code in the client
program, and facilities for setting and managing breakpoints in the
GDS front end. On the Scheme side the entry points are as follows.
@deffn {Getter with Setter} default-breakpoint-behaviour
A ``getter with setter'' procedure that can be used to get or set the
default behaviour for new breakpoints. When a new default behaviour
is set, by calling
@lisp
(set! (default-breakpoint-behaviour) @var{new-behaviour})
@end lisp
@noindent
the new behaviour applies to all following @code{break-in} and
@code{break-at} calls, but does not affect breakpoints which have
already been set. @var{new-behaviour} should be a behaviour procedure
with the signature
@lisp
(lambda (trap-context) @dots{})
@end lisp
@noindent
as described in @ref{Specifying Trap Behaviour}.
@end deffn
@deffn {Procedure} break-in procedure-name [module-or-file-name] [options]
Set a breakpoint on entry to the procedure named @var{procedure-name},
which should be a symbol. @var{module-or-file-name}, if present, is
the name of the module (a list of symbols) or file (a string) which
includes the target procedure. If @var{module-or-file-name} is
absent, the target procedure is assumed to be in the current module.
The available options are any of the common trap options
(@pxref{Common Trap Options}), and are used when creating the
breakpoint's underlying traps. The default breakpoint behaviour
(given earlier to @code{default-breakpoint-behaviour}) is only used if
these options do not include @code{#:behaviour @var{behaviour}}.
@end deffn
@deffn {Procedure} break-at file-name line column [options]
Set a breakpoint on the expression in file @var{file-name} whose
opening parenthesis is on line @var{line} at column @var{column}.
@var{line} and @var{column} both count from 0 (not from 1).
The available options are any of the common trap options
(@pxref{Common Trap Options}), and are used when creating the
breakpoint's underlying traps. The default breakpoint behaviour
(given earlier to @code{default-breakpoint-behaviour}) is only used if
these options do not include @code{#:behaviour @var{behaviour}}.
@end deffn
@deffn {Procedure} set-gds-breakpoints
Ask the GDS front end for a list of breakpoints to set, and set these
using @code{break-in} and @code{break-at} as appropriate.
@end deffn
@code{default-breakpoint-behaviour}, @code{break-in} and
@code{break-at} allow an application's startup code to specify any
breakpoints that it needs inline in that code. For example, to trace
calls and arguments to a group of procedures to handle HTTP requests,
one might write something like this:
@lisp
(use-modules (ice-9 debugging breakpoints)
(ice-9 debugging trace))
(set! (default-breakpoint-behaviour) trace-trap)
(break-in 'handle-http-request '(web http))
(break-in 'read-http-request '(web http))
(break-in 'decode-form-data '(web http))
(break-in 'send-http-response '(web http))
@end lisp
@code{set-gds-breakpoints} can be used as well as or instead of the
above, and is intended to be the most practical option if you are
using GDS. The idea is that you only need to add this one call
somewhere in your application's startup code, like this:
@lisp
(use-modules (ice-9 gds-client))
(set-gds-breakpoints)
@end lisp
@noindent
and then all the details of the breakpoints that you want to set can
be managed through GDS. For the details of GDS's breakpoints
interface, see @ref{Setting and Managing Breakpoints}.
@node Debugging Examples @node Debugging Examples
@subsection Debugging Examples @subsection Debugging Examples

188
doc/ref/scheme-using.texi
View file

@ -485,9 +485,9 @@ popping up in a temporary Emacs window.
@end itemize @end itemize
@item @item
Debugging a Guile Scheme program. When your program hits an error or a Debugging a Guile Scheme program. When your program hits an error or
breakpoint, GDS shows you the relevant code and the Scheme stack, and stops at a trap, GDS shows you the relevant code and the Scheme stack,
makes it easy to and makes it easy to
@itemize @itemize
@item @item
@ -495,9 +495,6 @@ look at the values of local variables
@item @item
see what is happening at all levels of the Scheme stack see what is happening at all levels of the Scheme stack
@item @item
set new breakpoints (by simply typing @kbd{C-x @key{SPC}}) or modify
existing ones
@item
continue execution, either normally or step by step. continue execution, either normally or step by step.
@end itemize @end itemize
@ -509,13 +506,6 @@ Guile to run until that frame completes, at which point GDS will display
the frame's return value. the frame's return value.
@end enumerate @end enumerate
Combinations of these well too. You can evaluate a fragment of code (in
a Scheme buffer) that contains a breakpoint, then use the debugging
interface to step through the code at the breakpoint. You can also run
a program until it hits a breakpoint, then examine, modify and
reevaluate some of the relevant code, and then tell the program to
continue running.
GDS can provide these facilities for any number of Guile Scheme programs GDS can provide these facilities for any number of Guile Scheme programs
(which we often refer to as ``clients'') at once, and these programs can (which we often refer to as ``clients'') at once, and these programs can
be started either independently of GDS, including outside Emacs, or be started either independently of GDS, including outside Emacs, or
@ -638,63 +628,16 @@ act on instructions from GDS, and we refer to it as a @dfn{utility}
Guile client. Over time this utility client will accumulate the code Guile client. Over time this utility client will accumulate the code
that you ask it to evaluate, and you can also tell it to load complete that you ask it to evaluate, and you can also tell it to load complete
files or modules by sending it @code{load} or @code{use-modules} files or modules by sending it @code{load} or @code{use-modules}
expressions. You can set breakpoints and evaluate code which hits those expressions.
breakpoints, and GDS will pop up the stack at the breakpoint so you can
explore your code by single-stepping and evaluating test expressions.
For a hands-on, tutorial introduction to using GDS in this way, use
Emacs to open the file @file{gds-tutorial.txt} (which should have been
installed as part of Guile, perhaps under @file{/usr/share/doc/guile}),
and then follow the steps in that file.
When you want to use GDS to work on an independent Guile When you want to use GDS to work on an independent Guile
application, you need to add something to that application's Scheme code application, you need to add something to that application's Scheme code
to cause it to connect to and interact with GDS at the right times. The to cause it to connect to and interact with GDS at the right times. The
following subsections describe the ways of doing this. following subsections describe the ways of doing this.
@subsubsection Setting Specific Breakpoints
The first option is to use @code{break-in} or @code{break-at} to set
specific breakpoints in the application's code. This requires code like
the following.
@lisp
(use-modules (ice-9 debugging breakpoints)
(ice-9 gds-client))
(break-in 'fact2 "ice-9/debugging/example-fns"
#:behaviour gds-debug-trap)
(break-in 'facti "ice-9/debugging/example-fns"
#:behaviour gds-debug-trap)
@end lisp
@noindent
The @code{#:behaviour gds-debug-trap} clauses mean to use GDS to
display the stack when one of these breakpoints is hit. For more on
breakpoints, @code{break-in} and @code{break-at}, see
@ref{Breakpoints}.
@subsubsection Setting GDS-managed Breakpoints
Instead of listing specific breakpoints in application code, you can use
GDS to manage the set of breakpoints that you want from Emacs, and tell
the application to download the breakpoints that it should set from
GDS. The code for this is:
@lisp
(use-modules (ice-9 gds-client))
(set-gds-breakpoints)
@end lisp
These lines tell the program to connect to GDS immediately and download
a set of breakpoint definitions. The program sets those breakpoints in
its code, then continues running.
When the program later hits one of the breakpoints, it will use GDS to
display the stack and wait for instruction on what to do next.
@subsubsection Invoking GDS when an Exception Occurs @subsubsection Invoking GDS when an Exception Occurs
Another option is to use GDS to catch and display any exceptions that One option is to use GDS to catch and display any exceptions that
are thrown by the application's code. If you already have a are thrown by the application's code. If you already have a
@code{lazy-catch} or @code{with-throw-handler} around the area of code @code{lazy-catch} or @code{with-throw-handler} around the area of code
that you want to monitor, you just need to add the following to the that you want to monitor, you just need to add the following to the
@ -749,12 +692,12 @@ hits an exception that is protected by a @code{lazy-catch} using
@subsubsection Accepting GDS Instructions at Any Time @subsubsection Accepting GDS Instructions at Any Time
In addition to setting breakpoints and/or an exception handler as In addition to setting an exception handler as described above, a
described above, a Guile program can in principle set itself up to Guile program can in principle set itself up to accept new
accept new instructions from GDS at any time, not just when it has instructions from GDS at any time, not just when it has stopped at an
stopped at a breakpoint or exception. This would allow the GDS user to exception. This would allow the GDS user to evaluate code in the
set new breakpoints or to evaluate code in the context of the running context of the running program, without having to wait for the program
program, without having to wait for the program to stop first. to stop first.
@lisp @lisp
(use-modules (ice-9 gds-client)) (use-modules (ice-9 gds-client))
@ -793,13 +736,11 @@ the utility Guile client is essentially just this:
@lisp @lisp
(use-modules (ice-9 gds-client)) (use-modules (ice-9 gds-client))
(set-gds-breakpoints)
(named-module-use! '(guile-user) '(ice-9 session)) (named-module-use! '(guile-user) '(ice-9 session))
(gds-accept-input #f)) (gds-accept-input #f))
@end lisp @end lisp
@code{set-gds-breakpoints} works as already described. The The @code{named-module-use!} line ensures that the client can process
@code{named-module-use!} line ensures that the client can process
@code{help} and @code{apropos} expressions, to implement lookups in @code{help} and @code{apropos} expressions, to implement lookups in
Guile's online help. The @code{#f} parameter to Guile's online help. The @code{#f} parameter to
@code{gds-accept-input} means that the @code{continue} instruction @code{gds-accept-input} means that the @code{continue} instruction
@ -827,9 +768,6 @@ GDS provides for working on code in @code{scheme-mode} buffers.
@menu @menu
* Access to Guile Help and Completion:: * Access to Guile Help and Completion::
* Setting and Managing Breakpoints::
* Listing and Deleting Breakpoints::
* Moving and Losing Breakpoints::
* Evaluating Scheme Code:: * Evaluating Scheme Code::
@end menu @end menu
@ -872,90 +810,6 @@ selected using either @kbd{@key{RET}} or the mouse.
@end table @end table
@node Setting and Managing Breakpoints
@subsubsection Setting and Managing Breakpoints
You can create a breakpoint in GDS by typing @kbd{C-x @key{SPC}} in a
Scheme mode buffer. To create a breakpoint on calls to a procedure ---
i.e. the equivalent of calling @code{break-in} --- place the cursor
anywhere within the procedure's definition, make sure that the region is
unset, and type @kbd{C-x @key{SPC}}. To create breakpoints on a
particular expression, or on the series of expressions in a particular
region --- i.e. as with @code{break-at} --- select a region containing
the open parentheses of the expressions where you want breakpoints, and
type @kbd{C-x @key{SPC}}. In other words, GDS assumes that you want a
@code{break-at} breakpoint if there is an active region, and a
@code{break-in} breakpoint otherwise.
There are three supported breakpoint behaviours, known as @code{debug},
@code{trace} and @code{trace-subtree}. @code{debug} means that GDS will
display the stack and wait for instruction when the breakpoint is hit.
@code{trace} means that a line will be written to the trace output
buffer (@code{*GDS Trace*}) when the breakpoint is hit, and when the
relevant expression or procedure call returns. @code{trace-subtree}
means that a line is written to the trace output buffer for every
evaluation step between when the breakpoint is hit and when the
expression or procedure returns.
@kbd{C-x @key{SPC}} creates a breakpoint with behaviour according to the
@code{gds-default-breakpoint-type} variable, which by default is
@code{debug}; you can customize this if you prefer a different default.
You can also create a breakpoint with behaviour other than the current
default by using the alternative key sequences @kbd{C-c C-b d} (for
@code{debug}), @kbd{C-c C-b t} (for @code{trace}) and @kbd{C-c C-b T}
(for @code{trace-subtree}).
GDS keeps all the breakpoints that you create in a single list, and
tries to set them in every Guile program that connects to GDS and calls
@code{set-gds-breakpoints}. That may sound surprising, because you are
probably thinking of one particular program when you create a
breakpoint; but GDS assumes that you would want the breakpoint to continue
taking effect if you stop and restart that program, and this is
currently achieved by giving all breakpoints to every program that asks
for them. In practice it doesn't matter if a program gets a breakpoint
definition --- such as ``break in procedure @code{foo}'' --- that it
can't actually map to any of its code.
If there are already Guile programs connected to GDS when you create a
new breakpoint, GDS also tries to set the new breakpoint in each of
those programs at the earliest opportunity, which is usually when they
decide to stop and talk to GDS for some other reason.
@node Listing and Deleting Breakpoints
@subsubsection Listing and Deleting Breakpoints
To see a list of all breakpoints, type @kbd{C-c C-b ?} (or @kbd{M-x
gds-describe-breakpoints}). GDS will then pop up a buffer that
describes each breakpoint and reports whether it is actually set in each
of the Guile programs connected to GDS.
To delete a breakpoint, type @kbd{C-c C-b @key{backspace}}. If the
region is active when you do this, GDS will delete all of the
breakpoints in the region. If the region is not active, GDS tries to
delete a ``break-in'' breakpoint for the procedure whose definition
contains point (the Emacs cursor). In either case, deletion means that
the breakpoint is removed both from GDS's global list and from all of
the connected Guile programs that had previously managed to set it.
@node Moving and Losing Breakpoints
@subsubsection Moving and Losing Breakpoints
Imagine that you set a breakpoint at line 80 of a Scheme code file, and
execute some code that hits this breakpoint; then you add some new code
at line 40, or delete some code that is no longer needed, and save the
file. Now the breakpoint will have moved up or down from line 80, and
any attached Guile program needs to be told about the new line number.
Otherwise, when a program loads this file again, it will try incorrectly
to set a breakpoint on whatever code is now at line 80, and will
@emph{not} set a breakpoint on the code where you want it.
For this reason, GDS checks all breakpoint positions whenever you save a
Scheme file, and sends the new position to connected Guile programs for
any breakpoints that have moved. @dots{} [to be continued]
@node Evaluating Scheme Code @node Evaluating Scheme Code
@subsubsection Evaluating Scheme Code @subsubsection Evaluating Scheme Code
@ -1000,15 +854,15 @@ are described in the next two sections.
@node Displaying the Scheme Stack @node Displaying the Scheme Stack
@subsection Displaying the Scheme Stack @subsection Displaying the Scheme Stack
When you specify @code{gds-debug-trap} as the behaviour for a trap or When you specify @code{gds-debug-trap} as the behaviour for a trap and
a breakpoint and the Guile program concerned hits that trap or the Guile program concerned hits that trap, GDS displays the stack and
breakpoint, GDS displays the stack and the relevant Scheme source code the relevant Scheme source code in Emacs, allowing you to explore the
in Emacs, allowing you to explore the state of the program and then state of the program and then decide what to do next. The same
decide what to do next. The same applies if the program calls applies if the program calls @code{(on-lazy-handler-dispatch
@code{(on-lazy-handler-dispatch gds-debug-trap)} and then throws an gds-debug-trap)} and then throws an exception that passes through
exception that passes through @code{lazy-handler-dispatch}, except @code{lazy-handler-dispatch}, except that in this case you can only
that in this case you can only explore; it isn't possible to continue explore; it isn't possible to continue normal execution after an
normal execution after an exception. exception.
The following commands are available in the stack buffer for exploring The following commands are available in the stack buffer for exploring
the state of the program. the state of the program.

521
emacs/gds-scheme.el
View file

@ -484,483 +484,6 @@ interesting happened, `nil' if not."
(display-completion-list gds-completion-results)) (display-completion-list gds-completion-results))
t))))) t)))))
;;;; Breakpoints.
(defvar gds-bufferless-breakpoints nil
"The list of breakpoints that are not yet associated with a
particular buffer. Each element looks like (BPDEF BPNUM) where BPDEF
is the breakpoint definition and BPNUM the breakpoint's unique
GDS-assigned number. A breakpoint definition BPDEF is a list of the
form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug
or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file
where the breakpoint is (or will be) set, and TYPE-ARGS is:
- the name of the procedure to break in, if TYPE is 'in
- the line number and column number to break at, if TYPE is 'at.
If persistent breakpoints are enabled (by configuring
gds-breakpoints-file-name), this list is initialized when GDS is
loaded by reading gds-breakpoints-file-name.")
(defsubst gds-bpdef:behaviour (bpdef)
(nth 0 bpdef))
(defsubst gds-bpdef:type (bpdef)
(nth 1 bpdef))
(defsubst gds-bpdef:file-name (bpdef)
(nth 2 bpdef))
(defsubst gds-bpdef:proc-name (bpdef)
(nth 3 bpdef))
(defsubst gds-bpdef:lc (bpdef)
(nth 3 bpdef))
(defvar gds-breakpoint-number 0
"The last assigned breakpoint number. GDS increments this whenever
it creates a new breakpoint.")
(defvar gds-breakpoint-buffers nil
"The list of buffers that contain GDS breakpoints. When Emacs
visits a Scheme file, GDS checks to see if any of the breakpoints in
the bufferless list can be assigned to that file's buffer. If they
can, they are removed from the bufferless list and become breakpoint
overlays in that buffer. To retain the ability to enumerate all
breakpoints, therefore, we keep a list of all such buffers.")
(defvar gds-breakpoint-programming nil
"Information about how each breakpoint is actually programmed in the
Guile clients that GDS is connected to. This is an alist of the form
\((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint
number, CLIENT is the number of a GDS client, and TRAPLIST is the list
of traps that that client has created for the breakpoint concerned (in
an arbitrary but Emacs-readable format).")
(defvar gds-breakpoint-cache nil
"Buffer-local cache of breakpoints in a particular buffer. When a
breakpoint is represented as an overlay is a Scheme mode buffer, we
need to be able to detect when the user has caused that overlay to
evaporate by deleting a region of code that included it. We do this
detection when the buffer is next saved, by comparing the current set
of overlays with this cache. The cache is a list in which each
element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already
described. The handling of such breakpoints (which we call \"lost\")
is controlled by the setting of gds-delete-lost-breakpoints.")
(make-variable-buffer-local 'gds-breakpoint-cache)
(defface gds-breakpoint-face
'((((background dark)) (:background "red"))
(t (:background "pink")))
"*Face used to highlight the location of a breakpoint."
:group 'gds)
(defcustom gds-breakpoints-file-name "~/.gds-breakpoints"
"Name of file used to store GDS breakpoints between sessions.
You can disable breakpoint persistence by setting this to nil."
:group 'gds
:type '(choice (const :tag "nil" nil) file))
(defcustom gds-delete-lost-breakpoints nil
"Whether to delete lost breakpoints.
A non-nil value means that the Guile clients where lost breakpoints
were programmed will be told immediately to delete their breakpoints.
\"Immediately\" means when the lost breakpoints are detected, which
means when the buffer that previously contained them is saved. Thus,
even if the affected code (which the GDS user has deleted from his/her
buffer in Emacs) is still in use in the Guile clients, the breakpoints
that were previously set in that code will no longer take effect.
Nil (which is the default) means that GDS leaves such breakpoints
active in their Guile clients. This allows those breakpoints to
continue taking effect until the affected code is no longer used by
the Guile clients."
:group 'gds
:type 'boolean)
(defvar gds-bpdefs-cache nil)
(defun gds-read-breakpoints-file ()
"Read the persistent breakpoints file, and use its contents to
initialize GDS's global breakpoint variables."
(let ((bpdefs (condition-case nil
(with-current-buffer
(find-file-noselect gds-breakpoints-file-name)
(goto-char (point-min))
(read (current-buffer)))
(error nil))))
;; Cache the overall value so we don't unnecessarily modify the
;; breakpoints buffer when `gds-write-breakpoints-file' is called.
(setq gds-bpdefs-cache bpdefs)
;; Move definitions into the bufferless breakpoint list, assigning
;; breakpoint numbers as we go.
(setq gds-bufferless-breakpoints
(mapcar (function (lambda (bpdef)
(setq gds-breakpoint-number
(1+ gds-breakpoint-number))
(list bpdef gds-breakpoint-number)))
bpdefs))
;; Check each existing Scheme buffer to see if it wants to take
;; ownership of any of these breakpoints.
(mapcar (function (lambda (buffer)
(with-current-buffer buffer
(if (eq (derived-mode-class major-mode) 'scheme-mode)
(gds-adopt-breakpoints)))))
(buffer-list))))
(defun gds-adopt-breakpoints ()
"Take ownership of any of the breakpoints in the bufferless list
that match the current buffer."
(mapcar (function gds-adopt-breakpoint)
(copy-sequence gds-bufferless-breakpoints)))
(defun gds-adopt-breakpoint (bpdefnum)
"Take ownership of the specified breakpoint if it matches the
current buffer."
(let ((bpdef (car bpdefnum))
(bpnum (cadr bpdefnum)))
;; Check if breakpoint's file name matches. If it does, try to
;; convert the breakpoint definition to a breakpoint overlay in
;; the current buffer.
(if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name)
(gds-make-breakpoint-overlay bpdef bpnum))
;; That all succeeded, so this breakpoint is no longer
;; bufferless.
(setq gds-bufferless-breakpoints
(delq bpdefnum gds-bufferless-breakpoints)))))
(defun gds-make-breakpoint-overlay (bpdef &optional bpnum)
;; If no explicit number given, assign the next available breakpoint
;; number.
(or bpnum
(setq gds-breakpoint-number (+ gds-breakpoint-number 1)
bpnum gds-breakpoint-number))
;; First decide where the overlay should be, and create it there.
(let ((o (cond ((eq (gds-bpdef:type bpdef) 'at)
(save-excursion
(goto-line (+ (car (gds-bpdef:lc bpdef)) 1))
(move-to-column (cdr (gds-bpdef:lc bpdef)))
(make-overlay (point) (1+ (point)))))
((eq (gds-bpdef:type bpdef) 'in)
(save-excursion
(goto-char (point-min))
(and (re-search-forward (concat "^(define +(?\\("
(regexp-quote
(gds-bpdef:proc-name
bpdef))
"\\>\\)")
nil t)
(make-overlay (match-beginning 1) (match-end 1)))))
(t
(error "Bad breakpoint type")))))
;; If that succeeded, initialize the overlay's properties.
(if o
(progn
(overlay-put o 'evaporate t)
(overlay-put o 'face 'gds-breakpoint-face)
(overlay-put o 'gds-breakpoint-number bpnum)
(overlay-put o 'gds-breakpoint-definition bpdef)
(overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef))
(overlay-put o 'priority 1000)
;; Make sure that the current buffer is included in
;; `gds-breakpoint-buffers'.
(or (memq (current-buffer) gds-breakpoint-buffers)
(setq gds-breakpoint-buffers
(cons (current-buffer) gds-breakpoint-buffers)))
;; Add the new breakpoint to this buffer's cache.
(setq gds-breakpoint-cache
(cons (list bpdef bpnum) gds-breakpoint-cache))
;; If this buffer is associated with a client, tell the
;; client about the new breakpoint.
(if gds-client (gds-send-breakpoint-to-client bpnum bpdef))))
;; Return the overlay, or nil if we weren't able to convert the
;; breakpoint definition.
o))
(defun gds-send-breakpoint-to-client (bpnum bpdef)
"Send specified breakpoint to this buffer's Guile client."
(gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client))
(add-hook 'scheme-mode-hook (function gds-adopt-breakpoints))
(defcustom gds-default-breakpoint-type 'debug
"The type of breakpoint set by `C-x SPC'."
:group 'gds
:type '(choice (const :tag "debug" debug) (const :tag "trace" trace)))
(defun gds-set-breakpoint ()
"Create a new GDS breakpoint at point."
(interactive)
;; Set up beg and end according to whether the mark is active.
(if mark-active
;; Set new breakpoints on all opening parentheses in the region.
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
(goto-char beg)
(beginning-of-defun)
(let ((defun-start (point)))
(goto-char beg)
(while (search-forward "(" end t)
(let ((state (parse-partial-sexp defun-start (point)))
(pos (- (point) 1)))
(or (nth 3 state)
(nth 4 state)
(gds-breakpoint-overlays-at pos)
(gds-make-breakpoint-overlay (list gds-default-breakpoint-type
'at
buffer-file-name
(gds-line-and-column
pos)))))))))
;; Set a new breakpoint on the defun at point.
(let ((region (gds-defun-name-region)))
;; Complain if there is no defun at point.
(or region
(error "Point is not in a procedure definition"))
;; Don't create another breakpoint if there is already one here.
(if (gds-breakpoint-overlays-at (car region))
(error "There is already a breakpoint here"))
;; Create and return the new breakpoint overlay.
(gds-make-breakpoint-overlay (list gds-default-breakpoint-type
'in
buffer-file-name
(buffer-substring-no-properties
(car region)
(cdr region))))))
;; Update the persistent breakpoints file.
(gds-write-breakpoints-file))
(defun gds-defun-name-region ()
"If point is in a defun, return the beginning and end positions of
the identifier being defined."
(save-excursion
(let ((p (point)))
(beginning-of-defun)
;; Check that we are looking at some kind of procedure
;; definition.
(and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)")
(let ((beg (match-beginning 1))
(end (match-end 1)))
(end-of-defun)
;; Check here that we have reached past the original point
;; position.
(and (>= (point) p)
(cons beg end)))))))
(defun gds-breakpoint-overlays-at (pos)
"Return a list of GDS breakpoint overlays at the specified position."
(let ((os (overlays-at pos))
(breakpoint-os nil))
;; Of the overlays at POS, select all those that have a
;; gds-breakpoint-definition property.
(while os
(if (overlay-get (car os) 'gds-breakpoint-definition)
(setq breakpoint-os (cons (car os) breakpoint-os)))
(setq os (cdr os)))
breakpoint-os))
(defun gds-write-breakpoints-file ()
"Write the persistent breakpoints file, if configured."
(if gds-breakpoints-file-name
(let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init)
(cons bpdef init)))
t)))
(or (equal bpdefs gds-bpdefs-cache)
(with-current-buffer (find-file-noselect gds-breakpoints-file-name)
(erase-buffer)
(pp (reverse bpdefs) (current-buffer))
(setq gds-bpdefs-cache bpdefs)
(let ((auto-fill-function normal-auto-fill-function))
(newline)))))))
(defun gds-fold-breakpoints (fn &optional foldp init)
;; Run through bufferless breakpoints first.
(let ((bbs gds-bufferless-breakpoints))
(while bbs
(let ((bpnum (cadr (car bbs)))
(bpdef (caar bbs)))
(if foldp
(setq init (funcall fn bpnum bpdef init))
(funcall fn bpnum bpdef)))
(setq bbs (cdr bbs))))
;; Now run through breakpoint buffers.
(let ((outbuf (current-buffer))
(bpbufs gds-breakpoint-buffers))
(while bpbufs
(let ((buf (car bpbufs)))
(if (buffer-live-p buf)
(with-current-buffer buf
(save-restriction
(widen)
(let ((os (overlays-in (point-min) (point-max))))
(while os
(let ((bpnum (overlay-get (car os)
'gds-breakpoint-number))
(bpdef (overlay-get (car os)
'gds-breakpoint-definition)))
(if bpdef
(with-current-buffer outbuf
(if foldp
(setq init (funcall fn bpnum bpdef init))
(funcall fn bpnum bpdef)))))
(setq os (cdr os))))))))
(setq bpbufs (cdr bpbufs))))
init)
(defun gds-delete-breakpoints ()
"Delete GDS breakpoints in the region or at point."
(interactive)
(if mark-active
;; Delete all breakpoints in the region.
(let ((os (overlays-in (region-beginning) (region-end))))
(while os
(if (overlay-get (car os) 'gds-breakpoint-definition)
(gds-delete-breakpoint (car os)))
(setq os (cdr os))))
;; Delete the breakpoint "at point".
(call-interactively (function gds-delete-breakpoint))))
(defun gds-delete-breakpoint (o)
(interactive (list (or (gds-breakpoint-at-point)
(error "There is no breakpoint here"))))
(let ((bpdef (overlay-get o 'gds-breakpoint-definition))
(bpnum (overlay-get o 'gds-breakpoint-number)))
;; If this buffer is associated with a client, tell the client
;; that the breakpoint has been deleted.
(if (and bpnum gds-client)
(gds-send (format "delete-breakpoint %d" bpnum) gds-client))
;; Remove this breakpoint from the cache also, so it isn't later
;; detected as having been "lost".
(setq gds-breakpoint-cache
(delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache)))
;; Remove the overlay from its buffer.
(delete-overlay o)
;; If that was the last breakpoint in this buffer, remove this
;; buffer from gds-breakpoint-buffers.
(or gds-breakpoint-cache
(setq gds-breakpoint-buffers
(delq (current-buffer) gds-breakpoint-buffers)))
;; Update the persistent breakpoints file.
(gds-write-breakpoints-file))
(defun gds-breakpoint-at-point ()
"Find and return the overlay for a breakpoint `at' the current
cursor position. This is intended for use in other functions'
interactive forms, so it intentionally uses the minibuffer in some
situations."
(let* ((region (gds-defun-name-region))
(os (gds-union (gds-breakpoint-overlays-at (point))
(and region
(gds-breakpoint-overlays-at (car region))))))
;; Switch depending whether we found 0, 1 or more overlays.
(cond ((null os)
;; None found: return nil.
nil)
((= (length os) 1)
;; One found: return it.
(car os))
(t
;; More than 1 found: ask the user to choose.
(gds-user-selected-breakpoint os)))))
(defun gds-union (first second &rest others)
(if others
(gds-union first (apply 'gds-union second others))
(progn
(while first
(or (memq (car first) second)
(setq second (cons (car first) second)))
(setq first (cdr first)))
second)))
(defun gds-user-selected-breakpoint (os)
"Ask the user to choose one of the given list of breakpoints, and
return the one that they chose."
(let ((table (mapcar
(lambda (o)
(cons (format "%S"
(overlay-get o 'gds-breakpoint-definition))
o))
os)))
(cdr (assoc (completing-read "Which breakpoint do you mean? "
table nil t)
table))))
(defun gds-describe-breakpoints ()
"Describe all breakpoints and their programming status."
(interactive)
(with-current-buffer (get-buffer-create "*GDS Breakpoints*")
(erase-buffer)
(gds-fold-breakpoints (function gds-describe-breakpoint))
(display-buffer (current-buffer))))
(defun gds-describe-breakpoint (bpnum bpdef)
(insert (format "Breakpoint %d: %S\n" bpnum bpdef))
(let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming))))
(mapcar (lambda (clientprog)
(let ((client (car clientprog))
(traplist (cdr clientprog)))
(mapcar (lambda (trap)
(insert (format " Client %d: %S\n" client trap)))
traplist)))
bpproglist)))
(defun gds-after-save-update-breakpoints ()
"Function called when a buffer containing breakpoints is saved."
(if (eq (derived-mode-class major-mode) 'scheme-mode)
(save-restriction
(widen)
;; Get the current breakpoint overlays.
(let ((os (overlays-in (point-min) (point-max)))
(cache (copy-sequence gds-breakpoint-cache)))
;; Identify any overlays that have disappeared by comparing
;; against this buffer's definition cache, and
;; simultaneously rebuild the cache to reflect the current
;; set of overlays.
(setq gds-breakpoint-cache nil)
(while os
(let* ((o (car os))
(bpdef (overlay-get o 'gds-breakpoint-definition))
(bpnum (overlay-get o 'gds-breakpoint-number)))
(if bpdef
;; o and bpdef describe a current breakpoint.
(progn
;; Remove this breakpoint from the old cache list,
;; so we don't think it got lost.
(setq cache (delq (assq bpdef cache) cache))
;; Check whether this breakpoint's location has
;; moved. If it has, update the breakpoint
;; definition and the associated client.
(let ((lcnow (gds-line-and-column (overlay-start o))))
(if (equal lcnow (gds-bpdef:lc bpdef))
nil ; Breakpoint hasn't moved.
(gds-bpdef:setlc bpdef lcnow)
(if gds-client
(gds-send-breakpoint-to-client bpnum bpdef))))
;; Add this breakpoint to the new cache list.
(setq gds-breakpoint-cache
(cons (list bpdef bpnum) gds-breakpoint-cache)))))
(setq os (cdr os)))
;; cache now holds the set of lost breakpoints. If we are
;; supposed to explicitly delete these from the associated
;; client, do that now.
(if (and gds-delete-lost-breakpoints gds-client)
(while cache
(gds-send (format "delete-breakpoint %d" (cadr (car cache)))
gds-client)
(setq cache (cdr cache)))))
;; If this buffer now has no breakpoints, remove it from
;; gds-breakpoint-buffers.
(or gds-breakpoint-cache
(setq gds-breakpoint-buffers
(delq (current-buffer) gds-breakpoint-buffers)))
;; Update the persistent breakpoints file.
(gds-write-breakpoints-file))))
(add-hook 'after-save-hook (function gds-after-save-update-breakpoints))
;;;; Dispatcher for non-debug protocol. ;;;; Dispatcher for non-debug protocol.
(defun gds-nondebug-protocol (client proc args) (defun gds-nondebug-protocol (client proc args)
@ -977,28 +500,6 @@ return the one that they chose."
(eq proc 'completion-result) (eq proc 'completion-result)
(setq gds-completion-results (or (car args) t))) (setq gds-completion-results (or (car args) t)))
(;; (breakpoint NUM STATUS) - Breakpoint set.
(eq proc 'breakpoint)
(let* ((bpnum (car args))
(traplist (cdr args))
(bpentry (assq bpnum gds-breakpoint-programming)))
(message "Breakpoint %d: %s" bpnum traplist)
(if bpentry
(let ((cliententry (assq client (cdr bpentry))))
(if cliententry
(setcdr cliententry traplist)
(setcdr bpentry
(cons (cons client traplist) (cdr bpentry)))))
(setq gds-breakpoint-programming
(cons (list bpnum (cons client traplist))
gds-breakpoint-programming)))))
(;; (get-breakpoints) - Set all breakpoints.
(eq proc 'get-breakpoints)
(let ((gds-client client))
(gds-fold-breakpoints (function gds-send-breakpoint-to-client)))
(gds-send "continue" client))
(;; (note ...) - For debugging only. (;; (note ...) - For debugging only.
(eq proc 'note)) (eq proc 'note))
@ -1025,28 +526,6 @@ return the one that they chose."
(define-key scheme-mode-map "\C-hG" 'gds-apropos) (define-key scheme-mode-map "\C-hG" 'gds-apropos)
(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack) (define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) (define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
(define-key scheme-mode-map "\C-x " 'gds-set-breakpoint)
(define-prefix-command 'gds-breakpoint-map)
(define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map)
(define-key gds-breakpoint-map " " 'gds-set-breakpoint)
(define-key gds-breakpoint-map "d"
(function (lambda ()
(interactive)
(let ((gds-default-breakpoint-type 'debug))
(gds-set-breakpoint)))))
(define-key gds-breakpoint-map "t"
(function (lambda ()
(interactive)
(let ((gds-default-breakpoint-type 'trace))
(gds-set-breakpoint)))))
(define-key gds-breakpoint-map "T"
(function (lambda ()
(interactive)
(let ((gds-default-breakpoint-type 'trace-subtree))
(gds-set-breakpoint)))))
(define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints)
(define-key gds-breakpoint-map "?" 'gds-describe-breakpoints)
;;;; The end! ;;;; The end!

12
emacs/gds.el
View file

@ -622,18 +622,6 @@ you would add an element to this alist to transform
(not gds-debug-server)) (not gds-debug-server))
(gds-run-debug-server)) (gds-run-debug-server))
;; Things to do only when this file is loaded for the first time.
;; (And not, for example, when code is reevaluated by eval-buffer.)
(defvar gds-scheme-first-load t)
(if gds-scheme-first-load
(progn
;; Read the persistent breakpoints file, if configured.
(if gds-breakpoints-file-name
(gds-read-breakpoints-file))
;; Note that first time load is complete.
(setq gds-scheme-first-load nil)))
;;;; The end! ;;;; The end!
(provide 'gds) (provide 'gds)

4
ice-9/debugging/Makefile.am
View file

@ -22,8 +22,8 @@
AUTOMAKE_OPTIONS = gnu AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed. # These should be installed and distributed.
ice9_debugging_sources = breakpoints.scm example-fns.scm \ ice9_debugging_sources = example-fns.scm \
ice-9-debugger-extensions.scm load-hooks.scm \ ice-9-debugger-extensions.scm \
steps.scm trace.scm traps.scm trc.scm steps.scm trace.scm traps.scm trc.scm
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging

415
ice-9/debugging/breakpoints.scm
View file

@ -1,415 +0,0 @@
;;;; (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.

33
ice-9/debugging/load-hooks.scm
View file

@ -1,33 +0,0 @@
(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))

90
ice-9/gds-client.scm
View file

@ -1,7 +1,6 @@
(define-module (ice-9 gds-client) (define-module (ice-9 gds-client)
#:use-module (oop goops) #:use-module (oop goops)
#:use-module (oop goops describe) #:use-module (oop goops describe)
#:use-module (ice-9 debugging breakpoints)
#:use-module (ice-9 debugging trace) #:use-module (ice-9 debugging trace)
#:use-module (ice-9 debugging traps) #:use-module (ice-9 debugging traps)
#:use-module (ice-9 debugging trc) #:use-module (ice-9 debugging trc)
@ -12,7 +11,6 @@
#:use-module (ice-9 string-fun) #:use-module (ice-9 string-fun)
#:export (gds-debug-trap #:export (gds-debug-trap
run-utility run-utility
set-gds-breakpoints
gds-accept-input)) gds-accept-input))
(cond ((string>=? (version) "1.7") (cond ((string>=? (version) "1.7")
@ -383,7 +381,6 @@ Thanks!\n\n"
;; Another complete expression read; add ;; Another complete expression read; add
;; it to the list. ;; it to the list.
(begin (begin
(for-each-breakpoint setup-after-read x)
(if (and (pair? x) (if (and (pair? x)
(memq 'debug flags)) (memq 'debug flags))
(install-trap (make <source-trap> (install-trap (make <source-trap>
@ -400,11 +397,7 @@ Thanks!\n\n"
(display " to evaluate\n") (display " to evaluate\n")
(apply display-error #f (apply display-error #f
(current-output-port) args))) (current-output-port) args)))
("error-in-read")))))))) ("error-in-read")))))))))
(if (string? port-name)
(without-traps
(lambda ()
(for-each-breakpoint setup-after-eval port-name)))))
(cdr protocol))) (cdr protocol)))
((complete) ((complete)
@ -441,83 +434,9 @@ Thanks!\n\n"
(gds-debug-trap last-lazy-trap-context) (gds-debug-trap last-lazy-trap-context)
(error "There is no stack available to show"))) (error "There is no stack available to show")))
((set-breakpoint)
;; Create or update a breakpoint object according to the
;; definition. If the target code is already loaded, note that
;; this may immediately install a trap.
(let* ((num (cadr protocol))
(def (caddr protocol))
(behaviour (case (list-ref def 0)
((debug) gds-debug-trap)
((trace) gds-trace-trap)
((trace-subtree) gds-trace-subtree)
(else (error "Unsupported behaviour:"
(list-ref def 0)))))
(bp (hash-ref breakpoints num)))
(trc 'existing-bp bp)
(if bp
(update-breakpoint bp (list-ref def 3))
(begin
(set! bp
(case (list-ref def 1)
((in)
(break-in (string->symbol (list-ref def 3))
(list-ref def 2)
#:behaviour behaviour))
((at)
(break-at (list-ref def 2)
(car (list-ref def 3))
(cdr (list-ref def 3))
#:behaviour behaviour))
(else
(error "Unsupported breakpoint type:"
(list-ref def 1)))))
;; Install an observer that will tell the frontend about
;; future changes in this breakpoint's status.
(slot-set! bp 'observer
(lambda ()
(write-form `(breakpoint
,num
,@(map trap-description
(slot-ref bp 'traps))))))
;; Add this to the breakpoint hash, and return the
;; breakpoint number and status to the front end.
(hash-set! breakpoints num bp)))
;; Call the breakpoint's observer now.
((slot-ref bp 'observer))))
((delete-breakpoint)
(let* ((num (cadr protocol))
(bp (hash-ref breakpoints num)))
(if bp
(begin
(hash-remove! breakpoints num)
(delete-breakpoint bp)))))
;;; ((describe-breakpoints)
;;; ;; Describe all breakpoints.
;;; (let ((desc
;;; (with-output-to-string
;;; (lambda ()
;;; (hash-fold (lambda (num bp acc)
;;; (format #t
;;; "Breakpoint ~a ~a (~a):\n"
;;; (class-name (class-of bp))
;;; num
;;; (slot-ref bp 'status))
;;; (for-each (lambda (trap)
;;; (write (trap-description trap))
;;; (newline))
;;; (slot-ref bp 'traps)))
;;; #f
;;; breakpoints)))))
;;; (write-form (list 'info-result desc))))
(else (else
(error "Unexpected protocol:" protocol)))) (error "Unexpected protocol:" protocol))))
(define breakpoints (make-hash-table 11))
(define (resolve-module-from-root name) (define (resolve-module-from-root name)
(save-module-excursion (save-module-excursion
(lambda () (lambda ()
@ -591,18 +510,13 @@ Thanks!\n\n"
(apply throw key args)) (apply throw key args))
(define (run-utility) (define (run-utility)
(set-gds-breakpoints) (connect-to-gds)
(write (getpid)) (write (getpid))
(newline) (newline)
(force-output) (force-output)
(named-module-use! '(guile-user) '(ice-9 session)) (named-module-use! '(guile-user) '(ice-9 session))
(gds-accept-input #f)) (gds-accept-input #f))
(define (set-gds-breakpoints)
(connect-to-gds)
(write-form '(get-breakpoints))
(gds-accept-input #t))
(define-method (trap-description (trap <trap>)) (define-method (trap-description (trap <trap>))
(let loop ((description (list (class-name (class-of trap)))) (let loop ((description (list (class-name (class-of trap))))
(next 'installed?)) (next 'installed?))