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.

5 files changed, 206 insertions, 19 deletions

diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog
index f4d59cf..718ce24 100644
--- a/gdb/testsuite/ChangeLog
+++ b/gdb/testsuite/ChangeLog
@@ -1,3 +1,19 @@
+2014-06-02  Doug Evans  <xdje42@gmail.com>
+
+	* 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  <palves@redhat.com>
 
 	* 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 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}>"