From: Andy Wingo <wingo@igalia.com>
To: Eli Zaretskii <eliz@gnu.org>
Cc: gdb-patches@sourceware.org, xdje42@gmail.com
Subject: Re: [PATCH] Add Guile frame filter interface
Date: Mon, 16 Feb 2015 13:48:00 -0000 [thread overview]
Message-ID: <871tlq55oj.fsf@igalia.com> (raw)
In-Reply-To: <83vbj3unk0.fsf@gnu.org> (Eli Zaretskii's message of "Sun, 15 Feb 2015 18:50:07 +0200")
[-- Attachment #1: Type: text/plain, Size: 1487 bytes --]
Hi,
Thank you for the review, Eli. I attach an updated patch that fixes the
things you pointed out. This patch also adds test cases, copied from
the Python tests, and fixes a few things in the scm-frame-filter.c /
frames.scm that allow the tests to work.
A couple of notes. One, there are no associated GDB commands like "info
frame-filters" and the like, as those are implemented in Python for the
Python interface, so there is no central list of filters in GDB. That's
probably fine for now, but worth noting.
Another note is that I use a mechanism in which any error or interrupt
causes a Scheme exception to be raised, for example if user code signals
an error or if the user interrupts a backtrace. The whole frame-filter
interface is wrapped in a gdbscm_safe_call(), which will catch
exceptions and print error messages. For me this is the natural way to
use the libguile interface. I arrange to run cleanups when Scheme
exceptions occur, and to turn GDB exceptions into Scheme exceptions.
However I saw that GDB is switching to C++ and plans on using RAII and
C++ exceptions. The strategy I use in this file will work fine with
this, as there will not be any live RAII data that a Scheme exception
might unwind; there's just one pair of macros that would need to be
redefined. I'd probably write this code differently if RAII and
exceptions were already in place, but I don't see this new code as being
incompatible with the exception-using refactor.
Regards,
Andy
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Add-Guile-frame-filter-interface.patch --]
[-- Type: text/x-diff, Size: 129224 bytes --]
From a3fee1361be7432984a918c28c4cf73d76992beb Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@igalia.com>
Date: Sun, 15 Feb 2015 12:17:23 +0100
Subject: [PATCH] Add Guile frame filter interface.
gdb/ChangeLog:
* guile/scm-frame-filter.c:
* guile/lib/gdb/frames.scm: New files.
* guile/guile.c (guile_extension_ops): Add the Guile frame
filter.
(initialize_gdb_module): Initialize the Guile frame filter
module.
* guile/guile-internal.h (frscm_scm_from_frame)
(gdbscm_apply_frame_filter, gdbscm_initialize_frame_filters): New
declarations.
* mi/mi-main.c (mi_cmd_list_features): Add the "guile" feature if
appropriate.
* Makefile.in: Add scm-frame-filter.c.
* data-directory/Makefile.in: Add frames.scm.
* guile/scm-frame.c (frscm_scm_from_frame): Export.
* gdb/testsuite/gdb.guile/amd64-scm-frame-filter-invalidarg.S:
* gdb/testsuite/gdb.guile/scm-frame-filter-gdb.scm.in:
* gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg-gdb.scm.in:
* gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.exp:
* gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.scm:
* gdb/testsuite/gdb.guile/scm-frame-filter-mi.c:
* gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp:
* gdb/testsuite/gdb.guile/scm-frame-filter.c:
* gdb/testsuite/gdb.guile/scm-frame-filter.exp:
* gdb/testsuite/gdb.guile/scm-frame-filter.scm: New files.
gdb/doc/ChangeLog:
* guile.texi (Guile Frame Filter API)
(Writing a Frame Filter in Guile): New sections.
---
gdb/ChangeLog | 27 +
gdb/Makefile.in | 6 +
gdb/data-directory/Makefile.in | 2 +
gdb/doc/ChangeLog | 5 +
gdb/doc/guile.texi | 389 +++++++-
gdb/guile/guile-internal.h | 10 +
gdb/guile/guile.c | 3 +-
gdb/guile/lib/gdb/frames.scm | 372 +++++++
gdb/guile/scm-frame-filter.c | 1027 ++++++++++++++++++++
gdb/guile/scm-frame.c | 2 +-
gdb/mi/mi-main.c | 3 +
.../gdb.guile/amd64-scm-frame-filter-invalidarg.S | 261 +++++
.../gdb.guile/scm-frame-filter-gdb.scm.in | 35 +
.../scm-frame-filter-invalidarg-gdb.scm.in | 35 +
.../gdb.guile/scm-frame-filter-invalidarg.exp | 66 ++
.../gdb.guile/scm-frame-filter-invalidarg.scm | 35 +
gdb/testsuite/gdb.guile/scm-frame-filter-mi.c | 140 +++
gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp | 179 ++++
gdb/testsuite/gdb.guile/scm-frame-filter.c | 157 +++
gdb/testsuite/gdb.guile/scm-frame-filter.exp | 248 +++++
gdb/testsuite/gdb.guile/scm-frame-filter.scm | 89 ++
21 files changed, 3087 insertions(+), 4 deletions(-)
create mode 100644 gdb/guile/lib/gdb/frames.scm
create mode 100644 gdb/guile/scm-frame-filter.c
create mode 100644 gdb/testsuite/gdb.guile/amd64-scm-frame-filter-invalidarg.S
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter-gdb.scm.in
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg-gdb.scm.in
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.exp
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.scm
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter-mi.c
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter.c
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter.exp
create mode 100644 gdb/testsuite/gdb.guile/scm-frame-filter.scm
diff --git a/gdb/ChangeLog b/gdb/ChangeLog
index 0b7b4b7..ee126eb 100644
--- a/gdb/ChangeLog
+++ b/gdb/ChangeLog
@@ -1,3 +1,30 @@
+2015-02-15 Andy Wingo <wingo@igalia.com>
+
+ * guile/scm-frame-filter.c:
+ * guile/lib/gdb/frames.scm: New files.
+ * guile/guile.c (guile_extension_ops): Add the Guile frame
+ filter.
+ (initialize_gdb_module): Initialize the Guile frame filter
+ module.
+ * guile/guile-internal.h (frscm_scm_from_frame)
+ (gdbscm_apply_frame_filter, gdbscm_initialize_frame_filters): New
+ declarations.
+ * mi/mi-main.c (mi_cmd_list_features): Add the "guile" feature if
+ appropriate.
+ * Makefile.in: Add scm-frame-filter.c.
+ * data-directory/Makefile.in: Add frames.scm.
+ * guile/scm-frame.c (frscm_scm_from_frame): Export.
+ * gdb/testsuite/gdb.guile/amd64-scm-frame-filter-invalidarg.S:
+ * gdb/testsuite/gdb.guile/scm-frame-filter-gdb.scm.in:
+ * gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg-gdb.scm.in:
+ * gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.exp:
+ * gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.scm:
+ * gdb/testsuite/gdb.guile/scm-frame-filter-mi.c:
+ * gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp:
+ * gdb/testsuite/gdb.guile/scm-frame-filter.c:
+ * gdb/testsuite/gdb.guile/scm-frame-filter.exp:
+ * gdb/testsuite/gdb.guile/scm-frame-filter.scm: New files.
+
2015-02-10 Andy Wingo <wingo@igalia.com>
* guile/guile.c (_initialize_guile): Disable automatic
diff --git a/gdb/Makefile.in b/gdb/Makefile.in
index 00fb2cd..49bd2d2 100644
--- a/gdb/Makefile.in
+++ b/gdb/Makefile.in
@@ -310,6 +310,7 @@ SUBDIR_GUILE_OBS = \
scm-disasm.o \
scm-exception.o \
scm-frame.o \
+ scm-frame-filter.o \
scm-gsmob.o \
scm-iterator.o \
scm-lazy-string.o \
@@ -336,6 +337,7 @@ SUBDIR_GUILE_SRCS = \
guile/scm-disasm.c \
guile/scm-exception.c \
guile/scm-frame.c \
+ guile/scm-frame-filter.c \
guile/scm-gsmob.c \
guile/scm-iterator.c \
guile/scm-lazy-string.c \
@@ -2405,6 +2407,10 @@ scm-frame.o: $(srcdir)/guile/scm-frame.c
$(COMPILE) $(srcdir)/guile/scm-frame.c
$(POSTCOMPILE)
+scm-frame-filter.o: $(srcdir)/guile/scm-frame-filter.c
+ $(COMPILE) $(srcdir)/guile/scm-frame-filter.c
+ $(POSTCOMPILE)
+
scm-gsmob.o: $(srcdir)/guile/scm-gsmob.c
$(COMPILE) $(srcdir)/guile/scm-gsmob.c
$(POSTCOMPILE)
diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in
index c01b86d..e406e9e 100644
--- a/gdb/data-directory/Makefile.in
+++ b/gdb/data-directory/Makefile.in
@@ -87,6 +87,7 @@ GUILE_SOURCE_FILES = \
./gdb.scm \
gdb/boot.scm \
gdb/experimental.scm \
+ gdb/frames.scm \
gdb/init.scm \
gdb/iterator.scm \
gdb/printing.scm \
@@ -96,6 +97,7 @@ GUILE_SOURCE_FILES = \
GUILE_COMPILED_FILES = \
./gdb.go \
gdb/experimental.go \
+ gdb/frames.go \
gdb/iterator.go \
gdb/printing.go \
gdb/support.go \
diff --git a/gdb/doc/ChangeLog b/gdb/doc/ChangeLog
index b8e1f7f..c7f6470 100644
--- a/gdb/doc/ChangeLog
+++ b/gdb/doc/ChangeLog
@@ -1,3 +1,8 @@
+2015-02-15 Andy Wingo <wingo@igalia.com>
+
+ * guile.texi (Guile Frame Filter API)
+ (Writing a Frame Filter in Guile): New sections.
+
2015-02-09 Markus Metzger <markus.t.metzger@intel.com>
* gdb.texinfo (Branch Trace Configuration Format): Add size.
diff --git a/gdb/doc/guile.texi b/gdb/doc/guile.texi
index 53e69f2..8ea9748 100644
--- a/gdb/doc/guile.texi
+++ b/gdb/doc/guile.texi
@@ -141,6 +141,8 @@ from the Guile interactive prompt.
* Guile Pretty Printing API:: Pretty-printing values with Guile
* Selecting Guile Pretty-Printers:: How GDB chooses a pretty-printer
* Writing a Guile Pretty-Printer:: Writing a pretty-printer
+* Guile Frame Filter API:: Filtering frames.
+* Writing a Frame Filter in Guile:: Writing a frame filter.
* Commands In Guile:: Implementing new commands in Guile
* Parameters In Guile:: Adding new @value{GDBN} parameters
* Progspaces In Guile:: Program spaces
@@ -170,8 +172,8 @@ output interrupted by the user (@pxref{Screen Size}). In this
situation, a Guile @code{signal} exception is thrown with value @code{SIGINT}.
Guile's history mechanism uses the same naming as @value{GDBN}'s,
-namely the user of dollar-variables (e.g., $1, $2, etc.).
-The results of evaluations in Guile and in GDB are counted separately,
+namely the user of dollar-variables (e.g., $1, $2, etc.). The results
+of evaluations in Guile and in @value{GDBN} are counted separately,
@code{$1} in Guile is not the same value as @code{$1} in @value{GDBN}.
@value{GDBN} is not thread-safe. If your Guile program uses multiple
@@ -1693,6 +1695,389 @@ my_library.so:
bar
@end smallexample
+@node Guile Frame Filter API
+@subsubsection Filtering Frames in Guile
+@cindex frame filters api, guile
+
+Frame filters allow the user to programmatically alter the way a
+backtrace (@pxref{Backtrace}) prints. Frame filters can reorganize,
+annotate, insert, and remove frames in a backtrace.
+
+Only commands that print a backtrace, or, in the case of @sc{gdb/mi}
+commands (@pxref{GDB/MI}), those that return a collection of frames
+are affected. The commands that work with frame filters are:
+
+@table @code
+@item backtrace
+@xref{backtrace-command,, The backtrace command}.
+@item -stack-list-frames
+@xref{-stack-list-frames,, The -stack-list-frames command}.
+@item -stack-list-variables
+@xref{-stack-list-variables,, The -stack-list-variables command}.
+@item -stack-list-arguments
+@xref{-stack-list-arguments,, The -stack-list-arguments command}.
+@item -stack-list-locals
+@xref{-stack-list-locals,, The -stack-list-locals command}.
+@end table
+
+@cindex frame annotator
+A frame filter is a function that takes a SRFI-41 stream of annotated
+frame objects as an argument, and returns a potentially modified
+stream of annotated frame objects. @xref{SRFI-41,,,guile,The Guile
+Reference Manual}, for more on the SRFI-41 specification for lazy
+streams. Operating over a stream allows frame filters to inspect,
+reorganize, insert, and remove frames. @value{GDBN} also provides a
+more simple @dfn{frame annotator} API that works on individual frames,
+for the common case in which the user does not need to reorganize the
+backtrace. Both APIs are described below.
+
+There can be multiple frame filters registered with @value{GDBN}, and
+each one may be individually enabled or disabled at will. Multiple
+frame filters can be enabled at the same time. Frame filters have an
+associated priority which determines the order in which they are
+applied over the annotated frame stream. For example, if there are
+two filters registered and enabled, @var{f1} and @var{f2}, and the
+priority of @var{f2} is greater than that of @var{f1}, then the result
+of frame filtering will be @code{(@var{f2} (@var{f1} @var{stream}))}.
+In this way, higher-priority frame filters get the last word on the
+backtrace that is ultimately printed.
+
+An important consideration when designing frame filters, and well
+worth reflecting upon, is that frame filters should avoid unwinding
+the call stack if possible. Some stacks can run very deep, into the
+tens of thousands in some cases. To search every frame when a frame
+filter executes may be too expensive at that step. The frame filter
+cannot know how many frames it has to iterate over, and it may have to
+iterate through them all. This ends up duplicating effort as
+@value{GDBN} performs this iteration when it prints the frames.
+Therefore a frame filter should avoid peeking ahead in the frame
+stream, if possible. @xref{Writing a Frame Filter}, for examples on
+how to write a good frame filter.
+
+To use frame filters, first load the @code{(gdb frames)} module to
+have access to the procedures that manipulate frame filters:
+
+@example
+(use-modules (gdb frames))
+@end example
+
+@deffn {Scheme Procedure} add-frame-filter! name filter @
+ @r{[}#:priority priority@r{]} @r{[}#:enabled? boolean@r{]} @
+ @r{[}#:objfile objfile@r{]} @r{[}#:progspace progspace@r{]}
+Register the frame filter procedure @var{filter} with @value{GDBN}.
+@var{filter} should be a function of one argument, taking a SRFI-41
+stream of annotated frames and returning a possibily modified stream
+of annotated frames. The filter is identified by @var{name}, which
+should be unique among all known filters.
+
+The filter will be registered with the given @var{priority}, which
+should be a number, and which defaults to 20 if not given. By
+default, the filter is global, meaning that it is associated with all
+objfiles and progspaces. Pass one of @code{#:objfile} or
+@code{#:progspace} to instead associate the filter with a specific
+objfile or progspace, respectively.
+
+The filter will be initially enabled, unless the keyword argument
+@code{#:enabled? #f} is given.
+@end deffn
+
+@deffn {Scheme Procedure} all-frame-filters
+Return a list of the names of all frame filters.
+@end deffn
+
+@deffn {Scheme Procedure} remove-frame-filter! name
+@deffnx {Scheme Procedure} enable-frame-filter! name
+@deffnx {Scheme Procedure} disable-frame-filter! name
+Remove, enable, or disable a frame filter, respectively. @var{name}
+should correspond to the name of a filter previously added with
+@code{add-frame-filter!}. If no such filter is found, an error is
+signalled.
+@end deffn
+
+When a command is executed from @value{GDBN} that is compatible with
+frame filters, @value{GDBN} selects all filters registered in the
+current progspace, filters for all objfiles, and filters with no
+associated objfile or progspace. That list is then sorted by
+priority, as described above, and applied to the annotated frame
+stream.
+
+An annotated frame is a Guile record type that holds information about
+a frame: its function name, its arguments, its locals, and so on. An
+annotated frame is always associated with a @value{GDBN} frame object. To
+add, remove, or otherwise alter information associated with an
+annotated frame, use the @code{reannotate-frame} procedure.
+
+@deffn {Scheme Procedure} reannotate-frame! ann @
+ @r{[}#:function-name function-name@r{]} @
+ @r{[}#:address address@r{]} @
+ @r{[}#:filename filename@r{]} @
+ @r{[}#:line line@r{]} @
+ @r{[}#:arguments arguments@r{]} @
+ @r{[}#:locals locals@r{]} @
+ @r{[}#:children children@r{]}
+Take the annotated frame object @var{ann} and return a new annotated
+frame object, replacing the fields specified by the keyword arguments
+with their new values. For example, calling @code{(reannotate-frame
+@var{x} #:function-name "foo")} will create a new annotated frame
+object that inherits all fields from @var{x}, but whose function name
+has been set to @samp{foo}.
+@end deffn
+
+The @code{(gdb frames)} module defines accessors for the various
+fields of annotated frame objects.
+
+@deffn {Scheme Procedure} annotated-frame-frame ann
+Return the @value{GDBN} frame object associated with the annotated frame
+@var{ann}. @xref{Frames In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} annotated-frame-function-name ann
+Return the function name associated with the annotated frame
+@var{ann}, as a string, or @code{#f} if not available.
+@end deffn
+
+@deffn {Scheme Procedure} annotated-frame-address ann
+Return the address associated with the annotated frame @var{ann}, as
+an integer.
+@end deffn
+
+@deffn {Scheme Procedure} annotated-frame-filename ann
+Return the file name associated with the annotated frame @var{ann}, as
+a string, or @code{#f} if not available.
+@end deffn
+
+@deffn {Scheme Procedure} annotated-frame-line ann
+Return the line number associated with the annotated frame @var{ann},
+as an integer, or @code{#f} if not available.
+@end deffn
+
+@deffn {Scheme Procedure} annotated-frame-arguments ann
+Return a list of the function arguments associated with the annotated
+frame @var{ann}. Each item of the list should either be a
+@value{GDBN} symbol (@pxref{Symbols In Guile}), a pair of a
+@value{GDBN} symbol and a @value{GDBN} value (@pxref{Values From
+Inferior In Guile}, or a pair of a string and a @value{GDBN} value.
+In the first case, the value will be loaded from the frame if needed.
+@end deffn
+
+@deffn {Scheme Procedure} annotated-frame-locals ann
+Return a list of the function arguments associated with the annotated
+frame @var{ann}, in the same format as for
+@code{annotated-frame-arguments}.
+@end deffn
+
+Annotated frames may also have child frames. By default, no frame has
+a child frame, but filters may reorganize the frame stream into a
+stream of frame trees, by populating the child list. Of course, such
+a reorganization is ultimately cosmetic, as it doesn't alter the stack
+of frames seen by @value{GDBN} and navigable by the user, for example
+by using the @code{frame} command. Still, nesting frames may lead to
+a more understandable presentation of a backtrace.
+
+@deffn {Scheme Procedure} annotated-frame-children ann
+Return a list of the child frames associated with the annotated frame
+@var{ann}. Each item of the list should be an annotated frame object.
+@end deffn
+
+While frame filters can both reorganize and reannotate the frame
+stream, it is often the case that one only wants to reannotate the
+frames in a stream, without reorganizing then. In that case there is
+a simpler API for frame annotators that simply maps annotated frames
+to annotated frames.
+
+@deffn {Scheme Procedure} add-frame-annotator! name annotator @
+ @r{[}#:priority priority@r{]} @r{[}#:enabled? boolean@r{]} @
+ @r{[}#:objfile objfile@r{]} @r{[}#:progspace progspace@r{]}
+Register the frame annotator procedure @var{annotator} with
+@value{GDBN}. @var{annotator} should be a function of one argument,
+taking annotated frame object and returning a possibily modified
+annotated frame. The annotator is identified by @var{name}, which
+should be unique among all known annotators.
+
+The annotator has an associated priority, as with frame filters. See
+the documentation on @code{add-frame-filter!}, for more.
+
+The annotator will be initially enabled, unless the keyword argument
+@code{#:enabled? #f} is given.
+@end deffn
+
+@deffn {Scheme Procedure} all-frame-annotators
+Return a list of the names of all frame annotators.
+@end deffn
+
+@deffn {Scheme Procedure} remove-frame-annotator! name
+@deffnx {Scheme Procedure} enable-frame-annotator! name
+@deffnx {Scheme Procedure} disable-frame-annotator! name
+Remove, enable, or disable a frame annotator, respectively.
+@var{name} should correspond to the name of a annotator previously
+added with @code{add-frame-annotator!}. If no such annotator is
+found, an error is signalled.
+@end deffn
+
+@node Writing a Frame Filter in Guile
+@subsubsection Writing a Frame Filter in Guile
+@cindex writing a frame filter in guile
+
+The simplest kind of frame filter just takes the incoming stream of
+frames and produces an identical stream of values. For example:
+
+@example
+(use-modules (gdb frames))
+
+(define (identity-frame-filter stream)
+ (cond
+ ((stream-null? stream)
+ ;; End of stream? Then return end-of-stream.
+ stream-null)
+ (else
+ ;; Otherwise recurse on the tail of the stream.
+ (stream-cons (stream-car stream)
+ (identity-frame-filter (stream-cdr stream))))))
+@end example
+
+If you are not familiar with SRFI-41 streams, you might think that
+this would eagerly traverse the whole stack of frames. This would be
+bad because we don't want to produce an entire backtrace at once when
+the user might cancel after only seeing one page. However this is not
+the case, because unlike normal Scheme procedures, @code{stream-cons}
+is @emph{lazy} in its arguments, which is to say that its arguments
+are only evaluated when they are accessed via @code{stream-car} and
+@code{stream-cdr}. In this way the stream looks infinite, but in
+reality only produces values as they are requested by the caller.
+
+To use this frame filter, we have to register it with @value{GDBN}.
+
+@example
+(add-frame-filter! "identity" identity-frame-filter)
+@end example
+
+Now our filter will run each time a backtrace is printed, or in
+general for any @value{GDBN} command that uses the frame filter interface.
+
+Filters are enabled when they are added. You can control the enabled
+or disabled state of a filter using the appropriate procedures:
+
+@example
+(disable-frame-filter! "identity")
+(enable-frame-filter! "identity")
+@end example
+
+Finally, we can remove all filters with a simple application of
+@code{for-each}:
+
+@example
+(for-each remove-frame-filter! (all-frame-filters))
+@end example
+
+The same general mechanics apply to frame annotators as well.
+
+Let us define a more interesting example. For example, in Guile there
+is a function @code{scm_call_n}, which may be invoked directly but is
+often invoked via well-known wrappers like @code{scm_call_0},
+@code{scm_call_1}, and so on. For example here is part of a backtrace
+of an optimized Guile build, when you first start a Guile REPL:
+
+@smallexample
+#10 0x00007ffff7b6ed91 in vm_debug_engine ([...]) at vm-engine.c:815
+#11 0x00007ffff7b74380 in scm_call_n ([...]) at vm.c:1258
+#12 0x00007ffff7afb9d9 in scm_call_0 ([...]) at eval.c:475
+#13 0x00007ffff7b74a0e in sf_fill_input ([...]) at vports.c:94
+@end smallexample
+
+For the sake of the example, the arguments to each have been
+abbreviated to @code{[...]}. Now, it might be nice if we could nest
+@code{scm_call_n} inside @code{scm_call_0}, so let's do that:
+
+@smallexample
+(use-modules (gdb) (gdb frames) (srfi srfi-41))
+
+(define (nest-scm-call-filter stream)
+ ;; When we have the new head and tail, use this helper to make a
+ ;; stream from them, lazily recursing on the tail.
+ (define (recur head tail)
+ (stream-cons head (nest-scm-call-filter tail)))
+
+ (cond
+ ((stream-null? stream)
+ ;; No more frames? Just return the stream as is.
+ stream)
+ (else
+ (let ((head (stream-car stream))
+ (tail (stream-cdr stream)))
+ (cond
+ ;; Is this a call to scm_call_n and is there a next frame?
+ ((and (equal? (annotated-frame-function-name head)
+ "scm_call_n")
+ (not (stream-null? tail)))
+ (let* ((next (stream-car tail))
+ (next-name (annotated-frame-function-name next)))
+ (cond
+ ;; Does the next frame have a function name and
+ ;; does it start with "scm_call_"?
+ ((and next-name
+ (string-prefix? "scm_call_" next-name))
+ ;; A match! Add `head' to the child list of `next'.
+ (let ((children (cons head
+ (annotated-frame-children next))))
+ (recur (reannotate-frame next #:children children)
+ (stream-cdr tail))))
+ (else (recur head tail)))))
+ (else (recur head tail)))))))
+
+(add-frame-filter! "nest-scm-call" nest-scm-call-filter)
+@end smallexample
+
+With this filter in place, the resulting backtrace looks like:
+
+@smallexample
+#10 0x00007ffff7b6ed91 in vm_debug_engine ([...]) at vm-engine.c:815
+#12 0x00007ffff7afb9d9 in scm_call_0 ([...]) at eval.c:475
+ #11 0x00007ffff7b74380 in scm_call_n ([...]) at vm.c:1258
+#13 0x00007ffff7b74a0e in sf_fill_input ([...]) at vports.c:94
+@end smallexample
+
+As you can see, frame #11 has been nested below frame #12.
+
+Sometimes, though, all this stream processing and stream recursion can
+be too complicated if your desire is just to annotate individual
+frames. In that situation, the frame annotator API can be more
+appropriate. For example, if we know that there are some C procedures
+that have ``aliases'' in some other language, like Scheme, then we can
+annotate them in the backtrace with their Scheme names.
+
+@smallexample
+(use-modules (gdb frames))
+
+(define *function-name-aliases*
+ '(("scm_primitive_eval" . "primitive-eval")))
+
+(define (alias-annotator ann)
+ (let* ((name (annotated-frame-function-name ann))
+ (alias (assoc-ref *function-name-aliases* name)))
+ (if alias
+ (reannotate-frame ann #:function-name
+ (string-append "[" alias "] " name))
+ ann)))
+
+(add-frame-annotator! "alias-annotator" alias-annotator)
+@end smallexample
+
+A backtrace with this annotator in place produces:
+
+@smallexample
+#19 [...] in vm_debug_engine ([...]) at vm-engine.c:806
+#20 [...] in scm_call_n ([...]) at vm.c:1258
+#21 [...] in [primitive-eval] scm_primitive_eval ([...]) at eval.c:656
+#22 [...] in scm_eval ([...]) at eval.c:690
+#23 [...] in scm_shell ([...]) at script.c:454
+@end smallexample
+
+Again, parts have been elided with @code{[...]}.
+
+It is possible to do the job of an annotator with a filter, but if the
+task is simple enough for an annotator, it's much less code, as the
+above example shows.
+
@node Commands In Guile
@subsubsection Commands In Guile
diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h
index 7b7f592..9733e20 100644
--- a/gdb/guile/guile-internal.h
+++ b/gdb/guile/guile-internal.h
@@ -32,6 +32,7 @@ struct block;
struct frame_info;
struct objfile;
struct symbol;
+struct inferior;
/* A function to pass to the safe-call routines to ignore things like
memory errors. */
@@ -421,6 +422,9 @@ typedef struct _frame_smob frame_smob;
extern int frscm_is_frame (SCM scm);
+extern SCM frscm_scm_from_frame (struct frame_info *frame,
+ struct inferior *inferior);
+
extern frame_smob *frscm_get_frame_smob_arg_unsafe (SCM frame_scm, int arg_pos,
const char *func_name);
@@ -578,6 +582,11 @@ extern enum ext_lang_rc gdbscm_apply_val_pretty_printer
const struct value_print_options *options,
const struct language_defn *language);
+extern enum ext_lang_bt_status gdbscm_apply_frame_filter
+ (const struct extension_language_defn *,
+ struct frame_info *frame, int flags, enum ext_lang_frame_args args_type,
+ struct ui_out *out, int frame_low, int frame_high);
+
extern int gdbscm_breakpoint_has_cond (const struct extension_language_defn *,
struct breakpoint *b);
@@ -594,6 +603,7 @@ extern void gdbscm_initialize_commands (void);
extern void gdbscm_initialize_disasm (void);
extern void gdbscm_initialize_exceptions (void);
extern void gdbscm_initialize_frames (void);
+extern void gdbscm_initialize_frame_filters (void);
extern void gdbscm_initialize_iterators (void);
extern void gdbscm_initialize_lazy_strings (void);
extern void gdbscm_initialize_math (void);
diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
index e9d2aae..3ad362b 100644
--- a/gdb/guile/guile.c
+++ b/gdb/guile/guile.c
@@ -147,7 +147,7 @@ static const struct extension_language_ops guile_extension_ops =
gdbscm_apply_val_pretty_printer,
- NULL, /* gdbscm_apply_frame_filter, */
+ gdbscm_apply_frame_filter,
gdbscm_preserve_values,
@@ -663,6 +663,7 @@ initialize_gdb_module (void *data)
gdbscm_initialize_commands ();
gdbscm_initialize_disasm ();
gdbscm_initialize_frames ();
+ gdbscm_initialize_frame_filters ();
gdbscm_initialize_iterators ();
gdbscm_initialize_lazy_strings ();
gdbscm_initialize_math ();
diff --git a/gdb/guile/lib/gdb/frames.scm b/gdb/guile/lib/gdb/frames.scm
new file mode 100644
index 0000000..ffce8ef
--- /dev/null
+++ b/gdb/guile/lib/gdb/frames.scm
@@ -0,0 +1,372 @@
+;; Frame filter support.
+;;
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;
+;; This file is part of GDB.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gdb frames)
+ #:use-module ((gdb) #:hide (frame? symbol?))
+ #:use-module ((gdb) #:select ((frame? . gdb:frame?) (symbol? . gdb:symbol?)))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-41)
+ #:export (reannotate-frame
+ annotated-frame?
+ annotated-frame-frame
+ annotated-frame-function-name
+ annotated-frame-address
+ annotated-frame-filename
+ annotated-frame-line
+ annotated-frame-arguments
+ annotated-frame-locals
+ annotated-frame-children
+
+ add-frame-annotator!
+ all-frame-annotators
+ frame-annotator-enabled?
+ frame-annotator-priority
+ remove-frame-annotator!
+ enable-frame-annotator!
+ disable-frame-annotator!
+
+ add-frame-filter!
+ all-frame-filters
+ frame-filter-enabled?
+ frame-filter-priority
+ remove-frame-filter!
+ enable-frame-filter!
+ disable-frame-filter!))
+
+(define-record-type <annotated-frame>
+ (make-annotated-frame frame function-name address filename line
+ arguments locals children)
+ annotated-frame?
+ (frame annotated-frame-frame) ; frame
+ (function-name annotated-frame-function-name) ; string or #f
+ (address annotated-frame-address) ; non-negative int
+ (filename annotated-frame-filename) ; string or #f
+ (line annotated-frame-line) ; positive int or #f
+ ;; binding := symbol | (symbol . value) | (string . value)
+ (arguments annotated-frame-arguments) ; (binding ...)
+ (locals annotated-frame-locals) ; (binding ...)
+ (children annotated-frame-children) ; (annotated-frame ...)
+ )
+
+(define (frame-function-name frame)
+ (let ((f (frame-function frame)))
+ (cond
+ ((not f) f)
+ ((gdb:symbol? f) (symbol-print-name f))
+ (else (object->string f)))))
+
+(define (frame-filename frame)
+ (or (and=> (frame-sal frame)
+ (lambda (sal)
+ (and=> (sal-symtab sal) symtab-filename)))
+ ;; FIXME: Fall back to (solib-name (frame-pc frame)) if present.
+ #f))
+
+(define (frame-line frame)
+ (and=> (frame-sal frame) sal-line))
+
+(define symbol-has-value?
+ (let ((*interesting-addr-classes* (list SYMBOL_LOC_STATIC
+ SYMBOL_LOC_REGISTER
+ SYMBOL_LOC_ARG
+ SYMBOL_LOC_REF_ARG
+ SYMBOL_LOC_LOCAL
+ SYMBOL_LOC_REGPARM_ADDR
+ SYMBOL_LOC_COMPUTED)))
+ (lambda (sym)
+ (memq (symbol-addr-class sym) *interesting-addr-classes*))))
+
+(define (frame-arguments frame)
+ (let lp ((block (false-if-exception (frame-block frame))))
+ (cond
+ ((not block) '())
+ ((not (block-function block)) (lp (block-superblock block)))
+ (else
+ (filter symbol-argument? (block-symbols block))))))
+
+(define (frame-locals frame)
+ (let lp ((block (false-if-exception (frame-block frame))))
+ (if (or (not block) (block-global? block) (block-static? block))
+ '()
+ (append (filter (lambda (sym)
+ (and (not (symbol-argument? sym))
+ (symbol-has-value? sym)))
+ (block-symbols block))
+ (lp (block-superblock block))))))
+
+;; frame -> annotated-frame
+(define (annotate-frame frame)
+ (make-annotated-frame frame
+ (frame-function-name frame)
+ (frame-pc frame)
+ (frame-filename frame)
+ (frame-line frame)
+ (frame-arguments frame)
+ (frame-locals frame)
+ '()))
+
+(define* (reannotate-frame ann #:key
+ (function-name (annotated-frame-function-name ann))
+ (address (annotated-frame-address ann))
+ (filename (annotated-frame-filename ann))
+ (line (annotated-frame-line ann))
+ (arguments (annotated-frame-arguments ann))
+ (locals (annotated-frame-locals ann))
+ (children (annotated-frame-children ann)))
+ (define (valid-local? x)
+ (or (gdb:symbol? x)
+ (and (pair? x)
+ (or (gdb:symbol? (car x)) (string? (car x)))
+ (value? (cdr x)))))
+ (define (list-of? pred x)
+ (and (list? x) (and-map pred x)))
+ (unless (or (not function-name) (string? function-name))
+ (error "function-name should be a string or #f"))
+ (unless (and (exact-integer? address) (not (negative? address)))
+ (error "address should be an non-negative integer"))
+ (unless (or (not filename) (string? filename))
+ (error "filename should be a string or #f"))
+ (unless (or (not line) (and (exact-integer? line) (positive? line)))
+ (error "line expected to a positive integer or #f"))
+ (unless (list-of? valid-local? arguments)
+ (error "arguments should be a list of symbol-value pairs, \
+string-value pairs, or symbols"))
+ (unless (list-of? valid-local? locals)
+ (error "locals should be a list of symbol-value pairs, \
+string-value pairs, or symbols"))
+ (unless (and-map annotated-frame? children)
+ (error "children should be annotated frames" children))
+ (make-annotated-frame (annotated-frame-frame ann)
+ function-name address filename line arguments locals
+ children))
+
+(define-record-type <scoped-priority-item>
+ (make-scoped-priority-item name priority enabled? entry scope)
+ priority-item?
+ (name &name)
+ (priority &priority)
+ (enabled? &enabled? set-enabled?!)
+ (entry &entry)
+ (scope &scope))
+
+(define (add-to-priority-list priority-list name priority enabled? entry scope)
+ (when (find (lambda (x) (equal? (&name x) name)) priority-list)
+ (error "Name already present in list" name))
+ (stable-sort
+ (cons (make-scoped-priority-item name priority enabled? entry scope)
+ priority-list)
+ (lambda (a b)
+ (>= (&priority a) (&priority b)))))
+
+(define (remove-from-priority-list priority-list name)
+ (remove (lambda (x) (equal? (&name x) name)) priority-list))
+
+(define (priority-list-enabled? priority-list name)
+ (let ((item (find (lambda (x) (equal? (&name x) name)) priority-list)))
+ (unless item
+ (error "Name not found in list" name))
+ (&enabled? item)))
+
+(define (priority-list-priority priority-list name)
+ (let ((item (find (lambda (x) (equal? (&name x) name)) priority-list)))
+ (unless item
+ (error "Name not found in list" name))
+ (&priority item)))
+
+(define (priority-list-enable! priority-list name)
+ (let ((item (find (lambda (x) (equal? (&name x) name)) priority-list)))
+ (unless item
+ (error "Name not found in list" name))
+ (set-enabled?! item #t)
+ *unspecified*))
+
+(define (priority-list-disable! priority-list name)
+ (let ((item (find (lambda (x) (equal? (&name x) name)) priority-list)))
+ (unless item
+ (error "Name not found in list" name))
+ (set-enabled?! item #f)
+ *unspecified*))
+
+(define-syntax-rule (define-scoped-priority-list *priority-list*
+ all-names active-entries
+ get-enabled? get-priority
+ add! remove! enable! disable!)
+ (begin
+ (define *priority-list* '())
+
+ ;; -> (name ...), from low to high priority
+ (define (all-names)
+ (reverse (map &name *priority-list*)))
+
+ ;; -> (entry ...), from low to high priority
+ (define* (active-entries progspace)
+ (reverse (filter-map (lambda (item)
+ (and (&enabled? item)
+ ;; The entry matches if its progspace
+ ;; matches, its objfile is still
+ ;; valid, or if it is not associated
+ ;; with a specific progspace or
+ ;; objfile.
+ (let ((scope (&scope item)))
+ (or (not scope)
+ (if (progspace? scope)
+ (eq? progspace scope)
+ (objfile-valid? scope))))
+ (&entry item)))
+ *priority-list*)))
+
+ (define (get-enabled? name)
+ (priority-list-enabled? *priority-list* name))
+
+ (define (get-priority name)
+ (priority-list-priority *priority-list* name))
+
+ (define* (add! name entry #:key
+ objfile progspace (priority 20) (enabled? #t))
+ ;; scope := objfile | progspace | #f
+ (define (compute-scope objfile progspace)
+ (cond
+ (objfile
+ (when progspace
+ (error "Only one of #:objfile or #:progspace may be given"))
+ (unless (objfile? objfile)
+ (error "Not an objfile" objfile))
+ objfile)
+ (progspace
+ (unless (progspace? progspace)
+ (error "Not a progspace" progspace))
+ progspace)
+ (else #f)))
+ (let ((scope (compute-scope objfile progspace)))
+ (set! *priority-list*
+ (add-to-priority-list *priority-list*
+ name priority enabled? entry scope))))
+
+ (define (remove! name)
+ (set! *priority-list*
+ (remove-from-priority-list *priority-list* name)))
+
+ (define (enable! name)
+ (priority-list-enable! *priority-list* name))
+
+ (define (disable! name)
+ (priority-list-disable! *priority-list* name))))
+
+;; frame-annotator := annotated-frame -> annotated-frame
+(define-scoped-priority-list *frame-annotators*
+ all-frame-annotators
+ active-frame-annotators
+ frame-annotator-enabled?
+ frame-annotator-priority
+ add-frame-annotator!
+ remove-frame-annotator!
+ enable-frame-annotator!
+ disable-frame-annotator!)
+
+(define (apply-fold functions seed)
+ (fold (lambda (f seed) (f seed)) seed functions))
+
+(define (apply-frame-annotators ann)
+ (apply-fold (active-frame-annotators (current-progspace)) ann))
+
+;; frame-filter := Stream annotated-frame -> Stream annotated-frame
+(define-scoped-priority-list *frame-filters*
+ all-frame-filters
+ active-frame-filters
+ frame-filter-enabled?
+ frame-filter-priority
+ add-frame-filter!
+ remove-frame-filter!
+ enable-frame-filter!
+ disable-frame-filter!)
+
+(define (apply-frame-filters ann)
+ (apply-fold (active-frame-filters (current-progspace)) ann))
+
+;; frame int int -> Stream annotated-frame
+(define (frame-stream frame frame-low frame-high)
+ (define (make-stream frame count)
+ (let ((frames (stream-unfold annotate-frame gdb:frame? frame-older frame)))
+ (if count
+ (stream-take count frames)
+ frames)))
+ (if (negative? frame-low)
+ ;; Traverse the stack to find the outermost N frames.
+ (let ((count (- frame-low)))
+ (let lp ((older frame) (n 0))
+ (cond
+ ((not older)
+ (make-stream frame #f))
+ ((< n count)
+ (lp (frame-older older) (1+ n)))
+ (else
+ ;; "older" is now "count" frames older than "frame". Keep
+ ;; going until we hit the oldest frame.
+ (let lp ((frame frame) (older older))
+ (if older
+ (lp (frame-older frame) (frame-older older))
+ (make-stream frame #f)))))))
+ (let lp ((frame frame) (frame-low frame-low) (newer-index 0))
+ ;; Cut the innermost N frames.
+ (cond
+ ((not frame) 'no-frames)
+ ((zero? frame-low)
+ (let ((count (if (eqv? frame-high -1)
+ #f
+ (1+ (max (- frame-high newer-index) 0)))))
+ (make-stream frame count)))
+ (else
+ (lp (frame-older frame) (1- frame-low) (1+ newer-index)))))))
+
+(define (stream->gdb-iterator stream lower)
+ (make-iterator stream stream
+ (lambda (iter)
+ (let ((stream (iterator-progress iter)))
+ (cond
+ ((stream-null? stream)
+ (end-of-iteration))
+ (else
+ (set-iterator-progress! iter (stream-cdr stream))
+ (lower (stream-car stream))))))))
+
+(define (annotated-frame->vector ann)
+ ;; C can't deal so nicely with record types, so lower to a more simple
+ ;; data structure.
+ (vector (annotated-frame-frame ann)
+ (annotated-frame-function-name ann)
+ (annotated-frame-address ann)
+ (annotated-frame-filename ann)
+ (annotated-frame-line ann)
+ (annotated-frame-arguments ann)
+ (annotated-frame-locals ann)
+ (map annotated-frame->vector (annotated-frame-children ann))))
+
+(define (apply-frame-filter frame frame-low frame-high)
+ (and (or (pair? (active-frame-filters (current-progspace)))
+ (pair? (active-frame-annotators (current-progspace))))
+ (stream->gdb-iterator
+ (apply-frame-filters
+ (stream-map
+ apply-frame-annotators
+ (frame-stream frame frame-low frame-high)))
+ annotated-frame->vector)))
+
+(load-extension "gdb" "gdbscm_load_frame_filters")
diff --git a/gdb/guile/scm-frame-filter.c b/gdb/guile/scm-frame-filter.c
new file mode 100644
index 0000000..21265f4
--- /dev/null
+++ b/gdb/guile/scm-frame-filter.c
@@ -0,0 +1,1027 @@
+/* Scheme interface to frame filter.
+
+ Copyright (C) 2015 Free Software Foundation, Inc.
+
+ This file is part of GDB.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* See README file in this directory for implementation notes, coding
+ conventions, et.al. */
+
+#include "defs.h"
+#include "annotate.h"
+#include "block.h"
+#include "demangle.h"
+#include "frame.h"
+#include "inferior.h"
+#include "language.h"
+#include "objfiles.h"
+#include "symfile.h"
+#include "symtab.h"
+#include "stack.h"
+#include "valprint.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* Non-zero if the (gdb frames) module has been loaded. */
+static int gdbscm_frame_filters_loaded = 0;
+
+/* The captured apply-frame-filter variable. */
+static SCM apply_frame_filter = SCM_BOOL_F;
+
+/* Called by lib/gdb/frames.scm. */
+static void
+gdbscm_load_frame_filters (void *unused)
+{
+ if (gdbscm_frame_filters_loaded)
+ return;
+
+ gdbscm_frame_filters_loaded = 1;
+
+ apply_frame_filter = scm_c_lookup ("apply-frame-filter");
+}
+
+/* Helper to throw type errors as Scheme exceptions. */
+static void
+gdbscm_throw_type_error (const char *subr, int arg_pos, SCM val,
+ const char *expected_type)
+{
+ gdbscm_throw (gdbscm_make_type_error (subr, arg_pos, val, expected_type));
+}
+
+/* We surround TRY_CATCH blocks with Scheme dynwinds, so that Scheme
+ exceptions can interoperate with GDB exceptions. Since GDB's
+ TRY_CATCH saves and restores cleanups around its body, and
+ automatically runs inner cleanups on exception, we arrange to do the
+ same on Scheme exceptions. */
+static void
+dynwind_restore_cleanups (void *data)
+{
+ struct cleanup *cleanups = data;
+ restore_cleanups (cleanups);
+}
+
+static void
+dynwind_do_cleanups (void *data)
+{
+ struct cleanup *cleanups = data;
+ do_cleanups (cleanups);
+}
+
+/* Use BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS instead of TRY_CATCH when
+ you are inside gdbscm_safe_call, and close it with
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND. This will cause
+ GDB exceptions raised within the block to be re-raised as Scheme
+ exceptions. Leaving the block in any way -- whether normally, via a
+ GDB exception, or a Scheme exception -- will cause any cleanups that
+ were registered within the block to run.
+
+ Given that almost all code in this file is dynamically within one of
+ these blocks, when should you add a new one? There are only a few
+ cases:
+
+ 1. You need to call make_cleanup_ui_out_tuple_begin_end or
+ some other bracketed UI operation.
+ 2. You are allocating something "big" that should be cleaned up
+ promptly, like make_cleanup_ui_file_delete.
+ 3. You want to register a Scheme unwind procedure, and need to
+ prevent GDB exceptions from passing your dynwind. */
+
+#define BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS() \
+ do { \
+ volatile struct gdb_exception __except; \
+ /* Any cleanup pushed within the TRY_CATCH will be run on GDB \
+ exception. We will have to run them manually on normal exit or \
+ Scheme exception. */ \
+ scm_dynwind_begin (0); \
+ /* Save the cleanup stack, and arrange to restore it after any exit \
+ from the TRY_CATCH, local or non-local. */ \
+ scm_dynwind_unwind_handler (dynwind_restore_cleanups, \
+ save_cleanups (), \
+ SCM_F_WIND_EXPLICITLY); \
+ TRY_CATCH (__except, RETURN_MASK_ALL) \
+ { \
+ struct cleanup *__cleanups = make_cleanup (null_cleanup, NULL); \
+ /* Ensure cleanups run on Scheme exception. */ \
+ scm_dynwind_unwind_handler (dynwind_do_cleanups, __cleanups, 0);\
+ do
+
+#define RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND() \
+ while (0); \
+ /* Ensure cleanups run on normal exit. */ \
+ do_cleanups (__cleanups); \
+ } \
+ /* Pop the dynwind and restore the saved cleanup stack. */ \
+ scm_dynwind_end (); \
+ if (__except.reason < 0) \
+ /* Rethrow GDB exception as Scheme exception. */ \
+ gdbscm_throw_gdb_exception (__except); \
+ } while (0)
+
+
+/* Helper function to extract a symbol, a name, a language definition,
+ and a value from ITEM, which is an element of a Scheme "arguments" or
+ "locals" list.
+
+ ITEM will either be a pair of a string and a value, a pair of a
+ symbol and a value, or just a symbol. NAME is a pass-through
+ argument where the name of the symbol will be written. NAME is
+ allocated in this function, and a cleanup handler is registered if
+ needed. SYM is a pass-through argument where the symbol will be
+ written. If the name is a string and not a symbol, SYM will be set
+ to NULL. LANGUAGE is also a pass-through argument denoting the
+ language attributed to the symbol. In the case of SYM being NULL,
+ this will be set to the current language. Finally, VALUE will be set
+ to the unwrapped GDB value, if ITEM is a pair, and otherwise
+ NULL. */
+static void
+extract_sym_and_value (SCM item, const char **name, struct symbol **sym,
+ const struct language_defn **language,
+ struct value **value, struct gdbarch *gdbarch)
+{
+ if (scm_is_pair (item))
+ {
+ SCM symbol_scm = scm_car (item), value_scm = scm_cdr (item);
+ SCM exception = SCM_BOOL_F;
+
+ if (scm_is_string (symbol_scm))
+ {
+ *name = gdbscm_scm_to_host_string (symbol_scm, NULL,
+ &exception);
+ if (!*name)
+ gdbscm_throw (exception);
+ make_cleanup (xfree, name);
+
+ *sym = NULL;
+ *language = current_language;
+ }
+ else
+ {
+ *sym = syscm_get_valid_symbol_arg_unsafe (symbol_scm,
+ GDBSCM_ARG_NONE,
+ "print-frame");
+ *name = SYMBOL_PRINT_NAME (*sym);
+
+ if (language_mode == language_mode_auto)
+ *language = language_def (SYMBOL_LANGUAGE (*sym));
+ else
+ *language = current_language;
+ }
+
+ *value = vlscm_convert_value_from_scheme ("print-frame",
+ GDBSCM_ARG_NONE,
+ value_scm,
+ &exception,
+ gdbarch,
+ *language);
+ if (!*value)
+ gdbscm_throw (exception);
+ }
+ else
+ {
+ *sym = syscm_get_valid_symbol_arg_unsafe (item, GDBSCM_ARG_NONE,
+ "print-frame");
+ *name = SYMBOL_PRINT_NAME (*sym);
+
+ if (language_mode == language_mode_auto)
+ *language = language_def (SYMBOL_LANGUAGE (*sym));
+ else
+ *language = current_language;
+
+ *value = NULL;
+ }
+}
+
+enum mi_print_types
+{
+ MI_PRINT_ARGS,
+ MI_PRINT_LOCALS
+};
+
+/* MI prints only certain values according to the type of symbol and
+ also what the user has specified. SYM is the symbol to check, and
+ MI_PRINT_TYPES is an enum specifying what the user wants emitted
+ for the MI command in question. */
+static int
+mi_should_print (struct symbol *sym, enum mi_print_types type)
+{
+ int print_me = 0;
+
+ switch (SYMBOL_CLASS (sym))
+ {
+ default:
+ case LOC_UNDEF: /* catches errors */
+ case LOC_CONST: /* constant */
+ case LOC_TYPEDEF: /* local typedef */
+ case LOC_LABEL: /* local label */
+ case LOC_BLOCK: /* local function */
+ case LOC_CONST_BYTES: /* loc. byte seq. */
+ case LOC_UNRESOLVED: /* unresolved static */
+ case LOC_OPTIMIZED_OUT: /* optimized out */
+ print_me = 0;
+ break;
+
+ case LOC_ARG: /* argument */
+ case LOC_REF_ARG: /* reference arg */
+ case LOC_REGPARM_ADDR: /* indirect register arg */
+ case LOC_LOCAL: /* stack local */
+ case LOC_STATIC: /* static */
+ case LOC_REGISTER: /* register */
+ case LOC_COMPUTED: /* computed location */
+ if (type == MI_PRINT_LOCALS)
+ print_me = ! SYMBOL_IS_ARGUMENT (sym);
+ else
+ print_me = SYMBOL_IS_ARGUMENT (sym);
+ }
+ return print_me;
+}
+
+/* Helper function which outputs a type name extracted from VAL to a
+ "type" field in the output stream OUT. OUT is the ui-out structure
+ the type name will be output too, and VAL is the value that the
+ type will be extracted from. */
+static void
+gdbscm_print_type (struct ui_out *out, struct value *val)
+{
+ struct type *type;
+
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ struct ui_file *stb = mem_fileopen ();
+ make_cleanup_ui_file_delete (stb);
+ type = check_typedef (value_type (val));
+ type_print (value_type (val), "", stb, -1);
+ ui_out_field_stream (out, "type", stb);
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+}
+
+/* Helper function which outputs a value to an output field in a
+ stream. OUT is the ui-out structure the value will be output to,
+ VAL is the value that will be printed, OPTS contains the value
+ printing options, ARGS_TYPE is an enumerator describing the
+ argument format, and LANGUAGE is the language_defn that the value
+ will be printed with. */
+static void
+gdbscm_print_value (struct ui_out *out, struct value *val,
+ const struct value_print_options *opts,
+ int indent,
+ enum ext_lang_frame_args args_type,
+ const struct language_defn *language)
+{
+ int should_print = 0;
+ int local_indent = (4 * indent);
+
+ /* Never set an indent level for common_val_print if MI. */
+ if (ui_out_is_mi_like_p (out))
+ local_indent = 0;
+
+ /* MI does not print certain values, differentiated by type,
+ depending on what ARGS_TYPE indicates. Test type against option.
+ For CLI print all values. */
+ if (args_type == MI_PRINT_SIMPLE_VALUES
+ || args_type == MI_PRINT_ALL_VALUES)
+ {
+ struct type *type = check_typedef (value_type (val));
+
+ if (args_type == MI_PRINT_ALL_VALUES)
+ should_print = 1;
+ else if (args_type == MI_PRINT_SIMPLE_VALUES
+ && TYPE_CODE (type) != TYPE_CODE_ARRAY
+ && TYPE_CODE (type) != TYPE_CODE_STRUCT
+ && TYPE_CODE (type) != TYPE_CODE_UNION)
+ should_print = 1;
+ }
+ else if (args_type != NO_VALUES)
+ should_print = 1;
+
+ if (should_print)
+ {
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ struct ui_file *stb = mem_fileopen ();
+ make_cleanup_ui_file_delete (stb);
+ common_val_print (val, stb, indent, opts, language);
+ ui_out_field_stream (out, "value", stb);
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+ }
+}
+
+enum print_args_field
+{
+ WITH_ARGS_FIELD,
+ WITHOUT_ARGS_FIELD
+};
+
+/* Helper function to output a single frame argument and value to an
+ output stream. This function will account for entry values if the FV
+ parameter is populated, the frame argument has entry values
+ associated with them, and the appropriate "set entry-value" options
+ are set. Will output in CLI or MI like format depending on the type
+ of output stream detected. OUT is the output stream, SYM_NAME is the
+ name of the symbol. If SYM_NAME is populated then it must have an
+ accompanying value in the parameter FV. FA is a frame argument
+ structure. If FA is populated, both SYM_NAME and FV are ignored.
+ OPTS contains the value printing options, ARGS_TYPE is an enumerator
+ describing the argument format, PRINT_ARGS_FIELD is a flag which
+ indicates if we output "ARGS=1" in MI output in commands where both
+ arguments and locals are printed. */
+static void
+gdbscm_print_single_arg (struct ui_out *out,
+ const char *sym_name,
+ struct frame_arg *fa,
+ struct value *fv,
+ const struct value_print_options *opts,
+ enum ext_lang_frame_args args_type,
+ enum print_args_field print_args_field,
+ const struct language_defn *language)
+{
+ struct value *val;
+
+ if (fa != NULL)
+ {
+ if (fa->val == NULL && fa->error == NULL)
+ return;
+ language = language_def (SYMBOL_LANGUAGE (fa->sym));
+ val = fa->val;
+ }
+ else
+ val = fv;
+
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ /* MI has varying rules for tuples, but generally if there is
+ only one element in each item in the list, do not start a
+ tuple. The exception is -stack-list-variables which emits an
+ ARGS="1" field if the value is a frame argument. This is
+ denoted in this function with PRINT_ARGS_FIELD which is flag
+ from the caller to emit the ARGS field. */
+ if (ui_out_is_mi_like_p (out))
+ {
+ if (print_args_field == WITH_ARGS_FIELD
+ || args_type != NO_VALUES)
+ make_cleanup_ui_out_tuple_begin_end (out, NULL);
+ }
+
+ annotate_arg_begin ();
+
+ /* If frame argument is populated, check for entry-values and the
+ entry value options. */
+ if (fa != NULL)
+ {
+ struct ui_file *stb;
+
+ stb = mem_fileopen ();
+ make_cleanup_ui_file_delete (stb);
+ fprintf_symbol_filtered (stb, SYMBOL_PRINT_NAME (fa->sym),
+ SYMBOL_LANGUAGE (fa->sym),
+ DMGL_PARAMS | DMGL_ANSI);
+ if (fa->entry_kind == print_entry_values_compact)
+ {
+ fputs_filtered ("=", stb);
+
+ fprintf_symbol_filtered (stb, SYMBOL_PRINT_NAME (fa->sym),
+ SYMBOL_LANGUAGE (fa->sym),
+ DMGL_PARAMS | DMGL_ANSI);
+ }
+ if (fa->entry_kind == print_entry_values_only
+ || fa->entry_kind == print_entry_values_compact)
+ {
+ fputs_filtered ("@entry", stb);
+ }
+ ui_out_field_stream (out, "name", stb);
+ }
+ else
+ /* Otherwise, just output the name. */
+ ui_out_field_string (out, "name", sym_name);
+
+ annotate_arg_name_end ();
+
+ if (! ui_out_is_mi_like_p (out))
+ ui_out_text (out, "=");
+
+ if (print_args_field == WITH_ARGS_FIELD)
+ ui_out_field_int (out, "arg", 1);
+
+ /* For MI print the type, but only for simple values. This seems
+ weird, but this is how MI choose to format the various output
+ types. */
+ if (args_type == MI_PRINT_SIMPLE_VALUES && val != NULL)
+ gdbscm_print_type (out, val);
+
+ if (val != NULL)
+ annotate_arg_value (value_type (val));
+
+ /* If the output is to the CLI, and the user option "set print
+ frame-arguments" is set to none, just output "...". */
+ if (! ui_out_is_mi_like_p (out) && args_type == NO_VALUES)
+ ui_out_field_string (out, "value", "...");
+ else
+ {
+ /* Otherwise, print the value for both MI and the CLI, except
+ for the case of MI_PRINT_NO_VALUES. */
+ if (args_type != NO_VALUES)
+ {
+ if (val == NULL)
+ {
+ gdb_assert (fa != NULL && fa->error != NULL);
+ ui_out_field_fmt (out, "value",
+ _("<error reading variable: %s>"),
+ fa->error);
+ }
+ else
+ gdbscm_print_value (out, val, opts, 0, args_type,
+ language);
+ }
+ }
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+}
+
+/* Helper function to print one local. LOCAL is the pair or symbol that
+ is compatible with extract_sym_and_value, OUT is the output stream,
+ INDENT is whether we should indent the output (for CLI), ARGS_TYPE is
+ an enumerator describing the argument format, PRINT_ARGS_FIELD is
+ flag which indicates whether to output the ARGS field in the case of
+ -stack-list-variables and FRAME is the backing frame. */
+static void
+gdbscm_print_local (SCM local,
+ struct ui_out *out,
+ int indent,
+ enum ext_lang_frame_args args_type,
+ struct frame_info *frame,
+ enum print_args_field print_args_field,
+ struct gdbarch *gdbarch)
+{
+ struct value_print_options opts;
+ const struct language_defn *language;
+ const char *sym_name;
+ struct value *val;
+ struct symbol *sym;
+ int local_indent = 8 + (8 * indent);
+ int out_is_mi = ui_out_is_mi_like_p (out);
+
+ get_user_print_options (&opts);
+ opts.deref_ref = 1;
+
+ extract_sym_and_value (local, &sym_name, &sym, &language, &val,
+ gdbarch);
+
+ if (sym && out_is_mi && ! mi_should_print (sym, MI_PRINT_LOCALS))
+ return;
+
+ if (!val)
+ /* If the object did not provide a value, read it. */
+ val = read_var_value (sym, frame);
+
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ /* With PRINT_NO_VALUES, MI does not emit a tuple normally as each
+ output contains only one field. The exception is
+ -stack-list-variables, which always provides a tuple. */
+ if (out_is_mi)
+ {
+ if (print_args_field == WITH_ARGS_FIELD
+ || args_type != NO_VALUES)
+ make_cleanup_ui_out_tuple_begin_end (out, NULL);
+ }
+ else
+ {
+ /* If the output is not MI we indent locals. */
+ ui_out_spaces (out, local_indent);
+ }
+
+ ui_out_field_string (out, "name", sym_name);
+
+ if (! out_is_mi)
+ ui_out_text (out, " = ");
+
+ if (args_type == MI_PRINT_SIMPLE_VALUES)
+ gdbscm_print_type (out, val);
+
+ /* CLI always prints values for locals. MI uses the
+ simple/no/all system. */
+ if (! out_is_mi)
+ {
+ int val_indent = (indent + 1) * 4;
+
+ gdbscm_print_value (out, val, &opts, val_indent, args_type,
+ language);
+ }
+ else
+ {
+ if (args_type != NO_VALUES)
+ gdbscm_print_value (out, val, &opts, 0, args_type, language);
+ }
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+
+ ui_out_text (out, "\n");
+}
+
+/* Helper function for printing locals. This function largely just
+ creates the wrapping tuple, and calls enumerate_locals. Returns
+ EXT_LANG_BT_ERROR on error, or EXT_LANG_BT_OK on success. */
+static void
+gdbscm_print_locals (SCM locals,
+ struct ui_out *out,
+ enum ext_lang_frame_args args_type,
+ int indent,
+ struct frame_info *frame,
+ enum print_args_field print_args_field,
+ struct gdbarch *gdbarch)
+{
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ if (print_args_field == WITHOUT_ARGS_FIELD)
+ make_cleanup_ui_out_list_begin_end (out, "locals");
+
+ for (; scm_is_pair (locals); locals = scm_cdr (locals))
+ {
+ SCM local = scm_car (locals);
+
+ gdbscm_print_local (local, out, indent, args_type, frame,
+ print_args_field, gdbarch);
+ }
+
+ if (!scm_is_null (locals))
+ gdbscm_throw_type_error ("print-locals", GDBSCM_ARG_NONE,
+ locals, "null-terminated locals list");
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+}
+
+/* Helper function to print an argument. ARG is a pair or a symbol, in
+ the format expected by extract_sym_and_value, OUT is the output
+ stream, ARGS_TYPE is an enumerator describing the argument format,
+ PRINT_ARGS_FIELD is a flag which indicates if we output "ARGS=1" in
+ MI output in commands where both arguments and locals are printed,
+ and FRAME is the backing frame. */
+static void
+gdbscm_print_arg (SCM arg, struct ui_out *out,
+ enum ext_lang_frame_args args_type,
+ struct frame_info *frame,
+ enum print_args_field print_args_field,
+ struct gdbarch *gdbarch)
+{
+ struct value_print_options opts;
+ const struct language_defn *language;
+ const char *sym_name;
+ struct symbol *sym;
+ struct value *val;
+
+ get_user_print_options (&opts);
+ if (args_type == CLI_SCALAR_VALUES)
+ opts.summary = 1;
+ opts.deref_ref = 1;
+
+ extract_sym_and_value (arg, &sym_name, &sym, &language, &val, gdbarch);
+
+ if (sym && ui_out_is_mi_like_p (out)
+ && ! mi_should_print (sym, MI_PRINT_ARGS))
+ return;
+
+ annotate_arg_begin ();
+
+ if (val)
+ {
+ /* If the annotated frame provides a value, just print that. */
+ gdbscm_print_single_arg (out, sym_name, NULL, val, &opts,
+ args_type, print_args_field,
+ language);
+ }
+ else
+ {
+ struct frame_arg arg, entryarg;
+
+ /* Otherwise, the annotated frame did not provide a value, so this
+ is a frame argument to be read by GDB. In this case we have to
+ account for entry-values. */
+ read_frame_arg (sym, frame, &arg, &entryarg);
+ make_cleanup (xfree, arg.error);
+ make_cleanup (xfree, entryarg.error);
+
+ if (arg.entry_kind != print_entry_values_only)
+ gdbscm_print_single_arg (out, NULL, &arg, NULL, &opts,
+ args_type, print_args_field, NULL);
+
+ if (entryarg.entry_kind != print_entry_values_no)
+ {
+ if (arg.entry_kind != print_entry_values_only)
+ {
+ /* Delimit the two arguments that we are printing. */
+ ui_out_text (out, ", ");
+ ui_out_wrap_hint (out, " ");
+ }
+
+ gdbscm_print_single_arg (out, NULL, &entryarg, NULL, &opts,
+ args_type, print_args_field, NULL);
+ }
+ }
+
+
+ annotate_arg_end ();
+}
+
+/* Helper function for printing frame arguments. */
+static void
+gdbscm_print_args (SCM args, struct ui_out *out,
+ enum ext_lang_frame_args args_type,
+ struct frame_info *frame,
+ enum print_args_field print_args_field,
+ struct gdbarch *gdbarch)
+{
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ int arg_index = 0;
+
+ if (print_args_field == WITHOUT_ARGS_FIELD)
+ make_cleanup_ui_out_list_begin_end (out, "args");
+
+ annotate_frame_args ();
+ if (! ui_out_is_mi_like_p (out))
+ ui_out_text (out, " (");
+
+ for (; scm_is_pair (args); args = scm_cdr (args), arg_index++)
+ {
+ SCM arg = scm_car (args);
+
+ if (arg_index > 0)
+ ui_out_text (out, ", ");
+
+ gdbscm_print_arg (arg, out, args_type, frame,
+ print_args_field, gdbarch);
+ }
+
+ if (!scm_is_null (args))
+ gdbscm_throw_type_error ("print-args", GDBSCM_ARG_NONE,
+ args, "null-terminated argument list");
+
+ if (! ui_out_is_mi_like_p (out))
+ ui_out_text (out, ")");
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+}
+
+/* Print a single frame to the designated output stream, detecting
+ whether the output is MI or console, and formatting the output
+ according to the conventions of that protocol. ANN is the annotated
+ frame object, as a vector. FLAGS is an integer describing the
+ various print options. The FLAGS variables is described in
+ "apply_frame_filter" function. ARGS_TYPE is an enumerator
+ describing the argument format. OUT is the output stream to print,
+ INDENT is the level of indention for this frame, in the case of
+ child frames. */
+static void
+gdbscm_print_frame (SCM ann, int flags, enum ext_lang_frame_args args_type,
+ struct ui_out *out, int indent)
+{
+ struct gdbarch *gdbarch;
+ struct frame_info *frame;
+ struct value_print_options opts;
+ int print_level, print_frame_info, print_args, print_locals;
+ SCM frame_scm, function_name_scm, address_scm, filename_scm, line_scm;
+ SCM arguments_scm, locals_scm, children_scm;
+
+ /* Extract print settings from FLAGS. */
+ print_level = (flags & PRINT_LEVEL) ? 1 : 0;
+ print_frame_info = (flags & PRINT_FRAME_INFO) ? 1 : 0;
+ print_args = (flags & PRINT_ARGS) ? 1 : 0;
+ print_locals = (flags & PRINT_LOCALS) ? 1 : 0;
+
+ get_user_print_options (&opts);
+
+ frame_scm = scm_c_vector_ref (ann, 0);
+ function_name_scm = scm_c_vector_ref (ann, 1);
+ address_scm = scm_c_vector_ref (ann, 2);
+ filename_scm = scm_c_vector_ref (ann, 3);
+ line_scm = scm_c_vector_ref (ann, 4);
+ arguments_scm = scm_c_vector_ref (ann, 5);
+ locals_scm = scm_c_vector_ref (ann, 6);
+ children_scm = scm_c_vector_ref (ann, 7);
+
+ {
+ frame_smob *smob =
+ frscm_get_frame_smob_arg_unsafe (frame_scm, 0, "print-frame");
+ frame = frscm_frame_smob_to_frame (smob);
+ }
+
+ /* stack-list-variables. */
+ if (print_locals && print_args && ! print_frame_info)
+ {
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ /* Getting the frame arch needs to happen within a dynwind. */
+ gdbarch = get_frame_arch (frame);
+
+ make_cleanup_ui_out_list_begin_end (out, "variables");
+ gdbscm_print_args (arguments_scm, out, args_type, frame,
+ WITH_ARGS_FIELD, gdbarch);
+ gdbscm_print_locals (locals_scm, out, args_type, indent, frame,
+ WITH_ARGS_FIELD, gdbarch);
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+ /* FIXME: Print variables for child frames? */
+ return;
+ }
+
+ BEGIN_DYNWIND_AND_CATCH_GDB_EXCEPTIONS ()
+ {
+ /* Getting the frame arch needs to happen within a dynwind. */
+ gdbarch = get_frame_arch (frame);
+
+ /* -stack-list-locals does not require a wrapping frame
+ attribute. */
+ if (print_frame_info || (print_args && ! print_locals))
+ make_cleanup_ui_out_tuple_begin_end (out, "frame");
+
+ if (print_frame_info && indent > 0)
+ {
+ /* Child frames are also printed with this function
+ (recursively) and are printed with indention. */
+ ui_out_spaces (out, indent * 4);
+ }
+
+ /* Print frame level. MI does not require the level if
+ locals/variables only are being printed. */
+ if ((print_frame_info || print_args) && print_level)
+ {
+ CORE_ADDR address = 0;
+ int level = frame_relative_level (frame);
+
+ if (gdbscm_is_true (address_scm))
+ address = gdbscm_scm_to_ulongest (address_scm);
+
+ annotate_frame_begin (print_level ? level : 0, gdbarch,
+ address);
+ ui_out_text (out, "#");
+ ui_out_field_fmt_int (out, 2, ui_left, "level", level);
+ }
+
+ if (print_frame_info)
+ {
+ /* Print address to the address field. If an address is not
+ provided, print nothing. */
+ if (opts.addressprint && gdbscm_is_true (address_scm))
+ {
+ CORE_ADDR addr = gdbscm_scm_to_ulongest (address_scm);
+ annotate_frame_address ();
+ ui_out_field_core_addr (out, "addr", gdbarch, addr);
+ annotate_frame_address_end ();
+ ui_out_text (out, " in ");
+ }
+
+ /* Print frame function name. */
+ if (gdbscm_is_false (function_name_scm))
+ {
+ const char *function_name = NULL;
+
+ /* Grovel for a minimal symbol before giving up. */
+ if (gdbscm_is_true (address_scm))
+ {
+ CORE_ADDR addr = gdbscm_scm_to_ulongest (address_scm);
+ struct bound_minimal_symbol msymbol;
+
+ msymbol = lookup_minimal_symbol_by_pc (addr);
+ if (msymbol.minsym != NULL)
+ function_name = MSYMBOL_PRINT_NAME (msymbol.minsym);
+ }
+
+ if (function_name)
+ {
+ annotate_frame_function_name ();
+ ui_out_field_string (out, "func", function_name);
+ }
+ else
+ {
+ annotate_frame_function_name ();
+ ui_out_field_skip (out, "func");
+ }
+ }
+ else if (scm_is_string (function_name_scm))
+ {
+ SCM exception = SCM_BOOL_F;
+ char *function;
+
+ function = gdbscm_scm_to_host_string (function_name_scm,
+ NULL,
+ &exception);
+ if (!function)
+ gdbscm_throw (exception);
+ make_cleanup (xfree, function);
+
+ annotate_frame_function_name ();
+ ui_out_field_string (out, "func", function);
+ }
+ else
+ {
+ gdbscm_throw_type_error ("print-frame", GDBSCM_ARG_NONE,
+ function_name_scm,
+ "string or false");
+ }
+ }
+
+ /* Frame arguments. Check the result, and error if something went
+ wrong. */
+ if (print_args)
+ gdbscm_print_args (arguments_scm, out, args_type, frame,
+ WITHOUT_ARGS_FIELD, gdbarch);
+
+ /* File name/source/line number information. */
+ if (print_frame_info)
+ {
+ char *filename = NULL;
+
+ annotate_frame_source_begin ();
+
+ if (gdbscm_is_true (filename_scm))
+ {
+ SCM exception = SCM_BOOL_F;
+
+ filename = gdbscm_scm_to_host_string (filename_scm, NULL,
+ &exception);
+
+ if (!filename)
+ gdbscm_throw (exception);
+
+ make_cleanup (xfree, filename);
+
+ ui_out_wrap_hint (out, " ");
+ ui_out_text (out, " at ");
+ annotate_frame_source_file ();
+ ui_out_field_string (out, "file", filename);
+ annotate_frame_source_file_end ();
+
+ if (gdbscm_is_true (line_scm))
+ {
+ int line = scm_to_int (line_scm);
+ ui_out_text (out, ":");
+ annotate_frame_source_line ();
+ ui_out_field_int (out, "line", line);
+ }
+ }
+ }
+
+ /* For MI we need to deal with child frames, so if MI output
+ detected do not send newline. */
+ if (! ui_out_is_mi_like_p (out))
+ {
+ annotate_frame_end ();
+ ui_out_text (out, "\n");
+ }
+
+ if (print_locals)
+ gdbscm_print_locals (locals_scm, out, args_type, indent, frame,
+ WITHOUT_ARGS_FIELD, gdbarch);
+
+ /* Finally recursively print child frames, if any. */
+ if (! ui_out_is_mi_like_p (out))
+ indent++;
+
+ if (!scm_is_null (children_scm))
+ {
+ /* No need for another dynwind; since we're at the end of the
+ function, the RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND
+ below will close the "children" list just fine. */
+ make_cleanup_ui_out_list_begin_end (out, "children");
+ for (;
+ scm_is_pair (children_scm);
+ children_scm = scm_cdr (children_scm))
+ {
+ SCM child = scm_car (children_scm);
+
+ gdbscm_print_frame (child, flags, args_type, out, indent);
+ }
+
+ if (!scm_is_null (children_scm))
+ gdbscm_throw_type_error ("print-frame", GDBSCM_ARG_NONE,
+ children_scm,
+ "null-terminated child list");
+ }
+ }
+ RETHROW_GDB_EXCEPTIONS_TO_SCHEME_AND_END_DYNWIND ();
+}
+
+/* Iterate through the frame stream, printing each one. Throws Scheme
+ exceptions on error. */
+static void
+print_annotated_frame_stream (SCM iter, int flags,
+ enum ext_lang_frame_args args_type,
+ struct ui_out *out)
+{
+ while (1)
+ {
+ SCM ann = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
+
+ if (itscm_is_end_of_iteration (ann))
+ break;
+
+ /* Since we handle all exceptions via gdbscm_safe_call, really
+ we'd like an itcm_call_next_x method that propagates the
+ exception, but lacking that we manually re-throw as needed. */
+ if (gdbscm_is_exception (ann))
+ gdbscm_throw (ann);
+
+ gdbscm_print_frame (ann, flags, args_type, out, 0);
+ }
+}
+
+struct print_args {
+ SCM iter;
+ int flags;
+ enum ext_lang_frame_args args_type;
+ struct ui_out *out;
+};
+
+/* Returns normally if successful, or otherwise throws an exception. */
+static SCM
+do_print_annotated_frame_stream (void *data)
+{
+ struct print_args *args = data;
+
+ print_annotated_frame_stream (args->iter, args->flags, args->args_type,
+ args->out);
+
+ return SCM_BOOL_T;
+}
+
+/* This is the only publicly exported function in this file. FRAME is
+ the source frame to start frame-filter invocation. FLAGS is an
+ integer holding the flags for printing. The following elements of
+ the FRAME_FILTER_FLAGS enum denotes the make-up of FLAGS:
+ PRINT_LEVEL is a flag indicating whether to print the frame's
+ relative level in the output. PRINT_FRAME_INFO is a flag that
+ indicates whether this function should print the frame information,
+ PRINT_ARGS is a flag that indicates whether to print frame
+ arguments, and PRINT_LOCALS, likewise, with frame local variables.
+ ARGS_TYPE is an enumerator describing the argument format, OUT is
+ the output stream to print. FRAME_LOW is the beginning of the slice
+ of frames to print, and FRAME_HIGH is the upper limit of the frames
+ to count. Returns EXT_LANG_BT_ERROR on error, or
+ EXT_LANG_BT_COMPLETED on success. */
+
+enum ext_lang_bt_status
+gdbscm_apply_frame_filter (const struct extension_language_defn *extlang,
+ struct frame_info *frame, int flags,
+ enum ext_lang_frame_args args_type,
+ struct ui_out *out, int frame_low,
+ int frame_high)
+{
+ struct inferior *inferior;
+ SCM result;
+
+ /* Note that it's possible to have loaded the Guile interface, but not
+ yet loaded (gdb frames), so checking gdb_scheme_initialized is not
+ sufficient. */
+ if (!gdbscm_frame_filters_loaded)
+ return EXT_LANG_BT_NO_FILTERS;
+
+ inferior = current_inferior();
+ result = gdbscm_safe_call_3 (scm_variable_ref (apply_frame_filter),
+ frscm_scm_from_frame (frame, inferior),
+ scm_from_int (frame_low),
+ scm_from_int (frame_high),
+ gdbscm_memory_error_p);
+
+ if (gdbscm_is_false (result))
+ return EXT_LANG_BT_NO_FILTERS;
+
+ if (itscm_is_iterator (result))
+ {
+ struct print_args args = { result, flags, args_type, out };
+
+ /* Recurse through gdbscm_call_guile so that we can just throw
+ exceptions on error. */
+ result = gdbscm_call_guile (do_print_annotated_frame_stream, &args,
+ gdbscm_memory_error_p);
+ }
+
+ if (gdbscm_is_exception (result))
+ {
+ gdbscm_print_gdb_exception (SCM_BOOL_F, result);
+ return EXT_LANG_BT_ERROR;
+ }
+
+ return EXT_LANG_BT_COMPLETED;
+}
+
+/* Register gdbscm_load_frame_filters for calling by (gdb frames). */
+void
+gdbscm_initialize_frame_filters (void)
+{
+ scm_c_register_extension ("gdb", "gdbscm_load_frame_filters",
+ gdbscm_load_frame_filters, NULL);
+}
diff --git a/gdb/guile/scm-frame.c b/gdb/guile/scm-frame.c
index a30c093..3927714 100644
--- a/gdb/guile/scm-frame.c
+++ b/gdb/guile/scm-frame.c
@@ -213,7 +213,7 @@ gdbscm_frame_p (SCM scm)
/* Create a new <gdb:frame> object that encapsulates FRAME.
Returns a <gdb:exception> object if there is an error. */
-static SCM
+SCM
frscm_scm_from_frame (struct frame_info *frame, struct inferior *inferior)
{
frame_smob *f_smob, f_smob_for_lookup;
diff --git a/gdb/mi/mi-main.c b/gdb/mi/mi-main.c
index 7412f7d..540dcbb 100644
--- a/gdb/mi/mi-main.c
+++ b/gdb/mi/mi-main.c
@@ -1865,6 +1865,9 @@ mi_cmd_list_features (char *command, char **argv, int argc)
if (ext_lang_initialized_p (get_ext_lang_defn (EXT_LANG_PYTHON)))
ui_out_field_string (uiout, NULL, "python");
+ if (ext_lang_initialized_p (get_ext_lang_defn (EXT_LANG_GUILE)))
+ ui_out_field_string (uiout, NULL, "guile");
+
do_cleanups (cleanup);
return;
}
diff --git a/gdb/testsuite/gdb.guile/amd64-scm-frame-filter-invalidarg.S b/gdb/testsuite/gdb.guile/amd64-scm-frame-filter-invalidarg.S
new file mode 100644
index 0000000..0901714
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/amd64-scm-frame-filter-invalidarg.S
@@ -0,0 +1,261 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014-2015 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* This file is compiled from a single line
+ int main (int argc, char **argv) { return 0; }
+ using -g -dA -S -O2 and patched as #if-ed below. */
+
+ .file "scm-frame-filter-invalidarg.c"
+ .text
+.Ltext0:
+ .globl main
+ .type main, @function
+main:
+.LFB0:
+ .file 1 "scm-frame-filter-invalidarg.c"
+ # scm-frame-filter-invalidarg.c:1
+ .loc 1 1 0
+ .cfi_startproc
+# BLOCK 2 seq:0
+# PRED: ENTRY (FALLTHRU)
+ pushq %rbp
+ .cfi_def_cfa_offset 16
+ .cfi_offset 6, -16
+ movq %rsp, %rbp
+ .cfi_def_cfa_register 6
+ movl %edi, -4(%rbp)
+ movq %rsi, -16(%rbp)
+ # scm-frame-filter-invalidarg.c:2
+ .loc 1 2 0
+ movl $0, %eax
+ # scm-frame-filter-invalidarg.c:3
+ .loc 1 3 0
+ popq %rbp
+ .cfi_def_cfa 7, 8
+# SUCC: EXIT [100.0%]
+ ret
+ .cfi_endproc
+.LFE0:
+ .size main, .-main
+.Letext0:
+ .section .debug_info,"",@progbits
+.Ldebug_info0:
+ .long .Le - .Ls # Length of Compilation Unit Info
+.Ls:
+ .value 0x4 # DWARF version number
+ .long .Ldebug_abbrev0 # Offset Into Abbrev. Section
+ .byte 0x8 # Pointer Size (in bytes)
+ .uleb128 0x1 # (DIE (0xb) DW_TAG_compile_unit)
+ .long .LASF3 # DW_AT_producer: "GNU C 4.9.1 20140813 (Red Hat 4.9.1-7) -mtune=generic -march=x86-64 -g"
+ .byte 0x1 # DW_AT_language
+ .long .LASF4 # DW_AT_name: "scm-frame-filter-invalidarg.c"
+ .long .LASF5 # DW_AT_comp_dir: ""
+ .quad .Ltext0 # DW_AT_low_pc
+ .quad .Letext0-.Ltext0 # DW_AT_high_pc
+ .long .Ldebug_line0 # DW_AT_stmt_list
+die2d:
+ .uleb128 0x2 # (DIE (0x2d) DW_TAG_subprogram)
+ # DW_AT_external
+ .long .LASF6 # DW_AT_name: "main"
+ .byte 0x1 # DW_AT_decl_file (scm-frame-filter-invalidarg.c)
+ .byte 0x1 # DW_AT_decl_line
+ # DW_AT_prototyped
+ .long die6b-.Ldebug_info0 # DW_AT_type
+ .quad .LFB0 # DW_AT_low_pc
+ .quad .LFE0-.LFB0 # DW_AT_high_pc
+ .uleb128 0x1 # DW_AT_frame_base
+ .byte 0x9c # DW_OP_call_frame_cfa
+ # DW_AT_GNU_all_call_sites
+die4e:
+ .uleb128 0x3 # (DIE (0x4e) DW_TAG_formal_parameter)
+ .long .LASF0 # DW_AT_name: "argc"
+ .byte 0x1 # DW_AT_decl_file (scm-frame-filter-invalidarg.c)
+ .byte 0x1 # DW_AT_decl_line
+ .long die6b-.Ldebug_info0 # DW_AT_type
+#if 0
+ .uleb128 0x2 # DW_AT_location
+ .byte 0x91 # DW_OP_fbreg
+ .sleb128 -20
+#endif
+#if 0
+ .uleb128 1f - 2f # DW_AT_location
+2:
+ .byte 0x03 # DW_OP_addr
+ .quad 0
+1:
+#endif
+#if 1
+ .uleb128 1f - 2f # DW_AT_location
+2:
+ .byte 0x13 # DW_OP_drop
+ .quad 0
+1:
+#endif
+die5c:
+ .uleb128 0x3 # (DIE (0x5c) DW_TAG_formal_parameter)
+ .long .LASF1 # DW_AT_name: "argv"
+ .byte 0x1 # DW_AT_decl_file (scm-frame-filter-invalidarg.c)
+ .byte 0x1 # DW_AT_decl_line
+ .long die72-.Ldebug_info0 # DW_AT_type
+ .uleb128 0x2 # DW_AT_location
+ .byte 0x91 # DW_OP_fbreg
+ .sleb128 -32
+ .byte 0 # end of children of DIE 0x2d
+die6b:
+ .uleb128 0x4 # (DIE (0x6b) DW_TAG_base_type)
+ .byte 0x4 # DW_AT_byte_size
+ .byte 0x5 # DW_AT_encoding
+ .ascii "int\0" # DW_AT_name
+die72:
+ .uleb128 0x5 # (DIE (0x72) DW_TAG_pointer_type)
+ .byte 0x8 # DW_AT_byte_size
+ .long die78-.Ldebug_info0 # DW_AT_type
+die78:
+ .uleb128 0x5 # (DIE (0x78) DW_TAG_pointer_type)
+ .byte 0x8 # DW_AT_byte_size
+ .long die7e-.Ldebug_info0 # DW_AT_type
+die7e:
+ .uleb128 0x6 # (DIE (0x7e) DW_TAG_base_type)
+ .byte 0x1 # DW_AT_byte_size
+ .byte 0x6 # DW_AT_encoding
+ .long .LASF2 # DW_AT_name: "char"
+ .byte 0 # end of children of DIE 0xb
+.Le:
+ .section .debug_abbrev,"",@progbits
+.Ldebug_abbrev0:
+ .uleb128 0x1 # (abbrev code)
+ .uleb128 0x11 # (TAG: DW_TAG_compile_unit)
+ .byte 0x1 # DW_children_yes
+ .uleb128 0x25 # (DW_AT_producer)
+ .uleb128 0xe # (DW_FORM_strp)
+ .uleb128 0x13 # (DW_AT_language)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3 # (DW_AT_name)
+ .uleb128 0xe # (DW_FORM_strp)
+ .uleb128 0x1b # (DW_AT_comp_dir)
+ .uleb128 0xe # (DW_FORM_strp)
+ .uleb128 0x11 # (DW_AT_low_pc)
+ .uleb128 0x1 # (DW_FORM_addr)
+ .uleb128 0x12 # (DW_AT_high_pc)
+ .uleb128 0x7 # (DW_FORM_data8)
+ .uleb128 0x10 # (DW_AT_stmt_list)
+ .uleb128 0x17 # (DW_FORM_sec_offset)
+ .byte 0
+ .byte 0
+ .uleb128 0x2 # (abbrev code)
+ .uleb128 0x2e # (TAG: DW_TAG_subprogram)
+ .byte 0x1 # DW_children_yes
+ .uleb128 0x3f # (DW_AT_external)
+ .uleb128 0x19 # (DW_FORM_flag_present)
+ .uleb128 0x3 # (DW_AT_name)
+ .uleb128 0xe # (DW_FORM_strp)
+ .uleb128 0x3a # (DW_AT_decl_file)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3b # (DW_AT_decl_line)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x27 # (DW_AT_prototyped)
+ .uleb128 0x19 # (DW_FORM_flag_present)
+ .uleb128 0x49 # (DW_AT_type)
+ .uleb128 0x13 # (DW_FORM_ref4)
+ .uleb128 0x11 # (DW_AT_low_pc)
+ .uleb128 0x1 # (DW_FORM_addr)
+ .uleb128 0x12 # (DW_AT_high_pc)
+ .uleb128 0x7 # (DW_FORM_data8)
+ .uleb128 0x40 # (DW_AT_frame_base)
+ .uleb128 0x18 # (DW_FORM_exprloc)
+ .uleb128 0x2117 # (DW_AT_GNU_all_call_sites)
+ .uleb128 0x19 # (DW_FORM_flag_present)
+ .byte 0
+ .byte 0
+ .uleb128 0x3 # (abbrev code)
+ .uleb128 0x5 # (TAG: DW_TAG_formal_parameter)
+ .byte 0 # DW_children_no
+ .uleb128 0x3 # (DW_AT_name)
+ .uleb128 0xe # (DW_FORM_strp)
+ .uleb128 0x3a # (DW_AT_decl_file)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3b # (DW_AT_decl_line)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x49 # (DW_AT_type)
+ .uleb128 0x13 # (DW_FORM_ref4)
+ .uleb128 0x2 # (DW_AT_location)
+ .uleb128 0x18 # (DW_FORM_exprloc)
+ .byte 0
+ .byte 0
+ .uleb128 0x4 # (abbrev code)
+ .uleb128 0x24 # (TAG: DW_TAG_base_type)
+ .byte 0 # DW_children_no
+ .uleb128 0xb # (DW_AT_byte_size)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3e # (DW_AT_encoding)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3 # (DW_AT_name)
+ .uleb128 0x8 # (DW_FORM_string)
+ .byte 0
+ .byte 0
+ .uleb128 0x5 # (abbrev code)
+ .uleb128 0xf # (TAG: DW_TAG_pointer_type)
+ .byte 0 # DW_children_no
+ .uleb128 0xb # (DW_AT_byte_size)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x49 # (DW_AT_type)
+ .uleb128 0x13 # (DW_FORM_ref4)
+ .byte 0
+ .byte 0
+ .uleb128 0x6 # (abbrev code)
+ .uleb128 0x24 # (TAG: DW_TAG_base_type)
+ .byte 0 # DW_children_no
+ .uleb128 0xb # (DW_AT_byte_size)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3e # (DW_AT_encoding)
+ .uleb128 0xb # (DW_FORM_data1)
+ .uleb128 0x3 # (DW_AT_name)
+ .uleb128 0xe # (DW_FORM_strp)
+ .byte 0
+ .byte 0
+ .byte 0
+ .section .debug_aranges,"",@progbits
+ .long 0x2c # Length of Address Ranges Info
+ .value 0x2 # DWARF Version
+ .long .Ldebug_info0 # Offset of Compilation Unit Info
+ .byte 0x8 # Size of Address
+ .byte 0 # Size of Segment Descriptor
+ .value 0 # Pad to 16 byte boundary
+ .value 0
+ .quad .Ltext0 # Address
+ .quad .Letext0-.Ltext0 # Length
+ .quad 0
+ .quad 0
+ .section .debug_line,"",@progbits
+.Ldebug_line0:
+ .section .debug_str,"MS",@progbits,1
+.LASF1:
+ .string "argv"
+.LASF4:
+ .string "scm-frame-filter-invalidarg.c"
+.LASF5:
+ .string ""
+.LASF0:
+ .string "argc"
+.LASF3:
+ .string "GNU C 4.9.1 20140813 (Red Hat 4.9.1-7) -mtune=generic -march=x86-64 -g"
+.LASF6:
+ .string "main"
+.LASF2:
+ .string "char"
+ .ident "GCC: (GNU) 4.9.1 20140813 (Red Hat 4.9.1-7)"
+ .section .note.GNU-stack,"",@progbits
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter-gdb.scm.in b/gdb/testsuite/gdb.guile/scm-frame-filter-gdb.scm.in
new file mode 100644
index 0000000..91a5c4c
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter-gdb.scm.in
@@ -0,0 +1,35 @@
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is part of the GDB test-suite. It tests Guile-based frame
+;; filters.
+
+(use-modules (gdb) (gdb frames))
+
+(define (filter-one stream)
+ stream)
+
+(define (filter-two stream)
+ stream)
+
+(add-frame-filter! "filter-one-progspace" filter-one #:priority 1
+ #:progspace (current-progspace))
+(add-frame-filter! "filter-one-objfile" filter-one #:priority 1
+ #:objfile (current-objfile))
+
+(add-frame-filter! "filter-two-progspace" filter-two #:priority 100
+ #:progspace (current-progspace))
+(add-frame-filter! "filter-two-objfile" filter-two #:priority 100
+ #:objfile (current-objfile))
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg-gdb.scm.in b/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg-gdb.scm.in
new file mode 100644
index 0000000..91a5c4c
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg-gdb.scm.in
@@ -0,0 +1,35 @@
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is part of the GDB test-suite. It tests Guile-based frame
+;; filters.
+
+(use-modules (gdb) (gdb frames))
+
+(define (filter-one stream)
+ stream)
+
+(define (filter-two stream)
+ stream)
+
+(add-frame-filter! "filter-one-progspace" filter-one #:priority 1
+ #:progspace (current-progspace))
+(add-frame-filter! "filter-one-objfile" filter-one #:priority 1
+ #:objfile (current-objfile))
+
+(add-frame-filter! "filter-two-progspace" filter-two #:priority 100
+ #:progspace (current-progspace))
+(add-frame-filter! "filter-two-objfile" filter-two #:priority 100
+ #:objfile (current-objfile))
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.exp b/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.exp
new file mode 100644
index 0000000..6eaf2ae
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.exp
@@ -0,0 +1,66 @@
+# Copyright (C) 2014-2015 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+load_lib gdb-guile.exp
+
+standard_testfile amd64-scm-frame-filter-invalidarg.S
+
+if { ![istarget x86_64-*-* ] || ![is_lp64_target] } {
+ verbose "Skipping scm-frame-filter-invalidarg."
+ return
+}
+
+# We cannot use prepare_for_testing as we have to set the safe-patch
+# to check objfile and progspace printers.
+if {[build_executable $testfile.exp $testfile $srcfile {}] == -1} {
+ return -1
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# Make the -gdb.scm script available to gdb, it is automagically loaded
+# by gdb. Care is taken to put it in the same directory as the binary
+# so that gdb will find it.
+set remote_obj_guile_file \
+ [remote_download \
+ host ${srcdir}/${subdir}/${testfile}-gdb.scm.in \
+ [standard_output_file ${testfile}-gdb.scm]]
+
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_test_no_output "set auto-load safe-path ${remote_obj_guile_file}" \
+ "set auto-load safe-path"
+gdb_load ${binfile}
+# Verify gdb loaded the script.
+gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*" \
+ "Test auto-load had loaded guile scripts"
+
+if ![runto_main] then {
+ perror "couldn't run to breakpoint"
+ return
+}
+gdb_test_no_output "set guile print-stack full" \
+ "Set guile print-stack to full"
+
+# Load global frame-filters
+set remote_guile_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+gdb_scm_load_file ${remote_guile_file}
+
+gdb_test "bt" " in niam \\(argc=<error reading variable: dwarf expression stack underflow>, argv=0x\[0-9a-f\]+\\) at scm-frame-filter-invalidarg.c:\[0-9\]+" "bt full with filters"
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.scm b/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.scm
new file mode 100644
index 0000000..e809877
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter-invalidarg.scm
@@ -0,0 +1,35 @@
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is part of the GDB test-suite. It tests Guile-based frame
+;; filters.
+
+(use-modules (gdb) (gdb frames) (srfi srfi-41))
+
+(define (reverse-annotator ann)
+ (let ((name (annotated-frame-function-name ann)))
+ (reannotate-frame
+ ann
+ #:function-name
+ (cond
+ ((not name) #f)
+ ((equal? name "end_func")
+ (string-append (string-reverse name)
+ (let ((frame (annotated-frame-frame ann)))
+ (value->string (frame-read-var frame "str")))))
+ (else
+ (string-reverse name))))))
+
+(add-frame-annotator! "Reverse" reverse-annotator #:priority 100)
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter-mi.c b/gdb/testsuite/gdb.guile/scm-frame-filter-mi.c
new file mode 100644
index 0000000..308a56a
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter-mi.c
@@ -0,0 +1,140 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2013-2015 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <stdlib.h>
+
+void funca(void);
+int count = 0;
+
+typedef struct
+{
+ char *nothing;
+ int f;
+ short s;
+} foobar;
+
+void end_func (int foo, char *bar, foobar *fb, foobar bf)
+{
+ const char *str = "The End";
+ const char *st2 = "Is Near";
+ int b = 12;
+ short c = 5;
+ {
+ int d = 15;
+ int e = 14;
+ const char *foo = "Inside block";
+ {
+ int f = 42;
+ int g = 19;
+ const char *bar = "Inside block x2";
+ {
+ short h = 9;
+ h = h +1; /* Inner test breakpoint */
+ }
+ }
+ }
+
+ return; /* Backtrace end breakpoint */
+}
+
+void funcb(int j)
+{
+ struct foo
+ {
+ int a;
+ int b;
+ };
+
+ struct foo bar;
+
+ bar.a = 42;
+ bar.b = 84;
+
+ funca();
+ return;
+}
+
+void funca(void)
+{
+ foobar fb;
+ foobar *bf;
+
+ if (count < 10)
+ {
+ count++;
+ funcb(count);
+ }
+
+ fb.nothing = "Foo Bar";
+ fb.f = 42;
+ fb.s = 19;
+
+ bf = malloc (sizeof (foobar));
+ bf->nothing = malloc (128);
+ bf->nothing = "Bar Foo";
+ bf->f = 24;
+ bf->s = 91;
+
+ end_func(21, "Param", bf, fb);
+ free (bf->nothing);
+ free (bf);
+ return;
+}
+
+
+void func1(void)
+{
+ funca();
+ return;
+}
+
+int func2(void)
+{
+ func1();
+ return 1;
+}
+
+void func3(int i)
+{
+ func2();
+
+ return;
+}
+
+int func4(int j)
+{
+ func3(j);
+
+ return 2;
+}
+
+int func5(int f, int d)
+{
+ int i = 0;
+ char *random = "random";
+ i=i+f;
+
+ func4(i);
+ return i;
+}
+
+int
+main()
+{
+ func5(3,5);
+ return 0;
+}
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp b/gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp
new file mode 100644
index 0000000..3310944
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter-mi.exp
@@ -0,0 +1,179 @@
+# Copyright (C) 2013-2015 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# This file is part of the GDB testsuite. It tests Guile-based
+# frame-filters.
+load_lib mi-support.exp
+load_lib gdb-guile.exp
+
+set MIFLAGS "-i=mi2"
+
+gdb_exit
+if [mi_gdb_start] {
+ continue
+}
+
+standard_testfile scm-frame-filter-mi.c
+set scmfile scm-frame-filter.scm
+
+if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable {debug additional_flags=-DMI}] != "" } {
+ untested ${testfile}.exp
+ return -1
+}
+
+mi_delete_breakpoints
+mi_gdb_reinitialize_dir $srcdir/$subdir
+mi_gdb_load ${binfile}
+
+if {[lsearch -exact [mi_get_features] guile] < 0} {
+ unsupported "guile support is disabled"
+ return -1
+}
+
+mi_runto main
+
+set remote_guile_file [gdb_remote_download host ${srcdir}/${subdir}/${scmfile}]
+
+mi_gdb_test "guile (load \"${remote_guile_file}\")" ".*\\^done." \
+ "Load guile file"
+
+# Multiple blocks test
+mi_continue_to_line [gdb_get_line_number {Inner test breakpoint} ${srcfile}] \
+ "step to breakpoint"
+
+mi_gdb_test "-stack-list-locals --all-values" \
+ "\\^done,locals=\\\[{name=\"h\",value=\"9\"},{name=\"f\",value=\"42\"},{name=\"g\",value=\"19\"},{name=\"bar\",value=\"$hex \\\\\"Inside block x2\\\\\"\"},{name=\"d\",value=\"15\"},{name=\"e\",value=\"14\"},{name=\"foo\",value=\"$hex \\\\\"Inside block\\\\\"\"},{name=\"str\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",value=\"12\"},{name=\"c\",value=\"5\"}\\\]" \
+ "stack-list-locals --all-values"
+
+mi_gdb_test "-enable-frame-filters" ".*\\^done." "enable frame filters"
+mi_gdb_test "-stack-list-locals --all-values" \
+ "\\^done,locals=\\\[{name=\"h\",value=\"9\"},{name=\"f\",value=\"42\"},{name=\"g\",value=\"19\"},{name=\"bar\",value=\"$hex \\\\\"Inside block x2\\\\\"\"},{name=\"d\",value=\"15\"},{name=\"e\",value=\"14\"},{name=\"foo\",value=\"$hex \\\\\"Inside block\\\\\"\"},{name=\"str\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",value=\"12\"},{name=\"c\",value=\"5\"}\\\]" \
+ "stack-list-locals --all-values frame filters enabled"
+
+mi_continue_to_line [gdb_get_line_number {Backtrace end breakpoint} ${srcfile}] \
+ "step to breakpoint"
+
+mi_gdb_test "-stack-list-frames" \
+ "\\^done,stack=\\\[frame={level=\"0\",addr=\"$hex\",func=\"cnuf_dne.*\".*},frame={level=\"1\",addr=\"$hex\",func=\"acnuf\".*},frame={level=\"2\",addr=\"$hex\",func=\"bcnuf\".*},frame={level=\"3\",addr=\"$hex\",func=\"acnuf\".*},frame={level=\"22\",addr=\"$hex\",func=\"1cnuf\".*,children=\\\[frame={level=\"23\",addr=\"$hex\",func=\"2cnuf\".*}\\\]},frame={level=\"24\",addr=\"$hex\",func=\"3cnuf\".*},frame={level=\"27\",addr=\"$hex\",func=\"niam\".*}\\\].*" \
+ "filtered stack listing"
+mi_gdb_test "-stack-list-frames 0 3" \
+ "\\^done,stack=\\\[frame={level=\"0\",addr=\"$hex\",func=\"cnuf_dne.*\".*},frame={level=\"1\",addr=\"$hex\",func=\"acnuf\".*},frame={level=\"2\",addr=\"$hex\",func=\"bcnuf\".*},frame={level=\"3\",addr=\"$hex\",func=\"acnuf\".*}\\\]" \
+ "filtered stack list 0 3"
+mi_gdb_test "-stack-list-frames 22 24" \
+ "\\^done,stack=\\\[frame={level=\"22\",addr=\"$hex\",func=\"1cnuf\".*,children=\\\[frame={level=\"23\",addr=\"$hex\",func=\"2cnuf\".*}\\\]},frame={level=\"24\",addr=\"$hex\",func=\"3cnuf\".*}\\\]" \
+ "filtered stack list 22 24"
+
+#stack list arguments
+
+
+mi_gdb_test "-stack-list-arguments 0" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[name=\"foo\",name=\"bar\",name=\"fb\",name=\"bf\"\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[name=\"j\"\\\]},.*frame={level=\"22\",args=\\\[\\\],children=\\\[frame={level=\"23\",args=\\\[\\\]}\\\]},.*frame={level=\"26\",args=\\\[name=\"f\",name=\"d\"\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 0"
+
+mi_gdb_test "-stack-list-arguments --no-frame-filters 0" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[name=\"foo\",name=\"bar\",name=\"fb\",name=\"bf\"\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[name=\"j\"\\\]},.*frame={level=\"22\",args=\\\[\\\]},frame={level=\"23\",args=\\\[\\\]},.*frame={level=\"26\",args=\\\[name=\"f\",name=\"d\"\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments --no-frame-filters 0"
+
+mi_gdb_test "-stack-list-arguments 0 0 3" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[name=\"foo\",name=\"bar\",name=\"fb\",name=\"bf\"\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[name=\"j\"\\\]},frame={level=\"3\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 0 0 3"
+
+mi_gdb_test "-stack-list-arguments 0 22 27" \
+ "\\^done,stack-args=\\\[frame={level=\"22\",args=\\\[\\\],children=\\\[frame={level=\"23\",args=\\\[\\\]}\\\]},.*frame={level=\"26\",args=\\\[name=\"f\",name=\"d\"\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 0 22 27"
+
+mi_gdb_test "-stack-list-arguments 1" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[{name=\"foo\",value=\"21\"},{name=\"bar\",value=\"$hex \\\\\"Param\\\\\"\"},{name=\"fb\",value=\"$hex\"},{name=\"bf\",value=\"{nothing = $hex \\\\\"Foo Bar\\\\\", f = 42, s = 19}\"}\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[{name=\"j\",value=\"10\"}\\\]},.*frame={level=\"22\",args=\\\[\\\],children=\\\[frame={level=\"23\",args=\\\[\\\]}\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",value=\"3\"},{name=\"d\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 1"
+
+mi_gdb_test "-stack-list-arguments --no-frame-filters 1" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[{name=\"foo\",value=\"21\"},{name=\"bar\",value=\"$hex \\\\\"Param\\\\\"\"},{name=\"fb\",value=\"$hex\"},{name=\"bf\",value=\"{nothing = $hex \\\\\"Foo Bar\\\\\", f = 42, s = 19}\"}\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[{name=\"j\",value=\"10\"}\\\]},.*frame={level=\"22\",args=\\\[\\\]},frame={level=\"23\",args=\\\[\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",value=\"3\"},{name=\"d\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments --no-frame-filters 1"
+
+
+mi_gdb_test "-stack-list-arguments 1 0 3" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[{name=\"foo\",value=\"21\"},{name=\"bar\",value=\"$hex \\\\\"Param\\\\\"\"},{name=\"fb\",value=\"$hex\"},{name=\"bf\",value=\"{nothing = $hex \\\\\"Foo Bar\\\\\", f = 42, s = 19}\"}\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[{name=\"j\",value=\"10\"}\\\]},frame={level=\"3\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 1 0 3"
+
+mi_gdb_test "-stack-list-arguments 1 22 27" \
+ "\\^done,stack-args=\\\[frame={level=\"22\",args=\\\[\\\],children=\\\[frame={level=\"23\",args=\\\[\\\]}\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",value=\"3\"},{name=\"d\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 1 22 27"
+
+mi_gdb_test "-stack-list-arguments 2" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[{name=\"foo\",type=\"int\",value=\"21\"},{name=\"bar\",type=\"char \\\*\",value=\"$hex \\\\\"Param\\\\\"\"},{name=\"fb\",type=\"foobar \\\*\",value=\"$hex\"},{name=\"bf\",type=\"foobar\"\}\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[{name=\"j\",type=\"int\",value=\"10\"}\\\]},.*frame={level=\"22\",args=\\\[\\\],children=\\\[frame={level=\"23\",args=\\\[\\\]}\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",type=\"int\",value=\"3\"},{name=\"d\",type=\"int\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 2"
+
+mi_gdb_test "-stack-list-arguments --no-frame-filters 2" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[{name=\"foo\",type=\"int\",value=\"21\"},{name=\"bar\",type=\"char \\\*\",value=\"$hex \\\\\"Param\\\\\"\"},{name=\"fb\",type=\"foobar \\\*\",value=\"$hex\"},{name=\"bf\",type=\"foobar\"}\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[{name=\"j\",type=\"int\",value=\"10\"}\\\]},.*frame={level=\"22\",args=\\\[\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",type=\"int\",value=\"3\"},{name=\"d\",type=\"int\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments --no-frame-filters 2"
+
+
+mi_gdb_test "-stack-list-arguments 2 0 3" \
+ "\\^done,stack-args=\\\[frame={level=\"0\",args=\\\[{name=\"foo\",type=\"int\",value=\"21\"},{name=\"bar\",type=\"char \\\*\",value=\"$hex \\\\\"Param\\\\\"\"},{name=\"fb\",type=\"foobar \\\*\",value=\"$hex\"},{name=\"bf\",type=\"foobar\"}\\\]},frame={level=\"1\",args=\\\[\\\]},frame={level=\"2\",args=\\\[{name=\"j\",type=\"int\",value=\"10\"}\\\]},frame={level=\"3\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 2 0 3"
+
+mi_gdb_test "-stack-list-arguments 2 22 27" \
+ "\\^done,stack-args=\\\[frame={level=\"22\",args=\\\[\\\],children=\\\[frame={level=\"23\",args=\\\[\\\]}\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",type=\"int\",value=\"3\"},{name=\"d\",type=\"int\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments 2 22 27"
+
+mi_gdb_test "-stack-list-arguments --no-frame-filters 2 22 27" \
+ "\\^done,stack-args=\\\[frame={level=\"22\",args=\\\[\\\]},frame={level=\"23\",args=\\\[\\\]},.*frame={level=\"26\",args=\\\[{name=\"f\",type=\"int\",value=\"3\"},{name=\"d\",type=\"int\",value=\"5\"}\\\]},frame={level=\"27\",args=\\\[\\\]}\\\]" \
+ "stack-list-arguments --no-frame-filters 2 22 27"
+
+#stack-list-locals
+mi_gdb_test "-stack-list-locals --no-frame-filters 0" \
+ "\\^done,locals=\\\[name=\"str\",name=\"st2\",name=\"b\",name=\"c\"\\\]" \
+ "stack-list-locals --no-frame-filters 0"
+
+mi_gdb_test "-stack-list-locals --no-frame-filters 1" \
+ "\\^done,locals=\\\[{name=\"str\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",value=\"12\"},{name=\"c\",value=\"5\"}\\\]" \
+ "stack-list-locals --no-frame-filters 1"
+
+mi_gdb_test "-stack-list-locals --no-frame-filters 2" \
+ "\\^done,locals=\\\[{name=\"str\",type=\"const char \\\*\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",type=\"const char \\\*\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",type=\"int\",value=\"12\"},{name=\"c\",type=\"short\",value=\"5\"}\\\]" \
+ "stack-list-locals --no-frame-filters 2"
+
+mi_gdb_test "-stack-list-locals --no-frame-filters --no-values" \
+ "\\^done,locals=\\\[name=\"str\",name=\"st2\",name=\"b\",name=\"c\"\\\]" \
+ "stack-list-locals --no-frame-filters --no-values"
+
+mi_gdb_test "-stack-list-locals --no-frame-filters --all-values" \
+ "\\^done,locals=\\\[{name=\"str\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",value=\"12\"},{name=\"c\",value=\"5\"}\\\]" \
+ "stack-list-locals --no-frame-filters --all-values"
+
+mi_gdb_test "-stack-list-locals --no-frame-filters --simple-values" \
+ "\\^done,locals=\\\[{name=\"str\",type=\"const char \\\*\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",type=\"const char \\\*\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",type=\"int\",value=\"12\"},{name=\"c\",type=\"short\",value=\"5\"}\\\]" \
+ "stack-list-locals --no-frame-filters --simple-values"
+
+mi_gdb_test "-stack-list-locals 0" \
+ "\\^done,locals=\\\[name=\"str\",name=\"st2\",name=\"b\",name=\"c\"\\\]" \
+ "stack-list-locals 0"
+
+mi_gdb_test "-stack-list-locals 1" \
+ "\\^done,locals=\\\[{name=\"str\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",value=\"12\"},{name=\"c\",value=\"5\"}\\\]" \
+ "stack-list-locals 1"
+
+mi_gdb_test "-stack-list-locals 2" \
+ "\\^done,locals=\\\[{name=\"str\",type=\"const char \\\*\",value=\"$hex \\\\\"The End\\\\\"\"},{name=\"st2\",type=\"const char \\\*\",value=\"$hex \\\\\"Is Near\\\\\"\"},{name=\"b\",type=\"int\",value=\"12\"},{name=\"c\",type=\"short\",value=\"5\"}\\\]" \
+ "stack-list-locals 2"
+
+# stack-list-variables
+mi_gdb_test "-stack-list-variables --no-frame-filters 0" \
+ "\\^done,variables=\\\[{name=\"foo\",arg=\"1\"},{name=\"bar\",arg=\"1\"},{name=\"fb\",arg=\"1\"},{name=\"bf\",arg=\"1\"},{name=\"str\"},{name=\"st2\"},{name=\"b\"},{name=\"c\"}\\\]" \
+ "stack-list-variables --no-frame-filters 0"
+
+mi_gdb_test "-stack-list-variables 0" \
+ "\\^done,variables=\\\[{name=\"foo\",arg=\"1\"},{name=\"bar\",arg=\"1\"},{name=\"fb\",arg=\"1\"},{name=\"bf\",arg=\"1\"},{name=\"str\"},{name=\"st2\"},{name=\"b\"},{name=\"c\"}\\\]" \
+ "stack-list-variables 0"
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter.c b/gdb/testsuite/gdb.guile/scm-frame-filter.c
new file mode 100644
index 0000000..db3b360
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter.c
@@ -0,0 +1,157 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2013-2015 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <stdlib.h>
+
+void funca(void);
+int count = 0;
+
+typedef struct
+{
+ char *nothing;
+ int f;
+ short s;
+} foobar;
+
+void end_func (int foo, char *bar, foobar *fb, foobar bf)
+{
+ const char *str = "The End";
+ const char *st2 = "Is Near";
+ int b = 12;
+ short c = 5;
+
+ {
+ int d = 15;
+ int e = 14;
+ const char *foo = "Inside block";
+ {
+ int f = 42;
+ int g = 19;
+ const char *bar = "Inside block x2";
+ {
+ short h = 9;
+ h = h +1; /* Inner test breakpoint */
+ }
+ }
+ }
+
+ return; /* Backtrace end breakpoint */
+}
+
+void funcb(int j)
+{
+ struct foo
+ {
+ int a;
+ int b;
+ };
+
+ struct foo bar;
+
+ bar.a = 42;
+ bar.b = 84;
+
+ funca();
+ return;
+}
+
+void funca(void)
+{
+ foobar fb;
+ foobar *bf = NULL;
+
+ if (count < 10)
+ {
+ count++;
+ funcb(count);
+ }
+
+ fb.nothing = "Foo Bar";
+ fb.f = 42;
+ fb.s = 19;
+
+ bf = alloca (sizeof (foobar));
+ bf->nothing = alloca (128);
+ bf->nothing = "Bar Foo";
+ bf->f = 24;
+ bf->s = 91;
+
+ end_func(21, "Param", bf, fb);
+ return;
+}
+
+
+void func1(void)
+{
+ funca();
+ return;
+}
+
+int func2(int f)
+{
+ int c;
+ const char *elided = "Elided frame";
+ foobar fb;
+ foobar *bf = NULL;
+
+ fb.nothing = "Elided Foo Bar";
+ fb.f = 84;
+ fb.s = 38;
+
+ bf = alloca (sizeof (foobar));
+ bf->nothing = alloca (128);
+ bf->nothing = "Elided Bar Foo";
+ bf->f = 48;
+ bf->s = 182;
+
+ func1();
+ return 1;
+}
+
+void func3(int i)
+{
+ func2(i);
+
+ return;
+}
+
+int func4(int j)
+{
+ func3(j);
+
+ return 2;
+}
+
+int func5(int f, int d)
+{
+ int i = 0;
+ char *random = "random";
+ i=i+f;
+
+ func4(i);
+ return i;
+}
+
+int
+main()
+{
+ int z = 32;
+ int y = 44;
+ const char *foo1 = "Test";
+ func5(3,5);
+ return 0;
+}
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter.exp b/gdb/testsuite/gdb.guile/scm-frame-filter.exp
new file mode 100644
index 0000000..8c8093d
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter.exp
@@ -0,0 +1,248 @@
+# Copyright (C) 2013-2015 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# This file is part of the GDB testsuite. It tests Guile-based
+# frame-filters.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+# We cannot use prepare_for_testing as we have to set the safe-patch
+# to check objfile and progspace printers.
+if {[build_executable $testfile.exp $testfile $srcfile debug] == -1} {
+ return -1
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# Make the -gdb.scm script available to gdb, it is automagically loaded by gdb.
+# Care is taken to put it in the same directory as the binary so that
+# gdb will find it.
+set remote_obj_guile_file \
+ [remote_download \
+ host ${srcdir}/${subdir}/${testfile}-gdb.scm.in \
+ [standard_output_file ${testfile}-gdb.scm]]
+
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_test_no_output "set auto-load safe-path ${remote_obj_guile_file}" \
+ "set auto-load safe-path"
+gdb_load ${binfile}
+# Verify gdb loaded the script.
+gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*" \
+ "Test auto-load had loaded guile scripts"
+
+if ![runto_main] then {
+ perror "couldn't run to breakpoint"
+ return
+}
+gdb_test_no_output "set guile print-stack full" \
+ "Set guile print-stack to full"
+
+# Load global frame-filters
+set remote_guile_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+gdb_scm_load_file ${remote_guile_file}
+
+gdb_breakpoint [gdb_get_line_number "Backtrace end breakpoint"]
+gdb_breakpoint [gdb_get_line_number "Inner test breakpoint"]
+gdb_continue_to_breakpoint "Inner test breakpoint"
+
+# Test multiple local blocks.
+gdb_test "bt full no-filters" \
+ ".*#0.*end_func.*h = 9.*f = 42.*g = 19.*bar = $hex \"Inside block x2\".*d = 15.*e = 14.*foo = $hex \"Inside block\".*str = $hex \"The End\".*st2 = $hex \"Is Near\".*b = 12.*c = 5.*" \
+ "bt full no-filters"
+gdb_test "bt full" \
+ ".*#0.*cnuf_dne.*h = 9.*f = 42.*g = 19.*bar = $hex \"Inside block x2\".*d = 15.*e = 14.*foo = $hex \"Inside block\".*str = $hex \"The End\".*st2 = $hex \"Is Near\".*b = 12.*c = 5.*" \
+ "bt full with filters"
+
+gdb_continue_to_breakpoint "Backtrace end breakpoint"
+
+# Test query
+gdb_test "guile (all-frame-filters)" \
+ ".*Elider.*" \
+ "all frame filters"
+gdb_test "guile (map frame-filter-priority (all-frame-filters))" \
+ ".*900.*" \
+ "all frame filter priorities"
+gdb_test "guile (map frame-filter-enabled? (all-frame-filters))" \
+ ".*#t.*" \
+ "all frame filter enabled?"
+gdb_test "guile (all-frame-annotators)" \
+ ".*Error.*Dummy.*Reverse.*" \
+ "all frame annotators"
+gdb_test "guile (map frame-annotator-priority (all-frame-annotators))" \
+ ".*20 30 100.*" \
+ "all frame annotator priorities"
+gdb_test "guile (map frame-annotator-enabled? (all-frame-annotators))" \
+ ".*#f #f #t.*" \
+ "all frame annotator enabled?"
+
+gdb_test_no_output "guile (disable-frame-filter! \"Elider\")" \
+ "disable elider"
+gdb_test "guile (frame-filter-enabled? \"Elider\")" \
+ ".*#f.*" \
+ "elider not enabled"
+gdb_test_no_output "guile (enable-frame-filter! \"Elider\")" \
+ "re-enable elider"
+gdb_test "guile (frame-filter-enabled? \"Elider\")" \
+ ".*#t.*" \
+ "elider re-enabled"
+
+# Test no-filters
+gdb_test "bt no-filters" \
+ ".*#0.*end_func.*#22.*in func1.*#27.*in main \\(\\).*" \
+ "bt no-filters"
+
+# Test reverse
+gdb_test "bt" \
+ ".*#0.*cnuf_dne.*#22.*in 1cnuf.*#27.*in niam \\(\\).*" \
+ "bt with frame filters"
+
+# Disable Reverse
+gdb_test_no_output "guile (disable-frame-annotator! \"Reverse\")" \
+ "disable frame-filter global Reverse"
+gdb_test "bt" \
+ ".*#0.*end_func.*#22.*in func1.*#27.*in main \\(\\).*" \
+ "bt with frame-filter Reverse disabled"
+gdb_test "bt -2" \
+ ".*#26.*func5.*#27.*in main \\(\\).*" \
+ "bt -2 with frame-filter Reverse disabled"
+gdb_test "bt 3" \
+ ".*#0.*end_func.*#1.*in funca \\(\\).*#2.*in funcb \\(j=10\\).*" \
+ "bt 3 with frame-filter Reverse disabled"
+gdb_test "bt no-filter full" \
+ ".*#0.*end_func.*str = $hex \"The End\".*st2 = $hex \"Is Near\".*b = 12.*c = 5.*#1.*in funca \\(\\).*#2.*in funcb \\(j=10\\).*bar = \{a = 42, b = 84\}.*" \
+ "bt no-filters full with Reverse disabled"
+gdb_test "bt full" \
+ ".*#0.*end_func.*str = $hex \"The End\".*st2 = $hex \"Is Near\".*b = 12.*c = 5.*#1.*in funca \\(\\).*#2.*in funcb \\(j=10\\).*bar = \{a = 42, b = 84\}.*#22.*in func1 \\(\\).*#23.*in func2 \\(f=3\\).*elided = $hex \"Elided frame\".*fb = \{nothing = $hex \"Elided Foo Bar\", f = 84, s = 38\}.*bf = $hex.*" \
+ "bt full with Reverse disabled"
+
+# Test set print frame-arguments
+# none
+gdb_test_no_output "set print frame-arguments none" \
+ "turn off frame arguments"
+gdb_test "bt no-filter 1" \
+ "#0.*end_func \\(foo=\.\.\., bar=\.\.\., fb=\.\.\., bf=\.\.\.\\) at .*scm-frame-filter.c.*" \
+ "bt no-filter 1 no args"
+gdb_test "bt 1" \
+ "#0.*end_func \\(foo=\.\.\., bar=\.\.\., fb=\.\.\., bf=\.\.\.\\) at .*scm-frame-filter.c.*" \
+ "bt 1 no args"
+
+# scalars
+gdb_test_no_output "set print frame-arguments scalars" \
+ "turn frame arguments to scalars only"
+gdb_test "bt no-filter 1" \
+ "#0.*end_func \\(foo=21, bar=$hex \"Param\", fb=$hex, bf=\.\.\.\\) at .*scm-frame-filter.c.*" \
+ "bt no-filter 1 scalars"
+gdb_test "bt 1" \
+ "#0.*end_func \\(foo=21, bar=$hex \"Param\", fb=$hex, bf=\.\.\.\\) at .*scm-frame-filter.c.*" \
+ "bt 1 scalars"
+
+# all
+gdb_test_no_output "set print frame-arguments all" \
+ "turn on frame arguments"
+gdb_test "bt no-filter 1" \
+ "#0.*end_func \\(foo=21, bar=$hex \"Param\", fb=$hex, bf=\{nothing = $hex \"Foo Bar\", f = 42, s = 19\}\\) at .*scm-frame-filter.c.*" \
+ "bt no-filter 1 all args"
+gdb_test "bt 1" \
+ "#0.*end_func \\(foo=21, bar=$hex \"Param\", fb=$hex, bf=\{nothing = $hex \"Foo Bar\", f = 42, s = 19\}\\) at .*scm-frame-filter.c.*" \
+ "bt 1 all args"
+
+# set print address off
+gdb_test_no_output "set print address off" \
+ "Turn off address printing"
+gdb_test "bt no-filter 1" \
+ "#0 end_func \\(foo=21, bar=\"Param\", fb=, bf=\{nothing = \"Foo Bar\", f = 42, s = 19\}\\) at .*scm-frame-filter.c.*" \
+ "bt no-filter 1 no address"
+gdb_test "bt 1" \
+ "#0 end_func \\(foo=21, bar=\"Param\", fb=, bf=\{nothing = \"Foo Bar\", f = 42, s = 19\}\\) at .*scm-frame-filter.c.*" \
+ "bt 1 no addresss"
+
+gdb_test_no_output "set guile print-stack message" \
+ "Set guile print-stack to message for Error annotator"
+gdb_test_no_output "guile (enable-frame-annotator! \"Error\")" \
+ "enable Error annotator"
+set test "bt 1 with Error filter"
+gdb_test_multiple "bt 1" $test {
+ -re "ERROR: whoops.*$gdb_prompt $" {
+ pass $test
+ }
+}
+
+# # Test with no debuginfo
+
+# We cannot use prepare_for_testing as we have to set the safe-patch
+# to check objfile and progspace printers.
+if {[build_executable $testfile.exp $testfile $srcfile {nodebug}] == -1} {
+ return -1
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# Make the -gdb.scm script available to gdb, it is automagically loaded by gdb.
+# Care is taken to put it in the same directory as the binary so that
+# gdb will find it.
+set remote_obj_guile_file \
+ [remote_download \
+ host ${srcdir}/${subdir}/${testfile}-gdb.scm.in \
+ [standard_output_file ${testfile}-gdb.scm]]
+
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_test_no_output "set auto-load safe-path ${remote_obj_guile_file}" \
+ "set auto-load safe-path for no debug info"
+gdb_load ${binfile}
+
+# Verify gdb loaded the script.
+gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*" \
+ "Set autoload path for no debug info tests"
+if ![runto_main] then {
+ perror "couldn't run to breakpoint"
+ return
+}
+
+gdb_test_no_output "set guile print-stack full" \
+ "set guile print-stack full for no debuginfo tests"
+
+# Load global frame-filters
+set remote_guile_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+gdb_scm_load_file ${remote_guile_file}
+
+# Disable Reverse
+gdb_test_no_output "guile (disable-frame-annotator! \"Reverse\")" \
+ "disable frame-filter global Reverse for no debuginfo"
+gdb_test "bt" \
+ ".*#0..*in main \\(\\).*" \
+ "bt for no debuginfo"
+gdb_test "bt full" \
+ ".*#0..*in main \\(\\).*" \
+ "bt full for no debuginfo"
+gdb_test "bt no-filters" \
+ ".*#0..*in main \\(\\).*" \
+ "bt no filters for no debuginfo"
+gdb_test "bt no-filters full" \
+ ".*#0..*in main \\(\\).*" \
+ "bt no-filters full no debuginfo"
diff --git a/gdb/testsuite/gdb.guile/scm-frame-filter.scm b/gdb/testsuite/gdb.guile/scm-frame-filter.scm
new file mode 100644
index 0000000..39f6fba
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-frame-filter.scm
@@ -0,0 +1,89 @@
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is part of the GDB test-suite. It tests Guile-based frame
+;; filters.
+
+(use-modules (gdb)
+ ((gdb) #:select ((symbol? . gdb:symbol?)))
+ (gdb frames)
+ (srfi srfi-41))
+
+(define (reverse-annotator ann)
+ (let ((name (annotated-frame-function-name ann)))
+ (reannotate-frame
+ ann
+ #:function-name
+ (cond
+ ((not name) #f)
+ ((equal? name "end_func")
+ (string-append (string-reverse name)
+ (let ((frame (annotated-frame-frame ann)))
+ (value->string (frame-read-var frame "str")))))
+ (else
+ (string-reverse name))))))
+
+(define (dummy-annotator ann)
+ (reannotate-frame ann
+ #:function-name "Dummy function"
+ #:address #x123
+ #:filename "Dummy filename"
+ #:line 1
+ #:arguments (list (cons "Foo" (make-value 12))
+ (cons "Bar" (make-value "Stuff"))
+ (cons "FooBar" (make-value 42)))
+ #:locals '()
+ #:children '()))
+
+(define (frame-function-name frame)
+ (let ((f (frame-function frame)))
+ (cond
+ ((not f) f)
+ ((gdb:symbol? f) (symbol-print-name f))
+ (else (object->string f)))))
+
+(define (eliding-filter stream)
+ (define (recur head tail)
+ (stream-cons head (eliding-filter tail)))
+ (cond
+ ((stream-null? stream) stream)
+ (else
+ (let ((head (stream-car stream))
+ (tail (stream-cdr stream)))
+ ;; Unlike Python, which has a unified "filter" interface that
+ ;; exposes the complexity of filters even to simple annotators, in
+ ;; Guile we have filters and annotators. In Guile, annotators run
+ ;; first. Therefore for this filter to do the same thing the
+ ;; corresponding test Python filter does, we match the function
+ ;; based on its original name.
+ (if (and (equal? (frame-function-name (annotated-frame-frame head))
+ "func1")
+ (not (stream-null? tail)))
+ ;; Suppose we want to return the 'func1' frame but elide the
+ ;; next frame. E.g., if call in our interpreter language
+ ;; takes two C frames to implement, and the first one we see
+ ;; is the "sentinel".
+ (recur (reannotate-frame head #:children (list (stream-car tail)))
+ (stream-cdr tail))
+ (recur head tail))))))
+
+;; A simple annotator that gives an error when computing the function.
+(define (error-annotator frame)
+ (reannotate-frame frame #:function-name (error "whoops")))
+
+(add-frame-annotator! "Reverse" reverse-annotator #:priority 100)
+(add-frame-annotator! "Dummy" dummy-annotator #:enabled? #f #:priority 30)
+(add-frame-filter! "Elider" eliding-filter #:priority 900)
+(add-frame-annotator! "Error" error-annotator #:enabled? #f)
--
2.1.4
next prev parent reply other threads:[~2015-02-16 13:48 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2015-02-15 11:28 Andy Wingo
2015-02-15 16:50 ` Eli Zaretskii
2015-02-16 13:48 ` Andy Wingo [this message]
2015-02-22 21:54 ` Doug Evans
2015-03-04 13:07 ` Andy Wingo
2015-03-17 16:29 ` Doug Evans
2015-02-27 15:40 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=871tlq55oj.fsf@igalia.com \
--to=wingo@igalia.com \
--cc=eliz@gnu.org \
--cc=gdb-patches@sourceware.org \
--cc=xdje42@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).