diff options
author | Neil Jerram <neil@ossau.uklinux.net> | 2008-12-09 23:56:51 +0000 |
---|---|---|
committer | Neil Jerram <neil@ossau.uklinux.net> | 2008-12-10 00:19:11 +0000 |
commit | 69986e21d30b85bd0b4fd7e81cd24cef586c4871 (patch) | |
tree | 4b47dd67d5593b7b41b044db762faccb271a742e | |
parent | e00634774a68694911b933fd619ee3d2e1033f76 (diff) | |
download | guile-69986e21d30b85bd0b4fd7e81cd24cef586c4871.tar.gz |
Remove everything to do with GDS Breakpoints
(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'.
-rw-r--r-- | doc/ref/api-debug.texi | 134 | ||||
-rw-r--r-- | doc/ref/scheme-using.texi | 188 | ||||
-rwxr-xr-x | emacs/gds-scheme.el | 521 | ||||
-rw-r--r-- | emacs/gds.el | 12 | ||||
-rw-r--r-- | ice-9/debugging/Makefile.am | 4 | ||||
-rw-r--r-- | ice-9/debugging/breakpoints.scm | 415 | ||||
-rw-r--r-- | ice-9/debugging/load-hooks.scm | 33 | ||||
-rwxr-xr-x | ice-9/gds-client.scm | 90 |
8 files changed, 26 insertions, 1371 deletions
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index d99a56724..0d4398015 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @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 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. * Debug on Error:: Debugging when an error occurs. * Traps:: -* Breakpoints:: * Debugging Examples:: @end menu @@ -1691,137 +1690,6 @@ if there isn't one. @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 @subsection Debugging Examples diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 96273b7d0..a8a2568e3 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -485,9 +485,9 @@ popping up in a temporary Emacs window. @end itemize @item -Debugging a Guile Scheme program. When your program hits an error or a -breakpoint, GDS shows you the relevant code and the Scheme stack, and -makes it easy to +Debugging a Guile Scheme program. When your program hits an error or +stops at a trap, GDS shows you the relevant code and the Scheme stack, +and makes it easy to @itemize @item @@ -495,9 +495,6 @@ look at the values of local variables @item see what is happening at all levels of the Scheme stack @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. @end itemize @@ -509,13 +506,6 @@ Guile to run until that frame completes, at which point GDS will display the frame's return value. @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 (which we often refer to as ``clients'') at once, and these programs can 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 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} -expressions. You can set breakpoints and evaluate code which hits those -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. +expressions. When you want to use GDS to work on an independent Guile 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 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 -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 @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 @@ -749,12 +692,12 @@ hits an exception that is protected by a @code{lazy-catch} using @subsubsection Accepting GDS Instructions at Any Time -In addition to setting breakpoints and/or an exception handler as -described above, a Guile program can in principle set itself up to -accept new instructions from GDS at any time, not just when it has -stopped at a breakpoint or exception. This would allow the GDS user to -set new breakpoints or to evaluate code in the context of the running -program, without having to wait for the program to stop first. +In addition to setting an exception handler as described above, a +Guile program can in principle set itself up to accept new +instructions from GDS at any time, not just when it has stopped at an +exception. This would allow the GDS user to evaluate code in the +context of the running program, without having to wait for the program +to stop first. @lisp (use-modules (ice-9 gds-client)) @@ -793,13 +736,11 @@ the utility Guile client is essentially just this: @lisp (use-modules (ice-9 gds-client)) -(set-gds-breakpoints) (named-module-use! '(guile-user) '(ice-9 session)) (gds-accept-input #f)) @end lisp -@code{set-gds-breakpoints} works as already described. The -@code{named-module-use!} line ensures that the client can process +The @code{named-module-use!} line ensures that the client can process @code{help} and @code{apropos} expressions, to implement lookups in Guile's online help. The @code{#f} parameter to @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 * Access to Guile Help and Completion:: -* Setting and Managing Breakpoints:: -* Listing and Deleting Breakpoints:: -* Moving and Losing Breakpoints:: * Evaluating Scheme Code:: @end menu @@ -872,90 +810,6 @@ selected using either @kbd{@key{RET}} or the mouse. @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 @subsubsection Evaluating Scheme Code @@ -1000,15 +854,15 @@ are described in the next two sections. @node Displaying the Scheme Stack @subsection Displaying the Scheme Stack -When you specify @code{gds-debug-trap} as the behaviour for a trap or -a breakpoint and the Guile program concerned hits that trap or -breakpoint, GDS displays the stack and the relevant Scheme source code -in Emacs, allowing you to explore the state of the program and then -decide what to do next. The same applies if the program calls -@code{(on-lazy-handler-dispatch gds-debug-trap)} and then throws an -exception that passes through @code{lazy-handler-dispatch}, except -that in this case you can only explore; it isn't possible to continue -normal execution after an exception. +When you specify @code{gds-debug-trap} as the behaviour for a trap and +the Guile program concerned hits that trap, GDS displays the stack and +the relevant Scheme source code in Emacs, allowing you to explore the +state of the program and then decide what to do next. The same +applies if the program calls @code{(on-lazy-handler-dispatch +gds-debug-trap)} and then throws an exception that passes through +@code{lazy-handler-dispatch}, except that in this case you can only +explore; it isn't possible to continue normal execution after an +exception. The following commands are available in the stack buffer for exploring the state of the program. diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index db0e6cd41..b8a161b37 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -484,483 +484,6 @@ interesting happened, `nil' if not." (display-completion-list gds-completion-results)) 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. (defun gds-nondebug-protocol (client proc args) @@ -977,28 +500,6 @@ return the one that they chose." (eq proc 'completion-result) (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. (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-hS" 'gds-show-last-stack) (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! diff --git a/emacs/gds.el b/emacs/gds.el index 71d9a99d4..7a1486d8d 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -622,18 +622,6 @@ you would add an element to this alist to transform (not gds-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! (provide 'gds) diff --git a/ice-9/debugging/Makefile.am b/ice-9/debugging/Makefile.am index 5fbe9c6de..44d86d3cf 100644 --- a/ice-9/debugging/Makefile.am +++ b/ice-9/debugging/Makefile.am @@ -22,8 +22,8 @@ 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 \ +ice9_debugging_sources = example-fns.scm \ + ice-9-debugger-extensions.scm \ steps.scm trace.scm traps.scm trc.scm subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging diff --git a/ice-9/debugging/breakpoints.scm b/ice-9/debugging/breakpoints.scm deleted file mode 100644 index 132746f17..000000000 --- a/ice-9/debugging/breakpoints.scm +++ /dev/null @@ -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. diff --git a/ice-9/debugging/load-hooks.scm b/ice-9/debugging/load-hooks.scm deleted file mode 100644 index fb869ed23..000000000 --- a/ice-9/debugging/load-hooks.scm +++ /dev/null @@ -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)) diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index d3d6146e9..960015abd 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -1,7 +1,6 @@ (define-module (ice-9 gds-client) #:use-module (oop goops) #:use-module (oop goops describe) - #:use-module (ice-9 debugging breakpoints) #:use-module (ice-9 debugging trace) #:use-module (ice-9 debugging traps) #:use-module (ice-9 debugging trc) @@ -12,7 +11,6 @@ #:use-module (ice-9 string-fun) #:export (gds-debug-trap run-utility - set-gds-breakpoints gds-accept-input)) (cond ((string>=? (version) "1.7") @@ -383,7 +381,6 @@ Thanks!\n\n" ;; Another complete expression read; add ;; it to the list. (begin - (for-each-breakpoint setup-after-read x) (if (and (pair? x) (memq 'debug flags)) (install-trap (make <source-trap> @@ -400,11 +397,7 @@ Thanks!\n\n" (display " to evaluate\n") (apply display-error #f (current-output-port) args))) - ("error-in-read")))))))) - (if (string? port-name) - (without-traps - (lambda () - (for-each-breakpoint setup-after-eval port-name))))) + ("error-in-read"))))))))) (cdr protocol))) ((complete) @@ -441,83 +434,9 @@ Thanks!\n\n" (gds-debug-trap last-lazy-trap-context) (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 (error "Unexpected protocol:" protocol)))) -(define breakpoints (make-hash-table 11)) - (define (resolve-module-from-root name) (save-module-excursion (lambda () @@ -591,18 +510,13 @@ Thanks!\n\n" (apply throw key args)) (define (run-utility) - (set-gds-breakpoints) + (connect-to-gds) (write (getpid)) (newline) (force-output) (named-module-use! '(guile-user) '(ice-9 session)) (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>)) (let loop ((description (list (class-name (class-of trap)))) (next 'installed?)) |