@@ -298,6 +298,7 @@ SUBDIR_GUILE_OBS = \
scm-math.o \
scm-ports.o \
scm-pretty-print.o \
+ scm-progspace.o \
scm-safe-call.o \
scm-string.o \
scm-symbol.o \
@@ -321,6 +322,7 @@ SUBDIR_GUILE_SRCS = \
guile/scm-math.c \
guile/scm-ports.c \
guile/scm-pretty-print.c \
+ guile/scm-progspace.c \
guile/scm-safe-call.c \
guile/scm-string.c \
guile/scm-symbol.c \
@@ -2310,6 +2312,10 @@ scm-pretty-print.o: $(srcdir)/guile/scm-pretty-print.c
$(COMPILE) $(srcdir)/guile/scm-pretty-print.c
$(POSTCOMPILE)
+scm-progspace.o: $(srcdir)/guile/scm-progspace.c
+ $(COMPILE) $(srcdir)/guile/scm-progspace.c
+ $(POSTCOMPILE)
+
scm-safe-call.o: $(srcdir)/guile/scm-safe-call.c
$(COMPILE) $(srcdir)/guile/scm-safe-call.c
$(POSTCOMPILE)
@@ -141,6 +141,7 @@ 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
+* Progspaces In Guile:: Program spaces
* Objfiles In Guile:: Object files in Guile
* Frames In Guile:: Accessing inferior stack frames from Guile
* Blocks In Guile:: Accessing blocks from Guile
@@ -406,6 +407,9 @@ Return an unsorted list of names of properties.
@item <gdb:pretty-printer-worker>
@xref{Guile Pretty Printing API}.
+@item <gdb:progspace>
+@xref{Progspaces In Guile}.
+
@item <gdb:symbol>
@xref{Symbols In Guile}.
@@ -434,6 +438,7 @@ The following gsmobs are managed internally so that the Scheme function
@item <gdb:breakpoint>
@item <gdb:frame>
@item <gdb:objfile>
+@item <gdb:progspace>
@item <gdb:symbol>
@item <gdb:symtab>
@item <gdb:type>
@@ -1688,6 +1693,78 @@ my_library.so:
bar
@end smallexample
+@node Progspaces In Guile
+@subsubsection Program Spaces In Guile
+
+@cindex progspaces in guile
+@tindex <gdb:progspace>
+A program space, or @dfn{progspace}, represents a symbolic view
+of an address space.
+It consists of all of the objfiles of the program.
+@xref{Objfiles In Guile}.
+@xref{Inferiors and Programs, program spaces}, for more details
+about program spaces.
+
+Each progspace is represented by an instance of the @code{<gdb:progspace>}
+smob. @xref{GDB Scheme Data Types}.
+
+The following progspace-related functions are available in the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} progspace? object
+Return @code{#t} if @var{object} is a @code{<gdb:progspace>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} progspace-valid? progspace
+Return @code{#t} if @var{progspace} is valid, @code{#f} if not.
+A @code{<gdb:progspace>} object can become invalid
+if the program it refers to is not loaded in @value{GDBN} any longer.
+@end deffn
+
+@deffn {Scheme Procedure} current-progspace
+This function returns the program space of the currently selected inferior.
+There is always a current progspace, this never returns @code{#f}.
+@xref{Inferiors and Programs}.
+@end deffn
+
+@deffn {Scheme Procedure} progspaces
+Return a list of all the progspaces currently known to @value{GDBN}.
+@end deffn
+
+@deffn {Scheme Procedure} progspace-filename progspace
+Return the file name of @var{progspace} as a string.
+If the program space does not have an associated file name,
+then @code{#f} is returned. This occurs, for example, when @value{GDBN}
+is started without a program to debug.
+
+A @code{gdb:invalid-object-error} exception is thrown if @var{PROGSPACE}
+is invalid.
+@end deffn
+
+@deffn {Scheme Procedure} progspace-objfiles progspace
+Return the list of objfiles of @var{progspace}.
+The order of objfiles in the result is arbitrary.
+Each element is an object of type @code{<gdb:objfile>}.
+@xref{Objfiles In Guile}.
+
+A @code{gdb:invalid-object-error} exception is thrown if @var{PROGSPACE}
+is invalid.
+@end deffn
+
+@deffn {Scheme Procedure} progspace-pretty-printers progspace
+Return the list of pretty-printers of @var{progspace}.
+Each element is an object of type @code{<gdb:pretty-printer>}.
+@xref{Guile Pretty Printing API}, for more information.
+@end deffn
+
+@deffn {Scheme Procedure} set-progspace-pretty-printers! progspace printer-list
+Set the list of registered @code{<gdb:pretty-printer>} objects for
+@var{progspace} to @var{printer-list}.
+@var{printer-list} must be a list of @code{<gdb:pretty-printer>} objects.
+@xref{Guile Pretty Printing API}, for more information.
+@end deffn
+
@node Objfiles In Guile
@subsubsection Objfiles In Guile
@@ -426,6 +426,16 @@ extern objfile_smob *ofscm_objfile_smob_from_objfile (struct objfile *objfile);
extern SCM ofscm_scm_from_objfile (struct objfile *objfile);
+/* scm-progspace.c */
+
+typedef struct _pspace_smob pspace_smob;
+
+extern SCM psscm_pspace_smob_pretty_printers (const pspace_smob *);
+
+extern pspace_smob *psscm_pspace_smob_from_pspace (struct program_space *);
+
+extern SCM psscm_scm_from_pspace (struct program_space *);
+
/* scm-string.c */
extern char *gdbscm_scm_to_c_string (SCM string);
@@ -533,6 +543,7 @@ extern void gdbscm_initialize_math (void);
extern void gdbscm_initialize_objfiles (void);
extern void gdbscm_initialize_pretty_printers (void);
extern void gdbscm_initialize_ports (void);
+extern void gdbscm_initialize_pspaces (void);
extern void gdbscm_initialize_smobs (void);
extern void gdbscm_initialize_strings (void);
extern void gdbscm_initialize_symbols (void);
@@ -545,6 +545,7 @@ initialize_gdb_module (void *data)
gdbscm_initialize_objfiles ();
gdbscm_initialize_ports ();
gdbscm_initialize_pretty_printers ();
+ gdbscm_initialize_pspaces ();
gdbscm_initialize_strings ();
gdbscm_initialize_symbols ();
gdbscm_initialize_symtabs ();
@@ -270,6 +270,17 @@
make-pretty-printer-worker
pretty-printer-worker?
+ ;; scm-progspace.c
+
+ progspace?
+ progspace-valid?
+ progspace-filename
+ progspace-objfiles
+ progspace-pretty-printers
+ set-progspace-pretty-printers!
+ current-progspace
+ progspaces
+
;; scm-smob.c
gsmob-kind
@@ -19,8 +19,9 @@
(define-module (gdb printing)
#:use-module ((gdb) #:select
- (*pretty-printers* pretty-printer? objfile?
- objfile-pretty-printers set-objfile-pretty-printers!))
+ (*pretty-printers* pretty-printer? objfile? progspace?
+ objfile-pretty-printers set-objfile-pretty-printers!
+ progspace-pretty-printers set-progspace-pretty-printers!))
#:use-module (gdb init))
(define-public (prepend-pretty-printer! obj matcher)
@@ -31,9 +32,11 @@ If OBJ is #f, add MATCHER to the global list."
(cond ((eq? obj #f)
(set! *pretty-printers* (cons matcher *pretty-printers*)))
((objfile? obj)
- (set-objfile-pretty-printers! obj
- (cons matcher
- (objfile-pretty-printers obj))))
+ (set-objfile-pretty-printers!
+ obj (cons matcher (objfile-pretty-printers obj))))
+ ((progspace? obj)
+ (set-progspace-pretty-printers!
+ obj (cons matcher (progspace-pretty-printers obj))))
(else
(%assert-type #f obj SCM_ARG1 'prepend-pretty-printer!))))
@@ -45,8 +48,10 @@ If OBJ is #f, add MATCHER to the global list."
(cond ((eq? obj #f)
(set! *pretty-printers* (append! *pretty-printers* (list matcher))))
((objfile? obj)
- (set-objfile-pretty-printers! obj
- (append! (objfile-pretty-printers obj)
- (list matcher))))
+ (set-objfile-pretty-printers!
+ obj (append! (objfile-pretty-printers obj) (list matcher))))
+ ((progspace? obj)
+ (set-progspace-pretty-printers!
+ obj (append! (progspace-pretty-printers obj) (list matcher))))
(else
(%assert-type #f obj SCM_ARG1 'append-pretty-printer!))))
@@ -470,7 +470,11 @@ ppscm_find_pretty_printer_from_objfiles (SCM value)
static SCM
ppscm_find_pretty_printer_from_progspace (SCM value)
{
- return SCM_BOOL_F; /*TODO*/
+ pspace_smob *p_smob = psscm_pspace_smob_from_pspace (current_program_space);
+ SCM pp
+ = ppscm_search_pp_list (psscm_pspace_smob_pretty_printers (p_smob), value);
+
+ return pp;
}
/* Subroutine of find_pretty_printer to simplify it.
new file mode 100644
@@ -0,0 +1,426 @@
+/* Guile interface to program spaces.
+
+ Copyright (C) 2010-2014 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/>. */
+
+#include "defs.h"
+#include "charset.h"
+#include "progspace.h"
+#include "objfiles.h"
+#include "language.h"
+#include "arch-utils.h"
+#include "guile-internal.h"
+
+/* NOTE: Python exports the name "Progspace", so we export "progspace".
+ Internally we shorten that to "pspace". */
+
+/* The <gdb:progspace> smob.
+ The typedef for this struct is in guile-internal.h. */
+
+struct _pspace_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The corresponding pspace. */
+ struct program_space *pspace;
+
+ /* The pretty-printer list of functions. */
+ SCM pretty_printers;
+
+ /* The <gdb:progspace> object we are contained in, needed to
+ protect/unprotect the object since a reference to it comes from
+ non-gc-managed space (the progspace). */
+ SCM containing_scm;
+};
+
+static const char pspace_smob_name[] = "gdb:progspace";
+
+/* The tag Guile knows the pspace smob by. */
+static scm_t_bits pspace_smob_tag;
+
+static const struct program_space_data *psscm_pspace_data_key;
+
+/* Return the list of pretty-printers registered with P_SMOB. */
+
+SCM
+psscm_pspace_smob_pretty_printers (const pspace_smob *p_smob)
+{
+ return p_smob->pretty_printers;
+}
+
+/* Administrivia for progspace smobs. */
+
+/* The smob "print" function for <gdb:progspace>. */
+
+static int
+psscm_print_pspace_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ pspace_smob *p_smob = (pspace_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", pspace_smob_name);
+ if (p_smob->pspace != NULL)
+ {
+ struct objfile *objfile = p_smob->pspace->symfile_object_file;
+
+ gdbscm_printf (port, "%s",
+ objfile != NULL
+ ? objfile_name (objfile)
+ : "{no symfile}");
+ }
+ else
+ scm_puts ("{invalid}", port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:progspace> object.
+ It's empty in the sense that a progspace still needs to be associated
+ with it. */
+
+static SCM
+psscm_make_pspace_smob (void)
+{
+ pspace_smob *p_smob = (pspace_smob *)
+ scm_gc_malloc (sizeof (pspace_smob), pspace_smob_name);
+ SCM p_scm;
+
+ p_smob->pspace = NULL;
+ p_smob->pretty_printers = SCM_EOL;
+ p_scm = scm_new_smob (pspace_smob_tag, (scm_t_bits) p_smob);
+ p_smob->containing_scm = p_scm;
+ gdbscm_init_gsmob (&p_smob->base);
+
+ return p_scm;
+}
+
+/* Clear the progspace pointer in P_SMOB and unprotect the object from GC. */
+
+static void
+psscm_release_pspace (pspace_smob *p_smob)
+{
+ p_smob->pspace = NULL;
+ scm_gc_unprotect_object (p_smob->containing_scm);
+}
+
+/* Progspace registry cleanup handler for when a progspace is deleted. */
+
+static void
+psscm_handle_pspace_deleted (struct program_space *pspace, void *datum)
+{
+ pspace_smob *p_smob = datum;
+
+ gdb_assert (p_smob->pspace == pspace);
+
+ psscm_release_pspace (p_smob);
+}
+
+/* Return non-zero if SCM is a <gdb:progspace> object. */
+
+static int
+psscm_is_pspace (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (pspace_smob_tag, scm);
+}
+
+/* (progspace? object) -> boolean */
+
+static SCM
+gdbscm_progspace_p (SCM scm)
+{
+ return scm_from_bool (psscm_is_pspace (scm));
+}
+
+/* Return a pointer to the progspace_smob that encapsulates PSPACE,
+ creating one if necessary.
+ The result is cached so that we have only one copy per objfile. */
+
+pspace_smob *
+psscm_pspace_smob_from_pspace (struct program_space *pspace)
+{
+ pspace_smob *p_smob;
+
+ p_smob = program_space_data (pspace, psscm_pspace_data_key);
+ if (p_smob == NULL)
+ {
+ SCM p_scm = psscm_make_pspace_smob ();
+
+ p_smob = (pspace_smob *) SCM_SMOB_DATA (p_scm);
+ p_smob->pspace = pspace;
+
+ set_program_space_data (pspace, psscm_pspace_data_key, p_smob);
+ scm_gc_protect_object (p_smob->containing_scm);
+ }
+
+ return p_smob;
+}
+
+/* Return the <gdb:progspace> object that encapsulates PSPACE. */
+
+SCM
+psscm_scm_from_pspace (struct program_space *pspace)
+{
+ pspace_smob *p_smob = psscm_pspace_smob_from_pspace (pspace);
+
+ return p_smob->containing_scm;
+}
+
+/* Returns the <gdb:progspace> object in SELF.
+ Throws an exception if SELF is not a <gdb:progspace> object. */
+
+static SCM
+psscm_get_pspace_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (psscm_is_pspace (self), self, arg_pos, func_name,
+ pspace_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the pspace smob of SELF.
+ Throws an exception if SELF is not a <gdb:progspace> object. */
+
+static pspace_smob *
+psscm_get_pspace_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM p_scm = psscm_get_pspace_arg_unsafe (self, arg_pos, func_name);
+ pspace_smob *p_smob = (pspace_smob *) SCM_SMOB_DATA (p_scm);
+
+ return p_smob;
+}
+
+/* Return non-zero if pspace P_SMOB is valid. */
+
+static int
+psscm_is_valid (pspace_smob *p_smob)
+{
+ return p_smob->pspace != NULL;
+}
+
+/* Return the pspace smob in SELF, verifying it's valid.
+ Throws an exception if SELF is not a <gdb:progspace> object or is
+ invalid. */
+
+static pspace_smob *
+psscm_get_valid_pspace_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ pspace_smob *p_smob
+ = psscm_get_pspace_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!psscm_is_valid (p_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:progspace>"));
+ }
+
+ return p_smob;
+}
+
+/* Program space methods. */
+
+/* (progspace-valid? <gdb:progspace>) -> boolean
+ Returns #t if this program space still exists in GDB. */
+
+static SCM
+gdbscm_progspace_valid_p (SCM self)
+{
+ pspace_smob *p_smob
+ = psscm_get_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (p_smob->pspace != NULL);
+}
+
+/* (progspace-filename <gdb:progspace>) -> string
+ Returns the name of the main symfile associated with the progspace,
+ or #f if there isn't one.
+ Throw's an exception if the underlying pspace is invalid. */
+
+static SCM
+gdbscm_progspace_filename (SCM self)
+{
+ pspace_smob *p_smob
+ = psscm_get_valid_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct objfile *objfile = p_smob->pspace->symfile_object_file;
+
+ if (objfile != NULL)
+ return gdbscm_scm_from_c_string (objfile_name (objfile));
+ return SCM_BOOL_F;
+}
+
+/* (progspace-objfiles <gdb:progspace>) -> list
+ Return the list of objfiles in the progspace.
+ Objfiles that are separate debug objfiles are *not* included in the result,
+ only the "original/real" one appears in the result.
+ The order of appearance of objfiles in the result is arbitrary.
+ Throw's an exception if the underlying pspace is invalid.
+
+ Some apps can have 1000s of shared libraries. Seriously.
+ A future extension here could be to provide, e.g., a regexp to select
+ just the ones the caller is interested in (rather than building the list
+ and then selecting the desired ones). Another alternative is passing a
+ predicate, then the filter criteria can be more general. */
+
+static SCM
+gdbscm_progspace_objfiles (SCM self)
+{
+ pspace_smob *p_smob
+ = psscm_get_valid_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct objfile *objfile;
+ SCM result;
+
+ result = SCM_EOL;
+
+ ALL_PSPACE_OBJFILES (p_smob->pspace, objfile)
+ {
+ if (objfile->separate_debug_objfile_backlink == NULL)
+ {
+ SCM item = ofscm_scm_from_objfile (objfile);
+
+ result = scm_cons (item, result);
+ }
+ }
+
+ /* We don't really have to return the list in the same order as recorded
+ internally, but for consistency we do. We still advertise that one
+ cannot assume anything about the order. */
+ return scm_reverse_x (result, SCM_EOL);
+}
+
+/* (progspace-pretty-printers <gdb:progspace>) -> list
+ Returns the list of pretty-printers for this program space. */
+
+static SCM
+gdbscm_progspace_pretty_printers (SCM self)
+{
+ pspace_smob *p_smob
+ = psscm_get_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return p_smob->pretty_printers;
+}
+
+/* (set-progspace-pretty-printers! <gdb:progspace> list) -> unspecified
+ Set the pretty-printers for this program space. */
+
+static SCM
+gdbscm_set_progspace_pretty_printers_x (SCM self, SCM printers)
+{
+ pspace_smob *p_smob
+ = psscm_get_pspace_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
+ SCM_ARG2, FUNC_NAME, _("list"));
+
+ p_smob->pretty_printers = printers;
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (current-progspace) -> <gdb:progspace>
+ Return the current program space. There always is one. */
+
+static SCM
+gdbscm_current_progspace (void)
+{
+ SCM result;
+
+ result = psscm_scm_from_pspace (current_program_space);
+
+ return result;
+}
+
+/* (progspaces) -> list
+ Return a list of all progspaces. */
+
+static SCM
+gdbscm_progspaces (void)
+{
+ struct program_space *ps;
+ SCM result;
+
+ result = SCM_EOL;
+
+ ALL_PSPACES (ps)
+ {
+ SCM item = psscm_scm_from_pspace (ps);
+
+ result = scm_cons (item, result);
+ }
+
+ return scm_reverse_x (result, SCM_EOL);
+}
+
+/* Initialize the Scheme program space support. */
+
+static const scheme_function pspace_functions[] =
+{
+ { "progspace?", 1, 0, 0, gdbscm_progspace_p,
+ "\
+Return #t if the object is a <gdb:objfile> object." },
+
+ { "progspace-valid?", 1, 0, 0, gdbscm_progspace_valid_p,
+ "\
+Return #t if the progspace is valid (hasn't been deleted from gdb)." },
+
+ { "progspace-filename", 1, 0, 0, gdbscm_progspace_filename,
+ "\
+Return the name of the main symbol file of the progspace." },
+
+ { "progspace-objfiles", 1, 0, 0, gdbscm_progspace_objfiles,
+ "\
+Return the list of objfiles associated with the progspace.\n\
+Objfiles that are separate debug objfiles are not included in the result.\n\
+The order of appearance of objfiles in the result is arbitrary." },
+
+ { "progspace-pretty-printers", 1, 0, 0, gdbscm_progspace_pretty_printers,
+ "\
+Return a list of pretty-printers of the progspace." },
+
+ { "set-progspace-pretty-printers!", 2, 0, 0,
+ gdbscm_set_progspace_pretty_printers_x,
+ "\
+Set the list of pretty-printers of the progspace." },
+
+ { "current-progspace", 0, 0, 0, gdbscm_current_progspace,
+ "\
+Return the current program space if there is one or #f if there isn't one." },
+
+ { "progspaces", 0, 0, 0, gdbscm_progspaces,
+ "\
+Return a list of all program spaces." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_pspaces (void)
+{
+ pspace_smob_tag
+ = gdbscm_make_smob_type (pspace_smob_name, sizeof (pspace_smob));
+ scm_set_smob_print (pspace_smob_tag, psscm_print_pspace_smob);
+
+ gdbscm_define_functions (pspace_functions, 1);
+
+ psscm_pspace_data_key
+ = register_program_space_data_with_cleanup (NULL,
+ psscm_handle_pspace_deleted);
+}
@@ -138,11 +138,19 @@ gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
"print ss enabled #1"
gdb_test_no_output "guile (disable-matcher!)"
-
gdb_test "print ss" " = {a = {a = 1, b = $hex}, b = {a = 2, b = $hex}}" \
"print ss disabled"
gdb_test_no_output "guile (enable-matcher!)"
-
gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
"print ss enabled #2"
+
+gdb_test_no_output "guile (install-progspace-pretty-printers! (current-progspace))"
+gdb_test "print ss" \
+ " = a=<progspace a=<1> b=<$hex>> b=<progspace a=<2> b=<$hex>>" \
+ "print ss via progspace"
+
+gdb_test_no_output "guile (install-objfile-pretty-printers! (current-progspace) \"scm-pretty-print\")"
+gdb_test "print ss" \
+ " = a=<objfile a=<1> b=<$hex>> b=<objfile a=<2> b=<$hex>>" \
+ "print ss via objfile"
@@ -104,16 +104,22 @@
(lambda (printer)
(make-pointer-iterator-except elements (value->integer len))))))
+;; The actual pretty-printer for pp_s is split out so that we can pass
+;; in a prefix to distinguish objfile/progspace/global.
+
+(define (pp_s-printer prefix val)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (if (not (value=? (value-address a) b))
+ (error (format #f "&a(~A) != b(~A)"
+ (value-address a) b)))
+ (format #f "~aa=<~A> b=<~A>" prefix a b)))
+
(define (make-pp_s-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
- (let ((a (value-field val "a"))
- (b (value-field val "b")))
- (if (not (value=? (value-address a) b))
- (error (format #f "&a(~A) != b(~A)"
- (value-address a) b)))
- (format #f "a=<~A> b=<~A>" a b)))
+ (pp_s-printer "" val))
#f))
(define (make-pp_ss-printer val)
@@ -285,17 +291,60 @@
;; This is one way to register a printer that is composed of several
;; subprinters, but there's no way to disable or list individual subprinters.
+(define (make-pretty-printer-from-dict name dict lookup-maker)
+ (make-pretty-printer
+ name
+ (lambda (matcher val)
+ (let ((printer-maker (lookup-maker dict val)))
+ (and printer-maker (printer-maker val))))))
+
+(define (lookup-pretty-printer-maker-from-dict dict val)
+ (let ((type-name (type-tag (get-type-for-printing val))))
+ (and type-name
+ (hash-ref dict type-name))))
+
(define *pretty-printer*
- (make-pretty-printer
- "pretty-printer-test"
- (let ((pretty-printers-dict (make-pretty-printer-dict)))
- (lambda (matcher val)
- "Look-up and return a pretty-printer that can print val."
- (let ((type (get-type-for-printing val)))
- (let ((typename (type-tag type)))
- (if typename
- (let ((printer-maker (hash-ref pretty-printers-dict typename)))
- (and printer-maker (printer-maker val)))
- #f)))))))
+ (make-pretty-printer-from-dict "pretty-printer-test"
+ (make-pretty-printer-dict)
+ lookup-pretty-printer-maker-from-dict))
(append-pretty-printer! #f *pretty-printer*)
+
+;; Different versions of a simple pretty-printer for use in testing
+;; objfile/progspace lookup.
+
+(define (make-objfile-pp_s-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (pp_s-printer "objfile " val))
+ #f))
+
+(define (install-objfile-pretty-printers! pspace objfile-name)
+ (let ((objfiles (filter (lambda (objfile)
+ (string-contains (objfile-filename objfile)
+ objfile-name))
+ (progspace-objfiles pspace)))
+ (dict (make-hash-table)))
+ (if (not (= (length objfiles) 1))
+ (error "objfile not found or ambiguous: " objfile-name))
+ (hash-set! dict "s" make-objfile-pp_s-printer)
+ (let ((pp (make-pretty-printer-from-dict
+ "objfile-pretty-printer-test"
+ dict lookup-pretty-printer-maker-from-dict)))
+ (append-pretty-printer! (car objfiles) pp))))
+
+(define (make-progspace-pp_s-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (pp_s-printer "progspace " val))
+ #f))
+
+(define (install-progspace-pretty-printers! pspace)
+ (let ((dict (make-hash-table)))
+ (hash-set! dict "s" make-progspace-pp_s-printer)
+ (let ((pp (make-pretty-printer-from-dict
+ "progspace-pretty-printer-test"
+ dict lookup-pretty-printer-maker-from-dict)))
+ (append-pretty-printer! pspace pp))))
new file mode 100644
@@ -0,0 +1,22 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+int
+main ()
+{
+ return 0;
+}
new file mode 100644
@@ -0,0 +1,92 @@
+# Copyright (C) 2010-2014 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 the program space support in Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if {[build_executable $testfile.exp $testfile $srcfile debug] == -1} {
+ return -1
+}
+
+# Start with a fresh gdb.
+
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+proc print_current_progspace { filename_regexp smob_filename_regexp } {
+ gdb_test "gu (print (progspace-filename (current-progspace)))" \
+ "= $filename_regexp" "current progspace filename"
+ gdb_test "gu (print (progspaces))" \
+ "= \\(#<gdb:progspace $smob_filename_regexp>\\)"
+}
+
+gdb_test "gu (print (progspace? 42))" "= #f"
+gdb_test "gu (print (progspace? (current-progspace)))" "= #t"
+
+with_test_prefix "at start" {
+ print_current_progspace "#f" "{no symfile}"
+}
+
+gdb_load ${binfile}
+
+with_test_prefix "program loaded" {
+ print_current_progspace ".*$testfile" ".*$testfile"
+ gdb_test_no_output "gu (define progspace (current-progspace))"
+ gdb_test "gu (print (progspace-valid? progspace))" "= #t"
+ gdb_test "gu (print (progspace-filename progspace))" "= .*$testfile"
+ gdb_test "gu (print (list? (progspace-objfiles progspace)))" "= #t"
+}
+
+# Verify we keep the same progspace when the program is unloaded.
+
+gdb_unload
+with_test_prefix "program unloaded" {
+ print_current_progspace "#f" "{no symfile}"
+ gdb_test "gu (print (eq? progspace (current-progspace)))" "= #t"
+}
+
+# Verify the progspace is garbage collected ok.
+# Note that when a program is unloaded, the associated progspace doesn't get
+# deleted. We need to, for example, delete an inferior to get the progspace
+# to go away.
+
+gdb_test "add-inferior" "Added inferior 2" "Create new inferior"
+gdb_test "inferior 2" ".*" "Switch to new inferior"
+gdb_test_no_output "remove-inferiors 1" "Remove first inferior"
+
+with_test_prefix "inferior removed" {
+ gdb_test "gu (print (progspace-valid? progspace))" "= #f"
+ gdb_test "gu (print (progspace-filename progspace))" \
+ "ERROR:.*Invalid object.*"
+ gdb_test "gu (print (progspace-objfiles progspace))" \
+ "ERROR:.*Invalid object.*"
+ print_current_progspace "#f" "{no symfile}"
+}
+
+# garbage-collects can trigger segvs if we've messed up somewhere.
+
+gdb_test_no_output "gu (gc)"
+gdb_test "gu (print progspace)" "= #<gdb:progspace {invalid}>"