[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-80-g39
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-80-g3932bdb |
|
Date: |
Fri, 24 Sep 2010 18:54:05 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=3932bdb3af23f2d04502c3fcb8cbe50e6d5b7e6d
The branch, master has been updated
via 3932bdb3af23f2d04502c3fcb8cbe50e6d5b7e6d (commit)
via 925c1bae1f4c23f4f320db00e2b0974b8cfa9b26 (commit)
via 178e9d237b6522ba8f72162949d9b925f6750266 (commit)
via d2c7e7de405682c043c8e4f2d7285824aafca71f (commit)
via 3b494f511ad6966acfa5bad751e27b152254fad5 (commit)
via a1652dec108b7b500146a57a99cd8aeb90e98ea9 (commit)
from 3e2c5f1ef32bee8cf0d728de558dbdd22316c966 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 3932bdb3af23f2d04502c3fcb8cbe50e6d5b7e6d
Author: Andy Wingo <address@hidden>
Date: Fri Sep 24 20:49:46 2010 +0200
remove a number of debug options
* libguile/private-options.h (SCM_BREAKPOINTS_P, SCM_TRACE_P)
(SCM_REC_PROCNAMES_P, SCM_BACKTRACE_INDENT, SCM_N_FRAMES)
(SCM_BACKTRACE_MAXDEPTH, SCM_DEVAL_P): Remove these internal names.
* libguile/eval.c (scm_debug_opts): Remove the corresponding debug
options -- breakpoints, trace, procnames, indent, frames, maxdepth,
and debug.
* libguile/debug.c (scm_debug_options): Remove SCM_N_FRAMES check.
* test-suite/lib.scm (with-debugging-evaluator*):
* module/scripts/summarize-guile-TODO.scm:
* module/statprof.scm (statprof-reset):
* module/ice-9/boot-9.scm (turn-on-debugging): Remove useless
debug-enable 'debug calls.
* module/ice-9/deprecated.scm (debug-enable): As it seems that 'debug is
a particulatly common option that we just removed, add a deprecation
shim.
* doc/ref/api-options.texi (Debugger options): Update the set of debug
options.
commit 925c1bae1f4c23f4f320db00e2b0974b8cfa9b26
Author: Andy Wingo <address@hidden>
Date: Fri Sep 24 18:44:21 2010 +0200
remove evaluator-traps-interface
* libguile/debug.h:
* libguile/debug.c (scm_with_traps):
* libguile/eval.c (scm_evaluator_traps, scm_evaluator_trap_table):
Remove these procedures. Note that scm_evaluator_traps was known in
Scheme as `evaluator-traps-interface'.
* libguile/private-options.h (SCM_TRAPS_P, SCM_ENTER_FRAME_P)
(SCM_APPLY_FRAME_P, SCM_EXIT_FRAME_P, SCM_ENTER_FRAME_HDLR)
(SCM_APPLY_FRAME_HDLR, SCM_EXIT_FRAME_HDLR, SCM_MEMOIZE_P)
(SCM_MEMOIZE_HDLR): Remove these private interfaces.
* module/ice-9/boot-9.scm (traps, trap-enable, trap-disable, trap-set!):
Remove.
* module/ice-9/scm-style-repl.scm (error-catching-loop): Remove
with-traps wrap.
* doc/ref/api-options.texi (Low level options interfaces):
(User level options interfaces, Evaluator trap options)
* doc/ref/api-evaluation.texi (Evaluator Behavior): Remove references to
the evaluator traps interface.
commit 178e9d237b6522ba8f72162949d9b925f6750266
Author: Andy Wingo <address@hidden>
Date: Fri Sep 24 18:34:02 2010 +0200
remove GDS
It is with a sigh that I do this. Farewell, old friend GDS; your bits
will live on, reclaimed and reused in the new debugger.
* module/Makefile.am:
* module/ice-9/gds-client.scm:
* module/ice-9/gds-server.scm: Remove these; we favor Geiser now.
* emacs/Makefile.am:
* emacs/gds-faq.txt:
* emacs/gds-scheme.el:
* emacs/gds-server.el:
* emacs/gds-test.el:
* emacs/gds-test.sh:
* emacs/gds-test.stdin:
* emacs/gds-tutorial.txt:
* emacs/gds.el: Remove GDS files. The docs are still around, as they
need to be folded into the docmentation of the new debugger.
commit d2c7e7de405682c043c8e4f2d7285824aafca71f
Author: Andy Wingo <address@hidden>
Date: Fri Sep 24 18:24:41 2010 +0200
remove (ice-9 debugger) and (ice-9 debugging)
* module/ice-9/debugger.scm:
* module/ice-9/debugger/command-loop.scm:
* module/ice-9/debugger/commands.scm:
* module/ice-9/debugger/state.scm:
* module/ice-9/debugger/trc.scm:
* module/ice-9/debugger/utils.scm:
* module/ice-9/debugging/breakpoints.scm:
* module/ice-9/debugging/example-fns.scm:
* module/ice-9/debugging/ice-9-debugger-extensions.scm:
* module/ice-9/debugging/load-hooks.scm:
* module/ice-9/debugging/steps.scm:
* module/ice-9/debugging/trace.scm:
* module/ice-9/debugging/traps.scm:
* module/ice-9/debugging/trc.scm: Remove these files, as we will favor
the REPL's implementation of a debugger, and (system vm traps) and
(system vm trap-state). But these old files will continue to inspire
the rest of the new debugger interface.
commit 3b494f511ad6966acfa5bad751e27b152254fad5
Author: Andy Wingo <address@hidden>
Date: Fri Sep 24 18:09:47 2010 +0200
remove eval-options
* libguile/eval.c:
* libguile/private-options.h (scm_eval_opts, scm_eval_options_interface)
(SCM_EVAL_STACK): Remove these private interfaces.
* module/ice-9/boot-9.scm (eval-options, eval-enable, eval-disable)
(eval-set!): Remove these procedures.
* doc/ref/api-evaluation.texi:
* doc/ref/api-options.texi: Remove references to eval options.
commit a1652dec108b7b500146a57a99cd8aeb90e98ea9
Author: Andy Wingo <address@hidden>
Date: Fri Sep 24 18:04:05 2010 +0200
api-debug.texi updates
* doc/ref/api-debug.texi (Debugging, Evaluation Model)
(Source Properties): Fixes.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-debug.texi | 40 +-
doc/ref/api-evaluation.texi | 75 --
doc/ref/api-options.texi | 145 +---
emacs/Makefile.am | 7 +-
emacs/gds-faq.txt | 225 -----
emacs/gds-scheme.el | 540 -----------
emacs/gds-server.el | 109 ---
emacs/gds-test.el | 166 ----
emacs/gds-test.sh | 2 -
emacs/gds-test.stdin | 1 -
emacs/gds-tutorial.txt | 223 -----
emacs/gds.el | 639 -------------
libguile/debug.c | 43 -
libguile/debug.h | 2 -
libguile/eval.c | 87 --
libguile/private-options.h | 44 +-
module/Makefile.am | 13 -
module/ice-9/boot-9.scm | 11 -
module/ice-9/debugger.scm | 167 ----
module/ice-9/debugger/command-loop.scm | 552 -----------
module/ice-9/debugger/commands.scm | 208 ----
module/ice-9/debugger/state.scm | 47 -
module/ice-9/debugger/trc.scm | 63 --
module/ice-9/debugger/utils.scm | 203 ----
module/ice-9/debugging/breakpoints.scm | 414 --------
module/ice-9/debugging/example-fns.scm | 17 -
module/ice-9/debugging/load-hooks.scm | 33 -
module/ice-9/debugging/steps.scm | 106 --
module/ice-9/debugging/trace.scm | 153 ---
module/ice-9/debugging/traps.scm | 1011 --------------------
module/ice-9/debugging/trc.scm | 63 --
module/ice-9/deprecated.scm | 11 +
module/ice-9/gds-client.scm | 583 -----------
module/ice-9/gds-server.scm | 188 ----
module/ice-9/scm-style-repl.scm | 22 +-
module/scripts/summarize-guile-TODO.scm | 4 +-
module/statprof.scm | 1 -
test-suite/lib.scm | 3 +-
38 files changed, 62 insertions(+), 6159 deletions(-)
delete mode 100755 emacs/gds-faq.txt
delete mode 100755 emacs/gds-scheme.el
delete mode 100644 emacs/gds-server.el
delete mode 100644 emacs/gds-test.el
delete mode 100755 emacs/gds-test.sh
delete mode 100644 emacs/gds-test.stdin
delete mode 100755 emacs/gds-tutorial.txt
delete mode 100644 emacs/gds.el
delete mode 100644 module/ice-9/debugger.scm
delete mode 100644 module/ice-9/debugger/command-loop.scm
delete mode 100644 module/ice-9/debugger/commands.scm
delete mode 100644 module/ice-9/debugger/state.scm
delete mode 100644 module/ice-9/debugger/trc.scm
delete mode 100644 module/ice-9/debugger/utils.scm
delete mode 100644 module/ice-9/debugging/breakpoints.scm
delete mode 100644 module/ice-9/debugging/example-fns.scm
delete mode 100644 module/ice-9/debugging/ice-9-debugger-extensions.scm
delete mode 100644 module/ice-9/debugging/load-hooks.scm
delete mode 100644 module/ice-9/debugging/steps.scm
delete mode 100644 module/ice-9/debugging/trace.scm
delete mode 100755 module/ice-9/debugging/traps.scm
delete mode 100644 module/ice-9/debugging/trc.scm
delete mode 100755 module/ice-9/gds-client.scm
delete mode 100644 module/ice-9/gds-server.scm
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index c1730a1..3f22e14 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -10,8 +10,8 @@
@cindex Debugging
In order to understand Guile's debugging facilities, you first need to
understand a little about how Guile represent the Scheme control stack.
-With that in place we explain the low level trap calls that the
-evaluator can be configured to make, and the trap and breakpoint
+With that in place we explain the low level trap calls that the virtual
+machine can be configured to make, and the trap and breakpoint
infrastructure that builds on top of those calls.
@menu
@@ -26,10 +26,10 @@ infrastructure that builds on top of those calls.
The idea of the Scheme stack is central to a lot of debugging. The
Scheme stack is a reified representation of the pending function returns
-in an expression's continuation. As Guile implements function calls
+in an expression's continuation. As Guile implements function calls
using a stack, this reification takes the form of a number of nested
-stack frames, each of which has the procedure and its arguments, along
-with local variables and temporary values.
+stack frames, each of which corresponds to the application of a
+procedure to a set of arguments.
A Scheme stack always exists implicitly, and can be summoned into
concrete existence as a first-class Scheme value by the
@@ -53,10 +53,10 @@ function will not be on the stack, as it has no work left
to do.
Therefore, when an error occurs in a running program, or the program
hits a breakpoint, or in fact at any point that the programmer chooses,
its state at that point can be represented by a @dfn{stack} of all the
-evaluations and procedure applications that are logically in progress at
-that time, each of which is known as a @dfn{frame}. The programmer can
-learn more about the program's state at that point by inspecting the
-stack and its frames.
+procedure applications that are logically in progress at that time, each
+of which is known as a @dfn{frame}. The programmer can learn more about
+the program's state at that point by inspecting the stack and its
+frames.
@menu
* Capturing the Stack or Innermost Stack Frame::
@@ -76,7 +76,7 @@ describes the Scheme stack at that point.
@lisp
(make-stack #t)
@result{}
-#<stack 805c840:808d250>
+#<stack 25205a0>
@end lisp
@deffn {Scheme Procedure} make-stack obj . args
@@ -206,20 +206,18 @@ can be seen by typing @code{(xxx)} and @code{xxx} at the
Guile prompt
(where the variable @code{xxx} has not been defined):
@example
-guile> (xxx)
-standard input:2:1: In expression (xxx):
-standard input:2:1: Unbound variable: xxx
-ABORT: (unbound-variable)
-guile> xxx
-<unnamed port>: In expression xxx:
-<unnamed port>: Unbound variable: xxx
-ABORT: (unbound-variable)
+scheme@@(guile-user)> (xxx)
+<unnamed port>:4:1: In procedure module-lookup:
+<unnamed port>:4:1: Unbound variable: xxx
+
+scheme@@(guile-user)> xxx
+ERROR: In procedure module-lookup:
+ERROR: Unbound variable: xxx
@end example
@noindent
-In the latter case, no source properties were stored, so the best that
-Guile could say regarding the location of the problem was ``<unnamed
-port>''.
+In the latter case, no source properties were stored, so the error
+doesn't have any source information.
The recording of source properties is controlled by the read option
named ``positions'' (@pxref{Reader options}). This option is switched
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 2e7d9dd..036e92a 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -18,7 +18,6 @@ loading, evaluating, and compiling Scheme code at run time.
* Loading:: Loading Scheme code from file.
* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
* Delayed Evaluation:: Postponing evaluation until it is needed.
-* Evaluator Behaviour:: Modifying Guile's evaluator.
* VM Behaviour:: Modifying Guile's virtual machine.
@end menu
@@ -789,80 +788,6 @@ value.
@end deffn
address@hidden Evaluator Behaviour
address@hidden Evaluator Behaviour
-
address@hidden FIXME::martin: Maybe this node name is bad, but the old name
clashed with
address@hidden `Evaluator options' under `Options and Config'.
-
-The behaviour of Guile's evaluator can be modified by manipulating the
-evaluator options. For more information about options, @xref{User level
-options interfaces}. If you want to know which evaluator options are
-available, @xref{Evaluator options}.
-
address@hidden FIXME::martin: This is taken from libguile/options.c. Is there
address@hidden actually a difference between 'help and 'full?
-
address@hidden {Scheme Procedure} eval-options [setting]
-Display the current settings of the evaluator options. If @var{setting}
-is omitted, only a short form of the current evaluator options is
-printed. Otherwise, @var{setting} should be one of the following
-symbols:
address@hidden @code
address@hidden help
-Display the complete option settings.
address@hidden full
-Like @code{help}, but also print programmer options.
address@hidden table
address@hidden deffn
-
address@hidden {Scheme Procedure} eval-enable option-name
address@hidden {Scheme Procedure} eval-disable option-name
address@hidden {Scheme Procedure} eval-set! option-name value
-Modify the evaluator options. @code{eval-enable} should be used with boolean
-options and switches them on, @code{eval-disable} switches them off.
address@hidden can be used to set an option to a specific value.
address@hidden deffn
-
address@hidden {Scheme Procedure} eval-options-interface [setting]
address@hidden {C Function} scm_eval_options_interface (setting)
-Option interface for the evaluation options. Instead of using
-this procedure directly, use the procedures @code{eval-enable},
address@hidden, @code{eval-set!} and @code{eval-options}.
address@hidden deffn
-
address@hidden FIXME::martin: Why aren't these procedure named like the other
options
address@hidden procedures?
-
address@hidden {Scheme Procedure} traps [setting]
-Display the current settings of the evaluator traps options. If
address@hidden is omitted, only a short form of the current evaluator
-traps options is printed. Otherwise, @var{setting} should be one of the
-following symbols:
address@hidden @code
address@hidden help
-Display the complete option settings.
address@hidden full
-Like @code{help}, but also print programmer options.
address@hidden table
address@hidden deffn
-
address@hidden {Scheme Procedure} trap-enable option-name
address@hidden {Scheme Procedure} trap-disable option-name
address@hidden {Scheme Procedure} trap-set! option-name value
-Modify the evaluator options. @code{trap-enable} should be used with boolean
-options and switches them on, @code{trap-disable} switches them off.
address@hidden can be used to set an option to a specific value.
-
-See @ref{Evaluator trap options} for more information on the available
-trap handlers.
address@hidden deffn
-
address@hidden {Scheme Procedure} evaluator-traps-interface [setting]
address@hidden {C Function} scm_evaluator_traps (setting)
-Option interface for the evaluator trap options.
address@hidden deffn
-
@node VM Behaviour
@subsection VM Behaviour
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index 6a3aa2f..b046633 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -392,8 +392,6 @@ configure @emph{reading}, @emph{printing}, @emph{debugging}
or
* Reader options::
* Printing options::
* Debugger options::
-* Evaluator options::
-* Evaluator trap options::
* Examples of option use::
@end menu
@@ -402,15 +400,11 @@ configure @emph{reading}, @emph{printing},
@emph{debugging} or
@subsubsection Low Level Options Interfaces
@deffn {Scheme Procedure} read-options-interface [setting]
address@hidden {Scheme Procedure} eval-options-interface [setting]
@deffnx {Scheme Procedure} print-options-interface [setting]
@deffnx {Scheme Procedure} debug-options-interface [setting]
address@hidden {Scheme Procedure} evaluator-traps-interface [setting]
@deffnx {C Function} scm_read_options (setting)
address@hidden {C Function} scm_eval_options_interface (setting)
@deffnx {C Function} scm_print_options (setting)
@deffnx {C Function} scm_debug_options (setting)
address@hidden {C Function} scm_evaluator_traps (setting)
If one of these procedures is called with no arguments (or with
@code{setting == SCM_UNDEFINED} in C code), it returns a list describing
the current setting of the read, eval, print, debug or evaluator traps
@@ -445,7 +439,6 @@ set of options.
@deffnx {Scheme Procedure} read-options [arg]
@deffnx {Scheme Procedure} print-options [arg]
@deffnx {Scheme Procedure} debug-options [arg]
address@hidden {Scheme Procedure} traps [arg]
These functions list the options in their group. The optional argument
@var{arg} is a symbol which modifies the form in which the options are
presented.
@@ -467,7 +460,6 @@ up?]
@deffnx {Scheme Procedure} read-enable option-symbol
@deffnx {Scheme Procedure} print-enable option-symbol
@deffnx {Scheme Procedure} debug-enable option-symbol
address@hidden {Scheme Procedure} trap-enable option-symbol
These functions set the specified @var{option-symbol} in their options
group. They only work if the option is boolean, and throw an error
otherwise.
@@ -478,7 +470,6 @@ otherwise.
@deffnx {Scheme Procedure} read-disable option-symbol
@deffnx {Scheme Procedure} print-disable option-symbol
@deffnx {Scheme Procedure} debug-disable option-symbol
address@hidden {Scheme Procedure} trap-disable option-symbol
These functions turn off the specified @var{option-symbol} in their
options group. They only work if the option is boolean, and throw an
error otherwise.
@@ -489,7 +480,6 @@ error otherwise.
@deffnx syntax read-set! option-symbol value
@deffnx syntax print-set! option-symbol value
@deffnx syntax debug-set! option-symbol value
address@hidden syntax trap-set! option-symbol value
These functions set a non-boolean @var{option-symbol} to the specified
@var{value}.
@end deffn
@@ -548,112 +538,6 @@ closure-hook #f Hook for printing
closures.
@end smallexample
address@hidden Evaluator options
address@hidden Evaluator options
-
-These are the evaluator options with their default values, as they are
-printed by typing @code{(eval-options 'full)} in Guile.
-
address@hidden
-stack 22000 Size of thread stacks (in machine words).
address@hidden smallexample
-
-
address@hidden Evaluator trap options
address@hidden Evaluator trap options
-[FIXME: These flags, together with their corresponding handlers, are not
-user level options. Probably this entire section should be moved to the
-documentation about the low-level programmer debugging interface.]
-
-Here is the list of evaluator trap options generated by typing
address@hidden(traps 'full)} in Guile. You can also see the default values.
-
address@hidden
-exit-frame no Trap when exiting eval or apply.
-apply-frame no Trap when entering apply.
-enter-frame no Trap when eval enters new frame.
-memoize-symbol no Trap when eval memoizes a symbol's value
-traps yes Enable evaluator traps.
address@hidden smallexample
-
address@hidden apply-frame-handler key cont tailp
-Called when a procedure is being applied.
-
-Called if:
-
address@hidden @bullet
address@hidden
-evaluator traps are enabled [traps interface], and
address@hidden
-either
address@hidden @minus
address@hidden
address@hidden is enabled [traps interface], or
address@hidden
-trace mode is on [debug-options interface], and the procedure being
-called has the trace property enabled.
address@hidden itemize
address@hidden itemize
-
address@hidden is a ``debug object'', which means that it can be passed to
address@hidden to discover the stack at the point of the trap. The
-apply frame handler's code can capture a restartable continuation if it
-wants to by using @code{call-with-current-continuation} in the usual way.
-
address@hidden is true if this is a tail call
address@hidden deffn
-
address@hidden exit-frame-handler key cont retval
-Called when a value is returned from a procedure.
-
-Called if:
-
address@hidden @bullet
address@hidden
-evaluator traps are enabled [traps interface], and
address@hidden
-either
address@hidden @minus
address@hidden
- @code{exit-frame} is enabled [traps interface], or
address@hidden
-trace mode is on [debug-options interface], and the procedure being
-called has the trace property enabled.
address@hidden itemize
address@hidden itemize
-
address@hidden is a ``debug object'', which means that it can be passed to
address@hidden to discover the stack at the point of the trap. The
-exit frame handler's code can capture a restartable continuation if it
-wants to by using @code{call-with-current-continuation} in the usual
-way.
-
address@hidden is the return value.
address@hidden deffn
-
address@hidden memoize-symbol-handler key cont expression env
-Called when the evaluator memoizes the value of a procedure symbol
-
address@hidden is a ``debug object'', which means that it can be passed to
address@hidden to discover the stack at the point of the trap. The
-exit frame handler's code can capture a restartable continuation if it
-wants to by using @code{call-with-current-continuation} in the usual
-way.
-
address@hidden is the return value.
address@hidden deffn
-
address@hidden {Scheme Procedure} with-traps thunk
address@hidden {C Function} scm_with_traps (thunk)
-Call @var{thunk} with traps enabled.
address@hidden deffn
-
address@hidden {Scheme Procedure} debug-object? obj
address@hidden {C Function} scm_debug_object_p (obj)
-Return @code{#t} if @var{obj} is a debug object.
address@hidden deffn
-
-
@node Debugger options
@subsubsection Debugger options
@@ -662,18 +546,15 @@ Here is the list of print options generated by typing
values.
@smallexample
-stack 20000 Stack size limit (0 = no check).
-debug yes Use the debugging evaluator.
-backtrace no Show backtrace on error.
-depth 20 Maximal length of printed backtrace.
-maxdepth 1000 Maximal number of stored backtrace frames.
-frames 3 Maximum number of tail-recursive frames in backtrace.
-indent 10 Maximal indentation in backtrace.
-backwards no Display backtrace in anti-chronological order.
-procnames yes Record procedure names at definition.
-trace no *Trace mode.
-breakpoints no *Check for breakpoints.
-cheap yes *This option is now obsolete. Setting it has no
effect.
+warn-deprecated no Warn when deprecated features are used.
+show-file-name #t Show file names and line numbers in backtraces
+ when not `#f'. A value of `base' displays only
+ base names, while `#t' displays full names.
+stack 1048576 Stack size limit (measured in words; 0 = no check).
+backtrace yes Show backtrace on error.
+depth 20 Maximal length of printed backtrace.
+width 79 Maximal width of backtrace.
+backwards no Display backtrace in anti-chronological order.
@end smallexample
@subsubheading Stack overflow
@@ -753,17 +634,9 @@ positions yes Record positions of source code
expressions.
copy no Copy source code expressions.
guile> (debug-options 'help)
stack 20000 Stack size limit (0 = no check).
-debug yes Use the debugging evaluator.
backtrace no Show backtrace on error.
depth 20 Maximal length of printed backtrace.
-maxdepth 1000 Maximal number of stored backtrace frames.
-frames 3 Maximum number of tail-recursive frames in backtrace.
-indent 10 Maximal indentation in backtrace.
backwards no Display backtrace in anti-chronological order.
-procnames yes Record procedure names at definition.
-trace no *Trace mode.
-breakpoints no *Check for breakpoints.
-cheap yes *This option is now obsolete. Setting it has no effect.
guile> (read-enable 'case-insensitive)
(keywords #f case-insensitive positions)
guile> aBc
diff --git a/emacs/Makefile.am b/emacs/Makefile.am
index e18f30b..69bab13 100644
--- a/emacs/Makefile.am
+++ b/emacs/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+## Copyright (C) 2006, 2008, 2010 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -21,7 +21,4 @@
AUTOMAKE_OPTIONS = gnu
-dist_lisp_LISP = gds.el gds-server.el gds-scheme.el
-ELCFILES =
-
-ETAGS_ARGS = $(dist_lisp_LISP) ChangeLog-2008
+ETAGS_ARGS = ChangeLog-2008
diff --git a/emacs/gds-faq.txt b/emacs/gds-faq.txt
deleted file mode 100755
index b60a2c9..0000000
--- a/emacs/gds-faq.txt
+++ /dev/null
@@ -1,225 +0,0 @@
-
-* Installation
-
-** How do I install guile-debugging?
-
-After unpacking the .tar.gz file, run the usual sequence of commands:
-
-$ ./configure
-$ make
-$ sudo make install
-
-Then you need to make sure that the directory where guile-debugging's
-Scheme files were installed is included in your Guile's load path.
-(The sequence above will usually install guile-debugging under
-/usr/local, and /usr/local is not in Guile's load path by default,
-unless Guile itself was installed under /usr/local.) You can discover
-your Guile's default load path by typing
-
-$ guile -q -c '(begin (write %load-path) (newline))'
-
-There are two ways to add guile-debugging's installation directory to
-Guile's load path, if it isn't already there.
-
-1. Edit or create the `init.scm' file, which Guile reads on startup,
- so that it includes a line like this:
-
- (set! %load-path (cons "/usr/local/share/guile" %load-path))
-
- but with "/usr/local" replaced by the prefix that you installed
- guile-debugging under, if not /usr/local.
-
- The init.scm file must be installed (if it does not already exist
- there) in one of the directories in Guile's default load-path.
-
-2. Add this line to your .emacs file:
-
- (setq gds-scheme-directory "/usr/local/share/guile")
-
- before the `require' or `load' line that loads GDS, but with
- "/usr/local" replaced by the prefix that you installed
- guile-debugging under, if not /usr/local.
-
-Finally, if you want guile-debugging's GDS interface to be loaded
-automatically whenever you run Emacs, add this line to your .emacs:
-
-(require 'gds)
-
-* Troubleshooting
-
-** "error in process filter" when starting Emacs (or loading GDS)
-
-This is caused by an internal error in GDS's Scheme code, for which a
-backtrace will have appeared in the gds-debug buffer, so please switch
-to the gds-debug buffer and see what it says there.
-
-The most common cause is a load path problem: Guile cannot find GDS's
-Scheme code because it is not in the known load path. In this case
-you should see the error message "no code for module" somewhere in the
-backtrace. If you see this, please try the remedies described in `How
-do I install guile-debugging?' above, then restart Emacs and see if
-the problem has been cured.
-
-If you don't see "no code for module", or if the described remedies
-don't fix the problem, please send the contents of the gds-debug
-buffer to me at <address@hidden>, so I can debug the problem.
-
-If you don't see a backtrace at all in the gds-debug buffer, try the
-next item ...
-
-** "error in process filter" at some other time
-
-This is caused by an internal error somewhere in GDS's Emacs Lisp
-code. If possible, please
-
-- switch on the `debug-on-error' option (M-x set-variable RET
- debug-on-error RET t RET)
-
-- do whatever you were doing so that the same error happens again
-
-- send the Emacs Lisp stack trace which pops up to me at
- <address@hidden>.
-
-If that doesn't work, please just mail me with as much detail as
-possible of what you were doing when the error occurred.
-
-* GDS Features
-
-** How do I inspect variable values?
-
-Type `e' followed by the name of the variable, then <RET>. This
-works whenever GDS is displaying a stack for an error at at a
-breakpoint. (You can actually `e' to evaluate any expression in the
-local environment of the selected stack frame; inspecting variables is
-the special case of this where the expression is only a variable name.)
-
-If GDS is displaying the associated source code in the window above or
-below the stack, you can see the values of any variables in the
-highlighted code just by hovering your mouse over them.
-
-** How do I change a variable's value?
-
-Type `e' and then `(set! VARNAME NEWVAL)', where VARNAME is the name
-of the variable you want to set and NEWVAL is an expression which
-Guile can evaluate to get the new value. This works whenever GDS is
-displaying a stack for an error at at a breakpoint. The setting will
-take effect in the local environment of the selected stack frame.
-
-** How do I change the expression that Guile is about to evaluate?
-
-Type `t' followed by the expression that you want Guile to evaluate
-instead, then <RET>.
-
-Then type one of the commands that tells Guile to continue execution.
-
-(Tweaking expressions, as described here, is only supported by the
-latest CVS version of Guile. The GDS stack display tells you when
-tweaking is possible by adding "(tweakable)" to the first line of the
-stack window.)
-
-** How do I return a value from the current stack frame different to what the
evaluator has calculated?
-
-You have to be at the normal exit of the relevant frame first, so if
-GDS is not already showing you the normally calculated return value,
-type `o' to finish the evaluation of the selected frame.
-
-Then type `t' followed by the value you want to return, and <RET>.
-The value that you type can be any expression, but note that it will
-not be evaluated before being returned; for example if you type `(+ 2
-3)', the return value will be a three-element list, not 5.
-
-Finally type one of the commands that tells Guile to continue
-execution.
-
-(Tweaking return values, as described here, is only supported by the
-latest CVS version of Guile. The GDS stack display tells you when
-tweaking is possible by adding "(tweakable)" to the first line of the
-stack window.)
-
-** How do I step over a line of code?
-
-Scheme isn't organized by lines, so it doesn't really make sense to
-think of stepping over lines. Instead please see the next entry on
-stepping over expressions.
-
-** How do I step over an expression?
-
-It depends what you mean by "step over". If you mean that you want
-Guile to evaluate that expression normally, but then show you its
-return value, type `o', which does exactly that.
-
-If you mean that you want to skip the evaluation of that expression
-(for example because it has side effects that you don't want to
-happen), use `t' to change the expression to something else which
-Guile will evaluate instead.
-
-There has to be a substitute expression so Guile can calculate a value
-to return to the calling frame. If you know at a particular point
-that the return value is not important, you can type `t #f <RET>' or
-`t 0 <RET>'.
-
-See `How do I change the expression that Guile is about to evaluate?'
-above for more on using `t'.
-
-** How do I move up and down the call stack?
-
-Type `u' to move up and `d' to move down. "Up" in GDS means to a more
-"inner" frame, and "down" means to a more "outer" frame.
-
-** How do I run until the next breakpoint?
-
-Type `g' (for "go").
-
-** How do I run until the end of the selected stack frame?
-
-Type `o'.
-
-** How do I set a breakpoint?
-
-First identify the code that you want to set the breakpoint in, and
-what kind of breakpoint you want. To set a breakpoint on entry to a
-top level procedure, move the cursor to anywhere in the procedure
-definition, and make sure that the region/mark is inactive. To set a
-breakpoint on a particular expression (or sequence of expressions) set
-point and mark so that the region covers the opening parentheses of
-all the target expressions.
-
-Then type ...
-
- `C-c C-b d' for a `debug' breakpoint, which means that GDS will
- display the stack when the breakpoint is hit
-
- `C-c C-b t' for a `trace' breakpoint, which means that the start and
- end of the relevant procedure or expression(s) will be traced to the
- *GDS Trace* buffer
-
- `C-c C-b T' for a `trace-subtree' breakpoint, which means that every
- evaluation step involved in the evaluation of the relevant procedure
- or expression(s) will be traced to the *GDS Trace* buffer.
-
-You can also type `C-x <SPC>', which does the same as one of the
-above, depending on the value of `gds-default-breakpoint-type'.
-
-** How do I clear a breakpoint?
-
-Select a region containing the breakpoints that you want to clear, and
-type `C-c C-b <DEL>'.
-
-** How do I trace calls to a particular procedure or evaluations of a
particular expression?
-
-In GDS this means setting a breakpoint whose type is `trace' or
-`trace-subtree'. See `How do I set a breakpoint?' above.
-
-* Development
-
-** How can I follow or contribute to guile-debugging's development?
-
-guile-debugging is hosted at http://gna.org, so please see the project
-page there. Feel free to raise bugs, tasks containing patches or
-feature requests, and so on. You can also write directly to me by
-email: <address@hidden>.
-
-
-Local Variables:
-mode: outline
-End:
diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el
deleted file mode 100755
index 326d152..0000000
--- a/emacs/gds-scheme.el
+++ /dev/null
@@ -1,540 +0,0 @@
-;;; gds-scheme.el -- GDS function for Scheme mode buffers
-
-;;;; 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 3 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
-
-(require 'comint)
-(require 'scheme)
-(require 'derived)
-(require 'pp)
-
-;;;; Maintaining an association between a Guile client process and a
-;;;; set of Scheme mode buffers.
-
-(defcustom gds-auto-create-utility-client t
- "Whether to automatically create a utility Guile client, and
-associate the current buffer with it, if there are no existing Guile
-clients available to GDS when the user does something that requires a
-running Guile client."
- :type 'boolean
- :group 'gds)
-
-(defcustom gds-auto-associate-single-client t
- "Whether to automatically associate the current buffer with an
-existing Guile client, if there is only only client known to GDS when
-the user does something that requires a running Guile client, and the
-current buffer is not already associated with a Guile client."
- :type 'boolean
- :group 'gds)
-
-(defcustom gds-auto-associate-last-client t
- "Whether to automatically associate the current buffer with the
-Guile client that most recently caused that buffer to be displayed,
-when the user does something that requires a running Guile client and
-the current buffer is not already associated with a Guile client."
- :type 'boolean
- :group 'gds)
-
-(defvar gds-last-touched-by nil
- "For each Scheme mode buffer, this records the GDS client that most
-recently `touched' that buffer in the sense of using it to display
-source code, for example for the source code relevant to a debugger
-stack frame.")
-(make-variable-buffer-local 'gds-last-touched-by)
-
-(defun gds-auto-associate-buffer ()
- "Automatically associate the current buffer with a Guile client, if
-possible."
- (let* ((num-clients (length gds-client-info))
- (client
- (or
- ;; If there are no clients yet, and
- ;; `gds-auto-create-utility-client' allows us to create one
- ;; automatically, do that.
- (and (= num-clients 0)
- gds-auto-create-utility-client
- (gds-start-utility-guile))
- ;; Otherwise, if there is a single existing client, and
- ;; `gds-auto-associate-single-client' allows us to use it
- ;; for automatic association, do that.
- (and (= num-clients 1)
- gds-auto-associate-single-client
- (caar gds-client-info))
- ;; Otherwise, if the current buffer was displayed because
- ;; of a Guile client trapping somewhere in its code, and
- ;; `gds-auto-associate-last-client' allows us to associate
- ;; with that client, do so.
- (and gds-auto-associate-last-client
- gds-last-touched-by))))
- (if client
- (gds-associate-buffer client))))
-
-(defun gds-associate-buffer (client)
- "Associate the current buffer with the Guile process CLIENT.
-This means that operations in this buffer that require a running Guile
-process - such as evaluation, help, completion and setting traps -
-will be sent to the Guile process whose name or connection number is
-CLIENT."
- (interactive (list (gds-choose-client)))
- ;; If this buffer is already associated, dissociate from its
- ;; existing client first.
- (if gds-client (gds-dissociate-buffer))
- ;; Store the client number in the buffer-local variable gds-client.
- (setq gds-client client)
- ;; Add this buffer to the list of buffers associated with the
- ;; client.
- (gds-client-put client 'associated-buffers
- (cons (current-buffer)
- (gds-client-get client 'associated-buffers))))
-
-(defun gds-dissociate-buffer ()
- "Dissociate the current buffer from any specific Guile process."
- (interactive)
- (if gds-client
- (progn
- ;; Remove this buffer from the list of buffers associated with
- ;; the current client.
- (gds-client-put gds-client 'associated-buffers
- (delq (current-buffer)
- (gds-client-get gds-client 'associated-buffers)))
- ;; Reset the buffer-local variable gds-client.
- (setq gds-client nil)
- ;; Clear any process status indication from the modeline.
- (setq mode-line-process nil)
- (force-mode-line-update))))
-
-(defun gds-show-client-status (client status-string)
- "Show a client's status in the modeline of all its associated
-buffers."
- (let ((buffers (gds-client-get client 'associated-buffers)))
- (while buffers
- (if (buffer-live-p (car buffers))
- (with-current-buffer (car buffers)
- (setq mode-line-process status-string)
- (force-mode-line-update)))
- (setq buffers (cdr buffers)))))
-
-(defcustom gds-running-text ":running"
- "*Mode line text used to show that a Guile process is \"running\".
-\"Running\" means that the process cannot currently accept any input
-from the GDS frontend in Emacs, because all of its threads are busy
-running code that GDS cannot easily interrupt."
- :type 'string
- :group 'gds)
-
-(defcustom gds-ready-text ":ready"
- "*Mode line text used to show that a Guile process is \"ready\".
-\"Ready\" means that the process is ready to interact with the GDS
-frontend in Emacs, because at least one of its threads is waiting for
-GDS input."
- :type 'string
- :group 'gds)
-
-(defcustom gds-debug-text ":debug"
- "*Mode line text used to show that a Guile process is \"debugging\".
-\"Debugging\" means that the process is using the GDS frontend in
-Emacs to display an error or trap so that the user can debug it."
- :type 'string
- :group 'gds)
-
-(defun gds-choose-client ()
- "Ask the user to choose a GDS client process from a list."
- (let ((table '())
- (default nil))
- ;; Prepare a table containing all current clients.
- (mapcar (lambda (client-info)
- (setq table (cons (cons (cadr (memq 'name client-info))
- (car client-info))
- table)))
- gds-client-info)
- ;; Add an entry to allow the user to ask for a new process.
- (setq table (cons (cons "Start a new Guile process" nil) table))
- ;; Work out a good default. If the buffer has a good value in
- ;; gds-last-touched-by, we use that; otherwise default to starting
- ;; a new process.
- (setq default (or (and gds-last-touched-by
- (gds-client-get gds-last-touched-by 'name))
- (caar table)))
- ;; Read using this table.
- (let* ((name (completing-read "Choose a Guile process: "
- table
- nil
- t ; REQUIRE-MATCH
- nil ; INITIAL-INPUT
- nil ; HIST
- default))
- ;; Convert name to a client number.
- (client (cdr (assoc name table))))
- ;; If the user asked to start a new Guile process, do that now.
- (or client (setq client (gds-start-utility-guile)))
- ;; Return the chosen client ID.
- client)))
-
-(defvar gds-last-utility-number 0
- "Number of the last started Guile utility process.")
-
-(defun gds-start-utility-guile ()
- "Start a new utility Guile process."
- (setq gds-last-utility-number (+ gds-last-utility-number 1))
- (let* ((procname (format "gds-util[%d]" gds-last-utility-number))
- (code (format "(begin
- %s
- (use-modules (ice-9 gds-client))
- (run-utility))"
- (if gds-scheme-directory
- (concat "(set! %load-path (cons "
- (format "%S" gds-scheme-directory)
- " %load-path))")
- "")))
- (proc (start-process procname
- (get-buffer-create procname)
- gds-guile-program
- "-q"
- "--debug"
- "-c"
- code)))
- ;; Note that this process can be killed automatically on Emacs
- ;; exit.
- (process-kill-without-query proc)
- ;; Set up a process filter to catch the new client's number.
- (set-process-filter proc
- (lambda (proc string)
- (if (process-buffer proc)
- (with-current-buffer (process-buffer proc)
- (insert string)
- (or gds-client
- (save-excursion
- (goto-char (point-min))
- (setq gds-client
- (condition-case nil
- (read (current-buffer))
- (error nil)))))))))
- ;; Accept output from the new process until we have its number.
- (while (not (with-current-buffer (process-buffer proc) gds-client))
- (accept-process-output proc))
- ;; Return the new process's client number.
- (with-current-buffer (process-buffer proc) gds-client)))
-
-;;;; Evaluating code.
-
-;; The following commands send code for evaluation through the GDS TCP
-;; connection, receive the result and any output generated through the
-;; same connection, and display the result and output to the user.
-;;
-;; For each buffer where evaluations can be requested, GDS uses the
-;; buffer-local variable `gds-client' to track which GDS client
-;; program should receive and handle that buffer's evaluations.
-
-(defun gds-module-name (start end)
- "Determine and return the name of the module that governs the
-specified region. The module name is returned as a list of symbols."
- (interactive "r") ; why not?
- (save-excursion
- (goto-char start)
- (let (module-name)
- (while (and (not module-name)
- (beginning-of-defun-raw 1))
- (if (looking-at "(define-module ")
- (setq module-name
- (progn
- (goto-char (match-end 0))
- (read (current-buffer))))))
- module-name)))
-
-(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
- "Prefix used when telling Guile the name of the port from which a
-chunk of Scheme code (to be evaluated) comes. GDS uses this prefix,
-followed by the buffer name, in two cases: when the buffer concerned
-is not associated with a file, or if the buffer has been modified
-since last saving to its file. In the case where the buffer is
-identical to a saved file, GDS uses the file name as the port name."
- :type '(string)
- :group 'gds)
-
-(defun gds-port-name (start end)
- "Return port name for the specified region of the current buffer.
-The name will be used by Guile as the port name when evaluating that
-region's code."
- (or (and (not (buffer-modified-p))
- buffer-file-name)
- (concat gds-emacs-buffer-port-name-prefix (buffer-name))))
-
-(defun gds-line-and-column (pos)
- "Return 0-based line and column number at POS."
- (let (line column)
- (save-excursion
- (goto-char pos)
- (setq column (current-column))
- (beginning-of-line)
- (setq line (count-lines (point-min) (point))))
- (cons line column)))
-
-(defun gds-eval-region (start end &optional debugp)
- "Evaluate the current region. If invoked with `C-u' prefix (or, in
-a program, with optional DEBUGP arg non-nil), pause and pop up the
-stack at the start of the evaluation, so that the user can single-step
-through the code."
- (interactive "r\nP")
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (let ((module (gds-module-name start end))
- (port-name (gds-port-name start end))
- (lc (gds-line-and-column start)))
- (let ((code (buffer-substring-no-properties start end)))
- (gds-send (format "eval (region . %S) %s %S %d %d %S %s"
- (gds-abbreviated code)
- (if module (prin1-to-string module) "#f")
- port-name (car lc) (cdr lc)
- code
- (if debugp '(debug) '(none)))
- gds-client))))
-
-(defun gds-eval-expression (expr &optional correlator debugp)
- "Evaluate the supplied EXPR (a string). If invoked with `C-u'
-prefix (or, in a program, with optional DEBUGP arg non-nil), pause and
-pop up the stack at the start of the evaluation, so that the user can
-single-step through the code."
- (interactive "sEvaluate expression: \ni\nP")
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (set-text-properties 0 (length expr) nil expr)
- (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s"
- (or correlator 'expression)
- (gds-abbreviated expr)
- expr
- (if debugp '(debug) '(none)))
- gds-client))
-
-(defconst gds-abbreviated-length 35)
-
-(defun gds-abbreviated (code)
- (let ((nlpos (string-match (regexp-quote "\n") code)))
- (while nlpos
- (setq code
- (if (= nlpos (- (length code) 1))
- (substring code 0 nlpos)
- (concat (substring code 0 nlpos)
- "\\n"
- (substring code (+ nlpos 1)))))
- (setq nlpos (string-match (regexp-quote "\n") code))))
- (if (> (length code) gds-abbreviated-length)
- (concat (substring code 0 (- gds-abbreviated-length 3)) "...")
- code))
-
-(defun gds-eval-defun (&optional debugp)
- "Evaluate the defun (top-level form) at point. If invoked with
-`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil),
-pause and pop up the stack at the start of the evaluation, so that the
-user can single-step through the code."
- (interactive "P")
- (save-excursion
- (end-of-defun)
- (let ((end (point)))
- (beginning-of-defun)
- (gds-eval-region (point) end debugp))))
-
-(defun gds-eval-last-sexp (&optional debugp)
- "Evaluate the sexp before point. If invoked with `C-u' prefix (or,
-in a program, with optional DEBUGP arg non-nil), pause and pop up the
-stack at the start of the evaluation, so that the user can single-step
-through the code."
- (interactive "P")
- (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp))
-
-;;;; Help.
-
-;; Help is implemented as a special case of evaluation, identified by
-;; the evaluation correlator 'help.
-
-(defun gds-help-symbol (sym)
- "Get help for SYM (a Scheme symbol)."
- (interactive
- (let ((sym (thing-at-point 'symbol))
- (enable-recursive-minibuffers t)
- val)
- (setq val (read-from-minibuffer
- (if sym
- (format "Describe Guile symbol (default %s): " sym)
- "Describe Guile symbol: ")))
- (list (if (zerop (length val)) sym val))))
- (gds-eval-expression (format "(help %s)" sym) 'help))
-
-(defun gds-apropos (regex)
- "List Guile symbols matching REGEX."
- (interactive
- (let ((sym (thing-at-point 'symbol))
- (enable-recursive-minibuffers t)
- val)
- (setq val (read-from-minibuffer
- (if sym
- (format "Guile apropos (regexp, default \"%s\"): " sym)
- "Guile apropos (regexp): ")))
- (list (if (zerop (length val)) sym val))))
- (set-text-properties 0 (length regex) nil regex)
- (gds-eval-expression (format "(apropos %S)" regex) 'apropos))
-
-;;;; Displaying results of help and eval.
-
-(defun gds-display-results (client correlator stack-available results)
- (let* ((helpp+bufname (cond ((eq (car correlator) 'help)
- '(t . "*Guile Help*"))
- ((eq (car correlator) 'apropos)
- '(t . "*Guile Apropos*"))
- (t
- '(nil . "*Guile Evaluation*"))))
- (helpp (car helpp+bufname)))
- (let ((buf (get-buffer-create (cdr helpp+bufname))))
- (save-selected-window
- (save-excursion
- (set-buffer buf)
- (gds-dissociate-buffer)
- (erase-buffer)
- (scheme-mode)
- (insert (cdr correlator) "\n\n")
- (while results
- (insert (car results))
- (or (bolp) (insert "\\\n"))
- (if helpp
- nil
- (if (cadr results)
- (mapcar (function (lambda (value)
- (insert " => " value "\n")))
- (cadr results))
- (insert " => no (or unspecified) value\n"))
- (insert "\n"))
- (setq results (cddr results)))
- (if stack-available
- (let ((beg (point))
- (map (make-sparse-keymap)))
- (define-key map [mouse-1] 'gds-show-last-stack)
- (define-key map "\C-m" 'gds-show-last-stack)
- (insert "[click here (or RET) to show error stack]")
- (add-text-properties beg (point)
- (list 'keymap map
- 'mouse-face 'highlight))
- (insert "\n")
- (add-text-properties (1- (point)) (point)
- (list 'keymap map))))
- (goto-char (point-min))
- (gds-associate-buffer client))
- (pop-to-buffer buf)
- (run-hooks 'temp-buffer-show-hook)))))
-
-(defun gds-show-last-stack ()
- "Show stack of the most recent error."
- (interactive)
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (gds-send "debug-lazy-trap-context" gds-client))
-
-;;;; Completion.
-
-(defvar gds-completion-results nil)
-
-(defun gds-complete-symbol ()
- "Complete the Guile symbol before point. Returns `t' if anything
-interesting happened, `nil' if not."
- (interactive)
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (let* ((chars (- (point) (save-excursion
- (while (let ((syntax (char-syntax (char-before
(point)))))
- (or (eq syntax ?w) (eq syntax ?_)))
- (forward-char -1))
- (point)))))
- (if (zerop chars)
- nil
- (setq gds-completion-results nil)
- (gds-send (format "complete %s"
- (prin1-to-string
- (buffer-substring-no-properties (- (point) chars)
- (point))))
- gds-client)
- (while (null gds-completion-results)
- (accept-process-output gds-debug-server 0 200))
- (cond ((eq gds-completion-results 'error)
- (error "Internal error - please report the contents of the *Guile
Evaluation* window"))
- ((eq gds-completion-results t)
- nil)
- ((stringp gds-completion-results)
- (if (<= (length gds-completion-results) chars)
- nil
- (insert (substring gds-completion-results chars))
- (message "Sole completion")
- t))
- ((= (length gds-completion-results) 1)
- (if (<= (length (car gds-completion-results)) chars)
- nil
- (insert (substring (car gds-completion-results) chars))
- t))
- (t
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list gds-completion-results))
- t)))))
-
-;;;; Dispatcher for non-debug protocol.
-
-(defun gds-nondebug-protocol (client proc args)
- (cond (;; (eval-results ...) - Results of evaluation.
- (eq proc 'eval-results)
- (gds-display-results client (car args) (cadr args) (cddr args))
- ;; If these results indicate an error, set
- ;; gds-completion-results to non-nil in case the error arose
- ;; when trying to do a completion.
- (if (eq (caar args) 'error)
- (setq gds-completion-results 'error)))
-
- (;; (completion-result ...) - Available completions.
- (eq proc 'completion-result)
- (setq gds-completion-results (or (car args) t)))
-
- (;; (note ...) - For debugging only.
- (eq proc 'note))
-
- (;; (trace ...) - Tracing.
- (eq proc 'trace)
- (with-current-buffer (get-buffer-create "*GDS Trace*")
- (save-excursion
- (goto-char (point-max))
- (or (bolp) (insert "\n"))
- (insert "[client " (number-to-string client) "] " (car args)
"\n"))))
-
- (t
- ;; Unexpected.
- (error "Bad protocol: %S" form))))
-
-;;;; Scheme mode keymap items.
-
-(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
-(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
-(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
-(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
-(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
-(define-key scheme-mode-map "\C-h\C-g" '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 "\e\t" 'gds-complete-symbol)
-
-;;;; The end!
-
-(provide 'gds-scheme)
-
-;;; gds-scheme.el ends here.
diff --git a/emacs/gds-server.el b/emacs/gds-server.el
deleted file mode 100644
index 9cfcd3a..0000000
--- a/emacs/gds-server.el
+++ /dev/null
@@ -1,109 +0,0 @@
-;;; gds-server.el -- infrastructure for running GDS server processes
-
-;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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
-
-
-;;;; Customization group setup.
-
-(defgroup gds nil
- "Customization options for Guile Emacs frontend."
- :group 'scheme)
-
-
-;;;; Communication with the (ice-9 gds-server) subprocess.
-
-;; Subprocess output goes into the `*GDS Process*' buffer, and
-;; is then read from there one form at a time. `gds-read-cursor' is
-;; the buffer position of the start of the next unread form.
-(defvar gds-read-cursor nil)
-
-;; The guile executable used by the GDS server process.
-(defcustom gds-guile-program "guile"
- "*The guile executable used by the GDS server process."
- :type 'string
- :group 'gds)
-
-(defcustom gds-scheme-directory nil
- "Where GDS's Scheme code is, if not in one of the standard places."
- :group 'gds
- :type '(choice (const :tag "nil" nil) directory))
-
-(defun gds-start-server (procname unix-socket-name tcp-port protocol-handler)
- "Start a GDS server process called PROCNAME, listening on Unix
-domain socket UNIX-SOCKET-NAME and TCP port number TCP-PORT.
-PROTOCOL-HANDLER should be a function that accepts and processes
-one protocol form."
- (with-current-buffer (get-buffer-create procname)
- (erase-buffer)
- (let* ((code (format "(begin
- %s
- (use-modules (ice-9 gds-server))
- (run-server %S %S))"
- (if gds-scheme-directory
- (concat "(set! %load-path (cons "
- (format "%S" gds-scheme-directory)
- " %load-path))")
- "")
- unix-socket-name
- tcp-port))
- (process-connection-type nil) ; use a pipe
- (proc (start-process procname
- (current-buffer)
- gds-guile-program
- "-q"
- "--debug"
- "-c"
- code)))
- (set (make-local-variable 'gds-read-cursor) (point-min))
- (set (make-local-variable 'gds-protocol-handler) protocol-handler)
- (set-process-filter proc (function gds-filter))
- (set-process-sentinel proc (function gds-sentinel))
- (set-process-coding-system proc 'latin-1-unix)
- (process-kill-without-query proc)
- proc)))
-
-;; Subprocess output filter: inserts normally into the process buffer,
-;; then tries to reread the output one form at a time and delegates
-;; processing of each form to `gds-protocol-handler'.
-(defun gds-filter (proc string)
- (with-current-buffer (process-buffer proc)
- (save-excursion
- (goto-char (process-mark proc))
- (insert-before-markers string))
- (goto-char gds-read-cursor)
- (while (let ((form (condition-case nil
- (read (current-buffer))
- (error nil))))
- (if form
- (save-excursion
- (funcall gds-protocol-handler (car form) (cdr form))))
- form)
- (setq gds-read-cursor (point)))))
-
-;; Subprocess sentinel: do nothing. (Currently just here to avoid
-;; inserting un-`read'able process status messages into the process
-;; buffer.)
-(defun gds-sentinel (proc event)
- )
-
-
-;;;; The end!
-
-(provide 'gds-server)
-
-;;; gds-server.el ends here.
diff --git a/emacs/gds-test.el b/emacs/gds-test.el
deleted file mode 100644
index dfd4f6c..0000000
--- a/emacs/gds-test.el
+++ /dev/null
@@ -1,166 +0,0 @@
-
-;; Test utility code.
-(defun gds-test-execute-keys (keys &optional keys2)
- (execute-kbd-macro (apply 'vector (listify-key-sequence keys))))
-
-(defvar gds-test-expecting nil)
-
-(defun gds-test-protocol-hook (form)
- (message "[protocol: %s]" (car form))
- (if (eq (car form) gds-test-expecting)
- (setq gds-test-expecting nil)))
-
-(defun gds-test-expect-protocol (proc &optional timeout)
- (message "[expect: %s]" proc)
- (setq gds-test-expecting proc)
- (while gds-test-expecting
- (or (accept-process-output gds-debug-server (or timeout 5))
- (error "Timed out after %ds waiting for %s" (or timeout 5) proc))))
-
-(defun gds-test-check-buffer (name &rest strings)
- (let ((buf (or (get-buffer name) (error "No %s buffer" name))))
- (save-excursion
- (set-buffer buf)
- (goto-char (point-min))
- (while strings
- (search-forward (car strings))
- (setq strings (cdr strings))))))
-
-(defun TEST (desc)
- (message "TEST: %s" desc))
-
-;; Make sure we take GDS elisp code from this code tree.
-(setq load-path (cons (concat default-directory "emacs/") load-path))
-
-;; Protect the tests so we can do some cleanups in case of error.
-(unwind-protect
- (progn
-
- ;; Visit the tutorial.
- (find-file "gds-tutorial.txt")
-
- (TEST "Load up GDS.")
- (search-forward "(require 'gds)")
- (setq load-path (cons (concat default-directory "emacs/") load-path))
- (gds-test-execute-keys "\C-x\C-e")
-
- ;; Install our testing hook.
- (add-hook 'gds-protocol-hook 'gds-test-protocol-hook)
-
- (TEST "Help.")
- (search-forward "(list-ref")
- (backward-char 2)
- (gds-test-execute-keys "\C-hg\C-m")
- (gds-test-expect-protocol 'eval-results 10)
- (gds-test-check-buffer "*Guile Help*"
- "help list-ref"
- "is a primitive procedure in the (guile) module")
-
- (TEST "Completion.")
- (re-search-forward "^with-output-to-s")
- (gds-test-execute-keys "\e\C-i")
- (beginning-of-line)
- (or (looking-at "with-output-to-string")
- (error "Expected completion `with-output-to-string' failed"))
-
- (TEST "Eval defun.")
- (search-forward "(display z)")
- (gds-test-execute-keys "\e\C-x")
- (gds-test-expect-protocol 'eval-results)
- (gds-test-check-buffer "*Guile Evaluation*"
- "(let ((x 1) (y 2))"
- "Arctangent is: 0.46"
- "=> 0.46")
-
- (TEST "Multiple values.")
- (search-forward "(values 'a ")
- (gds-test-execute-keys "\e\C-x")
- (gds-test-expect-protocol 'eval-results)
- (gds-test-check-buffer "*Guile Evaluation*"
- "(values 'a"
- "hello world"
- "=> a"
- "=> b"
- "=> c")
-
- (TEST "Eval region with multiple expressions.")
- (search-forward "(display \"Arctangent is: \")")
- (beginning-of-line)
- (push-mark nil nil t)
- (forward-line 3)
- (gds-test-execute-keys "\C-c\C-r")
- (gds-test-expect-protocol 'eval-results)
- (gds-test-check-buffer "*Guile Evaluation*"
- "(display \"Arctangent is"
- "Arctangent is:"
- "=> no (or unspecified) value"
- "ERROR: Unbound variable: z"
- "=> error-in-evaluation"
- "Evaluating expression 3"
- "=> no (or unspecified) value")
-
- (TEST "Eval syntactically unbalanced region.")
- (search-forward "(let ((z (atan x y)))")
- (beginning-of-line)
- (push-mark nil nil t)
- (forward-line 4)
- (gds-test-execute-keys "\C-c\C-r")
- (gds-test-expect-protocol 'eval-results)
- (gds-test-check-buffer "*Guile Evaluation*"
- "(let ((z (atan"
- "Reading expressions to evaluate"
- "ERROR"
- "end of file"
- "=> error-in-read")
-
- (TEST "Stepping through an evaluation.")
- (search-forward "(for-each (lambda (x)")
- (forward-line 1)
- (push-mark nil nil t)
- (forward-line 1)
- (gds-test-execute-keys "\C-u\e\C-x")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys " ")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "o")
- (gds-test-expect-protocol 'stack)
- (gds-test-execute-keys "g")
- (gds-test-expect-protocol 'eval-results)
- (gds-test-check-buffer "*Guile Evaluation*"
- "(for-each (lambda"
- "Evaluating in current module"
- "3 cubed is 27"
- "=> no (or unspecified) value")
-
- ;; Done.
- (message "====================================")
- (message "gds-test.el completed without errors")
- (message "====================================")
-
- )
-
- (switch-to-buffer "gds-debug")
- (write-region (point-min) (point-max) "gds-test.debug")
-
- (switch-to-buffer "*GDS Transcript*")
- (write-region (point-min) (point-max) "gds-test.transcript")
-
- )
diff --git a/emacs/gds-test.sh b/emacs/gds-test.sh
deleted file mode 100755
index 2f8ddff..0000000
--- a/emacs/gds-test.sh
+++ /dev/null
@@ -1,2 +0,0 @@
-#!/bin/sh
-GUILE_LOAD_PATH=$(pwd) emacs --batch --no-site-file -q -l gds-test.el <
gds-test.stdin
diff --git a/emacs/gds-test.stdin b/emacs/gds-test.stdin
deleted file mode 100644
index 8b13789..0000000
--- a/emacs/gds-test.stdin
+++ /dev/null
@@ -1 +0,0 @@
-
diff --git a/emacs/gds-tutorial.txt b/emacs/gds-tutorial.txt
deleted file mode 100755
index 4254803..0000000
--- a/emacs/gds-tutorial.txt
+++ /dev/null
@@ -1,223 +0,0 @@
-
-;; Welcome to the GDS tutorial!
-
-;; This tutorial teaches the use of GDS by leading you through a set
-;; of examples where you actually use GDS, in Emacs, along the way.
-;; To get maximum benefit, therefore, you should be reading this
-;; tutorial in Emacs.
-
-;; ** GDS setup
-
-;; The first thing to do, if you haven't already, is to load the GDS
-;; library into Emacs. The Emacs Lisp expression for this is:
-
-(require 'gds)
-
-;; So, if you don't already have this in your .emacs, either add it
-;; and then restart Emacs, or evaluate it just for this Emacs session
-;; by moving the cursor to just after the closing parenthesis and
-;; typing `C-x C-e'.
-
-;; (Note that if you _have_ already loaded GDS, and you type `C-x C-e'
-;; after this expression, you will see a *Guile Evaluation* window
-;; telling you that the evaluation failed because `require' is
-;; unbound. Don't worry; this is not a problem, and the rest of the
-;; tutorial should still work just fine.)
-
-;; ** Help
-
-;; GDS makes it easy to access the Guile help system when working on a
-;; Scheme program in Emacs. For example, suppose that you are writing
-;; code that uses list-ref, and need to remind yourself about
-;; list-ref's arguments ...
-
-(define (penultimate l)
- (list-ref
-
-;; Just place the cursor on the word "list-ref" and type `C-h g RET'.
-;; Try it now!
-
-;; If GDS is working correctly, a window should have popped up above
-;; or below showing the Guile help for list-ref.
-
-;; You can also do an "apropos" search through Guile's help. If you
-;; couldn't remember the name list-ref, for example, you could search
-;; for anything matching "list" by typing `C-h C-g' and entering
-;; "list" at the minibuffer prompt. Try doing this now: you should
-;; see a longish list of Guile definitions whose names include "list".
-;; As usual in Emacs, you can use `M-PageUp' and `M-PageDown' to
-;; conveniently scroll the other window without having to select it.
-
-;; The functions called by `C-h g' and `C-h C-g' are gds-help-symbol
-;; and gds-apropos. They both look up the symbol or word at point by
-;; default, but that default can be overidden by typing something else
-;; at the minibuffer prompt.
-
-;; ** Completion
-
-;; As you are typing Scheme code, you can ask GDS to complete the
-;; symbol before point for you, by typing `ESC TAB'. GDS selects
-;; possible completions by matching the text so far against all
-;; definitions in the Guile environment. (This may be contrasted with
-;; the "dabbrev" completion performed by `M-/', which selects possible
-;; completions from the contents of Emacs buffers. So, if you are
-;; trying to complete "with-ou", to get "with-output-to-string", for
-;; example, `ESC TAB' will always work, because with-output-to-string
-;; is always defined in Guile's default environment, whereas `M-/'
-;; will only work if one of Emacs's buffers happens to contain the
-;; full name "with-output-to-string".)
-
-;; To illustrate the idea, here are some partial names that you can
-;; try completing. For each one, move the cursor to the end of the
-;; line and type `ESC TAB' to try to complete it.
-
-list-
-with-ou
-with-output-to-s
-mkst
-
-;; (If you are not familiar with any of the completed definitions,
-;; feel free to use `C-h g' to find out about them!)
-
-;; ** Evaluation
-
-;; GDS provides several ways for you to evaluate Scheme code from
-;; within Emacs.
-
-;; Just like in Emacs Lisp, a single expression in a buffer can be
-;; evaluated using `C-x C-e' or `C-M-x'. For `C-x C-e', the
-;; expression is that which ends immediately before point (so that it
-;; is useful for evaluating something just after you have typed it).
-;; For `C-M-x', the expression is the "top level defun" around point;
-;; this means the balanced chunk of code around point whose opening
-;; parenthesis is in column 0.
-
-;; Take this code fragment as an example:
-
-(let ((x 1) (y 2))
- (let ((z (atan x y)))
- (display "Arctangent is: ")
- (display z)
- (newline)
- z))
-
-;; If you move the cursor to the end of the (display z) line and type
-;; `C-x C-e', the code evaluated is just "(display z)", which normally
-;; produces an error, because z is not defined in the usual Guile
-;; environment. If, however, you type `C-M-x' with the cursor in the
-;; same place, the code evaluated is the whole "(let ((x 1) (y 2))
-;; ...)" kaboodle, because that is the most recent expression before
-;; point that starts in column 0.
-
-;; Try these now. The Guile Evaluation window should pop up again,
-;; and show you:
-;; - the expression that was evaluated (probably abbreviated)
-;; - the module that it was evaluated in
-;; - anything that the code wrote to its standard output
-;; - the return value(s) of the evaluation.
-;; Following the convention of the Emacs Lisp and Guile manuals,
-;; return values are indicated by the symbol "=>".
-
-;; To see what happens when an expression has multiple return values,
-;; try evaluating this one:
-
-(values 'a (begin (display "hello world\n") 'b) 'c)
-
-;; You can also evaluate a region of a buffer using `C-c C-r'. If the
-;; code in the region consists of multiple expressions, GDS evaluates
-;; them sequentially. For example, try selecting the following three
-;; lines and typing `C-c C-r'.
-
- (display "Arctangent is: ")
- (display z)
- (newline)
-
-;; If the code in the region evaluated isn't syntactically balanced,
-;; GDS will indicate a read error, for example for this code:
-
- (let ((z (atan x y)))
- (display "Arctangent is: ")
- (display z)
- (newline)
-
-;; Finally, if you want to evaluate something quickly that is not in a
-;; buffer, you can use `C-c C-e' and type the code to evaluate at the
-;; minibuffer prompt. The results are popped up in the same way as
-;; for code from a buffer.
-
-;; ** Breakpoints
-
-;; Before evaluating Scheme code from an Emacs buffer, you may want to
-;; set some breakpoints in it. With GDS you can set breakpoints in
-;; Scheme code by typing `C-x SPC'.
-;;
-;; To see how this works, select the second line of the following code
-;; (the `(format ...)' line) and type `C-x SPC'.
-
-(for-each (lambda (x)
- (format #t "~A cubed is ~A\n" x (* x x x)))
- (iota 6))
-
-;; The two opening parentheses in that line should now be highlighted
-;; in red, to show that breakpoints have been set at the start of the
-;; `(format ...)' and `(* x x x)' expressions. Then evaluate the
-;; whole for-each expression by typing `C-M-x' ...
-;;
-;; In the upper half of your Emacs, a buffer appears showing you the
-;; Scheme stack.
-;;
-;; In the lower half, the `(format ...)' expression is highlighted.
-;;
-;; What has happened is that Guile started evaluating the for-each
-;; code, but then hit the breakpoint that you set on the start of the
-;; format expression. Guile therefore pauses the evaluation at that
-;; point and passes the stack (which encapsulates everything that is
-;; interesting about the state of Guile at that point) to GDS. You
-;; can then explore the stack and decide how to tell Guile to
-;; continue.
-;;
-;; - If you move your mouse over any of the identifiers in the
-;; highlighted code, a help echo (or tooltip) will appear to tell
-;; you that identifier's current value. (Note though that this only
-;; works when the stack buffer is selected. So if you have switched
-;; to this buffer in order to scroll down and read these lines, you
-;; will need to switch back to the stack buffer before trying this
-;; out.)
-;;
-;; - In the stack buffer, the "=>" on the left shows you that the top
-;; frame is currently selected. You can move up and down the stack
-;; by pressing the up and down arrows (or `u' and `d'). As you do
-;; this, GDS will change the highlight in the lower window to show
-;; the code that corresponds to the selected stack frame.
-;;
-;; - You can evaluate an arbitrary expression in the local environment
-;; of the selected stack frame by typing `e' followed by the
-;; expression.
-;;
-;; - You can show various bits of information about the selected frame
-;; by typing `I', `A' and `S'. Feel free to try these now, to see
-;; what they do.
-;;
-;; You also have control over the continuing evaluation of this code.
-;; Here are some of the things you can do - please try them as you
-;; read.
-;;
-;; - `g' tells Guile to continue execution normally. In this case
-;; that means that evaluation will continue until it hits the next
-;; breakpoint, which is on the `(* x x x)' expression.
-;;
-;; - `SPC' tells Guile to continue until the next significant event in
-;; the same source file as the selected frame. A "significant
-;; event" means either beginning to evaluate an expression in the
-;; relevant file, or completing such an evaluation, in which case
-;; GDS tells you the value that it is returning. Pressing `SPC'
-;; repeatedly is a nice way to step through all the details of the
-;; code in a given file, but stepping over calls that involve code
-;; from other files.
-;;
-;; - `o' tells Guile to continue execution until the selected stack
-;; frame completes, and then to show its return value.
-
-;; Local Variables:
-;; mode: scheme
-;; End:
diff --git a/emacs/gds.el b/emacs/gds.el
deleted file mode 100644
index 991ba75..0000000
--- a/emacs/gds.el
+++ /dev/null
@@ -1,639 +0,0 @@
-;;; gds.el -- frontend for Guile development in Emacs
-
-;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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
-
-; TODO:
-; ?transcript
-; scheme-mode menu
-; interrupt/sigint/async-break
-; (module browsing)
-; load file
-; doing common protocol from debugger
-; thread override for debugging
-
-;;;; Prerequisites.
-
-(require 'scheme)
-(require 'cl)
-(require 'gds-server)
-(require 'gds-scheme)
-
-;; The subprocess object for the debug server.
-(defvar gds-debug-server nil)
-
-(defvar gds-unix-socket-name (format "/tmp/.gds-socket-%d" (emacs-pid))
- "Name of the Unix domain socket that GDS will listen on.")
-
-(defvar gds-tcp-port 8333
- "The TCP port number that GDS will listen on.")
-
-(defun gds-run-debug-server ()
- "Start (or restart, if already running) the GDS debug server process."
- (interactive)
- (if gds-debug-server (gds-kill-debug-server))
- (setq gds-debug-server
- (gds-start-server "gds-debug"
- gds-unix-socket-name
- gds-tcp-port
- 'gds-debug-protocol))
- (process-kill-without-query gds-debug-server)
- ;; Add the Unix socket name to the environment, so that Guile
- ;; clients started from within this Emacs will be able to use it,
- ;; and thereby ensure that they connect to the GDS in this Emacs.
- (setenv "GDS_UNIX_SOCKET_NAME" gds-unix-socket-name))
-
-(defun gds-kill-debug-server ()
- "Kill the GDS debug server process."
- (interactive)
- (mapcar (function gds-client-gone)
- (mapcar (function car) gds-client-info))
- (condition-case nil
- (progn
- (kill-process gds-debug-server)
- (accept-process-output gds-debug-server 0 200))
- (error))
- (setq gds-debug-server nil))
-
-;; Send input to the subprocess.
-(defun gds-send (string client)
- (with-current-buffer (get-buffer-create "*GDS Transcript*")
- (goto-char (point-max))
- (insert (number-to-string client) ": (" string ")\n"))
- (gds-client-put client 'thread-id nil)
- (gds-show-client-status client gds-running-text)
- (process-send-string gds-debug-server (format "(%S %s)\n" client string)))
-
-
-;;;; Per-client information
-
-(defun gds-client-put (client property value)
- (let ((client-info (assq client gds-client-info)))
- (if client-info
- (let ((prop-info (memq property client-info)))
- (if prop-info
- (setcar (cdr prop-info) value)
- (setcdr client-info
- (list* property value (cdr client-info)))))
- (setq gds-client-info
- (cons (list client property value) gds-client-info)))))
-
-(defun gds-client-get (client property)
- (let ((client-info (assq client gds-client-info)))
- (and client-info
- (cadr (memq property client-info)))))
-
-(defvar gds-client-info '())
-
-(defun gds-get-client-buffer (client)
- (let ((existing-buffer (gds-client-get client 'stack-buffer)))
- (if (and existing-buffer
- (buffer-live-p existing-buffer))
- existing-buffer
- (let ((new-buffer (generate-new-buffer (gds-client-get client 'name))))
- (with-current-buffer new-buffer
- (gds-debug-mode)
- (setq gds-client client)
- (setq gds-stack nil))
- (gds-client-put client 'stack-buffer new-buffer)
- new-buffer))))
-
-(defun gds-client-gone (client &rest ignored)
- ;; Kill the client's stack buffer, if it has one.
- (let ((stack-buffer (gds-client-get client 'stack-buffer)))
- (if (and stack-buffer
- (buffer-live-p stack-buffer))
- (kill-buffer stack-buffer)))
- ;; Dissociate all the client's associated buffers.
- (mapcar (function (lambda (buffer)
- (if (buffer-live-p buffer)
- (with-current-buffer buffer
- (gds-dissociate-buffer)))))
- (copy-sequence (gds-client-get client 'associated-buffers)))
- ;; Remove this client's record from gds-client-info.
- (setq gds-client-info (delq (assq client gds-client-info) gds-client-info)))
-
-(defvar gds-client nil)
-(make-variable-buffer-local 'gds-client)
-
-(defvar gds-stack nil)
-(make-variable-buffer-local 'gds-stack)
-
-(defvar gds-tweaking nil)
-(make-variable-buffer-local 'gds-tweaking)
-
-(defvar gds-selected-frame-index nil)
-(make-variable-buffer-local 'gds-selected-frame-index)
-
-
-;;;; Debugger protocol
-
-(defcustom gds-protocol-hook nil
- "Hook called on receipt of a protocol form from the GDS client."
- :type 'hook
- :group 'gds)
-
-(defun gds-debug-protocol (client form)
- (run-hook-with-args 'gds-protocol-hook form)
- (or (eq client '*)
- (let ((proc (car form)))
- (cond ((eq proc 'name)
- ;; (name ...) - client name.
- (gds-client-put client 'name (caddr form)))
-
- ((eq proc 'stack)
- ;; (stack ...) - stack information.
- (with-current-buffer (gds-get-client-buffer client)
- (setq gds-stack (cddr form))
- (setq gds-tweaking (memq 'instead (cadr gds-stack)))
- (setq gds-selected-frame-index (cadr form))
- (gds-display-stack)))
-
- ((eq proc 'closed)
- ;; (closed) - client has gone/died.
- (gds-client-gone client))
-
- ((eq proc 'eval-result)
- ;; (eval-result RESULT) - result of evaluation.
- (if gds-last-eval-result
- (message "%s" (cadr form))
- (setq gds-last-eval-result (cadr form))))
-
- ((eq proc 'info-result)
- ;; (info-result RESULT) - info about selected frame.
- (message "%s" (cadr form)))
-
- ((eq proc 'thread-id)
- ;; (thread-id THREAD) - says which client thread is reading.
- (let ((thread-id (cadr form))
- (debug-thread-id (gds-client-get client
'debug-thread-id)))
- (if (and debug-thread-id
- (/= thread-id debug-thread-id))
- ;; Tell the newly reading thread to go away.
- (gds-send "dismiss" client)
- ;; Either there's no current debug-thread-id, or
- ;; the thread now reading is the debug thread.
- (if debug-thread-id
- (progn
- ;; Reset the debug-thread-id.
- (gds-client-put client 'debug-thread-id nil)
- ;; Indicate debug status in modelines.
- (gds-show-client-status client gds-debug-text))
- ;; Indicate normal read status in modelines..
- (gds-show-client-status client gds-ready-text)))))
-
- ((eq proc 'debug-thread-id)
- ;; (debug-thread-id THREAD) - debug override indication.
- (gds-client-put client 'debug-thread-id (cadr form))
- ;; If another thread is already reading, send it away.
- (if (gds-client-get client 'thread-id)
- (gds-send "dismiss" client)))
-
- (t
- ;; Non-debug-specific protocol.
- (gds-nondebug-protocol client proc (cdr form)))))))
-
-
-;;;; Displaying a stack
-
-(define-derived-mode gds-debug-mode
- scheme-mode
- "Guile-Debug"
- "Major mode for debugging a Guile client application."
- (use-local-map gds-mode-map))
-
-(defun gds-display-stack-first-line ()
- (let ((flags (cadr gds-stack)))
- (cond ((memq 'application flags)
- (insert "Calling procedure:\n"))
- ((memq 'evaluation flags)
- (insert "Evaluating expression"
- (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
- gds-tweaking))
- (gds-tweaking " (tweakable)")
- (t ""))
- ":\n"))
- ((memq 'return flags)
- (let ((value (cadr (memq 'return flags))))
- (while (string-match "\n" value)
- (setq value (replace-match "\\n" nil t value)))
- (insert "Return value"
- (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
- gds-tweaking))
- (gds-tweaking " (tweakable)")
- (t ""))
- ": " value "\n")))
- ((memq 'error flags)
- (let ((value (cadr (memq 'error flags))))
- (while (string-match "\n" value)
- (setq value (replace-match "\\n" nil t value)))
- (insert "Error: " value "\n")))
- (t
- (insert "Stack: " (prin1-to-string flags) "\n")))))
-
-(defun gds-display-stack ()
- (if gds-undisplay-timer
- (cancel-timer gds-undisplay-timer))
- (setq gds-undisplay-timer nil)
- ;(setq buffer-read-only nil)
- (mapcar 'delete-overlay
- (overlays-in (point-min) (point-max)))
- (erase-buffer)
- (gds-display-stack-first-line)
- (let ((frames (car gds-stack)))
- (while frames
- (let ((frame-text (cadr (car frames)))
- (frame-source (caddr (car frames))))
- (while (string-match "\n" frame-text)
- (setq frame-text (replace-match "\\n" nil t frame-text)))
- (insert " "
- (if frame-source "s" " ")
- frame-text
- "\n"))
- (setq frames (cdr frames))))
- ;(setq buffer-read-only t)
- (gds-show-selected-frame))
-
-(defun gds-tweak (expr)
- (interactive "sTweak expression or return value: ")
- (or gds-tweaking
- (error "The current stack cannot be tweaked"))
- (setq gds-tweaking
- (if (> (length expr) 0)
- expr
- t))
- (save-excursion
- (goto-char (point-min))
- (delete-region (point) (progn (forward-line 1) (point)))
- (gds-display-stack-first-line)))
-
-(defvar gds-undisplay-timer nil)
-(make-variable-buffer-local 'gds-undisplay-timer)
-
-(defvar gds-undisplay-wait 1)
-
-(defun gds-undisplay-buffer ()
- (if gds-undisplay-timer
- (cancel-timer gds-undisplay-timer))
- (setq gds-undisplay-timer
- (run-at-time gds-undisplay-wait
- nil
- (function kill-buffer)
- (current-buffer))))
-
-(defun gds-show-selected-frame ()
- (setq gds-local-var-cache nil)
- (goto-char (point-min))
- (forward-line (+ gds-selected-frame-index 1))
- (delete-char 3)
- (insert "=> ")
- (beginning-of-line)
- (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index
- (car gds-stack)))))
-
-(defun gds-unshow-selected-frame ()
- (if gds-frame-source-overlay
- (move-overlay gds-frame-source-overlay 0 0))
- (save-excursion
- (goto-char (point-min))
- (forward-line (+ gds-selected-frame-index 1))
- (delete-char 3)
- (insert " ")))
-
-;; Overlay used to highlight the source expression corresponding to
-;; the selected frame.
-(defvar gds-frame-source-overlay nil)
-
-(defcustom gds-source-file-name-transforms nil
- "Alist of regexps and substitutions for transforming Scheme source
-file names. Each element in the alist is (REGEXP . SUBSTITUTION).
-Each source file name in a Guile backtrace is compared against each
-REGEXP in turn until the first one that matches, then `replace-match'
-is called with SUBSTITUTION to transform that file name.
-
-This mechanism targets the situation where you are working on a Guile
-application and want to install it, in /usr/local say, before each
-test run. In this situation, even though Guile is reading your Scheme
-files from /usr/local/share/guile, you probably want Emacs to pop up
-the corresponding files from your working codebase instead. Therefore
-you would add an element to this alist to transform
-\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"."
- :type '(alist :key-type regexp :value-type string)
- :group 'gds)
-
-(defun gds-show-selected-frame-source (source)
- ;; Highlight the frame source, if possible.
- (if source
- (let ((filename (car source))
- (client gds-client)
- (transforms gds-source-file-name-transforms))
- ;; Apply possible transforms to the source file name.
- (while transforms
- (if (string-match (caar transforms) filename)
- (let ((trans-fn (replace-match (cdar transforms)
- t nil filename)))
- (if (file-readable-p trans-fn)
- (setq filename trans-fn
- transforms nil))))
- (setq transforms (cdr transforms)))
- ;; Try to map the (possibly transformed) source file to a
- ;; buffer.
- (let ((source-buffer (gds-source-file-name-to-buffer filename)))
- (if source-buffer
- (with-current-buffer source-buffer
- (if gds-frame-source-overlay
- nil
- (setq gds-frame-source-overlay (make-overlay 0 0))
- (overlay-put gds-frame-source-overlay 'face 'highlight)
- (overlay-put gds-frame-source-overlay
- 'help-echo
- (function gds-show-local-var)))
- ;; Move to source line. Note that Guile line numbering
- ;; is 0-based, while Emacs numbering is 1-based.
- (save-restriction
- (widen)
- (goto-line (+ (cadr source) 1))
- (move-to-column (caddr source))
- (move-overlay gds-frame-source-overlay
- (point)
- (if (not (looking-at ")"))
- (save-excursion (forward-sexp 1) (point))
- ;; It seems that the source
- ;; coordinates for backquoted
- ;; expressions are at the end of the
- ;; sexp rather than the beginning...
- (save-excursion (forward-char 1)
- (backward-sexp 1) (point)))
- (current-buffer)))
- ;; Record that this source buffer has been touched by a
- ;; GDS client process.
- (setq gds-last-touched-by client))
- (message "Source for this frame cannot be shown: %s:%d:%d"
- filename
- (cadr source)
- (caddr source)))))
- (message "Source for this frame was not recorded"))
- (gds-display-buffers))
-
-(defvar gds-local-var-cache nil)
-
-(defun gds-show-local-var (window overlay position)
- (let ((frame-index gds-selected-frame-index)
- (client gds-client))
- (with-current-buffer (overlay-buffer overlay)
- (save-excursion
- (goto-char position)
- (let ((gds-selected-frame-index frame-index)
- (gds-client client)
- (varname (thing-at-point 'symbol))
- (state (parse-partial-sexp (overlay-start overlay) (point))))
- (when (and gds-selected-frame-index
- gds-client
- varname
- (not (or (nth 3 state)
- (nth 4 state))))
- (set-text-properties 0 (length varname) nil varname)
- (let ((existing (assoc varname gds-local-var-cache)))
- (if existing
- (cdr existing)
- (gds-evaluate varname)
- (setq gds-last-eval-result nil)
- (while (not gds-last-eval-result)
- (accept-process-output gds-debug-server))
- (setq gds-local-var-cache
- (cons (cons varname gds-last-eval-result)
- gds-local-var-cache))
- gds-last-eval-result))))))))
-
-(defun gds-source-file-name-to-buffer (filename)
- ;; See if filename begins with gds-emacs-buffer-port-name-prefix.
- (if (string-match (concat "^"
- (regexp-quote gds-emacs-buffer-port-name-prefix))
- filename)
- ;; It does, so get the named buffer.
- (get-buffer (substring filename (match-end 0)))
- ;; It doesn't, so treat as a file name.
- (and (file-readable-p filename)
- (find-file-noselect filename))))
-
-(defun gds-select-stack-frame (&optional frame-index)
- (interactive)
- (let ((new-frame-index (or frame-index
- (gds-current-line-frame-index))))
- (or (and (>= new-frame-index 0)
- (< new-frame-index (length (car gds-stack))))
- (error (if frame-index
- "No more frames in this direction"
- "No frame here")))
- (gds-unshow-selected-frame)
- (setq gds-selected-frame-index new-frame-index)
- (gds-show-selected-frame)))
-
-(defun gds-up ()
- (interactive)
- (gds-select-stack-frame (- gds-selected-frame-index 1)))
-
-(defun gds-down ()
- (interactive)
- (gds-select-stack-frame (+ gds-selected-frame-index 1)))
-
-(defun gds-current-line-frame-index ()
- (- (count-lines (point-min)
- (save-excursion
- (beginning-of-line)
- (point)))
- 1))
-
-(defun gds-display-buffers ()
- (let ((buf (current-buffer)))
- ;; If there's already a window showing the buffer, use it.
- (let ((window (get-buffer-window buf t)))
- (if window
- (progn
- (make-frame-visible (window-frame window))
- (select-window window))
- (switch-to-buffer buf)
- (setq window (get-buffer-window buf t))))
- ;; If there is an associated source buffer, display it as well.
- (if (and gds-frame-source-overlay
- (overlay-end gds-frame-source-overlay)
- (> (overlay-end gds-frame-source-overlay) 1))
- (progn
- (delete-other-windows)
- (let ((window (display-buffer
- (overlay-buffer gds-frame-source-overlay))))
- (set-window-point window
- (overlay-start gds-frame-source-overlay)))))))
-
-
-;;;; Debugger commands.
-
-;; Typically but not necessarily used from the `stack' view.
-
-(defun gds-send-tweaking ()
- (if (stringp gds-tweaking)
- (gds-send (format "tweak %S" gds-tweaking) gds-client)))
-
-(defun gds-go ()
- (interactive)
- (gds-send-tweaking)
- (gds-send "continue" gds-client)
- (gds-unshow-selected-frame)
- (gds-undisplay-buffer))
-
-(defvar gds-last-eval-result t)
-
-(defun gds-evaluate (expr)
- (interactive "sEvaluate variable or expression: ")
- (gds-send (format "evaluate %d %s"
- gds-selected-frame-index
- (prin1-to-string expr))
- gds-client))
-
-(defun gds-frame-info ()
- (interactive)
- (gds-send (format "info-frame %d" gds-selected-frame-index)
- gds-client))
-
-(defun gds-frame-args ()
- (interactive)
- (gds-send (format "info-args %d" gds-selected-frame-index)
- gds-client))
-
-(defun gds-proc-source ()
- (interactive)
- (gds-send (format "proc-source %d" gds-selected-frame-index)
- gds-client))
-
-(defun gds-traps-here ()
- (interactive)
- (gds-send "traps-here" gds-client))
-
-(defun gds-step-into ()
- (interactive)
- (gds-send-tweaking)
- (gds-send (format "step-into %d" gds-selected-frame-index)
- gds-client)
- (gds-unshow-selected-frame)
- (gds-undisplay-buffer))
-
-(defun gds-step-over ()
- (interactive)
- (gds-send-tweaking)
- (gds-send (format "step-over %d" gds-selected-frame-index)
- gds-client)
- (gds-unshow-selected-frame)
- (gds-undisplay-buffer))
-
-(defun gds-step-file ()
- (interactive)
- (gds-send-tweaking)
- (gds-send (format "step-file %d" gds-selected-frame-index)
- gds-client)
- (gds-unshow-selected-frame)
- (gds-undisplay-buffer))
-
-
-
-
-;;;; Guile Interaction mode keymap and menu items.
-
-(defvar gds-mode-map (make-sparse-keymap))
-(define-key gds-mode-map "c" (function gds-go))
-(define-key gds-mode-map "g" (function gds-go))
-(define-key gds-mode-map "q" (function gds-go))
-(define-key gds-mode-map "e" (function gds-evaluate))
-(define-key gds-mode-map "I" (function gds-frame-info))
-(define-key gds-mode-map "A" (function gds-frame-args))
-(define-key gds-mode-map "S" (function gds-proc-source))
-(define-key gds-mode-map "T" (function gds-traps-here))
-(define-key gds-mode-map "\C-m" (function gds-select-stack-frame))
-(define-key gds-mode-map "u" (function gds-up))
-(define-key gds-mode-map [up] (function gds-up))
-(define-key gds-mode-map "\C-p" (function gds-up))
-(define-key gds-mode-map "d" (function gds-down))
-(define-key gds-mode-map [down] (function gds-down))
-(define-key gds-mode-map "\C-n" (function gds-down))
-(define-key gds-mode-map " " (function gds-step-file))
-(define-key gds-mode-map "i" (function gds-step-into))
-(define-key gds-mode-map "o" (function gds-step-over))
-(define-key gds-mode-map "t" (function gds-tweak))
-
-
-(defvar gds-menu nil
- "Global menu for GDS commands.")
-(if nil;gds-menu
- nil
- (setq gds-menu (make-sparse-keymap "Guile-Debug"))
- (define-key gds-menu [traps-here]
- '(menu-item "Show Traps Here" gds-traps-here))
- (define-key gds-menu [proc-source]
- '(menu-item "Show Procedure Source" gds-proc-source))
- (define-key gds-menu [frame-args]
- '(menu-item "Show Frame Args" gds-frame-args))
- (define-key gds-menu [frame-info]
- '(menu-item "Show Frame Info" gds-frame-info))
- (define-key gds-menu [separator-1]
- '("--"))
- (define-key gds-menu [evaluate]
- '(menu-item "Evaluate..." gds-evaluate))
- (define-key gds-menu [separator-2]
- '("--"))
- (define-key gds-menu [down]
- '(menu-item "Move Down A Frame" gds-down))
- (define-key gds-menu [up]
- '(menu-item "Move Up A Frame" gds-up))
- (define-key gds-menu [separator-3]
- '("--"))
- (define-key gds-menu [step-over]
- '(menu-item "Step Over Current Expression" gds-step-over))
- (define-key gds-menu [step-into]
- '(menu-item "Step Into Current Expression" gds-step-into))
- (define-key gds-menu [step-file]
- '(menu-item "Step Through Current Source File" gds-step-file))
- (define-key gds-menu [separator-4]
- '("--"))
- (define-key gds-menu [go]
- '(menu-item "Go [continue execution]" gds-go))
- (define-key gds-mode-map [menu-bar gds-debug]
- (cons "Guile-Debug" gds-menu)))
-
-
-;;;; Autostarting the GDS server.
-
-(defcustom gds-autorun-debug-server t
- "Whether to automatically run the GDS server when `gds.el' is loaded."
- :type 'boolean
- :group 'gds)
-
-(defcustom gds-server-socket-type 'tcp
- "This option is now obsolete and has no effect."
- :group 'gds
- :type '(choice (const :tag "TCP" tcp)
- (const :tag "Unix" unix)))
-
-;;;; If requested, autostart the server after loading.
-
-(if (and gds-autorun-debug-server
- (not gds-debug-server))
- (gds-run-debug-server))
-
-;;;; The end!
-
-(provide 'gds)
-
-;;; gds.el ends here.
diff --git a/libguile/debug.c b/libguile/debug.c
index cce7dd0..ab085f4 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -75,11 +75,6 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0,
1, 0,
scm_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
- if (SCM_N_FRAMES < 1)
- {
- scm_options (ans, scm_debug_opts, FUNC_NAME);
- SCM_OUT_OF_RANGE (1, setting);
- }
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
@@ -89,44 +84,6 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0,
1, 0,
}
#undef FUNC_NAME
-
-static void
-with_traps_before (void *data)
-{
- int *trap_flag = data;
- *trap_flag = SCM_TRAPS_P;
- SCM_TRAPS_P = 1;
-}
-
-static void
-with_traps_after (void *data)
-{
- int *trap_flag = data;
- SCM_TRAPS_P = *trap_flag;
-}
-
-static SCM
-with_traps_inner (void *data)
-{
- SCM thunk = SCM_PACK ((scm_t_bits) data);
- return scm_call_0 (thunk);
-}
-
-SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
- (SCM thunk),
- "Call @var{thunk} with traps enabled.")
-#define FUNC_NAME s_scm_with_traps
-{
- int trap_flag;
- SCM_VALIDATE_THUNK (1, thunk);
- return scm_internal_dynamic_wind (with_traps_before,
- with_traps_inner,
- with_traps_after,
- (void *) SCM_UNPACK (thunk),
- &trap_flag);
-}
-#undef FUNC_NAME
-
SCM_SYMBOL (scm_sym_source, "source");
diff --git a/libguile/debug.h b/libguile/debug.h
index 7c1d02f..d862aba 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -44,8 +44,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
-SCM_API SCM scm_with_traps (SCM thunk);
-SCM_API SCM scm_evaluator_traps (SCM setting);
SCM_API SCM scm_debug_options (SCM setting);
SCM_INTERNAL void scm_init_debug (void);
diff --git a/libguile/eval.c b/libguile/eval.c
index 8d11570..07233aa 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -435,31 +435,12 @@ eval (SCM x, SCM env)
}
}
-scm_t_option scm_eval_opts[] = {
- { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine
words)." },
- { 0 }
-};
-
scm_t_option scm_debug_opts[] = {
- { SCM_OPTION_BOOLEAN, "cheap", 1,
- "*This option is now obsolete. Setting it has no effect." },
- { SCM_OPTION_BOOLEAN, "breakpoints", 0,
- "*This option is now obsolete. Setting it has no effect." },
- { SCM_OPTION_BOOLEAN, "trace", 0,
- "*This option is now obsolete. Setting it has no effect." },
- { SCM_OPTION_BOOLEAN, "procnames", 1,
- "*This option is now obsolete. Setting it has no effect." },
{ SCM_OPTION_BOOLEAN, "backwards", 0,
"Display backtrace in anti-chronological order." },
{ SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
- { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
- { SCM_OPTION_INTEGER, "frames", 3,
- "Maximum number of tail-recursive frames in backtrace." },
- { SCM_OPTION_INTEGER, "maxdepth", 1000,
- "Maximal number of stored backtrace frames." },
{ SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
{ SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
- { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
/* This default stack limit will be overridden by debug.c:init_stack_limit(),
if we have getrlimit() and the stack limit is not INFINITY. But it is
still
important, as some systems have both the soft and the hard limits set to
@@ -483,69 +464,6 @@ scm_t_option scm_debug_opts[] = {
};
-/*
- * this ordering is awkward and illogical, but we maintain it for
- * compatibility. --hwn
- */
-scm_t_option scm_evaluator_trap_table[] = {
- { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
- { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
- { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
- { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
- { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler
for enter-frame traps." },
- { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler
for apply-frame traps." },
- { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler
for exit-frame traps." },
- { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." },
- { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The
handler for memoization." },
- { 0 }
-};
-
-
-SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the evaluation options. Instead of using\n"
- "this procedure directly, use the procedures @code{eval-enable},\n"
- "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
-#define FUNC_NAME s_scm_eval_options_interface
-{
- SCM ans;
-
- scm_dynwind_begin (0);
- scm_dynwind_critical_section (SCM_BOOL_F);
- ans = scm_options (setting,
- scm_eval_opts,
- FUNC_NAME);
- scm_dynwind_end ();
-
- return ans;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
- (SCM setting),
- "Option interface for the evaluator trap options.")
-#define FUNC_NAME s_scm_evaluator_traps
-{
- SCM ans;
-
-
- scm_options_try (setting,
- scm_evaluator_trap_table,
- FUNC_NAME, 1);
- SCM_CRITICAL_SECTION_START;
- ans = scm_options (setting,
- scm_evaluator_trap_table,
- FUNC_NAME);
-
- /* njrev: same again. */
- SCM_CRITICAL_SECTION_END;
- return ans;
-}
-#undef FUNC_NAME
-
-
-
/* Simple procedure calls
@@ -1137,11 +1055,6 @@ scm_init_eval ()
{
SCM primitive_eval;
- scm_init_opts (scm_evaluator_traps,
- scm_evaluator_trap_table);
- scm_init_opts (scm_eval_options_interface,
- scm_eval_opts);
-
f_apply = scm_c_define_gsubr ("apply", 2, 0, 1, scm_apply);
scm_tc16_boot_closure = scm_make_smob_type ("boot-closure", 0);
diff --git a/libguile/private-options.h b/libguile/private-options.h
index 7ef19c9..88f63f8 100644
--- a/libguile/private-options.h
+++ b/libguile/private-options.h
@@ -26,46 +26,18 @@
#define PRIVATE_OPTIONS
/*
- evaluator
- */
-SCM_API scm_t_option scm_eval_opts[];
-
-SCM_API scm_t_option scm_evaluator_trap_table[];
-
-SCM_API SCM scm_eval_options_interface (SCM setting);
-
-#define SCM_EVAL_STACK scm_eval_opts[0].val
-
-#define SCM_TRAPS_P scm_evaluator_trap_table[0].val
-#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val
-#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val
-#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val
-#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val))
-#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val))
-#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val))
-#define SCM_MEMOIZE_P scm_evaluator_trap_table[7].val
-#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val))
-
-/*
debugging.
*/
SCM_API scm_t_option scm_debug_opts[];
-#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
-#define SCM_TRACE_P scm_debug_opts[2].val
-#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
-#define SCM_BACKWARDS_P scm_debug_opts[4].val
-#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val
-#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val
-#define SCM_N_FRAMES scm_debug_opts[7].val
-#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val
-#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val
-#define SCM_BACKTRACE_P scm_debug_opts[10].val
-#define SCM_DEVAL_P scm_debug_opts[11].val
-#define SCM_STACK_LIMIT scm_debug_opts[12].val
-#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val
-#define SCM_WARN_DEPRECATED scm_debug_opts[14].val
-#define SCM_N_DEBUG_OPTIONS 15
+#define SCM_BACKWARDS_P scm_debug_opts[0].val
+#define SCM_BACKTRACE_WIDTH scm_debug_opts[1].val
+#define SCM_BACKTRACE_DEPTH scm_debug_opts[2].val
+#define SCM_BACKTRACE_P scm_debug_opts[3].val
+#define SCM_STACK_LIMIT scm_debug_opts[4].val
+#define SCM_SHOW_FILE_NAME scm_debug_opts[5].val
+#define SCM_WARN_DEPRECATED scm_debug_opts[6].val
+#define SCM_N_DEBUG_OPTIONS 7
/*
diff --git a/module/Makefile.am b/module/Makefile.am
index 1202e20..aad8c70 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -183,7 +183,6 @@ ICE_9_SOURCES = \
ice-9/control.scm \
ice-9/curried-definitions.scm \
ice-9/debug.scm \
- ice-9/debugger.scm \
ice-9/documentation.scm \
ice-9/expect.scm \
ice-9/format.scm \
@@ -229,7 +228,6 @@ ICE_9_SOURCES = \
ice-9/weak-vector.scm \
ice-9/list.scm \
ice-9/serialize.scm \
- ice-9/gds-server.scm \
ice-9/vlist.scm
SRFI_SOURCES = \
@@ -346,23 +344,12 @@ LIB_SOURCES = \
EXTRA_DIST += oop/ChangeLog-2008
NOCOMP_SOURCES = \
- ice-9/gds-client.scm \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \
ice-9/r6rs-libraries.scm \
ice-9/quasisyntax.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
- ice-9/debugger/command-loop.scm \
- ice-9/debugger/commands.scm \
- ice-9/debugger/state.scm \
- ice-9/debugger/trc.scm \
- ice-9/debugger/utils.scm \
- ice-9/debugging/example-fns.scm \
- ice-9/debugging/steps.scm \
- ice-9/debugging/trace.scm \
- ice-9/debugging/traps.scm \
- ice-9/debugging/trc.scm \
sxml/sxml-match.ss \
sxml/upstream/SSAX.scm \
sxml/upstream/SXML-tree-trans.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 3f00afb..b8f5a31 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1029,7 +1029,6 @@ If there is no handler at all, Guile prints an error and
then exits."
;; scm_compile_shell_switches.
(define (turn-on-debugging)
- (debug-enable 'debug)
(debug-enable 'backtrace)
(read-enable 'positions))
@@ -2645,21 +2644,11 @@ module '(ice-9 q) '(make-q q-length))}."
(options (append (options) (list 'opt val))))))))))
(define-option-interface
- (eval-options-interface
- (eval-options eval-enable eval-disable)
- (eval-set!)))
-
-(define-option-interface
(debug-options-interface
(debug-options debug-enable debug-disable)
(debug-set!)))
(define-option-interface
- (evaluator-traps-interface
- (traps trap-enable trap-disable)
- (trap-set!)))
-
-(define-option-interface
(read-options-interface
(read-options read-enable read-disable)
(read-set!)))
diff --git a/module/ice-9/debugger.scm b/module/ice-9/debugger.scm
deleted file mode 100644
index 9a5e4af..0000000
--- a/module/ice-9/debugger.scm
+++ /dev/null
@@ -1,167 +0,0 @@
-;;;; Guile Debugger
-
-;;; Copyright (C) 1999, 2001, 2002, 2006, 2010 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugger)
- #:use-module (ice-9 debugger command-loop)
- #:use-module (ice-9 debugger state)
- #:use-module (ice-9 debugger utils)
- #:use-module (ice-9 debugging traps)
- #:use-module (ice-9 scm-style-repl)
- #:use-module (ice-9 save-stack)
- #:use-module (ice-9 format)
- #:export (debug-stack
- debug
- debug-last-error
- debugger-error
- debugger-quit
- debugger-input-port
- debugger-output-port
- debug-on-error)
- #:no-backtrace)
-
-;;; The old (ice-9 debugger) has been factored into its constituent
-;;; parts:
-;;;
-;;; (ice-9 debugger) - public interface to all of the following
-;;;
-;;; (... commands) - procedures implementing the guts of the commands
-;;; provided by the interactive debugger
-;;;
-;;; (... command-loop) - binding these commands into the interactive
-;;; debugger command loop
-;;;
-;;; (... state) - implementation of an object that tracks current
-;;; debugger state
-;;;
-;;; (... utils) - utilities for printing out frame and stack
-;;; information in various formats
-;;;
-;;; The division between (... commands) and (... command-loop) exists
-;;; because I (NJ) have another generic command loop implementation
-;;; under development, and I want to be able to switch easily between
-;;; that and the command loop implementation here. Thus the
-;;; procedures in this file delegate to a debugger command loop
-;;; implementation via the `debugger-command-loop-*' interface. The
-;;; (ice-9 debugger command-loop) implementation can be replaced by
-;;; any other that implements the `debugger-command-loop-*' interface
-;;; simply by changing the relevant #:use-module line above.
-;;;
-;;; - Neil Jerram <address@hidden> 2002-10-26, updated 2005-07-09
-
-(define *not-yet-introduced* #t)
-
-(define (debug-stack stack . flags)
- "Invoke the Guile debugger to explore the specified @var{stack}.
-
address@hidden, if present, are keywords indicating characteristics of
-the debugging session: the valid keywords are as follows.
-
address@hidden @code
address@hidden #:continuable
-Indicates that the debugger is being invoked from a context (such as
-an evaluator trap handler) where it is possible to return from the
-debugger and continue normal code execution. This enables the
address@hidden execution} commands, for example @code{continue} and
address@hidden
-
address@hidden #:with-introduction
-Indicates that the debugger should display an introductory message.
address@hidden table"
- (start-stack 'debugger
- (let ((state (apply make-state stack 0 flags)))
- (with-input-from-port (debugger-input-port)
- (lambda ()
- (with-output-to-port (debugger-output-port)
- (lambda ()
- (if (or *not-yet-introduced*
- (memq #:with-introduction flags))
- (let ((ssize (stack-length stack)))
- (display "This is the Guile debugger -- for help, type
`help'.\n")
- (set! *not-yet-introduced* #f)
- (if (= ssize 1)
- (display "There is 1 frame on the stack.\n\n")
- (format #t "There are ~A frames on the stack.\n\n"
ssize))))
- (write-state-short state)
- (debugger-command-loop state))))))))
-
-(define (debug)
- "Invoke the Guile debugger to explore the context of the last error."
- (let ((stack (fluid-ref the-last-stack)))
- (if stack
- (debug-stack stack)
- (display "Nothing to debug.\n"))))
-
-(define debug-last-error debug)
-
-(define (debugger-error message)
- "Signal a debugger usage error with message @var{message}."
- (debugger-command-loop-error message))
-
-(define (debugger-quit)
- "Exit the debugger."
- (debugger-command-loop-quit))
-
-;;; {Debugger Input and Output Ports}
-
-(define debugger-input-port
- (let ((input-port (current-input-port)))
- (make-procedure-with-setter
- (lambda () input-port)
- (lambda (port) (set! input-port port)))))
-
-(define debugger-output-port
- (let ((output-port (current-output-port)))
- (make-procedure-with-setter
- (lambda () output-port)
- (lambda (port) (set! output-port port)))))
-
-;;; {Debug on Error}
-
-(define (debug-on-error syms)
- "Enable or disable debug on error."
- (set! default-pre-unwind-handler
- (if syms
- (lambda (key . args)
- (if (memq key syms)
- (begin
- (debug-stack (make-stack #t default-pre-unwind-handler)
- #:with-introduction
- #:continuable)
- (throw 'abort key)))
- (apply default-pre-unwind-handler key args))
- default-pre-unwind-handler)))
-
-;;; Also provide a `debug-trap' entry point. This maps from a
-;;; trap-context to a debug-stack call.
-
-(define-public (debug-trap trap-context)
- "Invoke the Guile debugger to explore the stack at the specified
@var{trap-context}."
- (let* ((stack (tc:stack trap-context))
- (flags1 (let ((trap-type (tc:type trap-context)))
- (case trap-type
- ((#:return #:error)
- (list trap-type
- (tc:return-value trap-context)))
- (else
- (list trap-type)))))
- (flags (if (tc:continuation trap-context)
- (cons #:continuable flags1)
- flags1)))
- (apply debug-stack stack flags)))
-
-;;; (ice-9 debugger) ends here.
diff --git a/module/ice-9/debugger/command-loop.scm
b/module/ice-9/debugger/command-loop.scm
deleted file mode 100644
index b58952d..0000000
--- a/module/ice-9/debugger/command-loop.scm
+++ /dev/null
@@ -1,552 +0,0 @@
-;;;; Guile Debugger command loop
-
-;;; Copyright (C) 1999, 2001, 2002, 2003, 2006, 2010 Free Software Foundation,
Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugger command-loop)
- #:use-module ((ice-9 debugger commands) :prefix debugger:)
- #:use-module (ice-9 debugger)
- #:use-module (ice-9 debugger state)
- #:use-module (ice-9 debugging traps)
- #:use-module (ice-9 save-stack)
- #:export (debugger-command-loop
- debugger-command-loop-error
- debugger-command-loop-quit)
- #:no-backtrace)
-
-;;; {Interface used by (ice-9 debugger).}
-
-(define (debugger-command-loop state)
- (read-and-dispatch-commands state (current-input-port)))
-
-(define (debugger-command-loop-error message)
- (user-error message))
-
-(define (debugger-command-loop-quit)
- (throw 'exit-debugger))
-
-;;; {Implementation.}
-
-(define debugger-prompt "debug> ")
-
-(define (debugger-handler key . args)
- (case key
- ((exit-debugger) #f)
- ((signal)
- (apply display-error #f (current-error-port) args))
- (else
- (display "Internal debugger error:\n")
- (save-stack debugger-handler)
- (apply throw key args)))
- (throw 'exit-debugger)) ;Pop the stack
-
-(define (read-and-dispatch-commands state port)
- (catch 'exit-debugger
- (lambda ()
- (lazy-catch #t
- (lambda ()
- (with-fluids ((last-command #f))
- (let loop ()
- (read-and-dispatch-command state port)
- (loop))))
- debugger-handler))
- (lambda args
- *unspecified*)))
-
-(define set-readline-prompt! #f)
-
-(define (read-and-dispatch-command state port)
- (if (using-readline?)
- (begin
- ;; Import set-readline-prompt! if we haven't already.
- (or set-readline-prompt!
- (set! set-readline-prompt!
- (module-ref (resolve-module '(ice-9 readline))
- 'set-readline-prompt!)))
- (set-readline-prompt! debugger-prompt debugger-prompt))
- (display debugger-prompt))
- (force-output) ;This should not be necessary...
- (let ((token (read-token port)))
- (cond ((eof-object? token)
- (throw 'exit-debugger))
- ((not token)
- (discard-rest-of-line port)
- (catch-user-errors port (lambda () (run-last-command state))))
- (else
- (catch-user-errors port
- (lambda ()
- (dispatch-command token command-table state port)))))))
-
-(define (run-last-command state)
- (let ((procedure (fluid-ref last-command)))
- (if procedure
- (procedure state))))
-
-(define (catch-user-errors port thunk)
- (catch 'debugger-user-error
- thunk
- (lambda (key . objects)
- (apply user-warning objects)
- (discard-rest-of-line port))))
-
-(define last-command (make-fluid))
-
-(define (user-warning . objects)
- (for-each (lambda (object)
- (display object))
- objects)
- (newline))
-
-(define (user-error . objects)
- (apply throw 'debugger-user-error objects))
-
-;;;; Command dispatch
-
-(define (dispatch-command string table state port)
- (let ((value (command-table-value table string)))
- (if value
- (dispatch-command/value value state port)
- (user-error "Unknown command: " string))))
-
-(define (dispatch-command/value value state port)
- (cond ((command? value)
- (dispatch-command/command value state port))
- ((command-table? value)
- (dispatch-command/table value state port))
- ((list? value)
- (dispatch-command/name value state port))
- (else
- (error "Unrecognized command-table value: " value))))
-
-(define (dispatch-command/command command state port)
- (let ((procedure (command-procedure command))
- (arguments ((command-parser command) port)))
- (let ((procedure (lambda (state) (apply procedure state arguments))))
- (warn-about-extra-args port)
- (fluid-set! last-command procedure)
- (procedure state))))
-
-(define (warn-about-extra-args port)
- ;; **** modify this to show the arguments.
- (let ((char (skip-whitespace port)))
- (cond ((eof-object? char) #f)
- ((char=? #\newline char) (read-char port))
- (else
- (user-warning "Extra arguments at end of line: "
- (read-rest-of-line port))))))
-
-(define (dispatch-command/table table state port)
- (let ((token (read-token port)))
- (if (or (eof-object? token)
- (not token))
- (user-error "Command name too short.")
- (dispatch-command token table state port))))
-
-(define (dispatch-command/name name state port)
- (let ((value (lookup-command name)))
- (cond ((not value)
- (apply user-error "Unknown command name: " name))
- ((command-table? value)
- (apply user-error "Partial command name: " name))
- (else
- (dispatch-command/value value state port)))))
-
-;;;; Command definition
-
-(define (define-command name argument-template procedure)
- (let ((name (canonicalize-command-name name)))
- (add-command name
- (make-command name
- (argument-template->parser argument-template)
- (procedure-documentation procedure)
- procedure)
- command-table)
- name))
-
-(define (define-command-alias name1 name2)
- (let ((name1 (canonicalize-command-name name1)))
- (add-command name1 (canonicalize-command-name name2) command-table)
- name1))
-
-(define (argument-template->parser template)
- ;; Deliberately handles only cases that occur in "commands.scm".
- (cond ((eq? 'tokens template)
- (lambda (port)
- (let loop ((tokens '()))
- (let ((token (read-token port)))
- (if (or (eof-object? token)
- (not token))
- (list (reverse! tokens))
- (loop (cons token tokens)))))))
- ((null? template)
- (lambda (port)
- '()))
- ((and (pair? template)
- (null? (cdr template))
- (eq? 'object (car template)))
- (lambda (port)
- (list (read port))))
- ((and (pair? template)
- (equal? ''optional (car template))
- (pair? (cdr template))
- (null? (cddr template)))
- (case (cadr template)
- ((token)
- (lambda (port)
- (let ((token (read-token port)))
- (if (or (eof-object? token)
- (not token))
- (list #f)
- (list token)))))
- ((exact-integer)
- (lambda (port)
- (list (parse-optional-exact-integer port))))
- ((exact-nonnegative-integer)
- (lambda (port)
- (list (parse-optional-exact-nonnegative-integer port))))
- ((object)
- (lambda (port)
- (list (parse-optional-object port))))
- (else
- (error "Malformed argument template: " template))))
- (else
- (error "Malformed argument template: " template))))
-
-(define (parse-optional-exact-integer port)
- (let ((object (parse-optional-object port)))
- (if (or (not object)
- (and (integer? object)
- (exact? object)))
- object
- (user-error "Argument not an exact integer: " object))))
-
-(define (parse-optional-exact-nonnegative-integer port)
- (let ((object (parse-optional-object port)))
- (if (or (not object)
- (and (integer? object)
- (exact? object)
- (not (negative? object))))
- object
- (user-error "Argument not an exact non-negative integer: " object))))
-
-(define (parse-optional-object port)
- (let ((terminator (skip-whitespace port)))
- (if (or (eof-object? terminator)
- (eq? #\newline terminator))
- #f
- (let ((object (read port)))
- (if (eof-object? object)
- #f
- object)))))
-
-;;;; Command tables
-
-(define (lookup-command name)
- (let loop ((table command-table) (strings name))
- (let ((value (command-table-value table (car strings))))
- (cond ((or (not value) (null? (cdr strings))) value)
- ((command-table? value) (loop value (cdr strings)))
- (else #f)))))
-
-(define (command-table-value table string)
- (let ((entry (command-table-entry table string)))
- (and entry
- (caddr entry))))
-
-(define (command-table-entry table string)
- (let loop ((entries (command-table-entries table)))
- (and (not (null? entries))
- (let ((entry (car entries)))
- (if (and (<= (cadr entry)
- (string-length string)
- (string-length (car entry)))
- (= (string-length string)
- (match-strings (car entry) string)))
- entry
- (loop (cdr entries)))))))
-
-(define (match-strings s1 s2)
- (let ((n (min (string-length s1) (string-length s2))))
- (let loop ((i 0))
- (cond ((= i n) i)
- ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
- (else i)))))
-
-(define (write-command-name name)
- (display (car name))
- (for-each (lambda (string)
- (write-char #\space)
- (display string))
- (cdr name)))
-
-(define (add-command name value table)
- (let loop ((strings name) (table table))
- (let ((entry
- (or (let loop ((entries (command-table-entries table)))
- (and (not (null? entries))
- (if (string=? (car strings) (caar entries))
- (car entries)
- (loop (cdr entries)))))
- (let ((entry (list (car strings) #f #f)))
- (let ((entries
- (let ((entries (command-table-entries table)))
- (if (or (null? entries)
- (string<? (car strings) (caar entries)))
- (cons entry entries)
- (begin
- (let loop ((prev entries) (this (cdr entries)))
- (if (or (null? this)
- (string<? (car strings) (caar this)))
- (set-cdr! prev (cons entry this))
- (loop this (cdr this))))
- entries)))))
- (compute-string-abbreviations! entries)
- (set-command-table-entries! table entries))
- entry))))
- (if (null? (cdr strings))
- (set-car! (cddr entry) value)
- (loop (cdr strings)
- (if (command-table? (caddr entry))
- (caddr entry)
- (let ((table (make-command-table '())))
- (set-car! (cddr entry) table)
- table)))))))
-
-(define (canonicalize-command-name name)
- (cond ((and (string? name)
- (not (string-null? name)))
- (list name))
- ((let loop ((name name))
- (and (pair? name)
- (string? (car name))
- (not (string-null? (car name)))
- (or (null? (cdr name))
- (loop (cdr name)))))
- name)
- (else
- (error "Illegal command name: " name))))
-
-(define (compute-string-abbreviations! entries)
- (let loop ((entries entries) (index 0))
- (let ((groups '()))
- (for-each
- (lambda (entry)
- (let* ((char (string-ref (car entry) index))
- (group (assv char groups)))
- (if group
- (set-cdr! group (cons entry (cdr group)))
- (set! groups
- (cons (list char entry)
- groups)))))
- entries)
- (for-each
- (lambda (group)
- (let ((index (+ index 1)))
- (if (null? (cddr group))
- (set-car! (cdadr group) index)
- (loop (let ((entry
- (let loop ((entries (cdr group)))
- (and (not (null? entries))
- (if (= index (string-length (caar entries)))
- (car entries)
- (loop (cdr entries)))))))
- (if entry
- (begin
- (set-car! (cdr entry) index)
- (delq entry (cdr group)))
- (cdr group)))
- index))))
- groups))))
-
-;;;; Data structures
-
-(define command-table-rtd (make-record-type "command-table" '(entries)))
-(define make-command-table (record-constructor command-table-rtd '(entries)))
-(define command-table? (record-predicate command-table-rtd))
-(define command-table-entries (record-accessor command-table-rtd 'entries))
-(define set-command-table-entries!
- (record-modifier command-table-rtd 'entries))
-
-(define command-rtd
- (make-record-type "command"
- '(name parser documentation procedure)))
-
-(define make-command
- (record-constructor command-rtd
- '(name parser documentation procedure)))
-
-(define command? (record-predicate command-rtd))
-(define command-name (record-accessor command-rtd 'name))
-(define command-parser (record-accessor command-rtd 'parser))
-(define command-documentation (record-accessor command-rtd 'documentation))
-(define command-procedure (record-accessor command-rtd 'procedure))
-
-;;;; Character parsing
-
-(define (read-token port)
- (letrec
- ((loop
- (lambda (chars)
- (let ((char (peek-char port)))
- (cond ((eof-object? char)
- (do-eof char chars))
- ((char=? #\newline char)
- (do-eot chars))
- ((char-whitespace? char)
- (do-eot chars))
- ((char=? #\# char)
- (read-char port)
- (let ((terminator (skip-comment port)))
- (if (eof-object? char)
- (do-eof char chars)
- (do-eot chars))))
- (else
- (read-char port)
- (loop (cons char chars)))))))
- (do-eof
- (lambda (eof chars)
- (if (null? chars)
- eof
- (do-eot chars))))
- (do-eot
- (lambda (chars)
- (if (null? chars)
- #f
- (list->string (reverse! chars))))))
- (skip-whitespace port)
- (loop '())))
-
-(define (skip-whitespace port)
- (let ((char (peek-char port)))
- (cond ((or (eof-object? char)
- (char=? #\newline char))
- char)
- ((char-whitespace? char)
- (read-char port)
- (skip-whitespace port))
- ((char=? #\# char)
- (read-char port)
- (skip-comment port))
- (else char))))
-
-(define (skip-comment port)
- (let ((char (peek-char port)))
- (if (or (eof-object? char)
- (char=? #\newline char))
- char
- (begin
- (read-char port)
- (skip-comment port)))))
-
-(define (read-rest-of-line port)
- (let loop ((chars '()))
- (let ((char (read-char port)))
- (if (or (eof-object? char)
- (char=? #\newline char))
- (list->string (reverse! chars))
- (loop (cons char chars))))))
-
-(define (discard-rest-of-line port)
- (let loop ()
- (if (not (let ((char (read-char port)))
- (or (eof-object? char)
- (char=? #\newline char))))
- (loop))))
-
-;;;; Commands
-
-(define command-table (make-command-table '()))
-
-(define-command "help" 'tokens
- (lambda (state tokens)
- "Type \"help\" followed by a command name for full documentation."
- (let loop ((name (if (null? tokens) '("help") tokens)))
- (let ((value (lookup-command name)))
- (cond ((not value)
- (write-command-name name)
- (display " is not a known command name.")
- (newline))
- ((command? value)
- (display (command-documentation value))
- (newline)
- (if (equal? '("help") (command-name value))
- (begin
- (display "Available commands are:")
- (newline)
- (for-each (lambda (entry)
- (if (not (list? (caddr entry)))
- (begin
- (display " ")
- (display (car entry))
- (newline))))
- (command-table-entries command-table)))))
- ((command-table? value)
- (display "The \"")
- (write-command-name name)
- (display "\" command requires a subcommand.")
- (newline)
- (display "Available subcommands are:")
- (newline)
- (for-each (lambda (entry)
- (if (not (list? (caddr entry)))
- (begin
- (display " ")
- (write-command-name name)
- (write-char #\space)
- (display (car entry))
- (newline))))
- (command-table-entries value)))
- ((list? value)
- (loop value))
- (else
- (error "Unknown value from lookup-command:" value)))))
- state))
-
-(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame)
-
-(define-command "position" '() debugger:position)
-
-(define-command "up" '('optional exact-integer) debugger:up)
-
-(define-command "down" '('optional exact-integer) debugger:down)
-
-(define-command "backtrace" '('optional exact-integer) debugger:backtrace)
-
-(define-command "evaluate" '(object) debugger:evaluate)
-
-(define-command '("info" "args") '() debugger:info-args)
-
-(define-command '("info" "frame") '() debugger:info-frame)
-
-(define-command "quit" '()
- (lambda (state)
- "Exit the debugger."
- (debugger-command-loop-quit)))
-
-(define-command-alias "f" "frame")
-(define-command-alias '("info" "f") '("info" "frame"))
-(define-command-alias "bt" "backtrace")
-(define-command-alias "where" "backtrace")
-(define-command-alias "p" "evaluate")
-(define-command-alias '("info" "stack") "backtrace")
-
-(define-command "continue" '() debugger:continue)
-
-(define-command "finish" '() debugger:finish)
-
-(define-command "step" '('optional exact-integer) debugger:step)
-
-(define-command "next" '('optional exact-integer) debugger:next)
diff --git a/module/ice-9/debugger/commands.scm
b/module/ice-9/debugger/commands.scm
deleted file mode 100644
index eece990..0000000
--- a/module/ice-9/debugger/commands.scm
+++ /dev/null
@@ -1,208 +0,0 @@
-;;;; (ice-9 debugger commands) -- debugger commands
-
-;;; Copyright (C) 2002, 2006, 2009, 2010 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugger commands)
- #:use-module ((ice-9 scm-style-repl) #:select (bad-throw))
- #:use-module (ice-9 debugger)
- #:use-module (ice-9 debugger state)
- #:use-module (ice-9 debugger utils)
- #:use-module (ice-9 debugging steps)
- #:export (backtrace
- evaluate
- info-args
- info-frame
- position
- up
- down
- frame
- continue
- finish
- step
- next))
-
-(define (backtrace state n-frames)
- "Print backtrace of all stack frames, or innermost COUNT frames.
-With a negative argument, print outermost -COUNT frames.
-If the number of frames isn't explicitly given, the debug option
-`depth' determines the maximum number of frames printed."
- (let ((stack (state-stack state)))
- ;; Kludge around lack of call-with-values.
- (let ((values
- (lambda (start end)
- (display-backtrace stack
- (current-output-port)
- (if (memq 'backwards (debug-options))
- start
- (- end 1))
- (- end start))
- )))
- (let ((end (stack-length stack)))
- (cond ((not n-frames) ;(>= (abs n-frames) end))
- (values 0 (min end (cadr (memq 'depth (debug-options))))))
- ((>= n-frames 0)
- (values 0 n-frames))
- (else
- (values (+ end n-frames) end)))))))
-
-(define (eval-handler key . args)
- (let ((stack (make-stack #t eval-handler)))
- (if (= (length args) 4)
- (apply display-error stack (current-error-port) args)
- ;; We want display-error to be the "final common pathway"
- (catch #t
- (lambda ()
- (apply bad-throw key args))
- (lambda (key . args)
- (apply display-error stack (current-error-port) args)))))
- (throw 'continue))
-
-;; FIXME: no longer working due to no more local-eval
-(define (evaluate state expression)
- "Evaluate an expression in the environment of the selected stack frame.
-The expression must appear on the same line as the command, however it
-may be continued over multiple lines."
- (let ((source (frame-source (stack-ref (state-stack state)
- (state-index state)))))
- (if (not source)
- (display "No environment for this frame.\n")
- (catch 'continue
- (lambda ()
- (lazy-catch #t
- (lambda ()
- (let* ((expr
- ;; We assume that no one will
- ;; really want to evaluate a
- ;; string (since it is
- ;; self-evaluating); so if we
- ;; have a string here, read the
- ;; expression to evaluate from
- ;; it.
- (if (string? expression)
- (with-input-from-string expression
- read)
- expression))
- (env (memoized-environment source))
- (value (local-eval expr env)))
- (write expr)
- (display " => ")
- (write value)
- (newline)))
- eval-handler))
- (lambda args args)))))
-
-(define (info-args state)
- "Display the argument variables of the current stack frame.
-Arguments can also be seen in the backtrace, but are presented more
-clearly by this command."
- (let ((index (state-index state)))
- (let ((frame (stack-ref (state-stack state) index)))
- (write-frame-index-long frame)
- (write-frame-args-long frame))))
-
-(define (info-frame state)
- "Display a verbose description of the selected frame. The
-information that this command provides is equivalent to what can be
-deduced from the one line summary for the frame that appears in a
-backtrace, but is presented and explained more clearly."
- (write-state-long state))
-
-(define (position state)
- "Display the name of the source file that the current expression
-comes from, and the line and column number of the expression's opening
-parenthesis within that file. This information is only available when
-the 'positions read option is enabled."
- (let* ((frame (stack-ref (state-stack state) (state-index state)))
- (source (frame-source frame)))
- (if (not source)
- (display "No source available for this frame.")
- (let ((position (source-position source)))
- (if (not position)
- (display "No position information available for this frame.")
- (display-position position)))))
- (newline))
-
-(define (up state n)
- "Move @var{n} frames up the stack. For positive @var{n}, this
-advances toward the outermost frame, to lower frame numbers, to
-frames that have existed longer. @var{n} defaults to one."
- (set-stack-index! state (+ (state-index state) (or n 1)))
- (write-state-short state))
-
-(define (down state n)
- "Move @var{n} frames down the stack. For positive @var{n}, this
-advances toward the innermost frame, to higher frame numbers, to frames
-that were created more recently. @var{n} defaults to one."
- (set-stack-index! state (- (state-index state) (or n 1)))
- (write-state-short state))
-
-(define (frame state n)
- "Select and print a stack frame.
-With no argument, print the selected stack frame. (See also \"info frame\").
-An argument specifies the frame to select; it must be a stack-frame number."
- (if n (set-stack-index! state (frame-number->index n (state-stack state))))
- (write-state-short state))
-
-(define (assert-continuable state)
- ;; Check that debugger is in a state where `continuing' makes sense.
- ;; If not, signal an error.
- (or (memq #:continuable (state-flags state))
- (user-error "This debug session is not continuable.")))
-
-(define (continue state)
- "Tell the program being debugged to continue running. (In fact this is
-the same as the @code{quit} command, because it exits the debugger
-command loop and so allows whatever code it was that invoked the
-debugger to continue.)"
- (assert-continuable state)
- (throw 'exit-debugger))
-
-(define (finish state)
- "Continue until evaluation of the current frame is complete, and
-print the result obtained."
- (assert-continuable state)
- (at-exit (- (stack-length (state-stack state))
- (state-index state))
- (list trace-trap debug-trap))
- (continue state))
-
-(define (step state n)
- "Tell the debugged program to do @var{n} more steps from its current
-position. One @dfn{step} means executing until the next frame entry
-or exit of any kind. @var{n} defaults to 1."
- (assert-continuable state)
- (at-step debug-trap (or n 1))
- (continue state))
-
-(define (next state n)
- "Tell the debugged program to do @var{n} more steps from its current
-position, but only counting frame entries and exits where the
-corresponding source code comes from the same file as the current
-stack frame. (See @ref{Step Traps} for the details of how this
-works.) If the current stack frame has no source code, the effect of
-this command is the same as of @code{step}. @var{n} defaults to 1."
- (assert-continuable state)
- (at-step debug-trap
- (or n 1)
- (frame-file-name (stack-ref (state-stack state)
- (state-index state)))
- (if (memq #:return (state-flags state))
- #f
- (- (stack-length (state-stack state)) (state-index state))))
- (continue state))
-
-;;; (ice-9 debugger commands) ends here.
diff --git a/module/ice-9/debugger/state.scm b/module/ice-9/debugger/state.scm
deleted file mode 100644
index 0bda0fa..0000000
--- a/module/ice-9/debugger/state.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-;;;; (ice-9 debugger state) -- debugger state representation
-
-;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugger state)
- #:export (make-state
- state-stack
- state-index
- state-flags
- set-stack-index!))
-
-(define state-rtd (make-record-type "debugger-state" '(stack index flags)))
-(define state? (record-predicate state-rtd))
-(define make-state
- (let ((make-state-internal (record-constructor state-rtd
- '(stack index flags))))
- (lambda (stack index . flags)
- (make-state-internal stack index flags))))
-(define state-stack (record-accessor state-rtd 'stack))
-(define state-index (record-accessor state-rtd 'index))
-(define state-flags (record-accessor state-rtd 'flags))
-
-(define set-state-index! (record-modifier state-rtd 'index))
-
-(define (set-stack-index! state index)
- (let* ((stack (state-stack state))
- (ssize (stack-length stack)))
- (set-state-index! state
- (cond ((< index 0) 0)
- ((>= index ssize) (- ssize 1))
- (else index)))))
-
-;;; (ice-9 debugger state) ends here.
diff --git a/module/ice-9/debugger/trc.scm b/module/ice-9/debugger/trc.scm
deleted file mode 100644
index 3e7e2f3..0000000
--- a/module/ice-9/debugger/trc.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-;;;; (ice-9 debugger trc) -- tracing for Guile debugger code
-
-;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugger trc)
- #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
-
-(define *syms* #f)
-
-(define (trc-set! syms)
- (set! *syms* syms))
-
-(define (trc-syms . syms)
- (trc-set! syms))
-
-(define (trc-all)
- (trc-set! #f))
-
-(define (trc-none)
- (trc-set! '()))
-
-(define (trc-add sym)
- (trc-set! (cons sym *syms*)))
-
-(define (trc-remove sym)
- (trc-set! (delq1! sym *syms*)))
-
-(define (trc sym . args)
- (if (or (not *syms*)
- (memq sym *syms*))
- (let ((port (trc-port)))
- (write sym port)
- (display ":" port)
- (for-each (lambda (arg)
- (display " " port)
- (write arg port))
- args)
- (newline port))))
-
-(define trc-port
- (let ((port (current-error-port)))
- (make-procedure-with-setter
- (lambda () port)
- (lambda (p) (set! port p)))))
-
-;; Default to no tracing.
-(trc-none)
-
-;;; (ice-9 debugger trc) ends here.
diff --git a/module/ice-9/debugger/utils.scm b/module/ice-9/debugger/utils.scm
deleted file mode 100644
index dfef25b..0000000
--- a/module/ice-9/debugger/utils.scm
+++ /dev/null
@@ -1,203 +0,0 @@
-
-(define-module (ice-9 debugger utils)
- #:use-module (ice-9 debugger state)
- #:export (display-position
- source-position
- write-frame-args-long
- write-frame-index-long
- write-frame-short/expression
- write-frame-short/application
- write-frame-long
- write-state-long
- write-state-short))
-
-;;; Procedures in this module print information about a stack frame.
-;;; The available information is as follows.
-;;;
-;;; * Source code location.
-;;;
-;;; For an evaluation frame, this is the location recorded at the time
-;;; that the expression being evaluated was read, if the 'positions
-;;; read option was enabled at that time.
-;;;
-;;; For an application frame, I'm not yet sure. Some applications
-;;; seem to have associated source expressions.
-;;;
-;;; * Whether frame is still evaluating its arguments.
-;;;
-;;; Only applies to an application frame. For example, an expression
-;;; like `(+ (* 2 3) 4)' goes through the following stages of
-;;; evaluation.
-;;;
-;;; (+ (* 2 3) 4) -- evaluation
-;;; [+ ... -- application; the car of the evaluation
-;;; has been evaluated and found to be a
-;;; procedure; before this procedure can
-;;; be applied, its arguments must be evaluated
-;;; [+ 6 ... -- same application after evaluating the
-;;; first argument
-;;; [+ 6 4] -- same application after evaluating all
-;;; arguments
-;;; 10 -- result
-;;;
-;;; * Whether frame is real or tail-recursive.
-;;;
-;;; If a frame is tail-recursive, its containing frame as shown by the
-;;; debugger backtrace doesn't really exist as far as the Guile
-;;; evaluator is concerned. The effect of this is that when a
-;;; tail-recursive frame returns, it looks as though its containing
-;;; frame returns at the same time. (And if the containing frame is
-;;; also tail-recursive, _its_ containing frame returns at that time
-;;; also, and so on ...)
-;;;
-;;; A `real' frame is one that is not tail-recursive.
-
-
-(define (write-state-short state)
- (let* ((frame (stack-ref (state-stack state) (state-index state)))
- (source (frame-source frame))
- (position (and source (source-position source))))
- (format #t "Frame ~A at " (frame-number frame))
- (if position
- (display-position position)
- (display "unknown source location"))
- (newline)
- (write-char #\tab)
- (write-frame-short frame)
- (newline)))
-
-(define (write-state-short* stack index)
- (write-frame-index-short stack index)
- (write-char #\space)
- (write-frame-short (stack-ref stack index))
- (newline))
-
-(define (write-frame-index-short stack index)
- (let ((s (number->string (frame-number (stack-ref stack index)))))
- (display s)
- (write-char #\:)
- (write-chars #\space (- 4 (string-length s)))))
-
-(define (write-frame-short frame)
- (if (frame-procedure? frame)
- (write-frame-short/application frame)
- (write-frame-short/expression frame)))
-
-(define (write-frame-short/application frame)
- (write-char #\[)
- (write (let ((procedure (frame-procedure frame)))
- (or (and (procedure? procedure)
- (procedure-name procedure))
- procedure)))
- (if (frame-evaluating-args? frame)
- (display " ...")
- (begin
- (for-each (lambda (argument)
- (write-char #\space)
- (write argument))
- (frame-arguments frame))
- (write-char #\]))))
-
-;;; Use builtin function instead:
-(set! write-frame-short/application
- (lambda (frame)
- (display-application frame (current-output-port) 12)))
-
-(define (write-frame-short/expression frame)
- (write (let* ((source (frame-source frame))
- (copy (source-property source 'copy)))
- (if (pair? copy)
- copy
- (unmemoize-expr source)))))
-
-(define (write-state-long state)
- (let ((index (state-index state)))
- (let ((frame (stack-ref (state-stack state) index)))
- (write-frame-index-long frame)
- (write-frame-long frame))))
-
-(define (write-frame-index-long frame)
- (display "Stack frame: ")
- (write (frame-number frame))
- (if (frame-real? frame)
- (display " (real)"))
- (newline))
-
-(define (write-frame-long frame)
- (if (frame-procedure? frame)
- (write-frame-long/application frame)
- (write-frame-long/expression frame)))
-
-(define (write-frame-long/application frame)
- (display "This frame is an application.")
- (newline)
- (if (frame-source frame)
- (begin
- (display "The corresponding expression is:")
- (newline)
- (display-source frame)
- (newline)))
- (display "The procedure being applied is: ")
- (write (let ((procedure (frame-procedure frame)))
- (or (and (procedure? procedure)
- (procedure-name procedure))
- procedure)))
- (newline)
- (display "The procedure's arguments are")
- (if (frame-evaluating-args? frame)
- (display " being evaluated.")
- (begin
- (display ": ")
- (write (frame-arguments frame))))
- (newline))
-
-(define (display-source frame)
- (let* ((source (frame-source frame))
- (copy (source-property source 'copy)))
- (cond ((source-position source)
- => (lambda (p) (display-position p) (display ":\n"))))
- (display " ")
- (write (or copy (unmemoize-expr source)))))
-
-(define (source-position source)
- (let ((fname (source-property source 'filename))
- (line (source-property source 'line))
- (column (source-property source 'column)))
- (and fname
- (list fname line column))))
-
-(define (display-position pos)
- (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos))))
-
-(define (write-frame-long/expression frame)
- (display "This frame is an evaluation.")
- (newline)
- (display "The expression being evaluated is:")
- (newline)
- (display-source frame)
- (newline))
-
-(define (write-frame-args-long frame)
- (if (frame-procedure? frame)
- (let ((arguments (frame-arguments frame)))
- (let ((n (length arguments)))
- (display "This frame has ")
- (write n)
- (display " argument")
- (if (not (= n 1))
- (display "s"))
- (write-char (if (null? arguments) #\. #\:))
- (newline))
- (for-each (lambda (argument)
- (display " ")
- (write argument)
- (newline))
- arguments))
- (begin
- (display "This frame is an evaluation frame; it has no arguments.")
- (newline))))
-
-(define (write-chars char n)
- (do ((i 0 (+ i 1)))
- ((>= i n))
- (write-char char)))
diff --git a/module/ice-9/debugging/breakpoints.scm
b/module/ice-9/debugging/breakpoints.scm
deleted file mode 100644
index 7293c8e..0000000
--- a/module/ice-9/debugging/breakpoints.scm
+++ /dev/null
@@ -1,414 +0,0 @@
-;;;; (ice-9 debugging breakpoints) -- practical breakpoints
-
-;;; Copyright (C) 2005, 2010 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
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 traps)
- #:use-module (ice-9 debugging trc)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-13)
- #:export (break-in
- break-at
- default-breakpoint-behaviour
- delete-breakpoint
- for-each-breakpoint
- setup-before-load
- setup-after-load
- setup-after-read
- setup-after-eval))
-
-;; If the running Guile does not provide before- and after- load hooks
-;; itself, install them using the (ice-9 debugging load-hooks) module.
-(or (defined? 'after-load-hook)
- (begin
- (use-modules (ice-9 debugging load-hooks))
- (install-load-hooks)))
-
-;; Getter/setter for default breakpoint behaviour.
-(define default-breakpoint-behaviour
- (let ((behaviour debug-trap))
- (make-procedure-with-setter
- ;; Getter: return current default behaviour.
- (lambda ()
- behaviour)
- ;; Setter: set default behaviour to given procedure.
- (lambda (new-behaviour)
- (set! behaviour new-behaviour)))))
-
-;; Base class for breakpoints. (We don't need to use GOOPS to
-;; represent breakpoints, but it's a nice way to describe a composite
-;; object.)
-(define-class <breakpoint> ()
- ;; This breakpoint's trap options, which include its behaviour.
- (trap-options #:init-keyword #:trap-options)
- ;; All the traps relating to this breakpoint.
- (traps #:init-value '())
- ;; Observer. This is a procedure that is called when the breakpoint
- ;; trap list changes.
- (observer #:init-value #f))
-
-;; Noop base class definitions of all the possible setup methods.
-(define-method (setup-before-load (bp <breakpoint>) filename)
- *unspecified*)
-(define-method (setup-after-load (bp <breakpoint>) filename)
- *unspecified*)
-(define-method (setup-after-read (bp <breakpoint>) x)
- *unspecified*)
-(define-method (setup-after-eval (bp <breakpoint>) filename)
- *unspecified*)
-
-;; Call the breakpoint's observer, if it has one.
-(define-method (call-observer (bp <breakpoint>))
- (cond ((slot-ref bp 'observer)
- =>
- (lambda (proc)
- (proc)))))
-
-;; Delete a breakpoint.
-(define (delete-breakpoint bp)
- ;; Remove this breakpoint from the global list.
- (set! breakpoints (delq! bp breakpoints))
- ;; Uninstall and discard all its traps.
- (for-each uninstall-trap (slot-ref bp 'traps))
- (slot-set! bp 'traps '()))
-
-;; Class for `break-in' breakpoints.
-(define-class <break-in> (<breakpoint>)
- ;; The name of the procedure to break in.
- (procedure-name #:init-keyword #:procedure-name)
- ;; The name of the module or file that the procedure is defined in.
- ;; A module name is a list of symbols that exactly names the
- ;; relevant module. A file name is a string, which can in fact be
- ;; any substring of the relevant full file name.
- (module-or-file-name #:init-keyword #:module-or-file-name))
-
-;; Class for `break-at' breakpoints.
-(define-class <break-at> (<breakpoint>)
- ;; The name of the file to break in. This is a string, which can in
- ;; fact be any substring of the relevant full file name.
- (file-name #:init-keyword #:file-name)
- ;; Line and column number to break at.
- (line #:init-keyword #:line)
- (column #:init-keyword #:column))
-
-;; Global list of non-deleted breakpoints.
-(define breakpoints '())
-
-;; Add to the above list.
-(define-method (add-to-global-breakpoint-list (bp <breakpoint>))
- (set! breakpoints (append! breakpoints (list bp))))
-
-;; break-in: create a `break-in' breakpoint.
-(define (break-in procedure-name . options)
- ;; Sort out the optional args.
- (let* ((module-or-file-name+options
- (cond ((and (not (null? options))
- (or (string? (car options))
- (list? (car options))))
- options)
- (else
- (cons (module-name (current-module)) options))))
- (module-or-file-name (car module-or-file-name+options))
- (trap-options (cdr module-or-file-name+options))
- ;; Create the new breakpoint object.
- (bp (make <break-in>
- #:procedure-name procedure-name
- #:module-or-file-name module-or-file-name
- #:trap-options (if (memq #:behaviour trap-options)
- trap-options
- (cons* #:behaviour
- (default-breakpoint-behaviour)
- trap-options)))))
- ;; Add it to the global breakpoint list.
- (add-to-global-breakpoint-list bp)
- ;; Set the new breakpoint, if possible, in already loaded code.
- (set-in-existing-code bp)
- ;; Return the breakpoint object to our caller.
- bp))
-
-;; break-at: create a `break-at' breakpoint.
-(define (break-at file-name line column . trap-options)
- ;; Create the new breakpoint object.
- (let* ((bp (make <break-at>
- #:file-name file-name
- #:line line
- #:column column
- #:trap-options (if (memq #:behaviour trap-options)
- trap-options
- (cons* #:behaviour
- (default-breakpoint-behaviour)
- trap-options)))))
- ;; Add it to the global breakpoint list.
- (add-to-global-breakpoint-list bp)
- ;; Set the new breakpoint, if possible, in already loaded code.
- (set-in-existing-code bp)
- ;; Return the breakpoint object to our caller.
- bp))
-
-;; Set a `break-in' breakpoint in already loaded code, if possible.
-(define-method (set-in-existing-code (bp <break-in>))
- ;; Get the module or file name that was specified for this
- ;; breakpoint.
- (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
- ;; Handling is simpler for a module name.
- (cond ((list? module-or-file-name)
- ;; See if the named module exists yet.
- (let ((m (module-if-already-loaded module-or-file-name)))
- (maybe-break-in-module-proc m bp)))
- ((string? module-or-file-name)
- ;; Try all loaded modules.
- (or-map (lambda (m)
- (maybe-break-in-module-proc m bp))
- (all-loaded-modules)))
- (else
- (error "Bad module-or-file-name:" module-or-file-name)))))
-
-(define (make-observer bp trap)
- (lambda (event)
- (trap-target-gone bp trap)))
-
-;; Set a `break-at' breakpoint in already loaded code, if possible.
-(define-method (set-in-existing-code (bp <break-at>) . code)
- ;; Procedure to install a source trap on each expression that we
- ;; find matching this breakpoint.
- (define (install-source-trap x)
- (or (or-map (lambda (trap)
- (and (is-a? trap <source-trap>)
- (eq? (slot-ref trap 'expression) x)))
- (slot-ref bp 'traps))
- (let ((trap (apply make <source-trap>
- #:expression x
- (slot-ref bp 'trap-options))))
- (slot-set! trap 'observer (make-observer bp trap))
- (install-trap trap)
- (trc 'install-source-trap (object-address trap) (object-address x))
- (trap-installed bp trap #t))))
- ;; Scan the source whash, and install a trap on all code matching
- ;; this breakpoint.
- (trc 'set-in-existing-code (length code))
- (if (null? code)
- (scan-source-whash (slot-ref bp 'file-name)
- (slot-ref bp 'line)
- (slot-ref bp 'column)
- install-source-trap)
- (scan-code (car code)
- (slot-ref bp 'file-name)
- (slot-ref bp 'line)
- (slot-ref bp 'column)
- install-source-trap)))
-
-;; Temporary implementation of scan-source-whash - this _really_ needs
-;; to be implemented in C.
-(define (scan-source-whash file-name line column proc)
- ;; Procedure to call for each source expression in the whash.
- (define (folder x props acc)
- (if (and (= line (source-property x 'line))
- (= column (source-property x 'column))
- (let ((fn (source-property x 'filename)))
- (trc 'scan-source-whash fn)
- (and (string? fn)
- (string-contains fn file-name))))
- (proc x)))
- ;; Tracing.
- (trc 'scan-source-whash file-name line column)
- ;; Apply this procedure to the whash.
- (hash-fold folder 0 source-whash))
-
-(define (scan-code x file-name line column proc)
- (trc 'scan-code file-name line column)
- (if (pair? x)
- (begin
- (if (and (eq? line (source-property x 'line))
- (eq? column (source-property x 'column))
- (let ((fn (source-property x 'filename)))
- (trc 'scan-code fn)
- (and (string? fn)
- (string-contains fn file-name))))
- (proc x))
- (scan-code (car x) file-name line column proc)
- (scan-code (cdr x) file-name line column proc))))
-
-;; If a module named MODULE-NAME has been loaded, return its module
-;; object; otherwise return #f.
-(define (module-if-already-loaded module-name)
- (nested-ref the-root-module (append '(%app modules) module-name)))
-
-;; Construct and return a list of all loaded modules.
-(define (all-loaded-modules)
- ;; This is the list that accumulates known modules. It has to be
- ;; defined outside the following functions, and accumulated using
- ;; set!, so as to avoid infinite loops - because of the fact that
- ;; all non-pure modules have a variable `app'.
- (define known-modules '())
- ;; Return an alist of submodules of the given PARENT-MODULE-NAME.
- ;; Each element of the alist is (NAME . MODULE), where NAME is the
- ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and
- ;; MODULE is the module object. By a "submodule of a parent
- ;; module", we mean any module value that is bound to a symbol in
- ;; the parent module, and which is not an interface module.
- (define (direct-submodules parent-module-name)
- (filter (lambda (name+value)
- (and (module? (cdr name+value))
- (not (eq? (module-kind (cdr name+value)) 'interface))))
- (map (lambda (name)
- (cons name (local-ref (append parent-module-name
- (list name)))))
- (cdar (lls parent-module-name)))))
- ;; Add all submodules (direct and indirect) of the module named
- ;; PARENT-MODULE-NAME to `known-modules', if not already there.
- (define (add-submodules-of parent-module-name)
- (let ((ds (direct-submodules parent-module-name)))
- (for-each
- (lambda (name+module)
- (or (memq (cdr name+module) known-modules)
- (begin
- (set! known-modules (cons (cdr name+module) known-modules))
- (add-submodules-of (append parent-module-name
- (list (car name+module)))))))
- ds)))
- ;; Add submodules recursively, starting from the root of all
- ;; modules.
- (add-submodules-of '(%app modules))
- ;; Return the result.
- known-modules)
-
-;; Before-load setup for `break-at' breakpoints.
-(define-method (setup-before-load (bp <break-at>) filename)
- (let ((trap (apply make <location-trap>
- #:file-regexp (regexp-quote (slot-ref bp 'file-name))
- #:line (slot-ref bp 'line)
- #:column (slot-ref bp 'column)
- (slot-ref bp 'trap-options))))
- (install-trap trap)
- (trap-installed bp trap #f)
- (letrec ((uninstaller
- (lambda (file-name)
- (uninstall-trap trap)
- (remove-hook! after-load-hook uninstaller))))
- (add-hook! after-load-hook uninstaller))))
-
-;; After-load setup for `break-in' breakpoints.
-(define-method (setup-after-load (bp <break-in>) filename)
- ;; Get the module that the loaded file created or was loaded into,
- ;; and the module or file name that were specified for this
- ;; breakpoint.
- (let ((m (current-module))
- (module-or-file-name (slot-ref bp 'module-or-file-name)))
- ;; Decide whether the breakpoint spec matches this load.
- (if (or (and (string? module-or-file-name)
- (string-contains filename module-or-file-name))
- (and (list? module-or-file-name)
- (equal? (module-name (current-module)) module-or-file-name)))
- ;; It does, so try to install the breakpoint.
- (maybe-break-in-module-proc m bp))))
-
-;; After-load setup for `break-at' breakpoints.
-(define-method (setup-after-load (bp <break-at>) filename)
- (if (string-contains filename (slot-ref bp 'file-name))
- (set-in-existing-code bp)))
-
-(define (maybe-break-in-module-proc m bp)
- "If module M defines a procedure matching the specification of
-breakpoint BP, install a trap on it."
- (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f)))
- (if (and proc
- (procedure? proc)
- (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
- (if (string? module-or-file-name)
- (source-file-matches (procedure-source proc)
- module-or-file-name)
- #t))
- (not (or-map (lambda (trap)
- (and (is-a? trap <procedure-trap>)
- (eq? (slot-ref trap 'procedure) proc)))
- (slot-ref bp 'traps))))
- ;; There is, so install a <procedure-trap> on it.
- (letrec ((trap (apply make <procedure-trap>
- #:procedure proc
- (slot-ref bp 'trap-options))))
- (slot-set! trap 'observer (make-observer bp trap))
- (install-trap trap)
- (trap-installed bp trap #t)
- ;; Tell caller that we installed a trap.
- #t)
- ;; Tell caller that we did not install a trap.
- #f)))
-
-;; After-read setup for `break-at' breakpoints.
-(define-method (setup-after-read (bp <break-at>) x)
- (set-in-existing-code bp x))
-
-;; Common code for associating a newly created and installed trap with
-;; a breakpoint object.
-(define (trap-installed bp trap record?)
- (if record?
- ;; Remember this trap in the breakpoint object.
- (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap))))
- ;; Update the breakpoint status.
- (call-observer bp))
-
-;; Common code for handling when the target of one of a breakpoint's
-;; traps is being GC'd.
-(define (trap-target-gone bp trap)
- (trc 'trap-target-gone (object-address trap))
- ;; Remove this trap from the breakpoint's list.
- (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps)))
- ;; Update the breakpoint status.
- (call-observer bp))
-
-(define (source-file-matches source file-name)
- "Return #t if any of the expressions in SOURCE have a 'filename
-source property that includes FILE-NAME; otherwise return #f."
- (and (pair? source)
- (or (let ((source-file-name (source-property source 'filename)))
- (and source-file-name
- (string? source-file-name)
- (string-contains source-file-name file-name)))
- (let loop ((source source))
- (and (pair? source)
- (or (source-file-matches (car source) file-name)
- (loop (cdr source))))))))
-
-;; Install load hook functions.
-(add-hook! before-load-hook
- (lambda (fn)
- (for-each-breakpoint setup-before-load fn)))
-
-(add-hook! after-load-hook
- (lambda (fn)
- (for-each-breakpoint setup-after-load fn)))
-
-;;; Apply generic function GF to each breakpoint, passing the
-;;; breakpoint object and ARGS as args on each call.
-(define (for-each-breakpoint gf . args)
- (for-each (lambda (bp)
- (apply gf bp args))
- breakpoints))
-
-;; Make sure that recording of source positions is enabled. Without
-;; this break-at breakpoints will obviously not work.
-(read-enable 'positions)
-
-;;; (ice-9 debugging breakpoints) ends here.
diff --git a/module/ice-9/debugging/example-fns.scm
b/module/ice-9/debugging/example-fns.scm
deleted file mode 100644
index 30d412f..0000000
--- a/module/ice-9/debugging/example-fns.scm
+++ /dev/null
@@ -1,17 +0,0 @@
-(define-module (ice-9 debugging example-fns)
- #:export (fact1 fact2 facti))
-
-(define (fact1 n)
- (if (= n 0)
- 1
- (* n (fact1 (- n 1)))))
-
-(define (facti n a)
- (if (= n 0)
- a
- (facti (- n 1) (* a n))))
-
-(define (fact2 n)
- (facti n 1))
-
-; Test: (fact2 3)
diff --git a/module/ice-9/debugging/ice-9-debugger-extensions.scm
b/module/ice-9/debugging/ice-9-debugger-extensions.scm
deleted file mode 100644
index e69de29..0000000
diff --git a/module/ice-9/debugging/load-hooks.scm
b/module/ice-9/debugging/load-hooks.scm
deleted file mode 100644
index fb869ed..0000000
--- a/module/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/module/ice-9/debugging/steps.scm b/module/ice-9/debugging/steps.scm
deleted file mode 100644
index cd328bd..0000000
--- a/module/ice-9/debugging/steps.scm
+++ /dev/null
@@ -1,106 +0,0 @@
-;;;; (ice-9 debugging steps) -- stepping through code from the debugger
-
-;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugging steps)
- #:use-module (ice-9 debugging traps)
- #:use-module (ice-9 and-let-star)
- #:use-module (ice-9 debugger)
- #:use-module (ice-9 optargs)
- #:export (at-exit
- at-entry
- at-apply
- at-step
- at-next))
-
-;;; at-exit DEPTH BEHAVIOUR
-;;;
-;;; Install a behaviour to run when we exit the current frame.
-
-(define (at-exit depth behaviour)
- (install-trap (make <exit-trap>
- #:depth depth
- #:single-shot #t
- #:behaviour behaviour)))
-
-;;; at-entry BEHAVIOUR [COUNT]
-;;;
-;;; Install a behaviour to run when we get to the COUNT'th next frame
-;;; entry. COUNT defaults to 1.
-
-(define* (at-entry behaviour #:optional (count 1))
- (install-trap (make <entry-trap>
- #:skip-count (- count 1)
- #:single-shot #t
- #:behaviour behaviour)))
-
-;;; at-apply BEHAVIOUR [COUNT]
-;;;
-;;; Install a behaviour to run when we get to the COUNT'th next
-;;; application. COUNT defaults to 1.
-
-(define* (at-apply behaviour #:optional (count 1))
- (install-trap (make <apply-trap>
- #:skip-count (- count 1)
- #:single-shot #t
- #:behaviour behaviour)))
-
-;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]]
-;;;
-;;; Install BEHAVIOUR to run on the COUNT'th next application, frame
-;;; entry or frame exit. COUNT defaults to 1. If FILENAME is
-;;; specified and not #f, only frames that begin in the named file are
-;;; counted.
-
-(define* (at-step behaviour #:optional (count 1) filename (depth 1000))
- (install-trap (make <step-trap>
- #:file-name filename
- #:exit-depth depth
- #:skip-count (- count 1)
- #:single-shot #t
- #:behaviour behaviour)))
-
-;; (or count (set! count 1))
-;; (letrec ((proc (lambda (trap-context)
-;; ;; Behaviour whenever we enter or exit a frame.
-;; (set! count (- count 1))
-;; (if (= count 0)
-;; (begin
-;; (remove-enter-frame-hook! step)
-;; (remove-apply-frame-hook! step)
-;; (behaviour trap-context)))))
-;; (step (lambda (trap-context)
-;; ;; Behaviour on frame entry: both execute the above
-;; ;; and install it as an exit hook.
-;; (if (or (not filename)
-;; (equal? (frame-file-name (tc:frame trap-context))
-;; filename))
-;; (begin
-;; (proc trap-context)
-;; (at-exit (tc:depth trap-context) proc))))))
-;; (at-exit depth proc)
-;; (add-enter-frame-hook! step)
-;; (add-apply-frame-hook! step)))
-
-;;; at-next BEHAVIOUR [COUNT]
-;;;
-;;; Install a behaviour to run when we get to the COUNT'th next frame
-;;; entry in the same source file as the current location. COUNT
-;;; defaults to 1. If the current location has no filename, fall back
-;;; silently to `at-entry' behaviour.
-
-;;; (ice-9 debugging steps) ends here.
diff --git a/module/ice-9/debugging/trace.scm b/module/ice-9/debugging/trace.scm
deleted file mode 100644
index c8d24d0..0000000
--- a/module/ice-9/debugging/trace.scm
+++ /dev/null
@@ -1,153 +0,0 @@
-;;;; (ice-9 debugging trace) -- breakpoint trace behaviour
-
-;;; Copyright (C) 2002, 2010 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugging trace)
- #:use-module (ice-9 debugger)
- #:use-module (ice-9 debugger utils)
- #:use-module (ice-9 debugging steps)
- #:use-module (ice-9 debugging traps)
- #:export (trace-trap
- trace-port
- set-trace-layout
- trace/pid
- trace/stack-id
- trace/stack-depth
- trace/stack-real-depth
- trace/stack
- trace/source-file-name
- trace/source-line
- trace/source-column
- trace/source
- trace/type
- trace/real?
- trace/info
- trace-at-exit
- trace-until-exit))
-
-(define trace-format-string #f)
-(define trace-arg-procs #f)
-
-(define (set-trace-layout format-string . arg-procs)
- (set! trace-format-string format-string)
- (set! trace-arg-procs arg-procs))
-
-(define (trace/pid trap-context)
- (getpid))
-
-(define (trace/stack-id trap-context)
- (stack-id (tc:stack trap-context)))
-
-(define (trace/stack-depth trap-context)
- (tc:depth trap-context))
-
-(define (trace/stack-real-depth trap-context)
- (tc:real-depth trap-context))
-
-(define (trace/stack trap-context)
- (format #f "~a:~a+~a"
- (stack-id (tc:stack trap-context))
- (tc:real-depth trap-context)
- (- (tc:depth trap-context) (tc:real-depth trap-context))))
-
-(define (trace/source-file-name trap-context)
- (cond ((frame->source-position (tc:frame trap-context)) => car)
- (else "")))
-
-(define (trace/source-line trap-context)
- (cond ((frame->source-position (tc:frame trap-context)) => cadr)
- (else 0)))
-
-(define (trace/source-column trap-context)
- (cond ((frame->source-position (tc:frame trap-context)) => caddr)
- (else 0)))
-
-(define (trace/source trap-context)
- (cond ((frame->source-position (tc:frame trap-context))
- =>
- (lambda (pos)
- (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
- (else "")))
-
-(define (trace/type trap-context)
- (case (tc:type trap-context)
- ((#:application) "APP")
- ((#:evaluation) "EVA")
- ((#:return) "RET")
- ((#:error) "ERR")
- (else "???")))
-
-(define (trace/real? trap-context)
- (if (frame-real? (tc:frame trap-context)) " " "t"))
-
-(define (trace/info trap-context)
- (with-output-to-string
- (lambda ()
- (if (memq (tc:type trap-context) '(#:application #:evaluation))
- ((if (tc:expression trap-context)
- write-frame-short/expression
- write-frame-short/application) (tc:frame trap-context))
- (begin
- (display "=>")
- (write (tc:return-value trap-context)))))))
-
-(set-trace-layout "|address@hidden: ~a\n" trace/stack-real-depth trace/info)
-
-;;; trace-trap
-;;;
-;;; Trace the current location, and install a hook to trace the return
-;;; value when we exit the current frame.
-
-(define (trace-trap trap-context)
- (apply format
- (trace-port)
- trace-format-string
- (map (lambda (arg-proc)
- (arg-proc trap-context))
- trace-arg-procs)))
-
-(set! (behaviour-ordering trace-trap) 50)
-
-;;; trace-port
-;;;
-;;; The port to which trace information is printed.
-
-(define trace-port
- (let ((port (current-output-port)))
- (make-procedure-with-setter
- (lambda () port)
- (lambda (new) (set! port new)))))
-
-;;; trace-at-exit
-;;;
-;;; Trace return value on exit from the current frame.
-
-(define (trace-at-exit trap-context)
- (at-exit (tc:depth trap-context) trace-trap))
-
-;;; trace-until-exit
-;;;
-;;; Trace absolutely everything until exit from the current frame.
-
-(define (trace-until-exit trap-context)
- (let ((step-trap (make <step-trap> #:behaviour trace-trap)))
- (install-trap step-trap)
- (at-exit (tc:depth trap-context)
- (lambda (trap-context)
- (uninstall-trap step-trap)))))
-
-;;; (ice-9 debugging trace) ends here.
diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm
deleted file mode 100755
index 5557cb3..0000000
--- a/module/ice-9/debugging/traps.scm
+++ /dev/null
@@ -1,1011 +0,0 @@
-;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
-
-;;; Copyright (C) 2002, 2004, 2009, 2010 Free Software Foundation, Inc.
-;;; Copyright (C) 2005 Neil Jerram
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-;;; This module provides an abstraction around Guile's low level trap
-;;; handler interface; its aim is to make the low level trap mechanism
-;;; shareable between the debugger and other applications, and to
-;;; insulate the rest of the debugger code a bit from changes that may
-;;; occur in the low level trap interface in future.
-
-(define-module (ice-9 debugging traps)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 weak-vector)
- #:use-module (ice-9 scm-style-repl)
- #:use-module (oop goops)
- #:use-module (oop goops describe)
- #:use-module (ice-9 debugging trc)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-2)
- #:export (tc:type
- tc:continuation
- tc:expression
- tc:return-value
- tc:stack
- tc:frame
- tc:depth
- tc:real-depth
- tc:exit-depth
- tc:fired-traps
- ;; Interface for users of <trap> subclasses defined in
- ;; this module.
- add-trapped-stack-id!
- remove-trapped-stack-id!
- <procedure-trap>
- <exit-trap>
- <entry-trap>
- <apply-trap>
- <step-trap>
- <source-trap>
- <location-trap>
- install-trap
- uninstall-trap
- all-traps
- get-trap
- list-traps
- trap-ordering
- behaviour-ordering
- throw->trap-context
- on-pre-unwind-handler-dispatch
- ;; Interface for authors of new <trap> subclasses.
- <trap-context>
- <trap>
- trap->behaviour
- trap-runnable?
- install-apply-frame-trap
- install-breakpoint-trap
- install-enter-frame-trap
- install-exit-frame-trap
- install-trace-trap
- uninstall-apply-frame-trap
- uninstall-breakpoint-trap
- uninstall-enter-frame-trap
- uninstall-exit-frame-trap
- uninstall-trace-trap
- frame->source-position
- frame-file-name
- without-traps
- guile-trap-features)
- #:re-export (make)
- ;; FIXME: see below
- ;; #:export-syntax (trap-here)
- )
-
-;; How to debug the debugging infrastructure, when needed. Grep for
-;; "(trc " to find other symbols that can be passed to trc-add.
-;; (trc-add 'after-gc-hook)
-
-;;; The current low level traps interface is as follows.
-;;;
-;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
-;;; by the `traps' setting of `(evaluator-traps-interface)' but also
-;;; (and more relevant in most cases) by the `with-traps' procedure.
-;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
-;;; its thunk parameter.
-;;;
-;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
-;;; for the duration of the call, to avoid nasty recursive trapping
-;;; loops. If a trap handler knows what it is doing, it can override
-;;; this by `(trap-enable traps)'.
-;;;
-;;; The apply-frame handler is called when Guile is about to perform
-;;; an application if EITHER the `apply-frame' evaluator trap option
-;;; is set, OR the `trace' debug option is set and the procedure to
-;;; apply has its `trace' procedure property set. The arguments
-;;; passed are:
-;;;
-;;; - the symbol 'apply-frame
-;;;
-;;; - a continuation or debug object describing the current stack
-;;;
-;;; - a boolean indicating whether the application is tail-recursive.
-;;;
-;;; The enter-frame handler is called when the evaluator begins a new
-;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
-;;; is set, OR the `breakpoints' debug option is set and the code to
-;;; be evaluated has its `breakpoint' source property set. The
-;;; arguments passed are:
-;;;
-;;; - the symbol 'enter-frame
-;;;
-;;; - a continuation or debug object describing the current stack
-;;;
-;;; - a boolean indicating whether the application is tail-recursive.
-;;;
-;;; - an unmemoized copy of the expression to be evaluated.
-;;;
-;;; If the `enter-frame' evaluator trap option is set, the enter-frame
-;;; handler is also called when about to perform an application in
-;;; SCM_APPLY, immediately before possibly calling the apply-frame
-;;; handler. (I don't totally understand this.) In this case, the
-;;; arguments passed are:
-;;;
-;;; - the symbol 'enter-frame
-;;;
-;;; - a continuation or debug object describing the current stack.
-;;;
-;;; The exit-frame handler is called when Guile exits an evaluation
-;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
-;;; EITHER the `exit-frame' evaluator trap option is set, OR the
-;;; `trace' debug option is set and the frame is marked as having been
-;;; traced. The frame will be marked as having been traced if the
-;;; apply-frame handler was called for this frame. (This is trickier
-;;; than it sounds because of tail recursion: the same debug frame
-;;; could have been used for multiple applications, only some of which
-;;; were traced - I think.) The arguments passed are:
-;;;
-;;; - the symbol 'exit-frame
-;;;
-;;; - a continuation or debug object describing the current stack
-;;;
-;;; - the result of the evaluation or application.
-
-;;; {Trap Context}
-;;;
-;;; A trap context is a GOOPS object that encapsulates all the useful
-;;; information about a particular trap. Encapsulating this
-;;; information in a single object also allows us:
-;;;
-;;; - to defer the calculation of information that is time-consuming
-;;; to calculate, such as the stack, and to cache such information so
-;;; that it is only ever calculated once per trap
-;;;
-;;; - to pass all interesting information to trap behaviour procedures
-;;; in a single parameter, which (i) is convenient and (ii) makes for
-;;; a more future-proof interface.
-;;;
-;;; It also allows us - where very carefully documented! - to pass
-;;; information from one behaviour procedure to another.
-
-(define-class <trap-context> ()
- ;; Information provided directly by the trap calls from the
- ;; evaluator. The "type" slot holds a keyword indicating the type
- ;; of the trap: one of #:evaluation, #:application, #:return,
- ;; #:error.
- (type #:getter tc:type
- #:init-keyword #:type)
- ;; The "continuation" slot holds the continuation (or debug object,
- ;; if "cheap" traps are enabled, which is the default) at the point
- ;; of the trap. For an error trap it is #f.
- (continuation #:getter tc:continuation
- #:init-keyword #:continuation)
- ;; The "expression" slot holds the source code expression, for an
- ;; evaluation trap.
- (expression #:getter tc:expression
- #:init-keyword #:expression
- #:init-value #f)
- ;; The "return-value" slot holds the return value, for a return
- ;; trap, or the error args, for an error trap.
- (return-value #:getter tc:return-value
- #:init-keyword #:return-value
- #:init-value #f)
- ;; The list of trap objects which fired in this trap context.
- (fired-traps #:getter tc:fired-traps
- #:init-value '())
- ;; The set of symbols which, if one of them is set in the CAR of the
- ;; handler-return-value slot, will cause the CDR of that slot to
- ;; have an effect.
- (handler-return-syms #:init-value '())
- ;; The value which the trap handler should return to the evaluator.
- (handler-return-value #:init-value #f)
- ;; Calculated and cached information. "stack" is the stack
- ;; (computed from the continuation (or debug object) by make-stack,
- ;; or else (in the case of an error trap) by (make-stack #t ...).
- (stack #:init-value #f)
- (frame #:init-value #f)
- (depth #:init-value #f)
- (real-depth #:init-value #f)
- (exit-depth #:init-value #f))
-
-(define-method (tc:stack (ctx <trap-context>))
- (or (slot-ref ctx 'stack)
- (let ((stack (make-stack (tc:continuation ctx))))
- (slot-set! ctx 'stack stack)
- stack)))
-
-(define-method (tc:frame (ctx <trap-context>))
- (or (slot-ref ctx 'frame)
- (let ((frame (cond ((tc:continuation ctx) => last-stack-frame)
- (else (stack-ref (tc:stack ctx) 0)))))
- (slot-set! ctx 'frame frame)
- frame)))
-
-(define-method (tc:depth (ctx <trap-context>))
- (or (slot-ref ctx 'depth)
- (let ((depth (stack-length (tc:stack ctx))))
- (slot-set! ctx 'depth depth)
- depth)))
-
-(define-method (tc:real-depth (ctx <trap-context>))
- (or (slot-ref ctx 'real-depth)
- (let* ((stack (tc:stack ctx))
- (real-depth (apply +
- (map (lambda (i)
- (if (frame-real? (stack-ref stack i))
- 1
- 0))
- (iota (tc:depth ctx))))))
- (slot-set! ctx 'real-depth real-depth)
- real-depth)))
-
-(define-method (tc:exit-depth (ctx <trap-context>))
- (or (slot-ref ctx 'exit-depth)
- (let* ((stack (tc:stack ctx))
- (depth (tc:depth ctx))
- (exit-depth (let loop ((exit-depth depth))
- (if (or (zero? exit-depth)
- (frame-real? (stack-ref stack
- (- depth
- exit-depth))))
- exit-depth
- (loop (- exit-depth 1))))))
- (slot-set! ctx 'exit-depth exit-depth)
- exit-depth)))
-
-;;; {Stack IDs}
-;;;
-;;; Mechanism for limiting trapping to contexts whose stack ID matches
-;;; one of a registered set. The default is for traps to fire
-;;; regardless of stack ID.
-
-(define trapped-stack-ids (list #t))
-(define all-stack-ids-trapped? #t)
-
-(define (add-trapped-stack-id! id)
- "Add ID to the set of stack ids for which traps are active.
-If `#t' is in this set, traps are active regardless of stack context.
-To remove ID again, use `remove-trapped-stack-id!'. If you add the
-same ID twice using `add-trapped-stack-id!', you will need to remove
-it twice."
- (set! trapped-stack-ids (cons id trapped-stack-ids))
- (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
-
-(define (remove-trapped-stack-id! id)
- "Remove ID from the set of stack ids for which traps are active."
- (set! trapped-stack-ids (delq1! id trapped-stack-ids))
- (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
-
-(define (trap-here? cont)
- ;; Return true if the stack id of the specified continuation (or
- ;; debug object) is in the set that we should trap for; otherwise
- ;; false.
- (or all-stack-ids-trapped?
- (memq (stack-id cont) trapped-stack-ids)))
-
-;;; {Global State}
-;;;
-;;; Variables tracking registered handlers, relevant procedures, and
-;;; what's turned on as regards the evaluator's debugging options.
-
-(define enter-frame-traps '())
-(define apply-frame-traps '())
-(define exit-frame-traps '())
-(define breakpoint-traps '())
-(define trace-traps '())
-
-(define (non-null? hook)
- (not (null? hook)))
-
-;; The low level frame handlers must all be initialized to something
-;; harmless. Otherwise we hit a problem immediately when trying to
-;; enable one of these handlers.
-(trap-set! enter-frame-handler noop)
-(trap-set! apply-frame-handler noop)
-(trap-set! exit-frame-handler noop)
-
-(define set-debug-and-trap-options
- (let ((dopts (debug-options))
- (topts (evaluator-traps-interface))
- (setting (lambda (key opts)
- (let ((l (memq key opts)))
- (and l
- (not (null? (cdr l)))
- (cadr l)))))
- (debug-set-boolean! (lambda (key value)
- ((if value debug-enable debug-disable) key)))
- (trap-set-boolean! (lambda (key value)
- ((if value trap-enable trap-disable) key))))
- (let ((save-debug (memq 'debug dopts))
- (save-trace (memq 'trace dopts))
- (save-breakpoints (memq 'breakpoints dopts))
- (save-enter-frame (memq 'enter-frame topts))
- (save-apply-frame (memq 'apply-frame topts))
- (save-exit-frame (memq 'exit-frame topts))
- (save-enter-frame-handler (setting 'enter-frame-handler topts))
- (save-apply-frame-handler (setting 'apply-frame-handler topts))
- (save-exit-frame-handler (setting 'exit-frame-handler topts)))
- (lambda ()
- (let ((need-trace (non-null? trace-traps))
- (need-breakpoints (non-null? breakpoint-traps))
- (need-enter-frame (non-null? enter-frame-traps))
- (need-apply-frame (non-null? apply-frame-traps))
- (need-exit-frame (non-null? exit-frame-traps)))
- (debug-set-boolean! 'debug
- (or need-trace
- need-breakpoints
- need-enter-frame
- need-apply-frame
- need-exit-frame
- save-debug))
- (debug-set-boolean! 'trace
- (or need-trace
- save-trace))
- (debug-set-boolean! 'breakpoints
- (or need-breakpoints
- save-breakpoints))
- (trap-set-boolean! 'enter-frame
- (or need-enter-frame
- save-enter-frame))
- (trap-set-boolean! 'apply-frame
- (or need-apply-frame
- save-apply-frame))
- (trap-set-boolean! 'exit-frame
- (or need-exit-frame
- save-exit-frame))
- (trap-set! enter-frame-handler
- (cond ((or need-breakpoints
- need-enter-frame)
- enter-frame-handler)
- (else save-enter-frame-handler)))
- (trap-set! apply-frame-handler
- (cond ((or need-trace
- need-apply-frame)
- apply-frame-handler)
- (else save-apply-frame-handler)))
- (trap-set! exit-frame-handler
- (cond ((or need-exit-frame)
- exit-frame-handler)
- (else save-exit-frame-handler))))
- ;;(write (evaluator-traps-interface))
- *unspecified*))))
-
-(define (enter-frame-handler key cont . args)
- ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
- ;; unmemoized copy of the source expression. For an application
- ;; entry, ARGS is empty.
- (if (trap-here? cont)
- (let* ((application-entry? (null? args))
- (trap-context (make <trap-context>
- #:type #:evaluation
- #:continuation cont
- #:expression (if application-entry?
- #f
- (cadr args)))))
- (trc 'enter-frame-handler)
- (if (and (not application-entry?)
- (memq 'tweaking guile-trap-features))
- (slot-set! trap-context 'handler-return-syms '(instead)))
- (run-traps (if application-entry?
- enter-frame-traps
- (append enter-frame-traps breakpoint-traps))
- trap-context)
- (slot-ref trap-context 'handler-return-value))))
-
-(define (apply-frame-handler key cont tail?)
- (if (trap-here? cont)
- (let ((trap-context (make <trap-context>
- #:type #:application
- #:continuation cont)))
- (trc 'apply-frame-handler tail?)
- (run-traps (append apply-frame-traps trace-traps) trap-context)
- (slot-ref trap-context 'handler-return-value))))
-
-(define (exit-frame-handler key cont retval)
- (if (trap-here? cont)
- (let ((trap-context (make <trap-context>
- #:type #:return
- #:continuation cont
- #:return-value retval)))
- (trc 'exit-frame-handler retval (tc:depth trap-context))
- (if (memq 'tweaking guile-trap-features)
- (slot-set! trap-context 'handler-return-syms '(instead)))
- (run-traps exit-frame-traps trap-context)
- (slot-ref trap-context 'handler-return-value))))
-
-(define-macro (trap-installer trap-list)
- `(lambda (trap)
- (set! ,trap-list (cons trap ,trap-list))
- (set-debug-and-trap-options)))
-
-(define install-enter-frame-trap (trap-installer enter-frame-traps))
-(define install-apply-frame-trap (trap-installer apply-frame-traps))
-(define install-exit-frame-trap (trap-installer exit-frame-traps))
-(define install-breakpoint-trap (trap-installer breakpoint-traps))
-(define install-trace-trap (trap-installer trace-traps))
-
-(define-macro (trap-uninstaller trap-list)
- `(lambda (trap)
- (or (memq trap ,trap-list)
- (error "Trap list does not include the specified trap"))
- (set! ,trap-list (delq1! trap ,trap-list))
- (set-debug-and-trap-options)))
-
-(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps))
-(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps))
-(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps))
-(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps))
-(define uninstall-trace-trap (trap-uninstaller trace-traps))
-
-(define trap-ordering (make-object-property))
-(define behaviour-ordering (make-object-property))
-
-(define (run-traps traps trap-context)
- (let ((behaviours (apply append
- (map (lambda (trap)
- (trap->behaviour trap trap-context))
- (sort traps
- (lambda (t1 t2)
- (< (or (trap-ordering t1) 0)
- (or (trap-ordering t2) 0))))))))
- (for-each (lambda (proc)
- (proc trap-context))
- (sort (delete-duplicates behaviours)
- (lambda (b1 b2)
- (< (or (behaviour-ordering b1) 0)
- (or (behaviour-ordering b2) 0)))))))
-
-;;; {Pseudo-Traps for Non-Trap Events}
-
-;;; Once there is a body of code to do with responding to (debugging,
-;;; tracing, etc.) traps, it makes sense to be able to leverage that
-;;; same code for certain events that are trap-like, but not actually
-;;; traps in the sense of the calls made by libguile's evaluator.
-
-;;; The main example of this is when an error is signalled. Guile
-;;; doesn't yet have a 100% reliable way of hooking into errors, but in
-;;; practice most errors go through a catch whose pre-unwind handler is
-;;; pre-unwind-handler-dispatch (defined in ice-9/boot-9.scm), which in
-;;; turn calls default-pre-unwind-handler. So we can present most errors
-;;; as pseudo-traps by modifying default-pre-unwind-handler.
-
-(define default-default-pre-unwind-handler default-pre-unwind-handler)
-
-(define (throw->trap-context key args . stack-args)
- (let ((ctx (make <trap-context>
- #:type #:error
- #:continuation #f
- #:return-value (cons key args))))
- (slot-set! ctx 'stack
- (let ((caller-stack (and (= (length stack-args) 1)
- (car stack-args))))
- (if (stack? caller-stack)
- caller-stack
- (apply make-stack #t stack-args))))
- ctx))
-
-(define (on-pre-unwind-handler-dispatch behaviour . ignored-keys)
- (set! default-pre-unwind-handler
- (if behaviour
- (lambda (key . args)
- (or (memq key ignored-keys)
- (behaviour (throw->trap-context key
- args
- default-pre-unwind-handler)))
- (apply default-default-pre-unwind-handler key args))
- default-default-pre-unwind-handler)))
-
-;;; {Trap Classes}
-
-;;; Class: <trap>
-;;;
-;;; <trap> is the base class for traps. Any actual trap should be an
-;;; instance of a class derived from <trap>, not of <trap> itself,
-;;; because there is no base class method for the install-trap,
-;;; trap-runnable? and uninstall-trap GFs.
-(define-class <trap> ()
- ;; "number" slot: the number of this trap (assigned automatically).
- (number)
- ;; "installed" slot: whether this trap is installed.
- (installed #:init-value #f)
- ;; "condition" slot: if non-#f, this is a thunk which is called when
- ;; the trap fires, to determine whether trap processing should
- ;; proceed any further.
- (condition #:init-value #f #:init-keyword #:condition)
- ;; "skip-count" slot: a count of valid (after "condition"
- ;; processing) firings of this trap to skip.
- (skip-count #:init-value 0 #:init-keyword #:skip-count)
- ;; "single-shot" slot: if non-#f, this trap is removed after it has
- ;; successfully fired (after "condition" and "skip-count"
- ;; processing) for the first time.
- (single-shot #:init-value #f #:init-keyword #:single-shot)
- ;; "behaviour" slot: procedure or list of procedures to call
- ;; (passing the trap context as parameter) if we finally decide
- ;; (after "condition" and "skip-count" processing) to run this
- ;; trap's behaviour.
- (behaviour #:init-value '() #:init-keyword #:behaviour)
- ;; "repeat-identical-behaviour" slot: normally, if multiple <trap>
- ;; objects are triggered by the same low level trap, and they
- ;; request the same behaviour, it's only useful to do that behaviour
- ;; once (per low level trap); so by default multiple requests for
- ;; the same behaviour are coalesced. If this slot is non-#f, the
- ;; contents of the "behaviour" slot are uniquified so that they
- ;; avoid being coalesced in this way.
- (repeat-identical-behaviour #:init-value #f
- #:init-keyword #:repeat-identical-behaviour)
- ;; "observer" slot: this is a procedure that is called with one
- ;; EVENT argument when the trap status changes in certain
- ;; interesting ways, currently the following. (1) When the trap is
- ;; uninstalled because of the target becoming inaccessible; EVENT in
- ;; this case is 'target-gone.
- (observer #:init-value #f #:init-keyword #:observer))
-
-(define last-assigned-trap-number 0)
-(define all-traps (make-weak-value-hash-table 7))
-
-(define-method (initialize (trap <trap>) initargs)
- (next-method)
- ;; Assign a trap number, and store in the hash of all traps.
- (set! last-assigned-trap-number (+ last-assigned-trap-number 1))
- (slot-set! trap 'number last-assigned-trap-number)
- (hash-set! all-traps last-assigned-trap-number trap)
- ;; Listify the behaviour slot, if not a list already.
- (let ((behaviour (slot-ref trap 'behaviour)))
- (if (procedure? behaviour)
- (slot-set! trap 'behaviour (list behaviour)))))
-
-(define-generic install-trap) ; provided mostly by subclasses
-(define-generic uninstall-trap) ; provided mostly by subclasses
-(define-generic trap->behaviour) ; provided by <trap>
-(define-generic trap-runnable?) ; provided by subclasses
-
-(define-method (install-trap (trap <trap>))
- (if (slot-ref trap 'installed)
- (error "Trap is already installed"))
- (slot-set! trap 'installed #t))
-
-(define-method (uninstall-trap (trap <trap>))
- (or (slot-ref trap 'installed)
- (error "Trap is not installed"))
- (slot-set! trap 'installed #f))
-
-;;; uniquify-behaviour
-;;;
-;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
-(define (uniquify-behaviour behaviour)
- (lambda (trap-context)
- (behaviour trap-context)))
-
-;;; trap->behaviour
-;;;
-;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of
-;;; behaviour procs to call with TRAP-CONTEXT as a parameter.
-;;; Otherwise return the empty list.
-(define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>))
- (if (and
- ;; Check that the trap is runnable. Runnability is implemented
- ;; by the subclass and allows us to check, for example, that
- ;; the procedure being applied in an apply-frame trap matches
- ;; this trap's procedure.
- (trap-runnable? trap trap-context)
- ;; Check the additional condition, if specified.
- (let ((condition (slot-ref trap 'condition)))
- (or (not condition)
- ((condition))))
- ;; Check for a skip count.
- (let ((skip-count (slot-ref trap 'skip-count)))
- (if (zero? skip-count)
- #t
- (begin
- (slot-set! trap 'skip-count (- skip-count 1))
- #f))))
- ;; All checks passed, so we will return the contents of this
- ;; trap's behaviour slot.
- (begin
- ;; First, though, remove this trap if its single-shot slot
- ;; indicates that it should fire only once.
- (if (slot-ref trap 'single-shot)
- (uninstall-trap trap))
- ;; Add this trap object to the context's list of traps which
- ;; fired here.
- (slot-set! trap-context 'fired-traps
- (cons trap (tc:fired-traps trap-context)))
- ;; Return trap behaviour, uniquified if necessary.
- (if (slot-ref trap 'repeat-identical-behaviour)
- (map uniquify-behaviour (slot-ref trap 'behaviour))
- (slot-ref trap 'behaviour)))
- '()))
-
-;;; Class: <procedure-trap>
-;;;
-;;; An installed instance of <procedure-trap> triggers on invocation
-;;; of a specific procedure.
-(define-class <procedure-trap> (<trap>)
- ;; "procedure" slot: the procedure to trap on. This is implemented
- ;; virtually, using the following weak vector slot, so as to avoid
- ;; this trap preventing the GC of the target procedure.
- (procedure #:init-keyword #:procedure
- #:allocation #:virtual
- #:slot-ref
- (lambda (trap)
- (vector-ref (slot-ref trap 'procedure-wv) 0))
- #:slot-set!
- (lambda (trap proc)
- (if (slot-bound? trap 'procedure-wv)
- (vector-set! (slot-ref trap 'procedure-wv) 0 proc)
- (slot-set! trap 'procedure-wv (weak-vector proc)))))
- (procedure-wv))
-
-;; Customization of the initialize method: set up to handle what
-;; should happen when the procedure is GC'd.
-(define-method (initialize (trap <procedure-trap>) initargs)
- (next-method)
- (let* ((proc (slot-ref trap 'procedure))
- (existing-traps (volatile-target-traps proc)))
- ;; If this is the target's first trap, give the target procedure
- ;; to the volatile-target-guardian, so we can find out if it
- ;; becomes inaccessible.
- (or existing-traps (volatile-target-guardian proc))
- ;; Add this trap to the target procedure's list of traps.
- (set! (volatile-target-traps proc)
- (cons trap (or existing-traps '())))))
-
-(define procedure-trace-count (make-object-property))
-
-(define-method (install-trap (trap <procedure-trap>))
- (next-method)
- (let* ((proc (slot-ref trap 'procedure))
- (trace-count (or (procedure-trace-count proc) 0)))
- (set-procedure-property! proc 'trace #t)
- (set! (procedure-trace-count proc) (+ trace-count 1)))
- (install-trace-trap trap))
-
-(define-method (uninstall-trap (trap <procedure-trap>))
- (next-method)
- (let* ((proc (slot-ref trap 'procedure))
- (trace-count (or (procedure-trace-count proc) 0)))
- (if (= trace-count 1)
- (set-procedure-property! proc 'trace #f))
- (set! (procedure-trace-count proc) (- trace-count 1)))
- (uninstall-trace-trap trap))
-
-(define-method (trap-runnable? (trap <procedure-trap>)
- (trap-context <trap-context>))
- (eq? (slot-ref trap 'procedure)
- (frame-procedure (tc:frame trap-context))))
-
-;;; Class: <exit-trap>
-;;;
-;;; An installed instance of <exit-trap> triggers on stack frame exit
-;;; past a specified stack depth.
-(define-class <exit-trap> (<trap>)
- ;; "depth" slot: the reference depth for the trap.
- (depth #:init-keyword #:depth))
-
-(define-method (install-trap (trap <exit-trap>))
- (next-method)
- (install-exit-frame-trap trap))
-
-(define-method (uninstall-trap (trap <exit-trap>))
- (next-method)
- (uninstall-exit-frame-trap trap))
-
-(define-method (trap-runnable? (trap <exit-trap>)
- (trap-context <trap-context>))
- (<= (tc:exit-depth trap-context)
- (slot-ref trap 'depth)))
-
-;;; Class: <entry-trap>
-;;;
-;;; An installed instance of <entry-trap> triggers on any frame entry.
-(define-class <entry-trap> (<trap>))
-
-(define-method (install-trap (trap <entry-trap>))
- (next-method)
- (install-enter-frame-trap trap))
-
-(define-method (uninstall-trap (trap <entry-trap>))
- (next-method)
- (uninstall-enter-frame-trap trap))
-
-(define-method (trap-runnable? (trap <entry-trap>)
- (trap-context <trap-context>))
- #t)
-
-;;; Class: <apply-trap>
-;;;
-;;; An installed instance of <apply-trap> triggers on any procedure
-;;; application.
-(define-class <apply-trap> (<trap>))
-
-(define-method (install-trap (trap <apply-trap>))
- (next-method)
- (install-apply-frame-trap trap))
-
-(define-method (uninstall-trap (trap <apply-trap>))
- (next-method)
- (uninstall-apply-frame-trap trap))
-
-(define-method (trap-runnable? (trap <apply-trap>)
- (trap-context <trap-context>))
- #t)
-
-;;; Class: <step-trap>
-;;;
-;;; An installed instance of <step-trap> triggers on the next frame
-;;; entry, exit or application, optionally with source location inside
-;;; a specified file.
-(define-class <step-trap> (<exit-trap>)
- ;; "file-name" slot: if non-#f, indicates that this trap should
- ;; trigger only for steps in source code from the specified file.
- (file-name #:init-value #f #:init-keyword #:file-name)
- ;; "exit-depth" slot: when non-#f, indicates that the next step may
- ;; be a frame exit past this depth; otherwise, indicates that the
- ;; next step must be an application or a frame entry.
- (exit-depth #:init-value #f #:init-keyword #:exit-depth))
-
-(define-method (initialize (trap <step-trap>) initargs)
- (next-method)
- (slot-set! trap 'depth (slot-ref trap 'exit-depth)))
-
-(define-method (install-trap (trap <step-trap>))
- (next-method)
- (install-enter-frame-trap trap)
- (install-apply-frame-trap trap))
-
-(define-method (uninstall-trap (trap <step-trap>))
- (next-method)
- (uninstall-enter-frame-trap trap)
- (uninstall-apply-frame-trap trap))
-
-(define-method (trap-runnable? (trap <step-trap>)
- (trap-context <trap-context>))
- (if (eq? (tc:type trap-context) #:return)
- ;; We're in the context of an exit-frame trap. Trap should only
- ;; be run if exit-depth is set and this exit-frame has returned
- ;; past the set depth.
- (and (slot-ref trap 'exit-depth)
- (next-method)
- ;; OK to run the trap here, but we should first reset the
- ;; exit-depth slot to indicate that the step after this one
- ;; must be an application or frame entry.
- (begin
- (slot-set! trap 'exit-depth #f)
- #t))
- ;; We're in the context of an application or frame entry trap.
- ;; Check whether trap is limited to a specified file.
- (let ((file-name (slot-ref trap 'file-name)))
- (and (or (not file-name)
- (equal? (frame-file-name (tc:frame trap-context)) file-name))
- ;; Trap should run here, but we should also set exit-depth to
- ;; the current stack length, so that - if we don't stop at any
- ;; other steps first - the next step shows the return value of
- ;; the current application or evaluation.
- (begin
- (slot-set! trap 'exit-depth (tc:depth trap-context))
- (slot-set! trap 'depth (tc:depth trap-context))
- #t)))))
-
-(define (frame->source-position frame)
- (let ((source (if (frame-procedure? frame)
- (or (frame-source frame)
- (let ((proc (frame-procedure frame)))
- (and proc
- (procedure? proc)
- (procedure-source proc))))
- (frame-source frame))))
- (and source
- (string? (source-property source 'filename))
- (list (source-property source 'filename)
- (source-property source 'line)
- (source-property source 'column)))))
-
-(define (frame-file-name frame)
- (cond ((frame->source-position frame) => car)
- (else #f)))
-
-;;; Class: <source-trap>
-;;;
-;;; An installed instance of <source-trap> triggers upon evaluation of
-;;; a specified source expression.
-(define-class <source-trap> (<trap>)
- ;; "expression" slot: the expression to trap on. This is
- ;; implemented virtually, using the following weak vector slot, so
- ;; as to avoid this trap preventing the GC of the target source
- ;; code.
- (expression #:init-keyword #:expression
- #:allocation #:virtual
- #:slot-ref
- (lambda (trap)
- (vector-ref (slot-ref trap 'expression-wv) 0))
- #:slot-set!
- (lambda (trap expr)
- (if (slot-bound? trap 'expression-wv)
- (vector-set! (slot-ref trap 'expression-wv) 0 expr)
- (slot-set! trap 'expression-wv (weak-vector expr)))))
- (expression-wv)
- ;; source property slots - for internal use only
- (filename)
- (line)
- (column))
-
-;; Customization of the initialize method: get and save the
-;; expression's source properties, or signal an error if it doesn't
-;; have the necessary properties.
-(define-method (initialize (trap <source-trap>) initargs)
- (next-method)
- (let* ((expr (slot-ref trap 'expression))
- (filename (source-property expr 'filename))
- (line (source-property expr 'line))
- (column (source-property expr 'column))
- (existing-traps (volatile-target-traps expr)))
- (or (and filename line column)
- (error "Specified source does not have the necessary properties"
- filename line column))
- (slot-set! trap 'filename filename)
- (slot-set! trap 'line line)
- (slot-set! trap 'column column)
- ;; If this is the target's first trap, give the target expression
- ;; to the volatile-target-guardian, so we can find out if it
- ;; becomes inaccessible.
- (or existing-traps (volatile-target-guardian expr))
- ;; Add this trap to the target expression's list of traps.
- (set! (volatile-target-traps expr)
- (cons trap (or existing-traps '())))))
-
-;; Just in case more than one trap is installed on the same source
-;; expression ... so that we can still get the setting and resetting
-;; of the 'breakpoint source property correct.
-(define source-breakpoint-count (make-object-property))
-
-(define-method (install-trap (trap <source-trap>))
- (next-method)
- (let* ((expr (slot-ref trap 'expression))
- (breakpoint-count (or (source-breakpoint-count expr) 0)))
- (set-source-property! expr 'breakpoint #t)
- (set! (source-breakpoint-count expr) (+ breakpoint-count 1)))
- (install-breakpoint-trap trap))
-
-(define-method (uninstall-trap (trap <source-trap>))
- (next-method)
- (let* ((expr (slot-ref trap 'expression))
- (breakpoint-count (or (source-breakpoint-count expr) 0)))
- (if (= breakpoint-count 1)
- (set-source-property! expr 'breakpoint #f))
- (set! (source-breakpoint-count expr) (- breakpoint-count 1)))
- (uninstall-breakpoint-trap trap))
-
-(define-method (trap-runnable? (trap <source-trap>)
- (trap-context <trap-context>))
- (or (eq? (slot-ref trap 'expression)
- (tc:expression trap-context))
- (let ((trap-location (frame->source-position (tc:frame trap-context))))
- (and trap-location
- (string=? (car trap-location) (slot-ref trap 'filename))
- (= (cadr trap-location) (slot-ref trap 'line))
- (= (caddr trap-location) (slot-ref trap 'column))))))
-
-;; (trap-here EXPRESSION . OPTIONS)
-;; FIXME: no longer working due to no mmacros, no local-eval
-#;
-(define trap-here
- (procedure->memoizing-macro
- (lambda (expr env)
- (let ((trap (apply make
- <source-trap>
- #:expression expr
- (local-eval `(list ,@(cddr expr))
- env))))
- (install-trap trap)
- (set-car! expr 'begin)
- (set-cdr! (cdr expr) '())
- expr))))
-
-;;; Class: <location-trap>
-;;;
-;;; An installed instance of <location-trap> triggers on entry to a
-;;; frame with a more-or-less precisely specified source location.
-(define-class <location-trap> (<trap>)
- ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to
- ;; trap in.
- (file-regexp #:init-keyword #:file-regexp)
- ;; "line" and "column" slots: position to trap at (0-based).
- (line #:init-value #f #:init-keyword #:line)
- (column #:init-value #f #:init-keyword #:column)
- ;; "compiled-regexp" slot - self explanatory, internal use only
- (compiled-regexp))
-
-(define-method (initialize (trap <location-trap>) initargs)
- (next-method)
- (slot-set! trap 'compiled-regexp
- (make-regexp (slot-ref trap 'file-regexp))))
-
-(define-method (install-trap (trap <location-trap>))
- (next-method)
- (install-enter-frame-trap trap))
-
-(define-method (uninstall-trap (trap <location-trap>))
- (next-method)
- (uninstall-enter-frame-trap trap))
-
-(define-method (trap-runnable? (trap <location-trap>)
- (trap-context <trap-context>))
- (and-let* ((trap-location (frame->source-position (tc:frame trap-context)))
- (tcline (cadr trap-location))
- (tccolumn (caddr trap-location)))
- (and (= tcline (slot-ref trap 'line))
- (= tccolumn (slot-ref trap 'column))
- (regexp-exec (slot-ref trap 'compiled-regexp)
- (car trap-location) 0))))
-
-;;; {Misc Trap Utilities}
-
-(define (get-trap number)
- (hash-ref all-traps number))
-
-(define (list-traps)
- (for-each describe
- (map cdr (sort (hash-fold acons '() all-traps)
- (lambda (x y) (< (car x) (car y)))))))
-
-;;; {Volatile Traps}
-;;;
-;;; Some traps are associated with Scheme objects that are likely to
-;;; be GC'd, such as procedures and read expressions. When those
-;;; objects are GC'd, we want to allow their traps to evaporate as
-;;; well, or at least not to prevent them from doing so because they
-;;; are (now pointlessly) included on the various installed trap
-;;; lists.
-
-;; An object property that maps each volatile target to the list of
-;; traps that are installed on it.
-(define volatile-target-traps (make-object-property))
-
-;; A guardian that tells us when a volatile target is no longer
-;; accessible.
-(define volatile-target-guardian (make-guardian))
-
-;; An after GC hook that checks for newly inaccessible targets.
-(add-hook! after-gc-hook
- (lambda ()
- (trc 'after-gc-hook)
- (let loop ((target (volatile-target-guardian)))
- (if target
- ;; We have a target which is now inaccessible. Get
- ;; the list of traps installed on it.
- (begin
- (trc 'after-gc-hook "got target")
- ;; Uninstall all the traps that are installed on
- ;; this target.
- (for-each (lambda (trap)
- (trc 'after-gc-hook "got trap")
- ;; If the trap is still installed,
- ;; uninstall it.
- (if (slot-ref trap 'installed)
- (uninstall-trap trap))
- ;; If the trap has an observer, tell
- ;; it that the target has gone.
- (cond ((slot-ref trap 'observer)
- =>
- (lambda (proc)
- (trc 'after-gc-hook "call obs")
- (proc 'target-gone)))))
- (or (volatile-target-traps target) '()))
- ;; Check for any more inaccessible targets.
- (loop (volatile-target-guardian)))))))
-
-(define (without-traps thunk)
- (with-traps (lambda ()
- (trap-disable 'traps)
- (thunk))))
-
-(define guile-trap-features '(tweaking))
-
-;; Make sure that traps are enabled.
-(trap-enable 'traps)
-
-;;; (ice-9 debugging traps) ends here.
diff --git a/module/ice-9/debugging/trc.scm b/module/ice-9/debugging/trc.scm
deleted file mode 100644
index face227..0000000
--- a/module/ice-9/debugging/trc.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-;;;; (ice-9 debugging trc) -- tracing for Guile debugger code
-
-;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 debugging trc)
- #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
-
-(define *syms* #f)
-
-(define (trc-set! syms)
- (set! *syms* syms))
-
-(define (trc-syms . syms)
- (trc-set! syms))
-
-(define (trc-all)
- (trc-set! #f))
-
-(define (trc-none)
- (trc-set! '()))
-
-(define (trc-add sym)
- (trc-set! (cons sym *syms*)))
-
-(define (trc-remove sym)
- (trc-set! (delq1! sym *syms*)))
-
-(define (trc sym . args)
- (if (or (not *syms*)
- (memq sym *syms*))
- (let ((port (trc-port)))
- (write sym port)
- (display ":" port)
- (for-each (lambda (arg)
- (display " " port)
- (write arg port))
- args)
- (newline port))))
-
-(define trc-port
- (let ((port (current-error-port)))
- (make-procedure-with-setter
- (lambda () port)
- (lambda (p) (set! port p)))))
-
-;; Default to no tracing.
-(trc-none)
-
-;;; (ice-9 debugging trc) ends here.
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 4ead075..17030bc 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -663,3 +663,14 @@ it.")
(issue-deprecation-warning
"`top-repl' has moved to the `(ice-9 top-repl)' module.")
((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
+
+(set! debug-enable
+ (let ((debug-enable debug-enable))
+ (lambda opts
+ (if (memq 'debug opts)
+ (begin
+ (issue-deprecation-warning
+ "`(debug-enable 'debug)' is obsolete and has no effect."
+ "Remove it from your code.")
+ (apply debug-enable (delq 'debug opts)))
+ (apply debug-enable opts)))))
diff --git a/module/ice-9/gds-client.scm b/module/ice-9/gds-client.scm
deleted file mode 100755
index 848b774..0000000
--- a/module/ice-9/gds-client.scm
+++ /dev/null
@@ -1,583 +0,0 @@
-(define-module (ice-9 gds-client)
- #:use-module (oop goops)
- #:use-module (oop goops describe)
- #:use-module (ice-9 debugging trace)
- #:use-module (ice-9 debugging traps)
- #:use-module (ice-9 debugging trc)
- #:use-module (ice-9 debugging steps)
- #:use-module (ice-9 pretty-print)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 session)
- #:use-module (ice-9 string-fun)
- #:export (gds-debug-trap
- run-utility
- gds-accept-input))
-
-(use-modules (ice-9 debugger utils))
-
-(use-modules (ice-9 debugger))
-
-(define gds-port #f)
-
-;; Return an integer that somehow identifies the current thread.
-(define (get-thread-id)
- (let ((root (dynamic-root)))
- (cond ((integer? root)
- root)
- ((pair? root)
- (object-address root))
- (else
- (error "Unexpected dynamic root:" root)))))
-
-;; gds-debug-read is a high-priority read. The (debug-thread-id ID)
-;; form causes the frontend to dismiss any reads from threads whose id
-;; is not ID, until it receives the (thread-id ...) form with the same
-;; id as ID. Dismissing the reads of any other threads (by sending a
-;; form that is otherwise ignored) causes those threads to release the
-;; read mutex, which allows the (gds-read) here to proceed.
-(define (gds-debug-read)
- (write-form `(debug-thread-id ,(get-thread-id)))
- (gds-read))
-
-(define (gds-debug-trap trap-context)
- "Invoke the GDS debugger to explore the stack at the specified trap."
- (connect-to-gds)
- (start-stack 'debugger
- (let* ((stack (tc:stack trap-context))
- (flags1 (let ((trap-type (tc:type trap-context)))
- (case trap-type
- ((#:return #:error)
- (list trap-type
- (tc:return-value trap-context)))
- (else
- (list trap-type)))))
- (flags (if (tc:continuation trap-context)
- (cons #:continuable flags1)
- flags1))
- (fired-traps (tc:fired-traps trap-context))
- (special-index (and (= (length fired-traps) 1)
- (is-a? (car fired-traps) <exit-trap>)
- (eq? (tc:type trap-context) #:return)
- (- (tc:depth trap-context)
- (slot-ref (car fired-traps)
'depth)))))
- ;; Write current stack to the frontend.
- (write-form (list 'stack
- (if (and special-index (> special-index 0))
- special-index
- 0)
- (stack->emacs-readable stack)
- (append (flags->emacs-readable flags)
- (slot-ref trap-context
- 'handler-return-syms))))
- ;; Now wait for instruction.
- (let loop ((protocol (gds-debug-read)))
- ;; Act on it.
- (case (car protocol)
- ((tweak)
- ;; Request to tweak the handler return value.
- (let ((tweaking (catch #t
- (lambda ()
- (list (with-input-from-string
- (cadr protocol)
- read)))
- (lambda ignored #f))))
- (if tweaking
- (slot-set! trap-context
- 'handler-return-value
- (cons 'instead (car tweaking)))))
- (loop (gds-debug-read)))
- ((continue)
- ;; Continue (by exiting the debugger).
- *unspecified*)
- ((evaluate)
- ;; Evaluate expression in specified frame.
- (eval-in-frame stack (cadr protocol) (caddr protocol))
- (loop (gds-debug-read)))
- ((info-frame)
- ;; Return frame info.
- (let ((frame (stack-ref stack (cadr protocol))))
- (write-form (list 'info-result
- (with-output-to-string
- (lambda ()
- (write-frame-long frame))))))
- (loop (gds-debug-read)))
- ((info-args)
- ;; Return frame args.
- (let ((frame (stack-ref stack (cadr protocol))))
- (write-form (list 'info-result
- (with-output-to-string
- (lambda ()
- (write-frame-args-long
frame))))))
- (loop (gds-debug-read)))
- ((proc-source)
- ;; Show source of application procedure.
- (let* ((frame (stack-ref stack (cadr protocol)))
- (proc (frame-procedure frame))
- (source (and proc (procedure-source proc))))
- (write-form (list 'info-result
- (if source
- (sans-surrounding-whitespace
- (with-output-to-string
- (lambda ()
- (pretty-print source))))
- (if proc
- "This procedure is coded in
C"
- "This frame has no
procedure")))))
- (loop (gds-debug-read)))
- ((traps-here)
- ;; Show the traps that fired here.
- (write-form (list 'info-result
- (with-output-to-string
- (lambda ()
- (for-each describe
- (tc:fired-traps
trap-context))))))
- (loop (gds-debug-read)))
- ((step-into)
- ;; Set temporary breakpoint on next trap.
- (at-step gds-debug-trap
- 1
- #f
- (if (memq #:return flags)
- #f
- (- (stack-length stack)
- (cadr protocol)))))
- ((step-over)
- ;; Set temporary breakpoint on exit from
- ;; specified frame.
- (at-exit (- (stack-length stack) (cadr protocol))
- gds-debug-trap))
- ((step-file)
- ;; Set temporary breakpoint on next trap in same
- ;; source file.
- (at-step gds-debug-trap
- 1
- (frame-file-name (stack-ref stack
- (cadr protocol)))
- (if (memq #:return flags)
- #f
- (- (stack-length stack)
- (cadr protocol)))))
- (else
- (safely-handle-nondebug-protocol protocol)
- (loop (gds-debug-read))))))))
-
-(define (connect-to-gds . application-name)
- (or gds-port
- (let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME")))
- (set! gds-port
- (or (and gds-unix-socket-name
- (false-if-exception
- (let ((s (socket PF_UNIX SOCK_STREAM 0)))
- (connect s AF_UNIX gds-unix-socket-name)
- s)))
- (false-if-exception
- (let ((s (socket PF_INET SOCK_STREAM 0))
- (SOL_TCP 6)
- (TCP_NODELAY 1))
- (setsockopt s SOL_TCP TCP_NODELAY 1)
- (connect s AF_INET (inet-aton "127.0.0.1") 8333)
- s))
- (error "Couldn't connect to GDS by TCP or Unix domain
socket")))
- (write-form (list 'name (getpid) (apply client-name
application-name))))))
-
-(define (client-name . application-name)
- (let loop ((args (append application-name (program-arguments))))
- (if (null? args)
- (format #f "PID ~A" (getpid))
- (let ((arg (car args)))
- (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
- (loop (cdr args)))
- ((string-match "^-" arg)
- (loop (cdr args)))
- (else
- (format #f "~A (PID ~A)" arg (getpid))))))))
-
-;;(if (not (defined? 'make-mutex))
-;; (begin
-;; (define (make-mutex) #f)
-;; (define lock-mutex noop)
-;; (define unlock-mutex noop)))
-
-(define write-mutex (make-mutex))
-
-(define (write-form form)
- ;; Write any form FORM to GDS.
- (lock-mutex write-mutex)
- (write form gds-port)
- (newline gds-port)
- (force-output gds-port)
- (unlock-mutex write-mutex))
-
-(define (stack->emacs-readable stack)
- ;; Return Emacs-readable representation of STACK.
- (map (lambda (index)
- (frame->emacs-readable (stack-ref stack index)))
- (iota (min (stack-length stack)
- (cadr (memq 'depth (debug-options)))))))
-
-(define (frame->emacs-readable frame)
- ;; Return Emacs-readable representation of FRAME.
- (if (frame-procedure? frame)
- (list 'application
- (with-output-to-string
- (lambda ()
- (display (if (frame-real? frame) " " "t "))
- (write-frame-short/application frame)))
- (source->emacs-readable frame))
- (list 'evaluation
- (with-output-to-string
- (lambda ()
- (display (if (frame-real? frame) " " "t "))
- (write-frame-short/expression frame)))
- (source->emacs-readable frame))))
-
-(define (source->emacs-readable frame)
- ;; Return Emacs-readable representation of the filename, line and
- ;; column source properties of SOURCE.
- (or (frame->source-position frame) 'nil))
-
-(define (flags->emacs-readable flags)
- ;; Return Emacs-readable representation of trap FLAGS.
- (let ((prev #f))
- (map (lambda (flag)
- (let ((erf (if (and (keyword? flag)
- (not (eq? prev #:return)))
- (keyword->symbol flag)
- (format #f "~S" flag))))
- (set! prev flag)
- erf))
- flags)))
-
-;; FIXME: the new evaluator breaks this, by removing local-eval. Need to
-;; figure out our story in this regard.
-(define (eval-in-frame stack index expr)
- (write-form
- (list 'eval-result
- (format #f "~S"
- (catch #t
- (lambda ()
- (local-eval (with-input-from-string expr read)
- (memoized-environment
- (frame-source (stack-ref stack
- index)))))
- (lambda args
- (cons 'ERROR args)))))))
-
-(set! (behaviour-ordering gds-debug-trap) 100)
-
-;;; Code below here adds support for interaction between the GDS
-;;; client program and the Emacs frontend even when not stopped in the
-;;; debugger.
-
-;; A mutex to control attempts by multiple threads to read protocol
-;; back from the frontend.
-(define gds-read-mutex (make-mutex))
-
-;; Read a protocol instruction from the frontend.
-(define (gds-read)
- ;; Acquire the read mutex.
- (lock-mutex gds-read-mutex)
- ;; Tell the front end something that identifies us as a thread.
- (write-form `(thread-id ,(get-thread-id)))
- ;; Now read, then release the mutex and return what was read.
- (let ((x (catch #t
- (lambda () (read gds-port))
- (lambda ignored the-eof-object))))
- (unlock-mutex gds-read-mutex)
- x))
-
-(define (gds-accept-input exit-on-continue)
- ;; If reading from the GDS connection returns EOF, we will throw to
- ;; this catch.
- (catch 'server-eof
- (lambda ()
- (let loop ((protocol (gds-read)))
- (if (or (eof-object? protocol)
- (and exit-on-continue
- (eq? (car protocol) 'continue)))
- (throw 'server-eof))
- (safely-handle-nondebug-protocol protocol)
- (loop (gds-read))))
- (lambda ignored #f)))
-
-(define (safely-handle-nondebug-protocol protocol)
- ;; This catch covers any internal errors in the GDS code or
- ;; protocol.
- (catch #t
- (lambda ()
- (lazy-catch #t
- (lambda ()
- (handle-nondebug-protocol protocol))
- save-lazy-trap-context-and-rethrow))
- (lambda (key . args)
- (write-form
- `(eval-results (error . ,(format #f "~s" protocol))
- ,(if last-lazy-trap-context 't 'nil)
- "GDS Internal Error
-Please report this to <address@hidden>, ideally including:
-- a description of the scenario in which this error occurred
-- which versions of Guile and guile-debugging you are using
-- the error stack, which you can get by clicking on the link below,
- and then cut and paste into your report.
-Thanks!\n\n"
- ,(list (with-output-to-string
- (lambda ()
- (write key)
- (display ": ")
- (write args)
- (newline)))))))))
-
-;; The key that is used to signal a read error changes from 1.6 to
-;; 1.8; here we cover all eventualities by discovering the key
-;; dynamically.
-(define read-error-key
- (catch #t
- (lambda ()
- (with-input-from-string "(+ 3 4" read))
- (lambda (key . args)
- key)))
-
-(define (handle-nondebug-protocol protocol)
- (case (car protocol)
-
- ((eval)
- (set! last-lazy-trap-context #f)
- (apply (lambda (correlator module port-name line column code flags)
- (with-input-from-string code
- (lambda ()
- (set-port-filename! (current-input-port) port-name)
- (set-port-line! (current-input-port) line)
- (set-port-column! (current-input-port) column)
- (let ((m (and module (resolve-module-from-root module))))
- (catch read-error-key
- (lambda ()
- (let loop ((exprs '()) (x (read)))
- (if (eof-object? x)
- ;; Expressions to be evaluated have all
- ;; been read. Now evaluate them.
- (let loop2 ((exprs (reverse! exprs))
- (results '())
- (n 1))
- (if (null? exprs)
- (write-form `(eval-results ,correlator
- ,(if
last-lazy-trap-context 't 'nil)
- ,@results))
- (loop2 (cdr exprs)
- (append results (gds-eval (car
exprs) m
- (if (and
(null? (cdr exprs))
-
(= n 1))
- #f
n)))
- (+ n 1))))
- ;; Another complete expression read; add
- ;; it to the list.
- (begin
- (if (and (pair? x)
- (memq 'debug flags))
- (install-trap (make <source-trap>
- #:expression x
- #:behaviour
gds-debug-trap)))
- (loop (cons x exprs) (read))))))
- (lambda (key . args)
- (write-form `(eval-results
- ,correlator
- ,(if last-lazy-trap-context 't 'nil)
- ,(with-output-to-string
- (lambda ()
- (display ";;; Reading expressions")
- (display " to evaluate\n")
- (apply display-error #f
- (current-output-port) args)))
- ("error-in-read")))))))))
- (cdr protocol)))
-
- ((complete)
- (let ((matches (apropos-internal
- (string-append "^" (regexp-quote (cadr protocol))))))
- (cond ((null? matches)
- (write-form '(completion-result nil)))
- (else
- ;;(write matches (current-error-port))
- ;;(newline (current-error-port))
- (let ((match
- (let loop ((match (symbol->string (car matches)))
- (matches (cdr matches)))
- ;;(write match (current-error-port))
- ;;(newline (current-error-port))
- ;;(write matches (current-error-port))
- ;;(newline (current-error-port))
- (if (null? matches)
- match
- (if (string-prefix=? match
- (symbol->string (car matches)))
- (loop match (cdr matches))
- (loop (substring match 0
- (- (string-length match) 1))
- matches))))))
- (if (string=? match (cadr protocol))
- (write-form `(completion-result
- ,(map symbol->string matches)))
- (write-form `(completion-result
- ,match))))))))
-
- ((debug-lazy-trap-context)
- (if last-lazy-trap-context
- (gds-debug-trap last-lazy-trap-context)
- (error "There is no stack available to show")))
-
- (else
- (error "Unexpected protocol:" protocol))))
-
-(define (resolve-module-from-root name)
- (save-module-excursion
- (lambda ()
- (set-current-module the-root-module)
- (resolve-module name))))
-
-(define (gds-eval x m part)
- ;; Consumer to accept possibly multiple values and present them for
- ;; Emacs as a list of strings.
- (define (value-consumer . values)
- (if (unspecified? (car values))
- '()
- (map (lambda (value)
- (with-output-to-string (lambda () (write value))))
- values)))
- ;; Now do evaluation.
- (let ((intro (if part
- (format #f ";;; Evaluating expression ~A" part)
- ";;; Evaluating"))
- (value #f))
- (let* ((do-eval (if m
- (lambda ()
- (display intro)
- (display " in module ")
- (write (module-name m))
- (newline)
- (set! value
- (call-with-values (lambda ()
- (start-stack 'gds-eval-stack
- (eval x m)))
- value-consumer)))
- (lambda ()
- (display intro)
- (display " in current module ")
- (write (module-name (current-module)))
- (newline)
- (set! value
- (call-with-values (lambda ()
- (start-stack 'gds-eval-stack
-
(primitive-eval x)))
- value-consumer)))))
- (output
- (with-output-to-string
- (lambda ()
- (catch #t
- (lambda ()
- (lazy-catch #t
- do-eval
- save-lazy-trap-context-and-rethrow))
- (lambda (key . args)
- (case key
- ((misc-error signal unbound-variable numerical-overflow)
- (apply display-error #f
- (current-output-port) args)
- (set! value '("error-in-evaluation")))
- (else
- (display "EXCEPTION: ")
- (display key)
- (display " ")
- (write args)
- (newline)
- (set! value
- '("unhandled-exception-in-evaluation"))))))))))
- (list output value))))
-
-(define last-lazy-trap-context #f)
-
-(define (save-lazy-trap-context-and-rethrow key . args)
- (set! last-lazy-trap-context
- (throw->trap-context key args save-lazy-trap-context-and-rethrow))
- (apply throw key args))
-
-(define (run-utility)
- (connect-to-gds)
- (write (getpid))
- (newline)
- (force-output)
- (module-use! (resolve-module '(guile-user))
- (resolve-interface '(ice-9 session)))
- (gds-accept-input #f))
-
-(define-method (trap-description (trap <trap>))
- (let loop ((description (list (class-name (class-of trap))))
- (next 'installed?))
- (case next
- ((installed?)
- (loop (if (slot-ref trap 'installed)
- (cons 'installed description)
- description)
- 'conditional?))
- ((conditional?)
- (loop (if (slot-ref trap 'condition)
- (cons 'conditional description)
- description)
- 'skip-count))
- ((skip-count)
- (loop (let ((skip-count (slot-ref trap 'skip-count)))
- (if (zero? skip-count)
- description
- (cons* skip-count 'skip-count description)))
- 'single-shot?))
- ((single-shot?)
- (loop (if (slot-ref trap 'single-shot)
- (cons 'single-shot description)
- description)
- 'done))
- (else
- (reverse! description)))))
-
-(define-method (trap-description (trap <procedure-trap>))
- (let ((description (next-method)))
- (set-cdr! description
- (cons (procedure-name (slot-ref trap 'procedure))
- (cdr description)))
- description))
-
-(define-method (trap-description (trap <source-trap>))
- (let ((description (next-method)))
- (set-cdr! description
- (cons (format #f "~s" (slot-ref trap 'expression))
- (cdr description)))
- description))
-
-(define-method (trap-description (trap <location-trap>))
- (let ((description (next-method)))
- (set-cdr! description
- (cons* (slot-ref trap 'file-regexp)
- (slot-ref trap 'line)
- (slot-ref trap 'column)
- (cdr description)))
- description))
-
-(define (gds-trace-trap trap-context)
- (connect-to-gds)
- (gds-do-trace trap-context)
- (at-exit (tc:depth trap-context) gds-do-trace))
-
-(define (gds-do-trace trap-context)
- (write-form (list 'trace
- (format #f
- "address@hidden: ~a"
- (trace/stack-real-depth trap-context)
- (trace/info trap-context)))))
-
-(define (gds-trace-subtree trap-context)
- (connect-to-gds)
- (gds-do-trace trap-context)
- (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
- (install-trap step-trap)
- (at-exit (tc:depth trap-context)
- (lambda (trap-context)
- (uninstall-trap step-trap)))))
-
-;;; (ice-9 gds-client) ends here.
diff --git a/module/ice-9/gds-server.scm b/module/ice-9/gds-server.scm
deleted file mode 100644
index 5ec8675..0000000
--- a/module/ice-9/gds-server.scm
+++ /dev/null
@@ -1,188 +0,0 @@
-;;;; Guile Debugger UI server
-
-;;; Copyright (C) 2003 Free Software Foundation, Inc.
-;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (ice-9 gds-server)
- #:export (run-server))
-
-;; UI is normally via a pipe to Emacs, so make sure to flush output
-;; every time we write.
-(define (write-to-ui form)
- (write form)
- (newline)
- (force-output))
-
-(define (trc . args)
- (write-to-ui (cons '* args)))
-
-(define (with-error->eof proc port)
- (catch #t
- (lambda () (proc port))
- (lambda args the-eof-object)))
-
-(define connection->id (make-object-property))
-
-(define (run-server unix-socket-name tcp-port)
-
- (let ((unix-server (socket PF_UNIX SOCK_STREAM 0))
- (tcp-server (socket PF_INET SOCK_STREAM 0)))
-
- ;; Bind and start listening on the Unix domain socket.
- (false-if-exception (delete-file unix-socket-name))
- (bind unix-server AF_UNIX unix-socket-name)
- (listen unix-server 5)
-
- ;; Bind and start listening on the TCP socket.
- (setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1)
- (false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port))
- (listen tcp-server 5)
-
- ;; Main loop.
- (let loop ((clients '()) (readable-sockets '()))
-
- (define (do-read port)
- (cond ((eq? port (current-input-port))
- (do-read-from-ui))
- ((eq? port unix-server)
- (accept-new-client unix-server))
- ((eq? port tcp-server)
- (accept-new-client tcp-server))
- (else
- (do-read-from-client port))))
-
- (define (do-read-from-ui)
- (trc "reading from ui")
- (let* ((form (with-error->eof read (current-input-port)))
- (client (assq-ref (map (lambda (port)
- (cons (connection->id port) port))
- clients)
- (car form))))
- (with-error->eof read-char (current-input-port))
- (if client
- (begin
- (write (cdr form) client)
- (newline client))
- (trc "client not found")))
- clients)
-
- (define (accept-new-client server)
- (let ((new-port (car (accept server))))
- ;; Read the client's ID.
- (let ((name-form (read new-port)))
- ;; Absorb the following newline character.
- (read-char new-port)
- ;; Check that we have a name form.
- (or (eq? (car name-form) 'name)
- (error "Invalid name form:" name-form))
- ;; Store an association from the connection to the ID.
- (set! (connection->id new-port) (cadr name-form))
- ;; Pass the name form on to Emacs.
- (write-to-ui (cons (connection->id new-port) name-form)))
- ;; Add the new connection to the set that we select on.
- (cons new-port clients)))
-
- (define (do-read-from-client port)
- (trc "reading from client")
- (let ((next-char (with-error->eof peek-char port)))
- ;;(trc 'next-char next-char)
- (cond ((eof-object? next-char)
- (write-to-ui (list (connection->id port) 'closed))
- (close port)
- (delq port clients))
- ((char=? next-char #\()
- (write-to-ui (cons (connection->id port)
- (with-error->eof read port)))
- clients)
- (else
- (with-error->eof read-char port)
- clients))))
-
- ;;(trc 'clients clients)
- ;;(trc 'readable-sockets readable-sockets)
-
- (if (null? readable-sockets)
- (loop clients (car (select (cons* (current-input-port)
- unix-server
- tcp-server
- clients)
- '()
- '())))
- (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))
-
-;; What happens if there are multiple copies of Emacs running on the
-;; same machine, and they all try to start up the GDS server? They
-;; can't all listen on the same TCP port, so the short answer is that
-;; all of them except the first will get an EADDRINUSE error when
-;; trying to bind.
-;;
-;; We want to be able to handle this scenario, though, so that Scheme
-;; code can be evaluated, and help invoked, in any of those Emacsen.
-;; So we introduce the idea of a "slave server". When a new GDS
-;; server gets an EADDRINUSE bind error, the implication is that there
-;; is already a GDS server running, so the new server instead connects
-;; to the existing one (by issuing a connect to the GDS port number).
-;;
-;; Let's call the first server the "master", and the new one the
-;; "slave". In principle the master can now proxy any GDS client
-;; connections through to the slave, so long as there is sufficient
-;; information in the protocol for it to decide when and how to do
-;; this.
-;;
-;; The basic information and mechanism that we need for this is as
-;; follows.
-;;
-;; - A unique ID for each Emacs; this can be each Emacs's PID. When a
-;; slave server connects to the master, it announces itself by sending
-;; the protocol (emacs ID).
-;;
-;; - A way for a client to indicate which Emacs it wants to use. At
-;; the protocol level, this is an extra argument in the (name ...)
-;; protocol. (The absence of this argument means "no preference". A
-;; simplistic master server might then decide to use its own Emacs; a
-;; cleverer one might monitor which Emacs appears to be most in use,
-;; and use that one.) At the API level this can be an optional
-;; argument to the `gds-connect' procedure, and the Emacs GDS code
-;; would obviously set this argument when starting a client from
-;; within Emacs.
-;;
-;; We also want a strategy for continuing seamlessly if the master
-;; server shuts down.
-;;
-;; - Each slave server will detect this as an error on the connection
-;; to the master socket. Each server then tries to bind to the GDS
-;; port again (a race which the OS will resolve), and if that fails,
-;; connect again. The result of this is that there should be a new
-;; master, and the others all slaves connected to the new master.
-;;
-;; - Each client will also detect this as an error on the connection
-;; to the (master) server. Either the client should try to connect
-;; again (perhaps after a short delay), or the reconnection can be
-;; delayed until the next time that the client requires the server.
-;; (Probably the latter, all done within `gds-read'.)
-;;
-;; (Historical note: Before this master-slave idea, clients were
-;; identified within gds-server.scm and gds*.el by an ID which was
-;; actually the file descriptor of their connection to the server.
-;; That is no good in the new scheme, because each client's ID must
-;; persist when the master server changes, so we now use the client's
-;; PID instead. We didn't use PID before because the client/server
-;; code was written to be completely asynchronous, which made it
-;; tricky for the server to discover each client's PID and associate
-;; it with a particular connection. Now we solve that problem by
-;; handling the initial protocol exchange synchronously.)
-(define (run-slave-server port)
- 'not-implemented)
diff --git a/module/ice-9/scm-style-repl.scm b/module/ice-9/scm-style-repl.scm
index 947d0f0..e71798b 100644
--- a/module/ice-9/scm-style-repl.scm
+++ b/module/ice-9/scm-style-repl.scm
@@ -81,18 +81,16 @@
(lambda ()
(call-with-unblocked-asyncs
(lambda ()
- (with-traps
- (lambda ()
- (first)
-
- ;; This line is needed because mark
- ;; doesn't do closures quite right.
- ;; Unreferenced locals should be
- ;; collected.
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)))))
+ (first)
+
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)))
(lambda (key . args)
(case key
diff --git a/module/scripts/summarize-guile-TODO.scm
b/module/scripts/summarize-guile-TODO.scm
index a67c92e..ee4f88c 100644
--- a/module/scripts/summarize-guile-TODO.scm
+++ b/module/scripts/summarize-guile-TODO.scm
@@ -1,6 +1,6 @@
;;; summarize-guile-TODO --- Display Guile TODO list in various ways
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -63,7 +63,7 @@
;; Add support for ORing criteria.
;;; Code:
-(debug-enable 'debug 'backtrace)
+(debug-enable 'backtrace)
(define-module (scripts summarize-guile-TODO)
:use-module (scripts read-text-outline)
diff --git a/module/statprof.scm b/module/statprof.scm
index 2a6cf12..da6f3f1 100644
--- a/module/statprof.scm
+++ b/module/statprof.scm
@@ -399,7 +399,6 @@ Enables traps and debugging as necessary."
(set! procedure-data (make-hash-table 131))
(set! record-full-stacks? (and (pair? full-stacks?) (car full-stacks?)))
(set! stacks '())
- (debug-enable 'debug)
(sigaction SIGPROF profile-signal-handler)
#t)
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index 235a101..13a268a 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -446,8 +446,7 @@
(let ((dopts #f))
(dynamic-wind
(lambda ()
- (set! dopts (debug-options))
- (debug-enable 'debug))
+ (set! dopts (debug-options)))
thunk
(lambda ()
(debug-options dopts)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-80-g3932bdb,
Andy Wingo <=