aboutsummaryrefslogtreecommitdiff
path: root/gdb/testsuite/gdb.guile
diff options
context:
space:
mode:
Diffstat (limited to 'gdb/testsuite/gdb.guile')
-rw-r--r--gdb/testsuite/gdb.guile/scm-pretty-print.exp12
-rw-r--r--gdb/testsuite/gdb.guile/scm-pretty-print.scm83
-rw-r--r--gdb/testsuite/gdb.guile/scm-progspace.c22
-rw-r--r--gdb/testsuite/gdb.guile/scm-progspace.exp92
4 files changed, 190 insertions, 19 deletions
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}>"
generated by cgit v1.1 at 2024-11-27 05:02:06 +0000