From ded0378278c7bbd5c6049446032b28196a5cfb38 Mon Sep 17 00:00:00 2001 From: Doug Evans Date: Mon, 2 Jun 2014 23:46:27 -0700 Subject: [PATCH] Add progspace support for Guile. * Makefile.in (SUBDIR_GUILE_OBS): Add scm-progspace.o. (SUBDIR_GUILE_SRCS): Add scm-progspace.c. (scm-progspace.o): New rule. * guile/guile-internal.h (pspace_smob): New typedef. (psscm_pspace_smob_pretty_printers): Declare. (psscm_pspace_smob_from_pspace): Declare. (psscm_scm_from_pspace): Declare. * guile/guile.c (initialize_gdb_module): Call gdbscm_initialize_pspaces. * guile/lib/gdb.scm: Export progspace symbols. * guile/lib/gdb/printing.scm (prepend-pretty-printer!): Add progspace support. (append-pretty-printer!): Ditto. * guile/scm-pretty-print.c (ppscm_find_pretty_printer_from_progspace): Implement. * guile/scm-progspace.c: New file. doc/ * guile.texi (Guile API): Add entry for Progspaces In Guile. (GDB Scheme Data Types): Mention object. (Progspaces In Guile): New node. testsuite/ * gdb.guile/scm-pretty-print.exp: Add tests for objfile and progspace pretty-printer lookup. * gdb.guile/scm-pretty-print.scm (pp_s-printer): New function. (make-pp_s-printer): Call it. (make-pretty-printer-from-dict): New function. (lookup-pretty-printer-maker-from-dict): New function. (*pretty-printer*): Simplify. (make-objfile-pp_s-printer): New function. (install-objfile-pretty-printers!): New function. (make-progspace-pp_s-printer): New function. (install-progspace-pretty-printers!): New function. * gdb.guile/scm-progspace.c: New file. * gdb.guile/scm-progspace.exp: New file. --- gdb/ChangeLog | 20 + gdb/Makefile.in | 6 + gdb/doc/ChangeLog | 6 + gdb/doc/guile.texi | 78 ++++ gdb/guile/guile-internal.h | 11 + gdb/guile/guile.c | 1 + gdb/guile/lib/gdb.scm | 11 + gdb/guile/lib/gdb/printing.scm | 21 +- gdb/guile/scm-pretty-print.c | 6 +- gdb/guile/scm-progspace.c | 426 +++++++++++++++++++ gdb/testsuite/ChangeLog | 16 + gdb/testsuite/gdb.guile/scm-pretty-print.exp | 12 +- gdb/testsuite/gdb.guile/scm-pretty-print.scm | 83 +++- gdb/testsuite/gdb.guile/scm-progspace.c | 22 + gdb/testsuite/gdb.guile/scm-progspace.exp | 92 ++++ 15 files changed, 783 insertions(+), 28 deletions(-) create mode 100644 gdb/guile/scm-progspace.c create mode 100644 gdb/testsuite/gdb.guile/scm-progspace.c create mode 100644 gdb/testsuite/gdb.guile/scm-progspace.exp diff --git a/gdb/ChangeLog b/gdb/ChangeLog index d7f5c6f8af3..22c7a1e7305 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,23 @@ +2014-06-02 Doug Evans + + Add progspace support for Guile. + * Makefile.in (SUBDIR_GUILE_OBS): Add scm-progspace.o. + (SUBDIR_GUILE_SRCS): Add scm-progspace.c. + (scm-progspace.o): New rule. + * guile/guile-internal.h (pspace_smob): New typedef. + (psscm_pspace_smob_pretty_printers): Declare. + (psscm_pspace_smob_from_pspace): Declare. + (psscm_scm_from_pspace): Declare. + * guile/guile.c (initialize_gdb_module): Call + gdbscm_initialize_pspaces. + * guile/lib/gdb.scm: Export progspace symbols. + * guile/lib/gdb/printing.scm (prepend-pretty-printer!): Add progspace + support. + (append-pretty-printer!): Ditto. + * guile/scm-pretty-print.c (ppscm_find_pretty_printer_from_progspace): + Implement. + * guile/scm-progspace.c: New file. + 2014-06-03 Alan Modra * ppc64-tdep.c (ppc64_standard_linkage8): New. diff --git a/gdb/Makefile.in b/gdb/Makefile.in index f2c16ec267d..51aeeb3945f 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -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) diff --git a/gdb/doc/ChangeLog b/gdb/doc/ChangeLog index 1a07a82cce1..cbe00db3144 100644 --- a/gdb/doc/ChangeLog +++ b/gdb/doc/ChangeLog @@ -1,3 +1,9 @@ +2014-06-02 Doug Evans + + * guile.texi (Guile API): Add entry for Progspaces In Guile. + (GDB Scheme Data Types): Mention object. + (Progspaces In Guile): New node. + 2014-05-30 Andrew Burgess * guile.texi (Frames In Guile): Mention FRAME_UNWIND_MEMORY_ERROR. diff --git a/gdb/doc/guile.texi b/gdb/doc/guile.texi index bc2a2ce46a0..23c83985701 100644 --- a/gdb/doc/guile.texi +++ b/gdb/doc/guile.texi @@ -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 @@ -378,6 +379,9 @@ as a symbol. @item @xref{Guile Pretty Printing API}. +@item +@xref{Progspaces In Guile}. + @item @xref{Symbols In Guile}. @@ -406,6 +410,7 @@ Scheme function @code{eq?} may be applied to them. @item @item @item +@item @item @item @item @@ -1660,6 +1665,79 @@ my_library.so: bar @end smallexample +@node Progspaces In Guile +@subsubsection Program Spaces In Guile + +@cindex progspaces in guile +@tindex +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{} +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{} 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{} 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 absolute file name of @var{progspace} as a string. +This is the name of the file passed as the argument to the @code{file} +or @code{symbol-file} commands. +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{}. +@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{}. +@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{} objects for +@var{progspace} to @var{printer-list}. +@xref{Guile Pretty Printing API}, for more information. +@end deffn + @node Objfiles In Guile @subsubsection Objfiles In Guile diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h index ff891b502a2..9f6a886ac8e 100644 --- a/gdb/guile/guile-internal.h +++ b/gdb/guile/guile-internal.h @@ -438,6 +438,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); @@ -542,6 +552,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); diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c index f2fd8d8aef9..51919de2515 100644 --- a/gdb/guile/guile.c +++ b/gdb/guile/guile.c @@ -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 (); diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm index abc4a67b45d..646ca81f535 100644 --- a/gdb/guile/lib/gdb.scm +++ b/gdb/guile/lib/gdb.scm @@ -271,6 +271,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-gsmob.c gdb-object-kind diff --git a/gdb/guile/lib/gdb/printing.scm b/gdb/guile/lib/gdb/printing.scm index 29447025bda..eac94178cbd 100644 --- a/gdb/guile/lib/gdb/printing.scm +++ b/gdb/guile/lib/gdb/printing.scm @@ -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!)))) diff --git a/gdb/guile/scm-pretty-print.c b/gdb/guile/scm-pretty-print.c index 6aa911912fe..e20da68027c 100644 --- a/gdb/guile/scm-pretty-print.c +++ b/gdb/guile/scm-pretty-print.c @@ -441,7 +441,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. diff --git a/gdb/guile/scm-progspace.c b/gdb/guile/scm-progspace.c new file mode 100644 index 00000000000..e329b3a95c0 --- /dev/null +++ b/gdb/guile/scm-progspace.c @@ -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 . */ + +#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 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 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 . */ + +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 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 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 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 object in SELF. + Throws an exception if SELF is not a 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 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 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, + _("")); + } + + return p_smob; +} + +/* Program space methods. */ + +/* (progspace-valid? ) -> 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 ) -> 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 ) -> 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 ) -> 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! 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) -> + 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 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); +} diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index f4d59cf78c3..718ce2432ea 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,19 @@ +2014-06-02 Doug Evans + + * gdb.guile/scm-pretty-print.exp: Add tests for objfile and progspace + pretty-printer lookup. + * gdb.guile/scm-pretty-print.scm (pp_s-printer): New function. + (make-pp_s-printer): Call it. + (make-pretty-printer-from-dict): New function. + (lookup-pretty-printer-maker-from-dict): New function. + (*pretty-printer*): Simplify. + (make-objfile-pp_s-printer): New function. + (install-objfile-pretty-printers!): New function. + (make-progspace-pp_s-printer): New function. + (install-progspace-pretty-printers!): New function. + * gdb.guile/scm-progspace.c: New file. + * gdb.guile/scm-progspace.exp: New file. + 2014-06-02 Pedro Alves * gdb.base/dprintf-bp-same-addr.c: New file. diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.exp b/gdb/testsuite/gdb.guile/scm-pretty-print.exp index cd3ae95478a..555d7514d92 100644 --- a/gdb/testsuite/gdb.guile/scm-pretty-print.exp +++ b/gdb/testsuite/gdb.guile/scm-pretty-print.exp @@ -138,11 +138,19 @@ gdb_test "print ss" " = a= b=<$hex>> b= 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= b=<$hex>> b= b=<$hex>>" \ "print ss enabled #2" + +gdb_test_no_output "guile (install-progspace-pretty-printers! (current-progspace))" +gdb_test "print ss" \ + " = a= b=<$hex>> b= 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= b=<$hex>> b= b=<$hex>>" \ + "print ss via objfile" diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.scm b/gdb/testsuite/gdb.guile/scm-pretty-print.scm index a42527ca49d..26c00936b8b 100644 --- a/gdb/testsuite/gdb.guile/scm-pretty-print.scm +++ b/gdb/testsuite/gdb.guile/scm-pretty-print.scm @@ -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)))) diff --git a/gdb/testsuite/gdb.guile/scm-progspace.c b/gdb/testsuite/gdb.guile/scm-progspace.c new file mode 100644 index 00000000000..003444921ae --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-progspace.c @@ -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 . */ + +int +main () +{ + return 0; +} diff --git a/gdb/testsuite/gdb.guile/scm-progspace.exp b/gdb/testsuite/gdb.guile/scm-progspace.exp new file mode 100644 index 00000000000..5ec2afe8fe1 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-progspace.exp @@ -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 . + +# 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_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)" "= #" -- 2.30.2