Hi Doug!
A bunch of nits, for you to address or not as you choose :)
On Wed 01 Apr 2015 08:25, Doug Evans <xdje42@gmail.com> writes:
> diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
> index 4abf5c5..5975472 100644
> --- a/gdb/guile/guile.c
> +++ b/gdb/guile/guile.c
> @@ -704,6 +705,15 @@ call_initialize_gdb_module (void *data)
> performed within the desired module. */
> scm_c_define_module (gdbscm_module_name, initialize_gdb_module, NULL);
>
> + /* Now that the (gdb) module is defined we can do the rest of Scheme
> + initialization. */
> + {
> + SCM finish_init = scm_c_public_lookup (gdbscm_init_module_name,
> + finish_init_func_name);
> +
> + scm_call_0 (scm_variable_ref (finish_init));
> + }
> +
> #if HAVE_GUILE_MANUAL_FINALIZATION
> scm_run_finalizers ();
> #endif
Here you can use scm_c_public_ref. "scm_c_public_ref (X, Y)" is the
same as "scm_variable_ref (scm_c_public_lookup (X, Y))".
> diff --git a/gdb/guile/lib/gdb/command-trio.scm b/gdb/guile/lib/gdb/command-trio.scm
> new file mode 100644
> index 0000000..5621121
> --- /dev/null
> +++ b/gdb/guile/lib/gdb/command-trio.scm
> @@ -0,0 +1,230 @@
> +(define-module (gdb command-trio)
> + #:use-module ((gdb) #:select (throw-user-error
> + string->argv
Side note: are we using tabs consciously? If not, the usual thing is to
use spaces, as it makes it easier to copy-paste definitions into a
console without causing tab completion to happen. If that's a possible
change, it's probably worth adding a .dir-locals.el addition.
> +(define-public (register-guile-command-trio!
> + cmd-name cmd-class
> + global-iterator progspace-iterator objfile-iterator
> + get-name-func get-enabled-func set-enabled-func
> + info-doc enable-doc disable-doc)
WDYT about changing these the "-func" names to get-name, get-enabled,
and set-enabled! ? That way their uses are clearer; something like:
(get-name-func x)
makes me think that the result is a name-func.
I also think that the iterators are not really idiomatic. As they are,
they should probably be named "for-each/global", "for-each/progspace"
etc because really they do a for-each on the lists; but it would be
better to express them as folds so that you can return a value if
needed. More comments below.
> + "Register info/enable/disable commands for CMD-NAME.
> +
> +INFO-DOC, ENABLE-DOC, DISABLE-DOC are the first sentence of the doc string
> +for their commands.
> +
> +Note: CMD-NAME must not be the plural form. We compute the plural form
> +in verbose output."
> +
> + (define (do-one doer name-re object arg count)
> + (if (re-match? name-re (get-name-func object))
> + (begin
> + (doer object arg)
> + (set-car! count (+ (car count) 1)))))
Single-arm "if" statements are usually better written with "when" or
"unless", especially if the body has a "begin". In this case:
(when (re-match? name-re (get-name-func object))
(doer object arg)
(set-car! count (+ (car count) 1)))
Incidentally "doer" is not a great name ;-) As a generic name "proc" is
better but not by much.
> + (define (do-locus iterator locus print-title name-re doer arg)
> + (let ((count (cons 0 0)))
> + (iterator locus name-re count-matching arg count)
> + (if (> (car count) 0)
> + (begin
> + (print-title)
> + (set! count (cons 0 0))
> + (iterator locus name-re doer arg count)))))
Regarding folds; how about:
(define (fold-matching-objects fold-objects locus name-re f seed)
(define (fold-matching object seed)
(if (re-match? name-re (get-name object))
(f object seed)
seed))
(fold-objects locus fold-matching seed))
(define (for-each-object fold-objects locus print-title name-re proc arg)
(match (fold-matching-objects fold-objects locus name-re cons '())
(()
;; No matching objects found.
*unspecified*)
(reversed-objects
(print-title)
(for-each (lambda (obj) (proc obj arg))
(reverse reversed-objects)))))
> + (define (print-info object name-re port count)
> + (do-one (lambda (object port)
> + (format port " ~a" (get-name-func object))
> + (if (not (get-enabled-func object))
> + (display " [disabled]" port))
> + (newline port))
> + name-re object port count))
See later use, but this can be simplified to:
(define (print-info object port)
(format port " ~a" (get-name object))
(unless (get-enabled object)
(display " [disabled]" port))
(newline port))
> +
> + (define (set-enabled! object name-re flag count)
> + (do-one set-enabled-func name-re object flag count))
> +
> + (define (count-matching object name-re ignore count)
> + (do-one (lambda (object arg) #f) name-re object ignore count))
> +
> + (define (re-match? regexp name)
> + (if regexp
> + (regexp-exec regexp name)
> + #t))
> +
> + (define (parse-args args)
> + (let loop ((argv (string->argv args))
> + (flags '()))
> + (cond ((eq? argv '())
> + (values flags #f #f))
> + ((string=? (string-take (car argv) 1) "-")
> + (loop (cdr argv) (cons (car argv) flags)))
> + ((> (length argv) 2)
> + (throw-user-error "too many args: ~a" args))
> + ((= (length argv) 2)
> + (values flags (car argv) (cadr argv)))
> + (else
> + (values flags (car argv) #f)))))
Better to use pattern matching to avoid meaningless cdaddring. You'd
have to import (ice-9 match).
(define (parse-args args)
(define (flag? str)
(string-prefix? "-" str))
(let loop ((argv (string->argv args)) (flags '()))
(match argv
(() (values flags #f #f))
(((? flag? flag) . argv)
(loop argv (cons flag flags)))
((locus)
(values flags locus #f))
((locus name)
(values flags locus name))
(_ (throw-user-error "too many args: ~a" args)))))
> + (define (print-all-info args)
> + (define-values (flags locus name) (parse-args args))
> + (let ((locus-re (and locus (make-regexp locus)))
> + (name-re (and name (make-regexp name)))
> + (port (current-output-port)))
> + (if (not (eq? flags '()))
> + (throw-user-error "unrecognized flag: ~a" (car flags)))
> + (if (re-match? locus-re "global")
> + (do-locus global-iterator #f
> + (lambda () (display "Global:\n"))
> + name-re print-info port))
(for-each-object fold-objects/global #f
(lambda () (display "Global:\n"))
name-re print-info port)
> + (if (re-match? locus-re "progspace")
> + (do-locus progspace-iterator (current-progspace)
> + (lambda ()
> + (format port "Progspace ~a:\n"
> + (progspace-filename (current-progspace))))
> + name-re print-info port))
> + (for-each (lambda (objfile)
> + (if (re-match? locus-re (objfile-filename objfile))
> + (do-locus objfile-iterator objfile
> + (lambda ()
> + (format port "Objfile ~a:\n"
> + (objfile-filename objfile)))
> + name-re print-info port)))
> + (objfiles))
> + *unspecified*))
> +
> + (define (count-enabled! object name-re ignore count)
> + (if (get-enabled-func object)
> + (set-car! count (+ (car count) 1)))
> + (set-cdr! count (+ (cdr count) 1)))
> +
> + (define (count-all-enabled)
> + (let ((count (cons 0 0)))
> + (global-iterator #f #f count-enabled! #f count)
> + (progspace-iterator (current-progspace) #f count-enabled! #f count)
> + (for-each (lambda (objfile)
> + (objfile-iterator objfile #f count-enabled! #f count))
> + (objfiles))
> + count))
Really here we want a two-valued fold; oh well.
(define (count-all-enabled)
(define (add-count object count)
(match count
((enabled . total)
(cons (+ enabled (if (get-enabled object) 1 0))
(+ total 1)))))
(define (visit-locus folder locus count)
(folder locus add-count count))
(let* ((count (cons 0 0))
(count (visit-locus fold-objects/global #f count))
(count (visit-locus fold-objects/progspace (current-progspace) count)))
;; SRFI-1 fold has its arguments reversed, oddly.
(fold (lambda (objfile count)
(visit-locus fold-objects/objfile objfile count))
count
(objfiles))))
Why are there three iterators? Is it not sufficient to have the
iterator test whether the argument is #f, a progspace, or an objfile?
If that were the case this could simplify to:
(define (count-all-enabled)
(define (add-count object count)
(match count
((enabled . total)
(cons (+ enabled (if (get-enabled object) 1 0))
(+ total 1)))))
(fold (lambda (locus count)
(fold-objects locus add-count count))
(cons 0 0)
(cons #f (current-progspace) (objfiles))))
> + (define (pluralize word count)
> + (if (= count 1)
> + word
> + (string-append word "s")))
Hmmmm :) I guess since the set of names is restricted this is fine.
We might as well use the facilities of "format" though:
(format #f "Disable filter~p" 3) => "Disable filters"
> + (define (summarize-enabled port setting orig-count new-count)
> + (let* ((change (- (car new-count) (car orig-count)))
Using "match" instead of cdaddring allows you to give a name to these
ad-hoc fields.
> diff --git a/gdb/guile/lib/gdb/command/pretty-printer.scm b/gdb/guile/lib/gdb/command/pretty-printer.scm
> new file mode 100644
> index 0000000..dff333c
> --- /dev/null
> +++ b/gdb/guile/lib/gdb/command/pretty-printer.scm
> @@ -0,0 +1,65 @@
> +;; Pretty-printer commands.
> +;;
> +;; Copyright (C) 2015 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/>.
> +
> +(define-module (gdb command pretty-printer)
> + #:use-module ((gdb) #:select (COMMAND_DATA
> + pretty-printers
> + objfile-pretty-printers
> + progspace-pretty-printers
> + pretty-printer-name
> + pretty-printer-enabled?
> + set-pretty-printer-enabled!))
> + #:use-module (gdb command-trio))
> +
> +(define (global-iterator locus name-re doer arg count)
> + (for-each (lambda (printer)
> + (doer printer name-re arg count))
> + (pretty-printers))
> + *unspecified*)
> +
> +(define (progspace-iterator pspace name-re doer arg count)
> + (for-each (lambda (printer)
> + (doer printer name-re arg count))
> + (progspace-pretty-printers pspace))
> + *unspecified*)
> +
> +(define (objfile-iterator objfile name-re doer arg count)
> + (for-each (lambda (printer)
> + (doer printer name-re arg count))
> + (objfile-pretty-printers objfile))
> + *unspecified*)
(use-modules ((srfi srfi-1) #:select (fold)))
(define (fold-pretty-printers locus proc seed)
(match locus
(#f ; Global.
(fold proc seed (pretty-printers)))
((? progspace?)
(fold proc seed (progspace-pretty-printers locus)))
((? objfile?)
(fold proc seed (objfile-pretty-printers locus)))))
> +
> +(define (get-name-func printer)
> + (pretty-printer-name printer))
> +
> +(define (get-enabled-func printer)
> + (pretty-printer-enabled? printer))
> +
> +(define (set-enabled-func printer flag)
> + (set-pretty-printer-enabled! printer flag))
I would just pass pretty-printer-name, etc as values to
register-guile-command-trio!.
> +
> +(define-public (%install-pretty-printer-commands!)
> + (register-guile-command-trio!
> + "pretty-printer" COMMAND_DATA
> + global-iterator progspace-iterator objfile-iterator
> + get-name-func get-enabled-func set-enabled-func
> + "List all registered Guile pretty-printers."
> + "Enable the specified Guile pretty-printers."
> + "Disable the specified Guile pretty-printers.")
> + *unspecified*)
> diff --git a/gdb/guile/lib/gdb/init-gdb.scm b/gdb/guile/lib/gdb/init-gdb.scm
I only got up to here, but figured this might be useful to you. Happy
hacking!
Andy
@@ -86,20 +86,26 @@ GUILE_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(GUILE_DIR)
GUILE_SOURCE_FILES = \
./gdb.scm \
gdb/boot.scm \
+ gdb/command-trio.scm \
gdb/experimental.scm \
+ gdb/init-gdb.scm \
gdb/init.scm \
gdb/iterator.scm \
gdb/printing.scm \
gdb/support.scm \
- gdb/types.scm
+ gdb/types.scm \
+ gdb/command/pretty-printer.scm
GUILE_COMPILED_FILES = \
./gdb.go \
+ gdb/command-trio.go \
gdb/experimental.go \
+ gdb/init.go \
gdb/iterator.go \
gdb/printing.go \
gdb/support.go \
- gdb/types.go
+ gdb/types.go \
+ gdb/command/pretty-printer.go
@HAVE_GUILE_TRUE@GUILE_FILES = $(GUILE_SOURCE_FILES) $(GUILE_COMPILED_FILES)
@HAVE_GUILE_FALSE@GUILE_FILES =
@@ -117,7 +117,6 @@ scm_new_smob (scm_t_bits tc, scm_t_bits data)
#define FUNC_NAME __func__
extern const char gdbscm_module_name[];
-extern const char gdbscm_init_module_name[];
extern int gdb_scheme_initialized;
@@ -117,10 +117,13 @@ static SCM to_string_keyword;
/* The name of the various modules (without the surrounding parens). */
const char gdbscm_module_name[] = "gdb";
-const char gdbscm_init_module_name[] = "gdb";
+static const char gdbscm_init_module_name[] = "gdb init";
/* The name of the bootstrap file. */
-static const char boot_scm_filename[] = "boot.scm";
+static const char boot_scm_file_name[] = "boot.scm";
+
+/* The name of the function that finished Scheme-side initialization. */
+static const char finish_init_func_name[] = "%finish-init!";
/* The interface between gdb proper and loading of python scripts. */
@@ -630,7 +633,7 @@ initialize_scheme_side (void)
guile_datadir = concat (gdb_datadir, SLASH_STRING, "guile", NULL);
boot_scm_path = concat (guile_datadir, SLASH_STRING, "gdb",
- SLASH_STRING, boot_scm_filename, NULL);
+ SLASH_STRING, boot_scm_file_name, NULL);
scm_c_catch (SCM_BOOL_T, boot_guile_support, boot_scm_path,
handle_boot_error, boot_scm_path, NULL, NULL);
@@ -639,7 +642,6 @@ initialize_scheme_side (void)
}
/* Install the gdb scheme module.
- The result is a boolean indicating success.
If initializing the gdb module fails an error message is printed.
Note: This function runs in the context of the gdb module. */
@@ -693,8 +695,7 @@ initialize_gdb_module (void *data)
gdb_scheme_initialized = 1;
}
-/* Utility to call scm_c_define_module+initialize_gdb_module from
- within scm_with_guile. */
+/* Utility to initialize GDB+Guile from within scm_with_guile. */
static void *
call_initialize_gdb_module (void *data)
@@ -704,6 +705,15 @@ call_initialize_gdb_module (void *data)
performed within the desired module. */
scm_c_define_module (gdbscm_module_name, initialize_gdb_module, NULL);
+ /* Now that the (gdb) module is defined we can do the rest of Scheme
+ initialization. */
+ {
+ SCM finish_init = scm_c_public_lookup (gdbscm_init_module_name,
+ finish_init_func_name);
+
+ scm_call_0 (scm_variable_ref (finish_init));
+ }
+
#if HAVE_GUILE_MANUAL_FINALIZATION
scm_run_finalizers ();
#endif
@@ -316,6 +316,7 @@
make-pretty-printer
pretty-printer?
+ pretty-printer-name
pretty-printer-enabled?
set-pretty-printer-enabled!
make-pretty-printer-worker
@@ -495,7 +496,7 @@
;; Load the rest of the Scheme side.
-(include "gdb/init.scm")
+(include "gdb/init-gdb.scm")
;; These come from other files, but they're really part of this module.
new file mode 100644
@@ -0,0 +1,230 @@
+;; Utilities for the standard info/enable/disable command trio.
+;;
+;; Copyright (C) 2015 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/>.
+
+;; This module exports one function: register-guile-command-trio!
+;; See its doc string for details.
+
+(define-module (gdb command-trio)
+ #:use-module ((gdb) #:select (throw-user-error
+ string->argv
+ current-progspace
+ progspace-filename
+ objfiles
+ objfile-filename
+ make-command
+ register-command!)))
+
+(define-public (register-guile-command-trio!
+ cmd-name cmd-class
+ global-iterator progspace-iterator objfile-iterator
+ get-name-func get-enabled-func set-enabled-func
+ info-doc enable-doc disable-doc)
+ "Register info/enable/disable commands for CMD-NAME.
+
+INFO-DOC, ENABLE-DOC, DISABLE-DOC are the first sentence of the doc string
+for their commands.
+
+Note: CMD-NAME must not be the plural form. We compute the plural form
+in verbose output."
+
+ (define (do-one doer name-re object arg count)
+ (if (re-match? name-re (get-name-func object))
+ (begin
+ (doer object arg)
+ (set-car! count (+ (car count) 1)))))
+
+ (define (do-locus iterator locus print-title name-re doer arg)
+ (let ((count (cons 0 0)))
+ (iterator locus name-re count-matching arg count)
+ (if (> (car count) 0)
+ (begin
+ (print-title)
+ (set! count (cons 0 0))
+ (iterator locus name-re doer arg count)))))
+
+ (define (print-info object name-re port count)
+ (do-one (lambda (object port)
+ (format port " ~a" (get-name-func object))
+ (if (not (get-enabled-func object))
+ (display " [disabled]" port))
+ (newline port))
+ name-re object port count))
+
+ (define (set-enabled! object name-re flag count)
+ (do-one set-enabled-func name-re object flag count))
+
+ (define (count-matching object name-re ignore count)
+ (do-one (lambda (object arg) #f) name-re object ignore count))
+
+ (define (re-match? regexp name)
+ (if regexp
+ (regexp-exec regexp name)
+ #t))
+
+ (define (parse-args args)
+ (let loop ((argv (string->argv args))
+ (flags '()))
+ (cond ((eq? argv '())
+ (values flags #f #f))
+ ((string=? (string-take (car argv) 1) "-")
+ (loop (cdr argv) (cons (car argv) flags)))
+ ((> (length argv) 2)
+ (throw-user-error "too many args: ~a" args))
+ ((= (length argv) 2)
+ (values flags (car argv) (cadr argv)))
+ (else
+ (values flags (car argv) #f)))))
+
+ (define (print-all-info args)
+ (define-values (flags locus name) (parse-args args))
+ (let ((locus-re (and locus (make-regexp locus)))
+ (name-re (and name (make-regexp name)))
+ (port (current-output-port)))
+ (if (not (eq? flags '()))
+ (throw-user-error "unrecognized flag: ~a" (car flags)))
+ (if (re-match? locus-re "global")
+ (do-locus global-iterator #f
+ (lambda () (display "Global:\n"))
+ name-re print-info port))
+ (if (re-match? locus-re "progspace")
+ (do-locus progspace-iterator (current-progspace)
+ (lambda ()
+ (format port "Progspace ~a:\n"
+ (progspace-filename (current-progspace))))
+ name-re print-info port))
+ (for-each (lambda (objfile)
+ (if (re-match? locus-re (objfile-filename objfile))
+ (do-locus objfile-iterator objfile
+ (lambda ()
+ (format port "Objfile ~a:\n"
+ (objfile-filename objfile)))
+ name-re print-info port)))
+ (objfiles))
+ *unspecified*))
+
+ (define (count-enabled! object name-re ignore count)
+ (if (get-enabled-func object)
+ (set-car! count (+ (car count) 1)))
+ (set-cdr! count (+ (cdr count) 1)))
+
+ (define (count-all-enabled)
+ (let ((count (cons 0 0)))
+ (global-iterator #f #f count-enabled! #f count)
+ (progspace-iterator (current-progspace) #f count-enabled! #f count)
+ (for-each (lambda (objfile)
+ (objfile-iterator objfile #f count-enabled! #f count))
+ (objfiles))
+ count))
+
+ (define (pluralize word count)
+ (if (= count 1)
+ word
+ (string-append word "s")))
+
+ (define (summarize-enabled port setting orig-count new-count)
+ (let* ((change (- (car new-count) (car orig-count)))
+ (abs-change (if setting change (- change))))
+ (format port "~a ~a ~a\n"
+ abs-change
+ (pluralize cmd-name abs-change)
+ (if setting "enabled" "disabled"))
+ (format port "~a of ~a ~a enabled\n"
+ (car new-count) (cdr new-count)
+ (pluralize cmd-name (cdr new-count)))))
+
+ (define (set-all-enabled! args setting)
+ (define-values (flags locus name) (parse-args args))
+ (let ((locus-re (and locus (make-regexp locus)))
+ (name-re (and name (make-regexp name)))
+ (port (current-output-port))
+ (verbose #f))
+ (for-each (lambda (flag)
+ (cond ((string=? flag "-v")
+ (set! verbose #t))
+ (else
+ (throw-user-error "unrecognized flag: ~a" flags))))
+ flags)
+ (let ((orig-count (count-all-enabled)))
+ (if (re-match? locus-re "global")
+ (do-locus global-iterator #f (lambda () #f)
+ name-re set-enabled! setting))
+ (if (re-match? locus-re "progspace")
+ (do-locus progspace-iterator (current-progspace) (lambda () #f)
+ name-re set-enabled! setting))
+ (for-each (lambda (objfile)
+ (if (re-match? locus-re (objfile-filename objfile))
+ (do-locus objfile-iterator objfile (lambda () #f)
+ name-re set-enabled! setting)))
+ (objfiles))
+ (if verbose
+ (summarize-enabled port setting orig-count (count-all-enabled)))))
+ *unspecified*)
+
+ ;; End of internal utilities.
+
+ (register-command!
+ (make-command (string-append "info guile " cmd-name)
+ #:command-class cmd-class
+ #:invoke (lambda (self arg from-tty)
+ (print-all-info arg))
+ #:doc (string-append info-doc "
+
+ Usage: info guile " cmd-name " [object-regexp [name-regexp]]
+
+ OBJECT-REGEXP is a regular expression matching the objects to list.
+ Objects are \"global\", \"progspace\", and the objfiles within
+ that program space.
+
+ NAME-REGEXP matches the name of the " cmd-name ".")))
+
+ (register-command!
+ (make-command (string-append "enable guile " cmd-name)
+ #:command-class cmd-class
+ #:invoke (lambda (self arg from-tty)
+ (set-all-enabled! arg #t))
+ #:doc (string-append enable-doc "
+
+ Usage: enable guile " cmd-name " [-v] [object-regexp [name-regexp]]
+
+ -v: Be verbose.
+
+ OBJECT-REGEXP is a regular expression matching the objects to examine.
+ Objects are \"global\", \"progspace\", and the objfiles within
+ that program space.
+
+ NAME-REGEXP matches the name of the " cmd-name ".")))
+
+ (register-command!
+ (make-command (string-append "disable guile " cmd-name)
+ #:command-class cmd-class
+ #:invoke (lambda (self arg from-tty)
+ (set-all-enabled! arg #f))
+ #:doc (string-append disable-doc "
+
+ Usage: disable guile " cmd-name " [-v] [object-regexp [name-regexp]]
+
+ -v: Be verbose.
+
+ OBJECT-REGEXP is a regular expression matching the objects to examine.
+ Objects are \"global\", \"progspace\", and the objfiles within
+ that program space.
+
+ NAME-REGEXP matches the name of the " cmd-name ".")))
+
+ *unspecified*)
new file mode 100644
@@ -0,0 +1,65 @@
+;; Pretty-printer commands.
+;;
+;; Copyright (C) 2015 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/>.
+
+(define-module (gdb command pretty-printer)
+ #:use-module ((gdb) #:select (COMMAND_DATA
+ pretty-printers
+ objfile-pretty-printers
+ progspace-pretty-printers
+ pretty-printer-name
+ pretty-printer-enabled?
+ set-pretty-printer-enabled!))
+ #:use-module (gdb command-trio))
+
+(define (global-iterator locus name-re doer arg count)
+ (for-each (lambda (printer)
+ (doer printer name-re arg count))
+ (pretty-printers))
+ *unspecified*)
+
+(define (progspace-iterator pspace name-re doer arg count)
+ (for-each (lambda (printer)
+ (doer printer name-re arg count))
+ (progspace-pretty-printers pspace))
+ *unspecified*)
+
+(define (objfile-iterator objfile name-re doer arg count)
+ (for-each (lambda (printer)
+ (doer printer name-re arg count))
+ (objfile-pretty-printers objfile))
+ *unspecified*)
+
+(define (get-name-func printer)
+ (pretty-printer-name printer))
+
+(define (get-enabled-func printer)
+ (pretty-printer-enabled? printer))
+
+(define (set-enabled-func printer flag)
+ (set-pretty-printer-enabled! printer flag))
+
+(define-public (%install-pretty-printer-commands!)
+ (register-guile-command-trio!
+ "pretty-printer" COMMAND_DATA
+ global-iterator progspace-iterator objfile-iterator
+ get-name-func get-enabled-func set-enabled-func
+ "List all registered Guile pretty-printers."
+ "Enable the specified Guile pretty-printers."
+ "Disable the specified Guile pretty-printers.")
+ *unspecified*)
new file mode 100644
@@ -0,0 +1,174 @@
+;; Scheme side initialization of the gdb module.
+;;
+;; Copyright (C) 2014-2015 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/>.
+
+;; This file is included by (gdb).
+;; Note: You can't refer to any gdb modules yet: The gdb module won't be
+;; fully defined until after we're done.
+
+;; The original i/o ports. In case the user wants them back.
+(define %orig-input-port #f)
+(define %orig-output-port #f)
+(define %orig-error-port #f)
+
+;; Keys for GDB-generated exceptions.
+;; gdb:with-stack is handled separately.
+
+(define %exception-keys '(gdb:error
+ gdb:invalid-object-error
+ gdb:memory-error
+ gdb:pp-type-error
+ gdb:user-error))
+
+;; Printer for gdb exceptions, used when Scheme tries to print them directly.
+
+(define (%exception-printer port key args default-printer)
+ (apply (case-lambda
+ ((subr msg args . rest)
+ (if subr
+ (format port "In procedure ~a: " subr))
+ (apply format port msg (or args '())))
+ (_ (default-printer)))
+ args))
+
+;; Print the message part of a gdb:with-stack exception.
+;; The arg list is the way it is because it's passed to set-exception-printer!.
+;; We don't print a backtrace here because Guile will have already printed a
+;; backtrace.
+
+(define (%with-stack-exception-printer port key args default-printer)
+ (let ((real-key (car args))
+ (real-args (cddr args)))
+ (%exception-printer port real-key real-args default-printer)))
+
+;; Copy of Guile's print-exception that tweaks the output for our purposes.
+
+(define (%print-exception-message-worker port key args)
+ (define (default-printer)
+ (format port "Throw to key `~a' with args `~s'." key args))
+ (format port "ERROR: ")
+ ;; Pass #t for tag to catch all errors.
+ (catch #t
+ (lambda ()
+ (%exception-printer port key args default-printer))
+ (lambda (k . args)
+ (format port "Error while printing gdb exception: ~a ~s."
+ k args)))
+ ;; Don't print a newline for user errors as gdb will print one too, and
+ ;; the blank line is inconsistent with non-Guile-implemented gdb commands.
+ (if (not (eq? key 'gdb:user-error))
+ (newline port))
+ (force-output port))
+
+;; Called from the C code to print an exception.
+;; Guile prints them a little differently than we want.
+;; See boot-9.scm:print-exception.
+
+(define (%print-exception-message port frame key args)
+ (cond ((memq key %exception-keys)
+ (%print-exception-message-worker port key args))
+ (else
+ (print-exception port frame key args)))
+ *unspecified*)
+
+;; Called from the C code to print an exception according to the setting
+;; of "guile print-stack".
+;;
+;; If PORT is #f, use the standard error port.
+;; If STACK is #f, never print the stack, regardless of whether printing it
+;; is enabled. If STACK is #t, then print it if it is contained in ARGS
+;; (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
+;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
+;; KEY is gdb:with-stack).
+;; KEY, ARGS are the standard arguments to scm_throw, et.al.
+
+(define (%print-exception-with-stack port stack key args)
+ (let ((style (%exception-print-style)))
+ (if (not (eq? style 'none))
+ (let ((error-port (current-error-port))
+ (frame #f))
+ (if (not port)
+ (set! port error-port))
+ (if (eq? port error-port)
+ (begin
+ (force-output (current-output-port))
+ ;; In case the current output port is not gdb's output port.
+ (force-output (output-port))))
+
+ ;; If the exception is gdb:with-stack, unwrap it to get the stack and
+ ;; underlying exception. If the caller happens to pass in a stack,
+ ;; we ignore it and use the one in ARGS instead.
+ (if (eq? key 'gdb:with-stack)
+ (begin
+ (set! key (car args))
+ (if stack
+ (set! stack (cadr args)))
+ (set! args (cddr args))))
+
+ ;; If caller wanted a stack and there isn't one, disable backtracing.
+ (if (eq? stack #t)
+ (set! stack #f))
+ ;; At this point if stack is true, then it is assumed to be a stack.
+ (if stack
+ (set! frame (stack-ref stack 0)))
+
+ (if (and (eq? style 'full) stack)
+ (begin
+ ;; This is derived from libguile/throw.c:handler_message.
+ ;; We include "Guile" in "Guile Backtrace" whereas the Guile
+ ;; version does not so that tests can know it's us printing
+ ;; the backtrace. Plus it could help beginners.
+ (display "Guile Backtrace:\n" port)
+ (display-backtrace stack port #f #f '())
+ (newline port)))
+
+ (%print-exception-message port frame key args)))))
+
+;; Internal utility called during startup to initialize the Scheme side of
+;; GDB+Guile.
+
+(define (%initialize!)
+ (for-each (lambda (key)
+ (set-exception-printer! key %exception-printer))
+ %exception-keys)
+ (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
+
+ (set! %orig-input-port (set-current-input-port (input-port)))
+ (set! %orig-output-port (set-current-output-port (output-port)))
+ (set! %orig-error-port (set-current-error-port (error-port)))
+
+ *unspecified*)
+
+;; Dummy routine to silence "possibly unused local top-level variable"
+;; warnings from the compiler.
+
+(define-public (%silence-compiler-warnings%)
+ (list %print-exception-with-stack %initialize!))
+
+;; Public routines.
+
+(define-public (orig-input-port) %orig-input-port)
+(define-public (orig-output-port) %orig-output-port)
+(define-public (orig-error-port) %orig-error-port)
+
+;; Utility to throw gdb:user-error for use in writing gdb commands.
+;; The requirements for the arguments to "throw" are a bit obscure,
+;; so give the user something simpler.
+
+(define-public (throw-user-error message . args)
+ (throw 'gdb:user-error #f message args))
@@ -1,6 +1,6 @@
-;; Scheme side of the gdb module.
+;; Finish Scheme initialization
;;
-;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2015 Free Software Foundation, Inc.
;;
;; This file is part of GDB.
;;
@@ -17,152 +17,51 @@
;; 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 included by (gdb).
-
-;; The original i/o ports. In case the user wants them back.
-(define %orig-input-port #f)
-(define %orig-output-port #f)
-(define %orig-error-port #f)
-
-;; Keys for GDB-generated exceptions.
-;; gdb:with-stack is handled separately.
-
-(define %exception-keys '(gdb:error
- gdb:invalid-object-error
- gdb:memory-error
- gdb:pp-type-error
- gdb:user-error))
-
-;; Printer for gdb exceptions, used when Scheme tries to print them directly.
-
-(define (%exception-printer port key args default-printer)
- (apply (case-lambda
- ((subr msg args . rest)
- (if subr
- (format port "In procedure ~a: " subr))
- (apply format port msg (or args '())))
- (_ (default-printer)))
- args))
-
-;; Print the message part of a gdb:with-stack exception.
-;; The arg list is the way it is because it's passed to set-exception-printer!.
-;; We don't print a backtrace here because Guile will have already printed a
-;; backtrace.
-
-(define (%with-stack-exception-printer port key args default-printer)
- (let ((real-key (car args))
- (real-args (cddr args)))
- (%exception-printer port real-key real-args default-printer)))
-
-;; Copy of Guile's print-exception that tweaks the output for our purposes.
-;; TODO: It's not clear the tweaking is still necessary.
-
-(define (%print-exception-message-worker port key args)
- (define (default-printer)
- (format port "Throw to key `~a' with args `~s'." key args))
- (format port "ERROR: ")
- ;; Pass #t for tag to catch all errors.
- (catch #t
- (lambda ()
- (%exception-printer port key args default-printer))
- (lambda (k . args)
- (format port "Error while printing gdb exception: ~a ~s."
- k args)))
- (newline port)
- (force-output port))
-
-;; Called from the C code to print an exception.
-;; Guile prints them a little differently than we want.
-;; See boot-9.scm:print-exception.
-
-(define (%print-exception-message port frame key args)
- (cond ((memq key %exception-keys)
- (%print-exception-message-worker port key args))
- (else
- (print-exception port frame key args)))
+(define-module (gdb init)
+ #:use-module ((gdb) #:select (register-command!
+ make-command
+ COMMAND_OBSCURE))
+ #:use-module (gdb command pretty-printer))
+
+;; Install the guile command prefixes:
+;; info guile ...
+;; enable guile ...
+;; disable guile ...
+
+(define (%install-guile-prefix-commands!)
+ (register-command!
+ (make-command
+ "info guile"
+ #:command-class COMMAND_OBSCURE
+ #:prefix? #t
+ #:invoke (lambda (self arg from-tty)
+ ;; TODO: Call a gdb-provided function to print the list.
+ (display "Provide an \"info guile\" subcommand.\n"))
+ #:doc "Print info on various Guile-implemented objects."))
+ (register-command!
+ (make-command
+ "enable guile"
+ #:command-class COMMAND_OBSCURE
+ #:prefix? #t
+ #:invoke (lambda (self arg from-tty)
+ ;; TODO: Call a gdb-provided function to print the list.
+ (display "Provide an \"enable guile\" subcommand.\n"))
+ #:doc "Enable the specified Guile-implemented objects."))
+ (register-command!
+ (make-command
+ "disable guile"
+ #:command-class COMMAND_OBSCURE
+ #:prefix? #t
+ #:invoke (lambda (self arg from-tty)
+ ;; TODO: Call a gdb-provided function to print the list.
+ (display "Provide a \"disable guile\" subcommand.\n"))
+ #:doc "Disable the specified Guile-implemented objects."))
*unspecified*)
-;; Called from the C code to print an exception according to the setting
-;; of "guile print-stack".
-;;
-;; If PORT is #f, use the standard error port.
-;; If STACK is #f, never print the stack, regardless of whether printing it
-;; is enabled. If STACK is #t, then print it if it is contained in ARGS
-;; (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
-;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
-;; KEY is gdb:with-stack).
-;; KEY, ARGS are the standard arguments to scm_throw, et.al.
-
-(define (%print-exception-with-stack port stack key args)
- (let ((style (%exception-print-style)))
- (if (not (eq? style 'none))
- (let ((error-port (current-error-port))
- (frame #f))
- (if (not port)
- (set! port error-port))
- (if (eq? port error-port)
- (begin
- (force-output (current-output-port))
- ;; In case the current output port is not gdb's output port.
- (force-output (output-port))))
+;; Finish Scheme side initialization.
+;; This is called from C.
- ;; If the exception is gdb:with-stack, unwrap it to get the stack and
- ;; underlying exception. If the caller happens to pass in a stack,
- ;; we ignore it and use the one in ARGS instead.
- (if (eq? key 'gdb:with-stack)
- (begin
- (set! key (car args))
- (if stack
- (set! stack (cadr args)))
- (set! args (cddr args))))
-
- ;; If caller wanted a stack and there isn't one, disable backtracing.
- (if (eq? stack #t)
- (set! stack #f))
- ;; At this point if stack is true, then it is assumed to be a stack.
- (if stack
- (set! frame (stack-ref stack 0)))
-
- (if (and (eq? style 'full) stack)
- (begin
- ;; This is derived from libguile/throw.c:handler_message.
- ;; We include "Guile" in "Guile Backtrace" whereas the Guile
- ;; version does not so that tests can know it's us printing
- ;; the backtrace. Plus it could help beginners.
- (display "Guile Backtrace:\n" port)
- (display-backtrace stack port #f #f '())
- (newline port)))
-
- (%print-exception-message port frame key args)))))
-
-;; Internal utility called during startup to initialize the Scheme side of
-;; GDB+Guile.
-
-(define (%initialize!)
- (for-each (lambda (key)
- (set-exception-printer! key %exception-printer))
- %exception-keys)
- (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
-
- (set! %orig-input-port (set-current-input-port (input-port)))
- (set! %orig-output-port (set-current-output-port (output-port)))
- (set! %orig-error-port (set-current-error-port (error-port))))
-
-;; Dummy routine to silence "possibly unused local top-level variable"
-;; warnings from the compiler.
-
-(define-public (%silence-compiler-warnings%)
- (list %print-exception-with-stack %initialize!))
-
-;; Public routines.
-
-(define-public (orig-input-port) %orig-input-port)
-(define-public (orig-output-port) %orig-output-port)
-(define-public (orig-error-port) %orig-error-port)
-
-;; Utility to throw gdb:user-error for use in writing gdb commands.
-;; The requirements for the arguments to "throw" are a bit obscure,
-;; so give the user something simpler.
-
-(define-public (throw-user-error message . args)
- (throw 'gdb:user-error #f message args))
+(define-public (%finish-init!)
+ (%install-guile-prefix-commands!)
+ (%install-pretty-printer-commands!)
+ *unspecified*)
@@ -18,18 +18,15 @@
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define-module (gdb printing)
- #:use-module ((gdb) #:select
- (pretty-printer? objfile? progspace?
- pretty-printers set-pretty-printers!
- objfile-pretty-printers set-objfile-pretty-printers!
- progspace-pretty-printers set-progspace-pretty-printers!))
- #:use-module (gdb support))
+ #:use-module (gdb)
+ #:use-module (gdb support)
+ #:use-module (ice-9 format))
(define-public (prepend-pretty-printer! obj matcher)
"Add MATCHER to the beginning of the pretty-printer list for OBJ.
If OBJ is #f, add MATCHER to the global list."
- (assert-type (pretty-printer? matcher) matcher SCM_ARG1
- 'prepend-pretty-printer! "pretty-printer")
+ (assert-type (pretty-printer? matcher)
+ matcher SCM_ARG1 'prepend-pretty-printer! "pretty-printer")
(cond ((eq? obj #f)
(set-pretty-printers! (cons matcher (pretty-printers))))
((objfile? obj)
@@ -45,8 +42,8 @@ If OBJ is #f, add MATCHER to the global list."
(define-public (append-pretty-printer! obj matcher)
"Add MATCHER to the end of the pretty-printer list for OBJ.
If OBJ is #f, add MATCHER to the global list."
- (assert-type (pretty-printer? matcher) matcher SCM_ARG1
- 'append-pretty-printer! "pretty-printer")
+ (assert-type (pretty-printer? matcher)
+ matcher SCM_ARG1 'append-pretty-printer! "pretty-printer")
(cond ((eq? obj #f)
(set-pretty-printers! (append! (pretty-printers) (list matcher))))
((objfile? obj)
@@ -58,3 +55,37 @@ If OBJ is #f, add MATCHER to the global list."
(else
(assert-type #f obj SCM_ARG1 'append-pretty-printer!
"#f, objfile, or progspace"))))
+
+(define-public (enum-type->flag-list enum-type)
+ "Helper function for pretty-print-enum.
+Return the flag-list arg needed by pretty-print-flag-enum from ENUM-TYPE."
+ (assert-type (and (type? enum-type)
+ (= (type-code enum-type) TYPE_CODE_ENUM))
+ enum-type SCM_ARG1 'enum-type->flag-list "enum <gdb:type>")
+ (let ((fields (map (lambda (field) (cons (field-name field)
+ (field-enumval field)))
+ (type-fields enum-type))))
+ ;; Output is generally more readable if bits are sorted.
+ (sort fields (lambda (a b) (< (cdr a) (cdr b))))))
+
+(define-public (pretty-print-flag-enum flag-list value)
+ "Print VALUE which is a collection of bits defined by FLAG-LIST.
+FLAG-LIST is a list of (name . value) pairs.
+Returns a string of the form (FLAG1_NAME | FLAG2_NAME | ...)"
+ (assert-type (list? flag-list)
+ flag-list SCM_ARG1 'pretty-print-flag-enum "list")
+ (assert-type (or (integer? value) (value? value))
+ value SCM_ARG2 'pretty-print-flag-enum "integer or <gdb:value>")
+ (let* ((value (if (integer? value) value (value->integer value)))
+ (flags (filter (lambda (flag)
+ (= (logand value (cdr flag)) (cdr flag)))
+ flag-list))
+ (all-present-names (map car flags))
+ (all-present-bits (apply logior (map cdr flags)))
+ (remaining (logand value (lognot all-present-bits)))
+ (all-names (if (= remaining 0)
+ all-present-names
+ (append all-present-names
+ (list (format #f "<unknown: 0x~x>"
+ remaining))))))
+ (format #f "(~a)" (string-join all-names " | "))))
@@ -482,7 +482,7 @@ gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args)
if (gdbscm_is_false (percent_print_exception_message_var))
{
percent_print_exception_message_var
- = scm_c_private_variable (gdbscm_init_module_name,
+ = scm_c_private_variable (gdbscm_module_name,
percent_print_exception_message_name);
/* If we can't find %print-exception-message, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
@@ -533,7 +533,7 @@ gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args)
if (gdbscm_is_false (percent_print_exception_with_stack_var))
{
percent_print_exception_with_stack_var
- = scm_c_private_variable (gdbscm_init_module_name,
+ = scm_c_private_variable (gdbscm_module_name,
percent_print_exception_with_stack_name);
/* If we can't find %print-exception-with-stack, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
@@ -211,6 +211,17 @@ ppscm_get_pretty_printer_smob_arg_unsafe (SCM self, int arg_pos,
/* Pretty-printer methods. */
+/* (pretty-printer-name <gdb:pretty-printer>) -> string */
+
+static SCM
+gdbscm_pretty_printer_name (SCM self)
+{
+ pretty_printer_smob *pp_smob
+ = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return pp_smob->name;
+}
+
/* (pretty-printer-enabled? <gdb:pretty-printer>) -> boolean */
static SCM
@@ -1068,6 +1079,10 @@ Create a <gdb:pretty-printer> object.\n\
"\
Return #t if the object is a <gdb:pretty-printer> object." },
+ { "pretty-printer-name", 1, 0, 0, gdbscm_pretty_printer_name,
+ "\
+Return the name of the pretty-printer." },
+
{ "pretty-printer-enabled?", 1, 0, 0, gdbscm_pretty_printer_enabled_p,
"\
Return #t if the pretty-printer is enabled." },
new file mode 100644
@@ -0,0 +1,116 @@
+;; Copyright (C) 2010-2015 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 guile pretty printer
+;; maintenance.
+
+(use-modules (gdb)
+ (gdb printing)
+ (ice-9 format))
+
+(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)
+ (pp_s-printer "" val))
+ #f))
+
+(define (make-pp_ss-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #f))
+
+(define (get-type-for-printing val)
+ "Return type of val, stripping away typedefs, etc."
+ (let ((type (value-type val)))
+ (if (= (type-code type) TYPE_CODE_REF)
+ (set! type (type-target type)))
+ (type-strip-typedefs (type-unqualified type))))
+
+(define (make-pretty-printer-dict)
+ (let ((dict (make-hash-table)))
+ (hash-set! dict "struct s" make-pp_s-printer)
+ (hash-set! dict "s" make-pp_s-printer)
+
+ (hash-set! dict "struct ss" make-pp_ss-printer)
+ (hash-set! dict "ss" make-pp_ss-printer)
+
+ dict))
+
+(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))))
+
+(append-pretty-printer! #f
+ (make-pretty-printer-from-dict
+ "s-ss-structs"
+ (make-pretty-printer-dict)
+ lookup-pretty-printer-maker-from-dict))
+
+(define (make-flag-enum-printer val type with-value)
+ "Pretty-print flag_enum VAL.
+If WITH_VALUE is true, include its hex value."
+ (make-pretty-printer-worker
+ #f
+ (let ((flag-list (enum-type->flag-list type)))
+ (lambda (printer)
+ (if with-value
+ (string-append (format #f "0x~x " (value->integer val))
+ (pretty-print-flag-enum flag-list val))
+ (pretty-print-flag-enum flag-list val))))
+ #f))
+
+(define (flag-enum-matcher-1 matcher val with-value)
+ (let* ((type (get-type-for-printing val))
+ (type-name (type-tag type)))
+ (and type-name
+ (string=? type-name "flag_enum")
+ (make-flag-enum-printer val type with-value))))
+
+(define (flag-enum-matcher matcher val)
+ (flag-enum-matcher-1 matcher val #f))
+
+(define (flag-enum-matcher-with-value matcher val)
+ (flag-enum-matcher-1 matcher val #t))
+
+(append-pretty-printer! (current-progspace)
+ (make-pretty-printer
+ "flag-enum"
+ flag-enum-matcher))
+
+(append-pretty-printer! (current-objfile)
+ (make-pretty-printer
+ "flag-enum-with-value"
+ flag-enum-matcher-with-value))
new file mode 100644
@@ -0,0 +1,65 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2015 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/>. */
+
+#include <string.h>
+
+enum flag_enum
+ {
+ FLAG_1 = 1,
+ FLAG_2 = 2,
+ FLAG_3 = 4,
+ ALL = FLAG_1 | FLAG_2 | FLAG_3
+ };
+
+enum flag_enum fval;
+
+struct s
+{
+ int a;
+ int *b;
+};
+
+struct ss
+{
+ struct s a;
+ struct s b;
+};
+
+void
+init_s (struct s *s, int a)
+{
+ s->a = a;
+ s->b = &s->a;
+}
+
+void
+init_ss (struct ss *s, int a, int b)
+{
+ init_s (&s->a, a);
+ init_s (&s->b, b);
+}
+
+int
+main ()
+{
+ struct ss ss;
+
+ init_ss (&ss, 1, 2);
+ fval = FLAG_1 | FLAG_3;
+
+ return 0; /* break to inspect */
+}
new file mode 100644
@@ -0,0 +1,199 @@
+# Copyright (C) 2010-2015 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 guile pretty printer
+# maintenance.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if {[prepare_for_testing $testfile.exp $testfile $srcfile debug]} {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+set remote_scheme_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}-gdb.in \
+ [standard_output_file ${testfile}-gdb.scm]]
+
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_test_no_output "set auto-load safe-path ${remote_scheme_file}" \
+ "set auto-load safe-path"
+gdb_load ${binfile}
+
+# Verify gdb loaded the script.
+gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*"
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+gdb_test "continue" ".*Breakpoint.*"
+
+set num_pp 3
+
+gdb_test "info guile pretty-printer" \
+ ".*Global.*s-ss-structs.*Progspace.*flag-enum.*${testfile}.*flag-enum-with-value"
+
+proc test_global { } {
+ global hex num_pp
+
+ gdb_test "info guile pretty-printer global .*s-ss" \
+ ".*Global.*s-ss-structs"
+
+ gdb_test "info guile pretty-printer .* s-ss" \
+ ".*Global.*s-ss-structs"
+
+ gdb_test "print ss" \
+ " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
+ "print ss enabled #1"
+
+ gdb_test "disable guile pretty-printer -v" \
+ "$num_pp pretty-printers disabled.*0 of $num_pp pretty-printers enabled"
+
+ gdb_test "enable guile pretty-printer -v" \
+ "$num_pp pretty-printers enabled.*$num_pp of $num_pp pretty-printers enabled"
+
+ gdb_test "disable guile pretty-printer -v global" \
+ "1 pretty-printer disabled.*[expr $num_pp - 1] of $num_pp pretty-printers enabled"
+
+ gdb_test "enable guile pretty-printer -v" \
+ "1 pretty-printer enabled.*$num_pp of $num_pp pretty-printers enabled"
+
+ gdb_test "disable guile pretty-printer -v global s-ss" \
+ "1 pretty-printer disabled.*[expr $num_pp - 1] of $num_pp pretty-printers enabled"
+
+ gdb_test "info guile pretty-printer global s-ss" \
+ {.*s-ss-structs \[disabled\]}
+
+ gdb_test "info guile pretty-printer .* s-ss" \
+ {.*s-ss-structs \[disabled\]}
+
+ gdb_test "print ss" \
+ " = {a = {a = 1, b = $hex}, b = {a = 2, b = $hex}}" \
+ "print ss disabled"
+
+ gdb_test "enable guile pretty-printer -v global s-ss" \
+ "1 pretty-printer enabled.*$num_pp of $num_pp pretty-printers enabled"
+
+ gdb_test "info guile pretty-printer .* s-ss" \
+ ".*s-ss-structs" \
+ "info guile pretty-printer .* s-ss, re-enabled"
+
+ gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
+ "print ss, re-enabled"
+}
+
+with_test_prefix global {
+ test_global
+}
+
+proc test_progspace { } {
+ global num_pp testfile
+
+ # First disable objfile version of flag_enum printer.
+ gdb_test "disable guile pretty-printer -v ${testfile}" \
+ "1 pretty-printer disabled.*[expr $num_pp - 1] of $num_pp pretty-printers enabled"
+
+ gdb_test "info guile pretty-printer progspace" \
+ ".*flag-enum"
+
+ gdb_test "print (enum flag_enum) (FLAG_1)" \
+ " = .FLAG_1." \
+ "print FLAG_1"
+
+ gdb_test "disable guile pretty-printer -v progspace" \
+ "1 pretty-printer disabled.*[expr $num_pp - 2] of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (FLAG_1)" \
+ " = FLAG_1" \
+ "print FLAG_1, disabled"
+
+ gdb_test "enable guile pretty-printer -v progspace" \
+ "1 pretty-printer enabled.*[expr $num_pp -1] of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (FLAG_1 | FLAG_3)" \
+ " = .FLAG_1 | FLAG_3." \
+ "print FLAG_1 | FLAG_3"
+
+ gdb_test "disable guile pretty-printer -v progspace flag-enum" \
+ "1 pretty-printer disabled.*[expr $num_pp - 2] of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (4 + 8)" \
+ " = 12" \
+ "print FLAG_3 | 8, disabled"
+
+ gdb_test "enable guile pretty-printer -v progspace flag-enum" \
+ "1 pretty-printer enabled.*[expr $num_pp - 1] of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (4 + 8)" \
+ " = .FLAG_3 | <unknown: 0x8>." \
+ "print FLAG_3 | 8"
+
+ gdb_test "enable guile pretty-printer -v ${testfile}" \
+ "1 pretty-printer enabled.*$num_pp of $num_pp pretty-printers enabled"
+}
+
+with_test_prefix progspace {
+ test_progspace
+}
+
+proc test_objfile { } {
+ global num_pp testfile
+
+ gdb_test "info guile pretty-printer ${testfile}" \
+ ".*flag-enum-with-value"
+
+ gdb_test "print (enum flag_enum) (FLAG_1)" \
+ " = 0x1 .FLAG_1." \
+ "print FLAG_1"
+
+ gdb_test "disable guile pretty-printer -v ${testfile}" \
+ "1 pretty-printer disabled.*[expr $num_pp - 1] of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (FLAG_1)" \
+ " = .FLAG_1." \
+ "print FLAG_1, disabled"
+
+ gdb_test "enable guile pretty-printer -v ${testfile}" \
+ "1 pretty-printer enabled.*$num_pp of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (FLAG_1 | FLAG_3)" \
+ " = 0x5 .FLAG_1 | FLAG_3." \
+ "print FLAG_1 | FLAG_3"
+
+ gdb_test "disable guile pretty-printer -v ${testfile} flag-enum-with-value" \
+ "1 pretty-printer disabled.*[expr $num_pp - 1] of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (4 + 8)" \
+ " = .FLAG_3 | <unknown: 0x8>." \
+ "print FLAG_3 | 8, disabled"
+
+ gdb_test "enable guile pretty-printer -v ${testfile} flag-enum-with-value" \
+ "1 pretty-printer enabled.*$num_pp of $num_pp pretty-printers enabled"
+
+ gdb_test "print (enum flag_enum) (4 + 8)" \
+ " = 0xc .FLAG_3 | <unknown: 0x8>." \
+ "print FLAG_3 | 8"
+}
+
+with_test_prefix objfile {
+ test_objfile
+}