From patchwork Wed Apr 1 06:25:16 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Doug Evans X-Patchwork-Id: 5942 Received: (qmail 108937 invoked by alias); 1 Apr 2015 06:26:10 -0000 Mailing-List: contact gdb-patches-help@sourceware.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-patches-owner@sourceware.org Delivered-To: mailing list gdb-patches@sourceware.org Received: (qmail 108915 invoked by uid 89); 1 Apr 2015 06:26:09 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.6 required=5.0 tests=AWL, BAYES_00, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, KAM_FROM_URIBL_PCCC, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=no version=3.3.2 X-HELO: mail-pa0-f42.google.com Received: from mail-pa0-f42.google.com (HELO mail-pa0-f42.google.com) (209.85.220.42) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-GCM-SHA256 encrypted) ESMTPS; Wed, 01 Apr 2015 06:26:04 +0000 Received: by patj18 with SMTP id j18so42777131pat.2 for ; Tue, 31 Mar 2015 23:26:03 -0700 (PDT) X-Received: by 10.68.216.166 with SMTP id or6mr6372231pbc.90.1427869562954; Tue, 31 Mar 2015 23:26:02 -0700 (PDT) Received: from seba.sebabeach.org.gmail.com (173-13-178-53-sfba.hfc.comcastbusiness.net. [173.13.178.53]) by mx.google.com with ESMTPSA id gu1sm870272pbd.67.2015.03.31.23.26.01 (version=TLSv1.2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Tue, 31 Mar 2015 23:26:02 -0700 (PDT) From: Doug Evans To: gdb-patches@sourceware.org, wingo@igalia.com Subject: [RFC] Guile info/enable/disable command trio support Date: Tue, 31 Mar 2015 23:25:16 -0700 Message-ID: MIME-Version: 1.0 X-IsSubscribed: yes Hi. This patch adds support for defining the info/enable/disable command trio that is common among things like pretty-printers, etc. In Python we replicate the support for each object kind (pretty-printer, xmethods, et.al.). I'd like to collapse all the infrastructure under a common roof. This patch is an experiment to see how doable that is for Guile. There is one unsolved problem which is that one pretty-printer can support many "subprinters", and this infrastructure doesn't support that. I'm leaving that to another pass. There's no docs yet, this is just an initial pass. I'll write some docs and send in a formal patch soon. diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in index c01b86d..c1408fc 100644 --- a/gdb/data-directory/Makefile.in +++ b/gdb/data-directory/Makefile.in @@ -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 = diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h index 509120b..fc2428b 100644 --- a/gdb/guile/guile-internal.h +++ b/gdb/guile/guile-internal.h @@ -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; 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 @@ -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 diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm index 8f238be..ea5fadb 100644 --- a/gdb/guile/lib/gdb.scm +++ b/gdb/guile/lib/gdb.scm @@ -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. 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 @@ +;; 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 . + +;; 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*) 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 . + +(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*) diff --git a/gdb/guile/lib/gdb/init-gdb.scm b/gdb/guile/lib/gdb/init-gdb.scm new file mode 100644 index 0000000..b637bea --- /dev/null +++ b/gdb/guile/lib/gdb/init-gdb.scm @@ -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 . + +;; 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)) diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm index 7bb1a58..0a67868 100644 --- a/gdb/guile/lib/gdb/init.scm +++ b/gdb/guile/lib/gdb/init.scm @@ -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 . -;; 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*) diff --git a/gdb/guile/lib/gdb/printing.scm b/gdb/guile/lib/gdb/printing.scm index 137fab4..20229e2 100644 --- a/gdb/guile/lib/gdb/printing.scm +++ b/gdb/guile/lib/gdb/printing.scm @@ -18,18 +18,15 @@ ;; along with this program. If not, see . (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 ") + (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 ") + (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 "" + remaining)))))) + (format #f "(~a)" (string-join all-names " | ")))) diff --git a/gdb/guile/scm-exception.c b/gdb/guile/scm-exception.c index 73dfb84..bd1f41b 100644 --- a/gdb/guile/scm-exception.c +++ b/gdb/guile/scm-exception.c @@ -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 diff --git a/gdb/guile/scm-pretty-print.c b/gdb/guile/scm-pretty-print.c index 860cf8e..5d5a184 100644 --- a/gdb/guile/scm-pretty-print.c +++ b/gdb/guile/scm-pretty-print.c @@ -211,6 +211,17 @@ ppscm_get_pretty_printer_smob_arg_unsafe (SCM self, int arg_pos, /* Pretty-printer methods. */ +/* (pretty-printer-name ) -> 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? ) -> boolean */ static SCM @@ -1068,6 +1079,10 @@ Create a object.\n\ "\ Return #t if the object is a 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." }, diff --git a/gdb/testsuite/gdb.guile/scm-pp-maint-gdb.in b/gdb/testsuite/gdb.guile/scm-pp-maint-gdb.in new file mode 100644 index 0000000..3dd93cc --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-pp-maint-gdb.in @@ -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 . + +;; 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)) diff --git a/gdb/testsuite/gdb.guile/scm-pp-maint.c b/gdb/testsuite/gdb.guile/scm-pp-maint.c new file mode 100644 index 0000000..4724fb53 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-pp-maint.c @@ -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 . */ + +#include + +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 */ +} diff --git a/gdb/testsuite/gdb.guile/scm-pp-maint.exp b/gdb/testsuite/gdb.guile/scm-pp-maint.exp new file mode 100644 index 0000000..19942b6 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-pp-maint.exp @@ -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 . + +# 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= b=<$hex>> b= 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= b=<$hex>> b= 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 | ." \ + "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 | ." \ + "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 | ." \ + "print FLAG_3 | 8" +} + +with_test_prefix objfile { + test_objfile +}