This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[PATCH v1 26/36] Guile extension language: scm-pretty-print.c
- From: Doug Evans <xdje42 at gmail dot com>
- To: gdb-patches at sourceware dot org
- Date: Tue, 24 Dec 2013 11:03:57 -0800
- Subject: [PATCH v1 26/36] Guile extension language: scm-pretty-print.c
- Authentication-results: sourceware.org; auth=none
This patch adds pretty-printer support.
There is still the higher level stuff to do (e.g. info,disable,enable),
but that has to wait until support for writing gdb commands is implemented.
2013-12-24 Doug Evans <xdje42@gmail.com>
* guile/scm-pretty-print.c: New file.
testsuite/
* gdb.guile/scm-pretty-print.c: New file.
* gdb.guile/scm-pretty-print.exp: New file.
* gdb.guile/scm-pretty-print.scm: New file.
diff --git a/gdb/guile/scm-pretty-print.c b/gdb/guile/scm-pretty-print.c
new file mode 100644
index 0000000..a964c4b
--- /dev/null
+++ b/gdb/guile/scm-pretty-print.c
@@ -0,0 +1,1198 @@
+/* GDB/Scheme pretty-printing.
+
+ Copyright (C) 2008-2013 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/>. */
+
+/* See README file in this directory for implementation notes, coding
+ conventions, et.al. */
+
+#include "defs.h"
+#include "charset.h"
+#include "gdb_assert.h"
+#include "symtab.h" /* Needed by language.h. */
+#include "language.h"
+#include "objfiles.h"
+#include "value.h"
+#include "valprint.h"
+#include "guile-internal.h"
+
+/* Return type of print_string_repr. */
+
+enum string_repr_result
+{
+ /* The string method returned None. */
+ STRING_REPR_NONE,
+ /* The string method had an error. */
+ STRING_REPR_ERROR,
+ /* Everything ok. */
+ STRING_REPR_OK
+};
+
+/* Display hints. */
+
+enum display_hint
+{
+ /* No display hint. */
+ HINT_NONE,
+ /* The display hint has a bad value. */
+ HINT_ERROR,
+ /* Print as an array. */
+ HINT_ARRAY,
+ /* Print as a map. */
+ HINT_MAP,
+ /* Print as a string. */
+ HINT_STRING
+};
+
+/* The <gdb:pretty-printer> smob. */
+
+typedef struct
+{
+ /* This must appear first. */
+ gdb_smob base;
+
+ /* A string representing the name of the printer. */
+ SCM name;
+
+ /* A boolean indicating whether the printer is enabled. */
+ SCM enabled;
+
+ /* A procedure called to look up the printer for the given value.
+ The procedure is called as (lookup gdb:pretty-printer value).
+ The result should either be a gdb:pretty-printer object that will print
+ the value, or #f if the value is not recognized. */
+ SCM lookup;
+
+ /* Note: Attaching subprinters to this smob is left to Scheme. */
+} pretty_printer_smob;
+
+/* The <gdb:pretty-printer-worker> smob. */
+
+typedef struct
+{
+ /* This must appear first. */
+ gdb_smob base;
+
+ /* Either #f or one of the supported display hints: map, array, string.
+ If neither of those then the display hint is ignored (treated as #f). */
+ SCM display_hint;
+
+ /* A procedure called to pretty-print the value.
+ (lambda (printer) ...) -> string | <gdb:lazy-string> | <gdb:value> */
+ SCM to_string;
+
+ /* A procedure called to print children of the value.
+ (lambda (printer) ...) -> <gdb:iterator>
+ The iterator returns a pair for each iteration: (name . value),
+ where "value" can have the same types as to_string. */
+ SCM children;
+} pretty_printer_worker_smob;
+
+static const char pretty_printer_smob_name[] =
+ "gdb:pretty-printer";
+static const char pretty_printer_worker_smob_name[] =
+ "gdb:pretty-printer-worker";
+
+/* The tag Guile knows the pretty-printer smobs by. */
+static scm_t_bits pretty_printer_smob_tag;
+static scm_t_bits pretty_printer_worker_smob_tag;
+
+/* Global list of pretty-printers. */
+static const char pretty_printer_list_name[] = "*pretty-printers*";
+
+/* The *pretty-printer* variable. */
+static SCM pretty_printer_list_var;
+
+/* gdb:pp-type-error. */
+static SCM gdbscm_pp_type_error_symbol;
+
+/* Pretty-printer display hints are specified by strings. */
+static SCM ppscm_map_string;
+static SCM ppscm_array_string;
+static SCM ppscm_string_string;
+
+/* Administrivia for pretty-printer matcher smobs. */
+
+/* The smob "mark" function for <gdb:pretty-printer>. */
+
+static SCM
+ppscm_mark_pretty_printer_smob (SCM self)
+{
+ pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (pp_smob->name);
+ scm_gc_mark (pp_smob->enabled);
+ scm_gc_mark (pp_smob->lookup);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&pp_smob->base);
+}
+
+/* The smob "print" function for <gdb:pretty-printer>. */
+
+static int
+ppscm_print_pretty_printer_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", pretty_printer_smob_name);
+ scm_write (pp_smob->name, port);
+ scm_puts (gdbscm_is_true (pp_smob->enabled) ? " enabled" : " disabled",
+ port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* (make-pretty-printer string procedure) -> <gdb:pretty-printer> */
+
+static SCM
+gdbscm_make_pretty_printer (SCM name, SCM lookup)
+{
+ pretty_printer_smob *pp_smob = (pretty_printer_smob *)
+ scm_gc_malloc (sizeof (pretty_printer_smob),
+ pretty_printer_smob_name);
+ SCM smob;
+
+ SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, FUNC_NAME,
+ _("string"));
+ SCM_ASSERT_TYPE (gdbscm_is_procedure (lookup), lookup, SCM_ARG2, FUNC_NAME,
+ _("procedure"));
+
+ pp_smob->name = name;
+ pp_smob->lookup = lookup;
+ pp_smob->enabled = SCM_BOOL_T;
+ smob = scm_new_smob (pretty_printer_smob_tag, (scm_t_bits) pp_smob);
+ gdbscm_init_gsmob (&pp_smob->base);
+
+ return smob;
+}
+
+/* Return non-zero if SCM is a <gdb:pretty-printer> object. */
+
+static int
+ppscm_is_pretty_printer (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (pretty_printer_smob_tag, scm);
+}
+
+/* (pretty-printer? object) -> boolean */
+
+static SCM
+gdbscm_pretty_printer_p (SCM scm)
+{
+ return scm_from_bool (ppscm_is_pretty_printer (scm));
+}
+
+/* Returns the <gdb:pretty-printer> object in SCM or #f if SCM is not a
+ <gdb:pretty-printer> object.
+ Returns a <gdb:exception> object if there was a problem during the
+ conversion. */
+
+static SCM
+ppscm_scm_to_pretty_printer_gsmob (SCM scm)
+{
+ return gdbscm_scm_to_gsmob_safe (scm, pretty_printer_smob_tag);
+}
+
+/* Returns the <gdb:pretty-printer> object in SELF.
+ Throws an exception if SELF is not a <gdb:pretty-printer> object
+ (after passing it through *scm->smob*). */
+
+static SCM
+ppscm_get_pretty_printer_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM pp_scm = ppscm_scm_to_pretty_printer_gsmob (self);
+
+ if (gdbscm_is_exception (pp_scm))
+ gdbscm_throw (pp_scm);
+
+ SCM_ASSERT_TYPE (ppscm_is_pretty_printer (pp_scm), self, arg_pos, func_name,
+ pretty_printer_smob_name);
+
+ return pp_scm;
+}
+
+/* Returns a pointer to the pretty-printer smob of SELF.
+ Throws an exception if SELF is not a <gdb:pretty-printer> object
+ (after passing it through *scm->smob*). */
+
+static pretty_printer_smob *
+ppscm_get_pretty_printer_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM pp_scm = ppscm_get_pretty_printer_arg_unsafe (self, arg_pos, func_name);
+ pretty_printer_smob *pp_smob
+ = (pretty_printer_smob *) SCM_SMOB_DATA (pp_scm);
+
+ return pp_smob;
+}
+
+/* Pretty-printer methods. */
+
+/* (pretty-printer-enabled? <gdb:pretty-printer>) -> boolean */
+
+static SCM
+gdbscm_pretty_printer_enabled_p (SCM self)
+{
+ pretty_printer_smob *pp_smob
+ = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return pp_smob->enabled;
+}
+
+/* (set-pretty-printer-enabled! <gdb:pretty-printer> boolean)
+ -> unspecified */
+
+static SCM
+gdbscm_set_pretty_printer_enabled_x (SCM self, SCM enabled)
+{
+ pretty_printer_smob *pp_smob
+ = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ pp_smob->enabled = scm_from_bool (gdbscm_is_true (enabled));
+
+ return SCM_UNSPECIFIED;
+}
+
+/* Administrivia for pretty-printer-worker smobs.
+ These are created when a matcher recognizes a value. */
+
+/* The smob "mark" function for <gdb:pretty-printer-worker>. */
+
+static SCM
+ppscm_mark_pretty_printer_worker_smob (SCM self)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (w_smob->display_hint);
+ scm_gc_mark (w_smob->to_string);
+ scm_gc_mark (w_smob->children);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&w_smob->base);
+}
+
+/* The smob "print" function for <gdb:pretty-printer-worker>. */
+
+static int
+ppscm_print_pretty_printer_worker_smob (SCM self, SCM port,
+ scm_print_state *pstate)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", pretty_printer_worker_smob_name);
+ scm_write (w_smob->display_hint, port);
+ scm_puts (" ", port);
+ scm_write (w_smob->to_string, port);
+ scm_puts (" ", port);
+ scm_write (w_smob->children, port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* (make-pretty-printer-worker string procedure procedure)
+ -> <gdb:pretty-printer-worker> */
+
+static SCM
+gdbscm_make_pretty_printer_worker (SCM display_hint, SCM to_string,
+ SCM children)
+{
+ pretty_printer_worker_smob *w_smob = (pretty_printer_worker_smob *)
+ scm_gc_malloc (sizeof (pretty_printer_worker_smob),
+ pretty_printer_worker_smob_name);
+ SCM w_scm;
+
+ w_smob->display_hint = display_hint;
+ w_smob->to_string = to_string;
+ w_smob->children = children;
+ w_scm = scm_new_smob (pretty_printer_worker_smob_tag, (scm_t_bits) w_smob);
+ gdbscm_init_gsmob (&w_smob->base);
+ return w_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:pretty-printer-worker> object. */
+
+static int
+ppscm_is_pretty_printer_worker (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (pretty_printer_worker_smob_tag, scm);
+}
+
+/* (pretty-printer-worker? object) -> boolean */
+
+static SCM
+gdbscm_pretty_printer_worker_p (SCM scm)
+{
+ return scm_from_bool (ppscm_is_pretty_printer_worker (scm));
+}
+
+/* Returns the <gdb:pretty-printer-worker> object in SCM or #f if SCM is not a
+ <gdb:pretty-printer-worker> object.
+ Returns a <gdb:exception> object if there was a problem during the
+ conversion. */
+
+static SCM
+ppscm_scm_to_pretty_printer_worker_gsmob (SCM scm)
+{
+ return gdbscm_scm_to_gsmob_safe (scm, pretty_printer_worker_smob_tag);
+}
+
+/* Helper function to create a <gdb:exception> object indicating that the
+ type of some value returned from a pretty-printer is invalid. */
+
+static SCM
+ppscm_make_pp_type_error_exception (const char *message, SCM object)
+{
+ char *msg = xstrprintf ("%s: ~S", message);
+ struct cleanup *cleanup = make_cleanup (xfree, msg);
+ SCM exception
+ = gdbscm_make_error (gdbscm_pp_type_error_symbol,
+ NULL /* func */, msg,
+ scm_list_1 (object), scm_list_1 (object));
+
+ do_cleanups (cleanup);
+
+ return exception;
+}
+
+/* Print MESSAGE as an exception (meaning it is controlled by
+ "guile print-stack").
+ Called from the printer code when the Scheme code returns an invalid type
+ for something. */
+
+static void
+ppscm_print_pp_type_error (const char *message, SCM object)
+{
+ SCM exception = ppscm_make_pp_type_error_exception (message, object);
+
+ gdbscm_print_exception (SCM_BOOL_F, exception);
+}
+
+/* Helper function for find_pretty_printer which iterates over a list,
+ calls each function and inspects output. This will return a
+ <gdb:pretty-printer> object if one recognizes VALUE. If no printer is
+ found, it will return #f. On error, it will return a <gdb:exception>
+ object.
+
+ Note: This has to be efficient and careful.
+ We don't want to excessively slow down printing of values, but any kind of
+ random crud can appear in the pretty-printer list, and we can't crash
+ because of it. */
+
+static SCM
+ppscm_search_pp_list (SCM list, SCM value)
+{
+ SCM orig_list = list;
+
+ if (scm_is_null (list))
+ return SCM_BOOL_F;
+ if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("pretty-printer list is not a list"), list);
+ }
+
+ for ( ; scm_is_pair (list); list = scm_cdr (list))
+ {
+ SCM maybe_matcher = scm_car (list);
+ SCM matcher, maybe_worker;
+ pretty_printer_smob *pp_smob;
+ int rc;
+
+ matcher = ppscm_scm_to_pretty_printer_gsmob (maybe_matcher);
+ if (gdbscm_is_exception (matcher))
+ return matcher;
+ if (!ppscm_is_pretty_printer (matcher))
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("pretty-printer list contains non-pretty-printer object"),
+ maybe_matcher);
+ }
+
+ pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
+
+ /* Skip if disabled. */
+ if (gdbscm_is_false (pp_smob->enabled))
+ continue;
+
+ if (!gdbscm_is_procedure (pp_smob->lookup))
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("invalid lookup object in pretty-printer matcher"),
+ pp_smob->lookup);
+ }
+
+ maybe_worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
+ value, gdbscm_memory_error_p);
+ if (!gdbscm_is_false (maybe_worker))
+ {
+ SCM worker;
+
+ if (gdbscm_is_exception (maybe_worker))
+ return maybe_worker;
+ worker = ppscm_scm_to_pretty_printer_worker_gsmob (maybe_worker);
+ if (gdbscm_is_true (worker))
+ {
+ /* Note: worker could be a <gdb:exception>. */
+ return worker;
+ }
+ return ppscm_make_pp_type_error_exception
+ (_("invalid result from pretty-printer lookup"), maybe_worker);
+ }
+ }
+
+ if (!scm_is_null (list))
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("pretty-printer list is not a list"), orig_list);
+ }
+
+ return SCM_BOOL_F;
+}
+
+/* Subroutine of find_pretty_printer to simplify it.
+ Look for a pretty-printer to print VALUE in all objfiles.
+ If there's an error an exception smob is returned.
+ The result is #f, if no pretty-printer was found.
+ Otherwise the result is the pretty-printer smob. */
+
+static SCM
+ppscm_find_pretty_printer_from_objfiles (SCM value)
+{
+ struct objfile *objfile;
+
+ ALL_OBJFILES (objfile)
+ {
+ objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
+ SCM pp = ppscm_search_pp_list (ofscm_objfile_smob_pretty_printers (o_smob),
+ value);
+
+ /* Note: This will return if pp is a <gdb:exception> object,
+ which is what we want. */
+ if (gdbscm_is_true (pp))
+ return pp;
+ }
+
+ return SCM_BOOL_F;
+}
+
+/* Subroutine of find_pretty_printer to simplify it.
+ Look for a pretty-printer to print VALUE in the current program space.
+ If there's an error an exception smob is returned.
+ The result is #f, if no pretty-printer was found.
+ Otherwise the result is the pretty-printer smob. */
+
+static SCM
+ppscm_find_pretty_printer_from_progspace (SCM value)
+{
+ return SCM_BOOL_F; /*TODO*/
+}
+
+/* Subroutine of find_pretty_printer to simplify it.
+ Look for a pretty-printer to print VALUE in the gdb module.
+ If there's an error a Scheme exception is returned.
+ The result is #f, if no pretty-printer was found.
+ Otherwise the result is the pretty-printer smob. */
+
+static SCM
+ppscm_find_pretty_printer_from_gdb (SCM value)
+{
+ SCM pp_list, pp;
+
+ /* Fetch the global pretty printer list. */
+ pp_list = scm_variable_ref (pretty_printer_list_var);
+ pp = ppscm_search_pp_list (pp_list, value);
+ return pp;
+}
+
+/* Find the pretty-printing constructor function for VALUE. If no
+ pretty-printer exists, return #f. If one exists, return the
+ gdb:pretty-printer smob that implements it. On error, an exception smob
+ is returned.
+
+ Note: In the end it may be better to call out to Scheme once, and then
+ do all of the lookup from Scheme. TBD. */
+
+static SCM
+ppscm_find_pretty_printer (SCM value)
+{
+ SCM pp;
+
+ /* Look at the pretty-printer list for each objfile
+ in the current program-space. */
+ pp = ppscm_find_pretty_printer_from_objfiles (value);
+ /* Note: This will return if function is a <gdb:exception> object,
+ which is what we want. */
+ if (gdbscm_is_true (pp))
+ return pp;
+
+ /* Look at the pretty-printer list for the current program-space. */
+ pp = ppscm_find_pretty_printer_from_progspace (value);
+ /* Note: This will return if function is a <gdb:exception> object,
+ which is what we want. */
+ if (gdbscm_is_true (pp))
+ return pp;
+
+ /* Look at the pretty-printer list in the gdb module. */
+ pp = ppscm_find_pretty_printer_from_gdb (value);
+ return pp;
+}
+
+/* Pretty-print a single value, via the PRINTER, which must be a
+ <gdb:pretty-printer-worker> object.
+ The caller is responsible for ensuring PRINTER is valid.
+ If the function returns a string, an SCM containing the string
+ is returned. If the function returns #f that means the pretty
+ printer returned #f as a value. Otherwise, if the function returns a
+ <gdb:value> object, *OUT_VALUE is set to the value and #t is returned.
+ It is an error if the printer returns #t.
+ On error, an exception smob is returned. */
+
+static SCM
+ppscm_pretty_print_one_value (SCM printer, struct value **out_value,
+ struct gdbarch *gdbarch,
+ const struct language_defn *language)
+{
+ volatile struct gdb_exception except;
+ SCM result = SCM_BOOL_F;
+
+ *out_value = NULL;
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ int rc;
+ SCM v_scm;
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
+
+ result = gdbscm_safe_call_1 (w_smob->to_string, printer,
+ gdbscm_memory_error_p);
+ if (gdbscm_is_false (result))
+ ; /* Done. */
+ else if (scm_is_string (result)
+ || lsscm_is_lazy_string (result))
+ ; /* Done. */
+ else if (vlscm_is_value (v_scm = vlscm_scm_to_value_gsmob (result)))
+ {
+ SCM except_scm;
+
+ *out_value
+ = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
+ v_scm, &except_scm,
+ gdbarch, language);
+ if (*out_value != NULL)
+ result = SCM_BOOL_T;
+ else
+ result = except_scm;
+ }
+ else if (gdbscm_is_exception (v_scm))
+ {
+ /* An exception occurred trying to convert RESULT to a <gdb:value>
+ object. */
+ result = v_scm;
+ }
+ else if (gdbscm_is_exception (result))
+ ; /* Done. */
+ else
+ {
+ /* Invalid result from to-string. */
+ result = ppscm_make_pp_type_error_exception
+ (_("invalid result from pretty-printer to-string"), result);
+ }
+ }
+
+ return result;
+}
+
+/* Return the display hint for PRINTER as a Scheme object.
+ The caller is responsible for ensuring PRINTER is a
+ <gdb:pretty-printer-worker> object. */
+
+static SCM
+ppscm_get_display_hint_scm (SCM printer)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
+
+ return w_smob->display_hint;
+}
+
+/* Return the display hint for the pretty-printer PRINTER.
+ The caller is responsible for ensuring PRINTER is a
+ <gdb:pretty-printer-worker> object.
+ Returns the display hint or #f if the hint is not a string. */
+
+static enum display_hint
+ppscm_get_display_hint_enum (SCM printer)
+{
+ SCM hint = ppscm_get_display_hint_scm (printer);
+
+ if (gdbscm_is_false (hint))
+ return HINT_NONE;
+ if (scm_is_string (hint))
+ {
+ if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_array_string)))
+ return HINT_STRING;
+ if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_map_string)))
+ return HINT_STRING;
+ if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_string_string)))
+ return HINT_STRING;
+ return HINT_ERROR;
+ }
+ return HINT_ERROR;
+}
+
+/* A wrapper for gdbscm_print_exception that ignores memory errors.
+ EXCEPTION is a <gdb:exception> object. */
+
+static void
+ppscm_print_exception_unless_memory_error (SCM exception,
+ struct ui_file *stream)
+{
+ if (gdbscm_memory_error_p (gdbscm_exception_key (exception)))
+ {
+ char *msg = gdbscm_exception_message_to_string (exception);
+ struct cleanup *cleanup = make_cleanup (xfree, msg);
+
+ /* This "shouldn't happen", but play it safe. */
+ if (msg == NULL || *msg == '\0')
+ fprintf_filtered (stream, _("<error reading variable>"));
+ else
+ {
+ /* Remove the trailing newline. We could instead call a special
+ routine for printing memory error messages, but this is easy
+ enough for now. */
+ size_t len = strlen (msg);
+
+ if (msg[len - 1] == '\n')
+ msg[len - 1] = '\0';
+ fprintf_filtered (stream, _("<error reading variable: %s>"), msg);
+ }
+
+ do_cleanups (cleanup);
+ }
+ else
+ gdbscm_print_exception (SCM_BOOL_F, exception);
+}
+
+/* Helper for gdbscm_apply_val_pretty_printer which calls to_string and
+ formats the result. */
+
+static enum string_repr_result
+ppscm_print_string_repr (SCM printer, enum display_hint hint,
+ struct ui_file *stream, int recurse,
+ const struct value_print_options *options,
+ struct gdbarch *gdbarch,
+ const struct language_defn *language)
+{
+ struct value *replacement = NULL;
+ SCM str_scm, ls_scm;
+ enum string_repr_result result = STRING_REPR_ERROR;
+
+ str_scm = ppscm_pretty_print_one_value (printer, &replacement,
+ gdbarch, language);
+ if (gdbscm_is_false (str_scm))
+ {
+ result = STRING_REPR_NONE;
+ }
+ else if (scm_is_eq (str_scm, SCM_BOOL_T))
+ {
+ struct value_print_options opts = *options;
+
+ gdb_assert (replacement != NULL);
+ opts.addressprint = 0;
+ common_val_print (replacement, stream, recurse, &opts, language);
+ result = STRING_REPR_OK;
+ }
+ else if (scm_is_string (str_scm))
+ {
+ struct cleanup *cleanup;
+ size_t length;
+ char *string
+ = gdbscm_scm_to_string (str_scm, &length,
+ target_charset (gdbarch), 0 /*!strict*/, NULL);
+
+ cleanup = make_cleanup (xfree, string);
+ if (hint == HINT_STRING)
+ {
+ struct type *type = builtin_type (gdbarch)->builtin_char;
+
+ LA_PRINT_STRING (stream, type, (gdb_byte *) string,
+ length, NULL, 0, options);
+ }
+ else
+ {
+ /* Alas scm_to_stringn doesn't nul-terminate the string if we
+ ask for the length. */
+ size_t i;
+
+ for (i = 0; i < length; ++i)
+ {
+ if (string[i] == '\0')
+ fputs_filtered ("\\000", stream);
+ else
+ fputc_filtered (string[i], stream);
+ }
+ }
+ result = STRING_REPR_OK;
+ do_cleanups (cleanup);
+ }
+ else if (lsscm_is_lazy_string (ls_scm
+ = (lsscm_scm_to_lazy_string_gsmob (str_scm))))
+ {
+ struct value_print_options local_opts = *options;
+
+ local_opts.addressprint = 0;
+ lsscm_val_print_lazy_string (str_scm, stream, &local_opts);
+ result = STRING_REPR_OK;
+ }
+ else if (gdbscm_is_exception (ls_scm))
+ {
+ /* An exception occurred trying to convert STR_SCM to a <gdb:lazy-string>
+ object. */
+ ppscm_print_exception_unless_memory_error (ls_scm, stream);
+ result = STRING_REPR_ERROR;
+ }
+ else
+ {
+ gdb_assert (gdbscm_is_exception (str_scm));
+ ppscm_print_exception_unless_memory_error (str_scm, stream);
+ result = STRING_REPR_ERROR;
+ }
+
+ return result;
+}
+
+/* Helper for gdbscm_apply_val_pretty_printer that formats children of the
+ printer, if any exist.
+ The caller is responsible for ensuring PRINTER is a printer smob.
+ If PRINTED_NOTHING is true, then nothing has been printed by to_string,
+ and format output accordingly. */
+
+static void
+ppscm_print_children (SCM printer, enum display_hint hint,
+ struct ui_file *stream, int recurse,
+ const struct value_print_options *options,
+ struct gdbarch *gdbarch,
+ const struct language_defn *language,
+ int printed_nothing)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
+ int is_map, is_array, done_flag, pretty;
+ unsigned int i;
+ SCM children, status;
+ SCM iter = SCM_BOOL_F; /* -Wall */
+ struct cleanup *cleanups;
+
+ if (gdbscm_is_false (w_smob->children))
+ return;
+ if (!gdbscm_is_procedure (w_smob->children))
+ {
+ ppscm_print_pp_type_error
+ (_("pretty-printer \"children\" object is not a procedure or #f"),
+ w_smob->children);
+ return;
+ }
+
+ cleanups = make_cleanup (null_cleanup, NULL);
+
+ /* If we are printing a map or an array, we want special formatting. */
+ is_map = hint == HINT_MAP;
+ is_array = hint == HINT_ARRAY;
+
+ children = gdbscm_safe_call_1 (w_smob->children, printer,
+ gdbscm_memory_error_p);
+ if (gdbscm_is_exception (children))
+ {
+ ppscm_print_exception_unless_memory_error (children, stream);
+ goto done;
+ }
+ /* We combine two steps here: get children, make an iterator out of them.
+ This simplifies things because there's no language means of creating
+ iterators, and it's the printer object that knows how it will want its
+ children iterated over. */
+ /* TODO: pass children through *scm->smob*. */
+ if (!itscm_is_iterator (children))
+ {
+ ppscm_print_pp_type_error
+ (_("result of pretty-printer \"children\" procedure is not"
+ " a <gdb:iterator> object"), children);
+ goto done;
+ }
+ iter = children;
+
+ /* Use the prettyformat_arrays option if we are printing an array,
+ and the pretty option otherwise. */
+ if (is_array)
+ pretty = options->prettyformat_arrays;
+ else
+ {
+ if (options->prettyformat == Val_prettyformat)
+ pretty = 1;
+ else
+ pretty = options->prettyformat_structs;
+ }
+
+ done_flag = 0;
+ for (i = 0; i < options->print_max; ++i)
+ {
+ int rc;
+ SCM scm_name, v_scm, ls_scm;
+ char *name;
+ SCM item = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
+ struct cleanup *inner_cleanup = make_cleanup (null_cleanup, NULL);
+
+ if (gdbscm_is_exception (item))
+ {
+ ppscm_print_exception_unless_memory_error (item, stream);
+ break;
+ }
+ if (gdbscm_is_false (item))
+ {
+ /* Set a flag so we can know whether we printed all the
+ available elements. */
+ done_flag = 1;
+ break;
+ }
+
+ if (! scm_is_pair (item))
+ {
+ ppscm_print_pp_type_error
+ (_("result of pretty-printer children iterator is not a pair"),
+ item);
+ continue;
+ }
+ scm_name = scm_car (item);
+ v_scm = scm_cdr (item);
+ if (!scm_is_string (scm_name))
+ {
+ ppscm_print_pp_type_error
+ (_("first element of pretty-printer children iterator is not"
+ " a string"), item);
+ continue;
+ }
+ name = gdbscm_scm_to_c_string (scm_name);
+ make_cleanup (xfree, name);
+
+ /* Print initial "{". For other elements, there are three cases:
+ 1. Maps. Print a "," after each value element.
+ 2. Arrays. Always print a ",".
+ 3. Other. Always print a ",". */
+ if (i == 0)
+ {
+ if (printed_nothing)
+ fputs_filtered ("{", stream);
+ else
+ fputs_filtered (" = {", stream);
+ }
+
+ else if (! is_map || i % 2 == 0)
+ fputs_filtered (pretty ? "," : ", ", stream);
+
+ /* In summary mode, we just want to print "= {...}" if there is
+ a value. */
+ if (options->summary)
+ {
+ /* This increment tricks the post-loop logic to print what
+ we want. */
+ ++i;
+ /* Likewise. */
+ pretty = 0;
+ break;
+ }
+
+ if (! is_map || i % 2 == 0)
+ {
+ if (pretty)
+ {
+ fputs_filtered ("\n", stream);
+ print_spaces_filtered (2 + 2 * recurse, stream);
+ }
+ else
+ wrap_here (n_spaces (2 + 2 *recurse));
+ }
+
+ if (is_map && i % 2 == 0)
+ fputs_filtered ("[", stream);
+ else if (is_array)
+ {
+ /* We print the index, not whatever the child method
+ returned as the name. */
+ if (options->print_array_indexes)
+ fprintf_filtered (stream, "[%d] = ", i);
+ }
+ else if (! is_map)
+ {
+ fputs_filtered (name, stream);
+ fputs_filtered (" = ", stream);
+ }
+
+ ls_scm = lsscm_scm_to_lazy_string_gsmob (v_scm);
+ if (lsscm_is_lazy_string (ls_scm))
+ {
+ struct value_print_options local_opts = *options;
+
+ local_opts.addressprint = 0;
+ lsscm_val_print_lazy_string (ls_scm, stream, &local_opts);
+ }
+ else if (gdbscm_is_exception (ls_scm))
+ {
+ ppscm_print_exception_unless_memory_error (ls_scm, stream);
+ break;
+ }
+ else if (scm_is_string (v_scm))
+ {
+ char *output = gdbscm_scm_to_c_string (v_scm);
+
+ fputs_filtered (output, stream);
+ xfree (output);
+ }
+ else
+ {
+ SCM except_scm;
+ struct value *value
+ = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
+ v_scm, &except_scm,
+ gdbarch, language);
+
+ if (value == NULL)
+ {
+ ppscm_print_exception_unless_memory_error (except_scm, stream);
+ break;
+ }
+ common_val_print (value, stream, recurse + 1, options, language);
+ }
+
+ if (is_map && i % 2 == 0)
+ fputs_filtered ("] = ", stream);
+
+ do_cleanups (inner_cleanup);
+ }
+
+ if (i)
+ {
+ if (!done_flag)
+ {
+ if (pretty)
+ {
+ fputs_filtered ("\n", stream);
+ print_spaces_filtered (2 + 2 * recurse, stream);
+ }
+ fputs_filtered ("...", stream);
+ }
+ if (pretty)
+ {
+ fputs_filtered ("\n", stream);
+ print_spaces_filtered (2 * recurse, stream);
+ }
+ fputs_filtered ("}", stream);
+ }
+
+ done:
+ do_cleanups (cleanups);
+
+ /* Play it safe, make sure ITER doesn't get GC'd. */
+ scm_remember_upto_here_1 (iter);
+}
+
+/* This is the extension_language_ops.apply_val_pretty_printer "method". */
+
+enum ext_lang_rc
+gdbscm_apply_val_pretty_printer (const struct extension_language_defn *extlang,
+ struct type *type, const gdb_byte *valaddr,
+ int embedded_offset, CORE_ADDR address,
+ struct ui_file *stream, int recurse,
+ const struct value *val,
+ const struct value_print_options *options,
+ const struct language_defn *language)
+{
+ struct gdbarch *gdbarch = get_type_arch (type);
+ SCM exception = SCM_BOOL_F;
+ SCM printer = SCM_BOOL_F;
+ SCM val_obj = SCM_BOOL_F;
+ struct value *value;
+ enum display_hint hint;
+ struct cleanup *cleanups;
+ int result = EXT_LANG_RC_NOP;
+ enum string_repr_result print_result;
+
+ /* No pretty-printer support for unavailable values. */
+ if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type)))
+ return EXT_LANG_RC_NOP;
+
+ if (!gdb_scheme_initialized)
+ return EXT_LANG_RC_NOP;
+
+ cleanups = make_cleanup (null_cleanup, NULL);
+
+ /* Instantiate the printer. */
+ if (valaddr)
+ valaddr += embedded_offset;
+ value = value_from_contents_and_address (type, valaddr,
+ address + embedded_offset);
+
+ set_value_component_location (value, val);
+ /* set_value_component_location resets the address, so we may
+ need to set it again. */
+ if (VALUE_LVAL (value) != lval_internalvar
+ && VALUE_LVAL (value) != lval_internalvar_component
+ && VALUE_LVAL (value) != lval_computed)
+ set_value_address (value, address + embedded_offset);
+
+ val_obj = vlscm_scm_from_value (value);
+ if (gdbscm_is_exception (val_obj))
+ {
+ exception = val_obj;
+ result = EXT_LANG_RC_ERROR;
+ goto done;
+ }
+
+ printer = ppscm_find_pretty_printer (val_obj);
+
+ if (gdbscm_is_exception (printer))
+ {
+ exception = printer;
+ result = EXT_LANG_RC_ERROR;
+ goto done;
+ }
+ if (gdbscm_is_false (printer))
+ {
+ result = EXT_LANG_RC_NOP;
+ goto done;
+ }
+ gdb_assert (ppscm_is_pretty_printer_worker (printer));
+
+ /* If we are printing a map, we want some special formatting. */
+ hint = ppscm_get_display_hint_enum (printer);
+ if (hint == HINT_ERROR)
+ {
+ /* Print the error as an exception for consistency. */
+ SCM hint_scm = ppscm_get_display_hint_scm (printer);
+
+ ppscm_print_pp_type_error ("Invalid display hint", hint_scm);
+ /* Fall through. A bad hint doesn't stop pretty-printing. */
+ hint = HINT_NONE;
+ }
+
+ /* Print the section. */
+ print_result = ppscm_print_string_repr (printer, hint, stream, recurse,
+ options, gdbarch, language);
+ if (print_result != STRING_REPR_ERROR)
+ {
+ ppscm_print_children (printer, hint, stream, recurse, options,
+ gdbarch, language,
+ print_result == STRING_REPR_NONE);
+ }
+
+ result = EXT_LANG_RC_OK;
+
+ done:
+ if (gdbscm_is_exception (exception))
+ ppscm_print_exception_unless_memory_error (exception, stream);
+ do_cleanups (cleanups);
+ return result;
+}
+
+/* Initialize the Scheme pretty-printer code. */
+
+static const scheme_function pretty_printer_functions[] =
+{
+ { "make-pretty-printer", 2, 0, 0, gdbscm_make_pretty_printer,
+ "\
+Create a <gdb:pretty-printer> object.\n\
+\n\
+ Arguments: name lookup\n\
+ name: a string naming the matcher\n\
+ lookup: a procedure:\n\
+ (pretty-printer <gdb:value>) -> <gdb:pretty-printer-worker> | #f." },
+
+ { "pretty-printer?", 1, 0, 0, gdbscm_pretty_printer_p,
+ "\
+Return #t if the object is a <gdb:pretty-printer> object." },
+
+ { "pretty-printer-enabled?", 1, 0, 0, gdbscm_pretty_printer_enabled_p,
+ "\
+Return #t if the pretty-printer is enabled." },
+
+ { "set-pretty-printer-enabled!", 2, 0, 0,
+ gdbscm_set_pretty_printer_enabled_x,
+ "\
+Set the enabled flag of the pretty-printer.\n\
+Returns \"unspecified\"." },
+
+ { "make-pretty-printer-worker", 3, 0, 0, gdbscm_make_pretty_printer_worker,
+ "\
+Create a <gdb:pretty-printer-worker> object.\n\
+\n\
+ Arguments: display-hint to-string children\n\
+ display-hint: either #f or one of \"array\", \"map\", or \"string\"\n\
+ to-string: a procedure:\n\
+ (pretty-printer) -> string | #f | <gdb:value>\n\
+ children: either #f or a procedure:\n\
+ (pretty-printer) -> <gdb:iterator>" },
+
+ { "pretty-printer-worker?", 1, 0, 0, gdbscm_pretty_printer_worker_p,
+ "\
+Return #t if the object is a <gdb:pretty-printer-worker> object." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_pretty_printers (void)
+{
+ pretty_printer_smob_tag
+ = gdbscm_make_smob_type (pretty_printer_smob_name,
+ sizeof (pretty_printer_smob));
+ scm_set_smob_mark (pretty_printer_smob_tag,
+ ppscm_mark_pretty_printer_smob);
+ scm_set_smob_print (pretty_printer_smob_tag,
+ ppscm_print_pretty_printer_smob);
+
+ pretty_printer_worker_smob_tag
+ = gdbscm_make_smob_type (pretty_printer_worker_smob_name,
+ sizeof (pretty_printer_worker_smob));
+ scm_set_smob_mark (pretty_printer_worker_smob_tag,
+ ppscm_mark_pretty_printer_worker_smob);
+ scm_set_smob_print (pretty_printer_worker_smob_tag,
+ ppscm_print_pretty_printer_worker_smob);
+
+ gdbscm_define_functions (pretty_printer_functions, 1);
+
+ scm_c_define (pretty_printer_list_name, SCM_EOL);
+
+ pretty_printer_list_var
+ = scm_c_private_variable (gdbscm_module_name,
+ pretty_printer_list_name);
+ gdb_assert (!gdbscm_is_false (pretty_printer_list_var));
+
+ gdbscm_pp_type_error_symbol
+ = gdbscm_symbol_from_c_string ("gdb:pp-type-error");
+
+ ppscm_map_string = scm_from_latin1_string ("map");
+ ppscm_array_string = scm_from_latin1_string ("array");
+ ppscm_string_string = scm_from_latin1_string ("string");
+}
diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.c b/gdb/testsuite/gdb.guile/scm-pretty-print.c
new file mode 100644
index 0000000..ce1d154
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-pretty-print.c
@@ -0,0 +1,353 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2008-2013 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>
+
+struct s
+{
+ int a;
+ int *b;
+};
+
+struct ss
+{
+ struct s a;
+ struct s b;
+};
+
+struct arraystruct
+{
+ int y;
+ struct s x[2];
+};
+
+struct ns {
+ const char *null_str;
+ int length;
+};
+
+struct lazystring {
+ const char *lazy_str;
+};
+
+struct hint_error {
+ int x;
+};
+
+struct children_as_list {
+ int x;
+};
+
+#ifdef __cplusplus
+struct S : public s {
+ int zs;
+};
+
+struct SS {
+ int zss;
+ S s;
+};
+
+struct SSS
+{
+ SSS (int x, const S& r);
+ int a;
+ const S &b;
+};
+SSS::SSS (int x, const S& r) : a(x), b(r) { }
+
+class VirtualTest
+{
+ private:
+ int value;
+
+ public:
+ VirtualTest ()
+ {
+ value = 1;
+ }
+};
+
+class Vbase1 : public virtual VirtualTest { };
+class Vbase2 : public virtual VirtualTest { };
+class Vbase3 : public virtual VirtualTest { };
+
+class Derived : public Vbase1, public Vbase2, public Vbase3
+{
+ private:
+ int value;
+
+ public:
+ Derived ()
+ {
+ value = 2;
+ }
+};
+
+class Fake
+{
+ int sname;
+
+ public:
+ Fake (const int name = 0):
+ sname (name)
+ {
+ }
+};
+#endif
+
+struct substruct {
+ int a;
+ int b;
+};
+
+struct outerstruct {
+ struct substruct s;
+ int x;
+};
+
+struct outerstruct
+substruct_test (void)
+{
+ struct outerstruct outer;
+ outer.s.a = 0;
+ outer.s.b = 0;
+ outer.x = 0;
+
+ outer.s.a = 3; /* MI outer breakpoint here */
+
+ return outer;
+}
+
+typedef struct string_repr
+{
+ struct whybother
+ {
+ const char *contents;
+ } whybother;
+} string;
+
+/* This lets us avoid malloc. */
+int array[100];
+int narray[10];
+
+struct justchildren
+{
+ int len;
+ int *elements;
+};
+
+typedef struct justchildren nostring_type;
+
+struct memory_error
+{
+ const char *s;
+};
+
+struct container
+{
+ string name;
+ int len;
+ int *elements;
+};
+
+typedef struct container zzz_type;
+
+string
+make_string (const char *s)
+{
+ string result;
+ result.whybother.contents = s;
+ return result;
+}
+
+zzz_type
+make_container (const char *s)
+{
+ zzz_type result;
+
+ result.name = make_string (s);
+ result.len = 0;
+ result.elements = 0;
+
+ return result;
+}
+
+void
+add_item (zzz_type *c, int val)
+{
+ if (c->len == 0)
+ c->elements = array;
+ c->elements[c->len] = val;
+ ++c->len;
+}
+
+void
+set_item(zzz_type *c, int i, int val)
+{
+ if (i < c->len)
+ c->elements[i] = val;
+}
+
+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);
+}
+
+void do_nothing(void)
+{
+ int c;
+
+ c = 23; /* Another MI breakpoint */
+}
+
+struct nullstr
+{
+ char *s;
+};
+
+struct string_repr string_1 = { { "one" } };
+struct string_repr string_2 = { { "two" } };
+
+static int
+eval_func (int p1, int p2, int p3, int p4, int p5, int p6, int p7, int p8)
+{
+ return p1;
+}
+
+static void
+eval_sub (void)
+{
+ struct eval_type_s { int x; } eval1 = { 1 }, eval2 = { 2 }, eval3 = { 3 },
+ eval4 = { 4 }, eval5 = { 5 }, eval6 = { 6 },
+ eval7 = { 7 }, eval8 = { 8 }, eval9 = { 9 };
+
+ eval1.x++; /* eval-break */
+}
+
+static void
+bug_14741()
+{
+ zzz_type c = make_container ("bug_14741");
+ add_item (&c, 71);
+ set_item(&c, 0, 42); /* breakpoint bug 14741 */
+ set_item(&c, 0, 5);
+}
+
+int
+main ()
+{
+ struct ss ss;
+ struct ss ssa[2];
+ struct arraystruct arraystruct;
+ string x = make_string ("this is x");
+ zzz_type c = make_container ("container");
+ zzz_type c2 = make_container ("container2");
+ const struct string_repr cstring = { { "const string" } };
+ /* Clearing by being `static' could invoke an other GDB C++ bug. */
+ struct nullstr nullstr;
+ nostring_type nstype, nstype2;
+ struct memory_error me;
+ struct ns ns, ns2;
+ struct lazystring estring, estring2;
+ struct hint_error hint_error;
+ struct children_as_list children_as_list;
+
+ nstype.elements = narray;
+ nstype.len = 0;
+
+ me.s = "blah";
+
+ init_ss(&ss, 1, 2);
+ init_ss(ssa+0, 3, 4);
+ init_ss(ssa+1, 5, 6);
+ memset (&nullstr, 0, sizeof nullstr);
+
+ arraystruct.y = 7;
+ init_s (&arraystruct.x[0], 23);
+ init_s (&arraystruct.x[1], 24);
+
+ ns.null_str = "embedded\0null\0string";
+ ns.length = 20;
+
+ /* Make a "corrupted" string. */
+ ns2.null_str = NULL;
+ ns2.length = 20;
+
+ estring.lazy_str = "embedded x\201\202\203\204" ;
+
+ /* Incomplete UTF-8, but ok Latin-1. */
+ estring2.lazy_str = "embedded x\302";
+
+#ifdef __cplusplus
+ S cps;
+
+ cps.zs = 7;
+ init_s(&cps, 8);
+
+ SS cpss;
+ cpss.zss = 9;
+ init_s(&cpss.s, 10);
+
+ SS cpssa[2];
+ cpssa[0].zss = 11;
+ init_s(&cpssa[0].s, 12);
+ cpssa[1].zss = 13;
+ init_s(&cpssa[1].s, 14);
+
+ SSS sss(15, cps);
+
+ SSS& ref (sss);
+
+ Derived derived;
+
+ Fake fake (42);
+#endif
+
+ add_item (&c, 23); /* MI breakpoint here */
+ add_item (&c, 72);
+
+#ifdef MI
+ add_item (&c, 1011);
+ c.elements[0] = 1023;
+ c.elements[0] = 2323;
+
+ add_item (&c2, 2222);
+ add_item (&c2, 3333);
+
+ substruct_test ();
+ do_nothing ();
+#endif
+
+ nstype.elements[0] = 7;
+ nstype.elements[1] = 42;
+ nstype.len = 2;
+
+ nstype2 = nstype;
+
+ eval_sub ();
+
+ bug_14741(); /* break to inspect struct and union */
+ return 0;
+}
diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.exp b/gdb/testsuite/gdb.guile/scm-pretty-print.exp
new file mode 100644
index 0000000..524c440
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-pretty-print.exp
@@ -0,0 +1,148 @@
+# Copyright (C) 2008-2013 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-based pretty-printing for the CLI.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+proc run_lang_tests {exefile lang} {
+ global srcdir subdir srcfile testfile hex
+ if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
+ untested "Couldn't compile ${srcfile} in $lang mode"
+ return
+ }
+
+ set nl "\[\r\n\]+"
+
+ # Start with a fresh gdb.
+ gdb_exit
+ gdb_start
+ gdb_reinitialize_dir $srcdir/$subdir
+ gdb_load ${exefile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ gdb_test_no_output "set print pretty on"
+
+ gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+ gdb_test "continue" ".*Breakpoint.*"
+
+ set remote_scheme_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+
+ gdb_scm_load_file ${remote_scheme_file}
+
+ gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>"
+ gdb_test "print ssa\[1\]" " = a=<a=<5> b=<$hex>> b=<a=<6> b=<$hex>>"
+ gdb_test "print ssa" " = {a=<a=<3> b=<$hex>> b=<a=<4> b=<$hex>>, a=<a=<5> b=<$hex>> b=<a=<6> b=<$hex>>}"
+
+ gdb_test "print arraystruct" " = {$nl *y = 7, *$nl *x = {a=<23> b=<$hex>, a=<24> b=<$hex>} *$nl *}"
+
+ if {$lang == "c++"} {
+ gdb_test "print cps" "= a=<8> b=<$hex>"
+ gdb_test "print cpss" " = {$nl *zss = 9, *$nl *s = a=<10> b=<$hex>$nl}"
+ gdb_test "print cpssa\[0\]" " = {$nl *zss = 11, *$nl *s = a=<12> b=<$hex>$nl}"
+ gdb_test "print cpssa\[1\]" " = {$nl *zss = 13, *$nl *s = a=<14> b=<$hex>$nl}"
+ gdb_test "print cpssa" " = {{$nl *zss = 11, *$nl *s = a=<12> b=<$hex>$nl *}, {$nl *zss = 13, *$nl *s = a=<14> b=<$hex>$nl *}}"
+ gdb_test "print sss" "= a=<15> b=<a=<8> b=<$hex>>"
+ gdb_test "print ref" "= a=<15> b=<a=<8> b=<$hex>>"
+ gdb_test "print derived" \
+ " = \{.*<Vbase1> = pp class name: Vbase1.*<Vbase2> = \{.*<VirtualTest> = pp value variable is: 1,.*members of Vbase2:.*_vptr.Vbase2 = $hex.*<Vbase3> = \{.*members of Vbase3.*members of Derived:.*value = 2.*"
+ gdb_test "print ns " "\"embedded\\\\000null\\\\000string\""
+ gdb_scm_test_silent_cmd "set print elements 3" "" 1
+ gdb_test "print ns" "emb\.\.\.."
+ gdb_scm_test_silent_cmd "set print elements 10" "" 1
+ gdb_test "print ns" "embedded\\\\000n\.\.\.."
+ gdb_scm_test_silent_cmd "set print elements 200" "" 1
+ }
+
+ gdb_test "print ns2" "<error reading variable: ERROR: Cannot access memory at address 0x0>"
+
+ gdb_test "print x" " = \"this is x\""
+ gdb_test "print cstring" " = \"const string\""
+
+ gdb_test "print estring" " = \"embedded x\\\\201\\\\202\\\\203\\\\204\""
+
+ gdb_test_no_output "guile (set! *pp-ls-encoding* \"UTF-8\")"
+ gdb_test "print estring2" "\"embedded \", <incomplete sequence \\\\302>"
+
+ gdb_test_no_output "set guile print-stack full"
+ gdb_test "print hint_error" "ERROR: Invalid display hint: 42\r\nhint_error_val"
+
+ gdb_test "print c" " = container \"container\" with 2 elements = {$nl *.0. = 23,$nl *.1. = 72$nl}"
+
+ gdb_test "print nstype" " = {$nl *.0. = 7,$nl *.1. = 42$nl}"
+
+ gdb_test_no_output "set print pretty off"
+ gdb_test "print nstype" " = {.0. = 7, .1. = 42}" \
+ "print nstype on one line"
+
+ gdb_continue_to_end
+}
+
+run_lang_tests "${binfile}" "c"
+run_lang_tests "${binfile}-cxx" "c++"
+
+# Run various other tests.
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+set remote_scheme_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+
+gdb_scm_load_file ${remote_scheme_file}
+
+gdb_breakpoint [gdb_get_line_number "eval-break"]
+gdb_continue_to_breakpoint "eval-break" ".* eval-break .*"
+
+gdb_test "info locals" "eval9 = eval=<123456789>"
+
+gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+gdb_test "continue" ".*Breakpoint.*"
+
+gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
+ "print ss enabled #1"
+
+gdb_test_no_output "guile (disable-matcher!)"
+
+gdb_test "print ss" " = {a = {a = 1, b = $hex}, b = {a = 2, b = $hex}}" \
+ "print ss disabled"
+
+gdb_test_no_output "guile (enable-matcher!)"
+
+gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
+ "print ss enabled #2"
diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.scm b/gdb/testsuite/gdb.guile/scm-pretty-print.scm
new file mode 100644
index 0000000..c914945
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-pretty-print.scm
@@ -0,0 +1,301 @@
+;; Copyright (C) 2008-2013 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 Scheme pretty printers.
+
+(use-modules (gdb) (gdb printing))
+
+(define (make-pointer-iterator pointer len)
+ (let ((next! (lambda (iter)
+ (let* ((start (iterator-object iter))
+ (progress (iterator-progress iter))
+ (current (car progress))
+ (len (cdr progress)))
+ (if (= current len)
+ #f
+ (let ((pointer (value-add start current)))
+ (set-car! progress (+ current 1))
+ (cons (format #f "[~A]" current)
+ (value-dereference pointer))))))))
+ (make-iterator pointer (cons 0 len) next!)))
+
+(define (make-pointer-iterator-except pointer len)
+ (let ((next! (lambda (iter)
+ (if *exception-flag*
+ (throw 'gdb:memory-error "hi bob"))
+ (let* ((start (iterator-object iter))
+ (progress (iterator-progress iter))
+ (current (car progress))
+ (len (cdr progress)))
+ (if (= current len)
+ #f
+ (let ((pointer (value-add start current)))
+ (set-car! progress (+ current 1))
+ (cons (format #f "[~A]" current)
+ (value-dereference pointer))))))))
+ (make-iterator pointer (cons 0 len) next!)))
+
+;; Test returning a <gdb:value> from a printer.
+
+(define (make-string-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (value-field (value-field val "whybother")
+ "contents"))
+ #f))
+
+;; Test a printer with children.
+
+(define (make-container-printer val)
+ ;; This is a little different than the Python version in that if there's
+ ;; an error accessing these fields we'll throw it at matcher time instead
+ ;; of at printer time. Done this way to explore the possibilities.
+ (let ((name (value-field val "name"))
+ (len (value-field val "len"))
+ (elements (value-field val "elements")))
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "container ~A with ~A elements"
+ name len))
+ (lambda (printer)
+ (make-pointer-iterator elements (value->integer len))))))
+
+;; Test "array" display hint.
+
+(define (make-array-printer val)
+ (let ((name (value-field val "name"))
+ (len (value-field val "len"))
+ (elements (value-field val "elements")))
+ (make-pretty-printer-worker
+ "array"
+ (lambda (printer)
+ (format #f "array ~A with ~A elements"
+ name len))
+ (lambda (printer)
+ (make-pointer-iterator elements (value->integer len))))))
+
+;; Flag to make no-string-container printer throw an exception.
+
+(define *exception-flag* #f)
+
+;; Test a printer where to_string returns #f.
+
+(define (make-no-string-container-printer val)
+ (let ((len (value-field val "len"))
+ (elements (value-field val "elements")))
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer) #f)
+ (lambda (printer)
+ (make-pointer-iterator-except elements (value->integer len))))))
+
+(define (make-pp_s-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (if (not (value=? (value-address a) b))
+ (error (format #f "&a(~A) != b(~A)"
+ (value-address a) b)))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #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 (make-pp_sss-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 (make-pp_multiple_virtual-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "pp value variable is: ~A" (value-field val "value")))
+ #f))
+
+(define (make-pp_vbase1-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "pp class name: ~A" (type-tag (value-type val))))
+ #f))
+
+(define (make-pp_nullstr-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (value->string (value-field val "s")
+ #:encoding (arch-charset (current-arch))))
+ #f))
+
+(define (make-pp_ns-printer val)
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (let ((len (value-field val "length")))
+ (value->string (value-field val "null_str")
+ #:encoding (arch-charset (current-arch))
+ #:length (value->integer len))))
+ #f))
+
+(define *pp-ls-encoding* #f)
+
+(define (make-pp_ls-printer val)
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (if *pp-ls-encoding*
+ (value->lazy-string (value-field val "lazy_str")
+ #:encoding *pp-ls-encoding*)
+ (value->lazy-string (value-field val "lazy_str"))))
+ #f))
+
+(define (make-pp_hint_error-printer val)
+ "Use an invalid value for the display hint."
+ (make-pretty-printer-worker
+ 42
+ (lambda (printer) "hint_error_val")
+ #f))
+
+(define (make-pp_children_as_list-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer) "children_as_list_val")
+ (lambda (printer) (make-list-iterator (list (cons "one" 1))))))
+
+(define (make-pp_outer-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "x = ~A" (value-field val "x")))
+ (lambda (printer)
+ (make-list-iterator (list (cons "s" (value-field val "s"))
+ (cons "x" (value-field val "x")))))))
+
+(define (make-memory-error-string-printer val)
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (scm-error 'gdb:memory-error "memory-error-printer"
+ "Cannot access memory." '() '()))
+ #f))
+
+(define (make-pp_eval_type-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (execute "bt" #:to-string #t)
+ (format #f "eval=<~A>"
+ (value-print
+ (parse-and-eval
+ "eval_func (123456789, 2, 3, 4, 5, 6, 7, 8)"))))
+ #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 (disable-matcher!)
+ (set-pretty-printer-enabled! *pretty-printer* #f))
+
+(define (enable-matcher!)
+ (set-pretty-printer-enabled! *pretty-printer* #t))
+
+(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 "S" make-pp_s-printer)
+
+ (hash-set! dict "struct ss" make-pp_ss-printer)
+ (hash-set! dict "ss" make-pp_ss-printer)
+ (hash-set! dict "const S &" make-pp_s-printer)
+ (hash-set! dict "SSS" make-pp_sss-printer)
+
+ (hash-set! dict "VirtualTest" make-pp_multiple_virtual-printer)
+ (hash-set! dict "Vbase1" make-pp_vbase1-printer)
+
+ (hash-set! dict "struct nullstr" make-pp_nullstr-printer)
+ (hash-set! dict "nullstr" make-pp_nullstr-printer)
+
+ ;; Note that we purposely omit the typedef names here.
+ ;; Printer lookup is based on canonical name.
+ ;; However, we do need both tagged and untagged variants, to handle
+ ;; both the C and C++ cases.
+ (hash-set! dict "struct string_repr" make-string-printer)
+ (hash-set! dict "struct container" make-container-printer)
+ (hash-set! dict "struct justchildren" make-no-string-container-printer)
+ (hash-set! dict "string_repr" make-string-printer)
+ (hash-set! dict "container" make-container-printer)
+ (hash-set! dict "justchildren" make-no-string-container-printer)
+
+ (hash-set! dict "struct ns" make-pp_ns-printer)
+ (hash-set! dict "ns" make-pp_ns-printer)
+
+ (hash-set! dict "struct lazystring" make-pp_ls-printer)
+ (hash-set! dict "lazystring" make-pp_ls-printer)
+
+ (hash-set! dict "struct outerstruct" make-pp_outer-printer)
+ (hash-set! dict "outerstruct" make-pp_outer-printer)
+
+ (hash-set! dict "struct hint_error" make-pp_hint_error-printer)
+ (hash-set! dict "hint_error" make-pp_hint_error-printer)
+
+ (hash-set! dict "struct children_as_list"
+ make-pp_children_as_list-printer)
+ (hash-set! dict "children_as_list" make-pp_children_as_list-printer)
+
+ (hash-set! dict "memory_error" make-memory-error-string-printer)
+
+ (hash-set! dict "eval_type_s" make-pp_eval_type-printer)
+
+ dict))
+
+;; This is one way to register a printer that is composed of several
+;; subprinters, but there's no way to disable or list individual subprinters.
+
+(define *pretty-printer*
+ (make-pretty-printer
+ "pretty-printer-test"
+ (let ((pretty-printers-dict (make-pretty-printer-dict)))
+ (lambda (matcher val)
+ "Look-up and return a pretty-printer that can print val."
+ (let ((type (get-type-for-printing val)))
+ (let ((typename (type-tag type)))
+ (if typename
+ (let ((printer-maker (hash-ref pretty-printers-dict typename)))
+ (and printer-maker (printer-maker val)))
+ #f)))))))
+
+(append-pretty-printer! #f *pretty-printer*)