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.

6 files changed, 467 insertions, 9 deletions

diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h
index ff891b5..9f6a886 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 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 abc4a67..646ca81 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 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 6aa9119..e20da68 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 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);
+}