Patchwork [doc,RFA] : Add guile progspace support

login
register
mail settings
Submitter Doug Evans
Date May 21, 2014, 7:22 p.m.
Message ID <m37g5fhr83.fsf@sspiff.org>
Download mbox | patch
Permalink /patch/1063/
State New
Headers show

Comments

Doug Evans - May 21, 2014, 7:22 p.m.
Hi.

This patch adds guile progspace support.

2014-05-21  Doug Evans  <xdje42@gmail.com>

	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 <gdb:progspace> 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.
Eli Zaretskii - May 22, 2014, 3:27 p.m.
> From: Doug Evans <xdje42@gmail.com>
> Date: Wed, 21 May 2014 12:22:20 -0700
> 
> This patch adds guile progspace support.

Thanks.

> +@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.

I guess this is the file name of the executable program running in the
progspace?  If so, why not tell that explicitly?  This text as written
begs the question what file is named by that string.  Also, is the
file absolute, relative, something else?  Is it just the value of
argv[0] in that program?  Etc. etc.

> +A @code{gdb:invalid-object-error} exception is thrown if @var{PROGSPACE}
> +is invalid.                                                   ^^^^^^^^^

"progspace", in lower case.

> +@deffn {Scheme Procedure} progspace-objfiles progspace
> +Return the list of objfiles of @var{progspace}.
> +The order of objfiles in the result is arbitrary.

"Arbitrary" or in the same order they are stored in some symbol table?

> +A @code{gdb:invalid-object-error} exception is thrown if @var{PROGSPACE}
> +is invalid.                                                   ^^^^^^^^^

"progspace" in lower case.
Doug Evans - May 24, 2014, 4:42 a.m.
On Thu, May 22, 2014 at 8:27 AM, Eli Zaretskii <eliz@gnu.org> wrote:
>> From: Doug Evans <xdje42@gmail.com>
>> Date: Wed, 21 May 2014 12:22:20 -0700
>>
>> This patch adds guile progspace support.
>
> Thanks.
>
>> +@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.
>
> I guess this is the file name of the executable program running in the
> progspace?  If so, why not tell that explicitly?  This text as written
> begs the question what file is named by that string.  Also, is the
> file absolute, relative, something else?  Is it just the value of
> argv[0] in that program?  Etc. etc.

I'll work on improving the text.

However,

I wish to point out that the python version says this:

@defvar Progspace.filename
The file name of the progspace as a string.
@end defvar

I have to say it's a bit disappointing that if there were issues with
this text that they weren't addressed the first time.
Eli Zaretskii - May 24, 2014, 7:31 a.m.
> Date: Fri, 23 May 2014 21:42:36 -0700
> From: Doug Evans <xdje42@gmail.com>
> Cc: "gdb-patches@sourceware.org" <gdb-patches@sourceware.org>
> 
> I wish to point out that the python version says this:
> 
> @defvar Progspace.filename
> The file name of the progspace as a string.
> @end defvar
> 
> I have to say it's a bit disappointing that if there were issues with
> this text that they weren't addressed the first time.

Yes, I'm a disappointing kind of person at times.

You get bonus points for fixing those places as well.

Thanks.
Doug Evans - June 1, 2014, 8:37 p.m.
Eli Zaretskii <eliz@gnu.org> writes:

>> From: Doug Evans <xdje42@gmail.com>
>> Date: Wed, 21 May 2014 12:22:20 -0700
>> 
>> This patch adds guile progspace support.
>
> Thanks.
>
>> +@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.
>
> I guess this is the file name of the executable program running in the
> progspace?  If so, why not tell that explicitly?  This text as written
> begs the question what file is named by that string.  Also, is the
> file absolute, relative, something else?  Is it just the value of
> argv[0] in that program?  Etc. etc.

How about this?

+@deffn {Scheme Procedure} progspace-filename progspace
+Return the file name of @var{progspace} as a string,
+as an absolute path.
+This is the name of 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

>> +A @code{gdb:invalid-object-error} exception is thrown if @var{PROGSPACE}
>> +is invalid.                                                   ^^^^^^^^^
>
> "progspace", in lower case.

Fixed.

>> +@deffn {Scheme Procedure} progspace-objfiles progspace
>> +Return the list of objfiles of @var{progspace}.
>> +The order of objfiles in the result is arbitrary.
>
> "Arbitrary" or in the same order they are stored in some symbol table?

Arbitrary.
gdb makes no promises to the user regarding the order.

>> +A @code{gdb:invalid-object-error} exception is thrown if @var{PROGSPACE}
>> +is invalid.                                                   ^^^^^^^^^
>
> "progspace" in lower case.

Fixed.
Eli Zaretskii - June 2, 2014, 3:19 p.m.
> From: Doug Evans <xdje42@gmail.com>
> Cc: gdb-patches@sourceware.org
> Date: Sun, 01 Jun 2014 13:37:16 -0700
> 
> Eli Zaretskii <eliz@gnu.org> writes:
> 
> >> From: Doug Evans <xdje42@gmail.com>
> >> Date: Wed, 21 May 2014 12:22:20 -0700
> >> 
> >> This patch adds guile progspace support.
> >
> > Thanks.
> >
> >> +@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.
> >
> > I guess this is the file name of the executable program running in the
> > progspace?  If so, why not tell that explicitly?  This text as written
> > begs the question what file is named by that string.  Also, is the
> > file absolute, relative, something else?  Is it just the value of
> > argv[0] in that program?  Etc. etc.
> 
> How about this?
> 
> +@deffn {Scheme Procedure} progspace-filename progspace
> +Return the file name of @var{progspace} as a string,
> +as an absolute path.
> +This is the name of 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

Allow me a slight rewording of the 1st sentence:

  Return the absolute file name of @var{progspace} as a string.

Also, "the name of the file" ("the" is missing).

Otherwise, OK.  Thanks.

Patch

diff --git a/gdb/Makefile.in b/gdb/Makefile.in
index f2c16ec..51aeeb3 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/guile.texi b/gdb/doc/guile.texi
index 56d817e..799e27c 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
@@ -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
 
diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h
index f95f092..8b9d0be 100644
--- a/gdb/guile/guile-internal.h
+++ b/gdb/guile/guile-internal.h
@@ -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);
diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
index f2fd8d8..51919de 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 f12769e..1aeb9d9 100644
--- a/gdb/guile/lib/gdb.scm
+++ b/gdb/guile/lib/gdb.scm
@@ -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
diff --git a/gdb/guile/lib/gdb/printing.scm b/gdb/guile/lib/gdb/printing.scm
index 2944702..eac9417 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 1b9902f4..fb62d9f 100644
--- a/gdb/guile/scm-pretty-print.c
+++ b/gdb/guile/scm-pretty-print.c
@@ -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.
diff --git a/gdb/guile/scm-progspace.c b/gdb/guile/scm-progspace.c
new file mode 100644
index 0000000..e329b3a
--- /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 <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);
+}
diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.exp b/gdb/testsuite/gdb.guile/scm-pretty-print.exp
index cd3ae95..555d751 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=<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"
diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.scm b/gdb/testsuite/gdb.guile/scm-pretty-print.scm
index a42527c..26c0093 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 0000000..0034449
--- /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 <http://www.gnu.org/licenses/>.  */
+
+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 0000000..5ec2afe
--- /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 <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}>"