gdb/guile/scm-pretty-print.c

   1 /* GDB/Scheme pretty-printing.
   2
   3    Copyright (C) 2008-2019 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "charset.h"
  25 #include "symtab.h" /* Needed by language.h.  */
  26 #include "language.h"
  27 #include "objfiles.h"
  28 #include "value.h"
  29 #include "valprint.h"
  30 #include "guile-internal.h"
  31
  32 /* Return type of print_string_repr.  */
  33
  34 enum string_repr_result
  35 {
  36   /* The string method returned None.  */
  37   STRING_REPR_NONE,
  38   /* The string method had an error.  */
  39   STRING_REPR_ERROR,
  40   /* Everything ok.  */
  41   STRING_REPR_OK
  42 };
  43
  44 /* Display hints.  */
  45
  46 enum display_hint
  47 {
  48   /* No display hint.  */
  49   HINT_NONE,
  50   /* The display hint has a bad value.  */
  51   HINT_ERROR,
  52   /* Print as an array.  */
  53   HINT_ARRAY,
  54   /* Print as a map.  */
  55   HINT_MAP,
  56   /* Print as a string.  */
  57   HINT_STRING
  58 };
  59
  60 /* The <gdb:pretty-printer> smob.  */
  61
  62 typedef struct
  63 {
  64   /* This must appear first.  */
  65   gdb_smob base;
  66
  67   /* A string representing the name of the printer.  */
  68   SCM name;
  69
  70   /* A boolean indicating whether the printer is enabled.  */
  71   SCM enabled;
  72
  73   /* A procedure called to look up the printer for the given value.
  74      The procedure is called as (lookup gdb:pretty-printer value).
  75      The result should either be a gdb:pretty-printer object that will print
  76      the value, or #f if the value is not recognized.  */
  77   SCM lookup;
  78
  79   /* Note: Attaching subprinters to this smob is left to Scheme.  */
  80 } pretty_printer_smob;
  81
  82 /* The <gdb:pretty-printer-worker> smob.  */
  83
  84 typedef struct
  85 {
  86   /* This must appear first.  */
  87   gdb_smob base;
  88
  89   /* Either #f or one of the supported display hints: map, array, string.
  90      If neither of those then the display hint is ignored (treated as #f).  */
  91   SCM display_hint;
  92
  93   /* A procedure called to pretty-print the value.
  94      (lambda (printer) ...) -> string | <gdb:lazy-string> | <gdb:value>  */
  95   SCM to_string;
  96
  97   /* A procedure called to print children of the value.
  98      (lambda (printer) ...) -> <gdb:iterator>
  99      The iterator returns a pair for each iteration: (name . value),
 100      where "value" can have the same types as to_string.  */
 101   SCM children;
 102 } pretty_printer_worker_smob;
 103
 104 static const char pretty_printer_smob_name[] =
 105   "gdb:pretty-printer";
 106 static const char pretty_printer_worker_smob_name[] =
 107   "gdb:pretty-printer-worker";
 108
 109 /* The tag Guile knows the pretty-printer smobs by.  */
 110 static scm_t_bits pretty_printer_smob_tag;
 111 static scm_t_bits pretty_printer_worker_smob_tag;
 112
 113 /* The global pretty-printer list.  */
 114 static SCM pretty_printer_list;
 115
 116 /* gdb:pp-type-error.  */
 117 static SCM pp_type_error_symbol;
 118
 119 /* Pretty-printer display hints are specified by strings.  */
 120 static SCM ppscm_map_string;
 121 static SCM ppscm_array_string;
 122 static SCM ppscm_string_string;
 123 \f
 124 /* Administrivia for pretty-printer matcher smobs.  */
 125
 126 /* The smob "print" function for <gdb:pretty-printer>.  */
 127
 128 static int
 129 ppscm_print_pretty_printer_smob (SCM self, SCM port, scm_print_state *pstate)
 130 {
 131   pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
 132
 133   gdbscm_printf (port, "#<%s ", pretty_printer_smob_name);
 134   scm_write (pp_smob->name, port);
 135   scm_puts (gdbscm_is_true (pp_smob->enabled) ? " enabled" : " disabled",
 136             port);
 137   scm_puts (">", port);
 138
 139   scm_remember_upto_here_1 (self);
 140
 141   /* Non-zero means success.  */
 142   return 1;
 143 }
 144
 145 /* (make-pretty-printer string procedure) -> <gdb:pretty-printer> */
 146
 147 static SCM
 148 gdbscm_make_pretty_printer (SCM name, SCM lookup)
 149 {
 150   pretty_printer_smob *pp_smob = (pretty_printer_smob *)
 151     scm_gc_malloc (sizeof (pretty_printer_smob),
 152                    pretty_printer_smob_name);
 153   SCM smob;
 154
 155   SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, FUNC_NAME,
 156                    _("string"));
 157   SCM_ASSERT_TYPE (gdbscm_is_procedure (lookup), lookup, SCM_ARG2, FUNC_NAME,
 158                    _("procedure"));
 159
 160   pp_smob->name = name;
 161   pp_smob->lookup = lookup;
 162   pp_smob->enabled = SCM_BOOL_T;
 163   smob = scm_new_smob (pretty_printer_smob_tag, (scm_t_bits) pp_smob);
 164   gdbscm_init_gsmob (&pp_smob->base);
 165
 166   return smob;
 167 }
 168
 169 /* Return non-zero if SCM is a <gdb:pretty-printer> object.  */
 170
 171 static int
 172 ppscm_is_pretty_printer (SCM scm)
 173 {
 174   return SCM_SMOB_PREDICATE (pretty_printer_smob_tag, scm);
 175 }
 176
 177 /* (pretty-printer? object) -> boolean */
 178
 179 static SCM
 180 gdbscm_pretty_printer_p (SCM scm)
 181 {
 182   return scm_from_bool (ppscm_is_pretty_printer (scm));
 183 }
 184
 185 /* Returns the <gdb:pretty-printer> object in SELF.
 186    Throws an exception if SELF is not a <gdb:pretty-printer> object.  */
 187
 188 static SCM
 189 ppscm_get_pretty_printer_arg_unsafe (SCM self, int arg_pos,
 190                                      const char *func_name)
 191 {
 192   SCM_ASSERT_TYPE (ppscm_is_pretty_printer (self), self, arg_pos, func_name,
 193                    pretty_printer_smob_name);
 194
 195   return self;
 196 }
 197
 198 /* Returns a pointer to the pretty-printer smob of SELF.
 199    Throws an exception if SELF is not a <gdb:pretty-printer> object.  */
 200
 201 static pretty_printer_smob *
 202 ppscm_get_pretty_printer_smob_arg_unsafe (SCM self, int arg_pos,
 203                                           const char *func_name)
 204 {
 205   SCM pp_scm = ppscm_get_pretty_printer_arg_unsafe (self, arg_pos, func_name);
 206   pretty_printer_smob *pp_smob
 207     = (pretty_printer_smob *) SCM_SMOB_DATA (pp_scm);
 208
 209   return pp_smob;
 210 }
 211 \f
 212 /* Pretty-printer methods.  */
 213
 214 /* (pretty-printer-enabled? <gdb:pretty-printer>) -> boolean */
 215
 216 static SCM
 217 gdbscm_pretty_printer_enabled_p (SCM self)
 218 {
 219   pretty_printer_smob *pp_smob
 220     = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 221
 222   return pp_smob->enabled;
 223 }
 224
 225 /* (set-pretty-printer-enabled! <gdb:pretty-printer> boolean)
 226      -> unspecified */
 227
 228 static SCM
 229 gdbscm_set_pretty_printer_enabled_x (SCM self, SCM enabled)
 230 {
 231   pretty_printer_smob *pp_smob
 232     = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 233
 234   pp_smob->enabled = scm_from_bool (gdbscm_is_true (enabled));
 235
 236   return SCM_UNSPECIFIED;
 237 }
 238
 239 /* (pretty-printers) -> list
 240    Returns the list of global pretty-printers.  */
 241
 242 static SCM
 243 gdbscm_pretty_printers (void)
 244 {
 245   return pretty_printer_list;
 246 }
 247
 248 /* (set-pretty-printers! list) -> unspecified
 249    Set the global pretty-printers list.  */
 250
 251 static SCM
 252 gdbscm_set_pretty_printers_x (SCM printers)
 253 {
 254   SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
 255                    SCM_ARG1, FUNC_NAME, _("list"));
 256
 257   pretty_printer_list = printers;
 258
 259   return SCM_UNSPECIFIED;
 260 }
 261 \f
 262 /* Administrivia for pretty-printer-worker smobs.
 263    These are created when a matcher recognizes a value.  */
 264
 265 /* The smob "print" function for <gdb:pretty-printer-worker>.  */
 266
 267 static int
 268 ppscm_print_pretty_printer_worker_smob (SCM self, SCM port,
 269                                         scm_print_state *pstate)
 270 {
 271   pretty_printer_worker_smob *w_smob
 272     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (self);
 273
 274   gdbscm_printf (port, "#<%s ", pretty_printer_worker_smob_name);
 275   scm_write (w_smob->display_hint, port);
 276   scm_puts (" ", port);
 277   scm_write (w_smob->to_string, port);
 278   scm_puts (" ", port);
 279   scm_write (w_smob->children, port);
 280   scm_puts (">", port);
 281
 282   scm_remember_upto_here_1 (self);
 283
 284   /* Non-zero means success.  */
 285   return 1;
 286 }
 287
 288 /* (make-pretty-printer-worker string procedure procedure)
 289      -> <gdb:pretty-printer-worker> */
 290
 291 static SCM
 292 gdbscm_make_pretty_printer_worker (SCM display_hint, SCM to_string,
 293                                    SCM children)
 294 {
 295   pretty_printer_worker_smob *w_smob = (pretty_printer_worker_smob *)
 296     scm_gc_malloc (sizeof (pretty_printer_worker_smob),
 297                    pretty_printer_worker_smob_name);
 298   SCM w_scm;
 299
 300   w_smob->display_hint = display_hint;
 301   w_smob->to_string = to_string;
 302   w_smob->children = children;
 303   w_scm = scm_new_smob (pretty_printer_worker_smob_tag, (scm_t_bits) w_smob);
 304   gdbscm_init_gsmob (&w_smob->base);
 305   return w_scm;
 306 }
 307
 308 /* Return non-zero if SCM is a <gdb:pretty-printer-worker> object.  */
 309
 310 static int
 311 ppscm_is_pretty_printer_worker (SCM scm)
 312 {
 313   return SCM_SMOB_PREDICATE (pretty_printer_worker_smob_tag, scm);
 314 }
 315
 316 /* (pretty-printer-worker? object) -> boolean */
 317
 318 static SCM
 319 gdbscm_pretty_printer_worker_p (SCM scm)
 320 {
 321   return scm_from_bool (ppscm_is_pretty_printer_worker (scm));
 322 }
 323 \f
 324 /* Helper function to create a <gdb:exception> object indicating that the
 325    type of some value returned from a pretty-printer is invalid.  */
 326
 327 static SCM
 328 ppscm_make_pp_type_error_exception (const char *message, SCM object)
 329 {
 330   std::string msg = string_printf ("%s: ~S", message);
 331   return gdbscm_make_error (pp_type_error_symbol,
 332                             NULL /* func */, msg.c_str (),
 333                             scm_list_1 (object), scm_list_1 (object));
 334 }
 335
 336 /* Print MESSAGE as an exception (meaning it is controlled by
 337    "guile print-stack").
 338    Called from the printer code when the Scheme code returns an invalid type
 339    for something.  */
 340
 341 static void
 342 ppscm_print_pp_type_error (const char *message, SCM object)
 343 {
 344   SCM exception = ppscm_make_pp_type_error_exception (message, object);
 345
 346   gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 347 }
 348
 349 /* Helper function for find_pretty_printer which iterates over a list,
 350    calls each function and inspects output.  This will return a
 351    <gdb:pretty-printer> object if one recognizes VALUE.  If no printer is
 352    found, it will return #f.  On error, it will return a <gdb:exception>
 353    object.
 354
 355    Note: This has to be efficient and careful.
 356    We don't want to excessively slow down printing of values, but any kind of
 357    random crud can appear in the pretty-printer list, and we can't crash
 358    because of it.  */
 359
 360 static SCM
 361 ppscm_search_pp_list (SCM list, SCM value)
 362 {
 363   SCM orig_list = list;
 364
 365   if (scm_is_null (list))
 366     return SCM_BOOL_F;
 367   if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
 368     {
 369       return ppscm_make_pp_type_error_exception
 370         (_("pretty-printer list is not a list"), list);
 371     }
 372
 373   for ( ; scm_is_pair (list); list = scm_cdr (list))
 374     {
 375       SCM matcher = scm_car (list);
 376       SCM worker;
 377       pretty_printer_smob *pp_smob;
 378
 379       if (!ppscm_is_pretty_printer (matcher))
 380         {
 381           return ppscm_make_pp_type_error_exception
 382             (_("pretty-printer list contains non-pretty-printer object"),
 383              matcher);
 384         }
 385
 386       pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
 387
 388       /* Skip if disabled.  */
 389       if (gdbscm_is_false (pp_smob->enabled))
 390         continue;
 391
 392       if (!gdbscm_is_procedure (pp_smob->lookup))
 393         {
 394           return ppscm_make_pp_type_error_exception
 395             (_("invalid lookup object in pretty-printer matcher"),
 396              pp_smob->lookup);
 397         }
 398
 399       worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
 400                                    value, gdbscm_memory_error_p);
 401       if (!gdbscm_is_false (worker))
 402         {
 403           if (gdbscm_is_exception (worker))
 404             return worker;
 405           if (ppscm_is_pretty_printer_worker (worker))
 406             return worker;
 407           return ppscm_make_pp_type_error_exception
 408             (_("invalid result from pretty-printer lookup"), worker);
 409         }
 410     }
 411
 412   if (!scm_is_null (list))
 413     {
 414       return ppscm_make_pp_type_error_exception
 415         (_("pretty-printer list is not a list"), orig_list);
 416     }
 417
 418   return SCM_BOOL_F;
 419 }
 420
 421 /* Subroutine of find_pretty_printer to simplify it.
 422    Look for a pretty-printer to print VALUE in all objfiles.
 423    If there's an error an exception smob is returned.
 424    The result is #f, if no pretty-printer was found.
 425    Otherwise the result is the pretty-printer smob.  */
 426
 427 static SCM
 428 ppscm_find_pretty_printer_from_objfiles (SCM value)
 429 {
 430   for (objfile *objfile : current_program_space->objfiles ())
 431     {
 432       objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
 433       SCM pp
 434         = ppscm_search_pp_list (ofscm_objfile_smob_pretty_printers (o_smob),
 435                                 value);
 436
 437       /* Note: This will return if pp is a <gdb:exception> object,
 438          which is what we want.  */
 439       if (gdbscm_is_true (pp))
 440         return pp;
 441     }
 442
 443   return SCM_BOOL_F;
 444 }
 445
 446 /* Subroutine of find_pretty_printer to simplify it.
 447    Look for a pretty-printer to print VALUE in the current program space.
 448    If there's an error an exception smob is returned.
 449    The result is #f, if no pretty-printer was found.
 450    Otherwise the result is the pretty-printer smob.  */
 451
 452 static SCM
 453 ppscm_find_pretty_printer_from_progspace (SCM value)
 454 {
 455   pspace_smob *p_smob = psscm_pspace_smob_from_pspace (current_program_space);
 456   SCM pp
 457     = ppscm_search_pp_list (psscm_pspace_smob_pretty_printers (p_smob), value);
 458
 459   return pp;
 460 }
 461
 462 /* Subroutine of find_pretty_printer to simplify it.
 463    Look for a pretty-printer to print VALUE in the gdb module.
 464    If there's an error a Scheme exception is returned.
 465    The result is #f, if no pretty-printer was found.
 466    Otherwise the result is the pretty-printer smob.  */
 467
 468 static SCM
 469 ppscm_find_pretty_printer_from_gdb (SCM value)
 470 {
 471   SCM pp = ppscm_search_pp_list (pretty_printer_list, value);
 472
 473   return pp;
 474 }
 475
 476 /* Find the pretty-printing constructor function for VALUE.  If no
 477    pretty-printer exists, return #f.  If one exists, return the
 478    gdb:pretty-printer smob that implements it.  On error, an exception smob
 479    is returned.
 480
 481    Note: In the end it may be better to call out to Scheme once, and then
 482    do all of the lookup from Scheme.  TBD.  */
 483
 484 static SCM
 485 ppscm_find_pretty_printer (SCM value)
 486 {
 487   SCM pp;
 488
 489   /* Look at the pretty-printer list for each objfile
 490      in the current program-space.  */
 491   pp = ppscm_find_pretty_printer_from_objfiles (value);
 492   /* Note: This will return if function is a <gdb:exception> object,
 493      which is what we want.  */
 494   if (gdbscm_is_true (pp))
 495     return pp;
 496
 497   /* Look at the pretty-printer list for the current program-space.  */
 498   pp = ppscm_find_pretty_printer_from_progspace (value);
 499   /* Note: This will return if function is a <gdb:exception> object,
 500      which is what we want.  */
 501   if (gdbscm_is_true (pp))
 502     return pp;
 503
 504   /* Look at the pretty-printer list in the gdb module.  */
 505   pp = ppscm_find_pretty_printer_from_gdb (value);
 506   return pp;
 507 }
 508
 509 /* Pretty-print a single value, via the PRINTER, which must be a
 510    <gdb:pretty-printer-worker> object.
 511    The caller is responsible for ensuring PRINTER is valid.
 512    If the function returns a string, an SCM containing the string
 513    is returned.  If the function returns #f that means the pretty
 514    printer returned #f as a value.  Otherwise, if the function returns a
 515    <gdb:value> object, *OUT_VALUE is set to the value and #t is returned.
 516    It is an error if the printer returns #t.
 517    On error, an exception smob is returned.  */
 518
 519 static SCM
 520 ppscm_pretty_print_one_value (SCM printer, struct value **out_value,
 521                               struct gdbarch *gdbarch,
 522                               const struct language_defn *language)
 523 {
 524   SCM result = SCM_BOOL_F;
 525
 526   *out_value = NULL;
 527   TRY
 528     {
 529       pretty_printer_worker_smob *w_smob
 530         = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 531
 532       result = gdbscm_safe_call_1 (w_smob->to_string, printer,
 533                                    gdbscm_memory_error_p);
 534       if (gdbscm_is_false (result))
 535         ; /* Done.  */
 536       else if (scm_is_string (result)
 537                || lsscm_is_lazy_string (result))
 538         ; /* Done.  */
 539       else if (vlscm_is_value (result))
 540         {
 541           SCM except_scm;
 542
 543           *out_value
 544             = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
 545                                                result, &except_scm,
 546                                                gdbarch, language);
 547           if (*out_value != NULL)
 548             result = SCM_BOOL_T;
 549           else
 550             result = except_scm;
 551         }
 552       else if (gdbscm_is_exception (result))
 553         ; /* Done.  */
 554       else
 555         {
 556           /* Invalid result from to-string.  */
 557           result = ppscm_make_pp_type_error_exception
 558             (_("invalid result from pretty-printer to-string"), result);
 559         }
 560     }
 561   CATCH (except, RETURN_MASK_ALL)
 562     {
 563     }
 564   END_CATCH
 565
 566   return result;
 567 }
 568
 569 /* Return the display hint for PRINTER as a Scheme object.
 570    The caller is responsible for ensuring PRINTER is a
 571    <gdb:pretty-printer-worker> object.  */
 572
 573 static SCM
 574 ppscm_get_display_hint_scm (SCM printer)
 575 {
 576   pretty_printer_worker_smob *w_smob
 577     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 578
 579   return w_smob->display_hint;
 580 }
 581
 582 /* Return the display hint for the pretty-printer PRINTER.
 583    The caller is responsible for ensuring PRINTER is a
 584    <gdb:pretty-printer-worker> object.
 585    Returns the display hint or #f if the hint is not a string.  */
 586
 587 static enum display_hint
 588 ppscm_get_display_hint_enum (SCM printer)
 589 {
 590   SCM hint = ppscm_get_display_hint_scm (printer);
 591
 592   if (gdbscm_is_false (hint))
 593     return HINT_NONE;
 594   if (scm_is_string (hint))
 595     {
 596       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_array_string)))
 597         return HINT_STRING;
 598       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_map_string)))
 599         return HINT_STRING;
 600       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_string_string)))
 601         return HINT_STRING;
 602       return HINT_ERROR;
 603     }
 604   return HINT_ERROR;
 605 }
 606
 607 /* A wrapper for gdbscm_print_gdb_exception that ignores memory errors.
 608    EXCEPTION is a <gdb:exception> object.  */
 609
 610 static void
 611 ppscm_print_exception_unless_memory_error (SCM exception,
 612                                            struct ui_file *stream)
 613 {
 614   if (gdbscm_memory_error_p (gdbscm_exception_key (exception)))
 615     {
 616       gdb::unique_xmalloc_ptr<char> msg
 617         = gdbscm_exception_message_to_string (exception);
 618
 619       /* This "shouldn't happen", but play it safe.  */
 620       if (msg == NULL || msg.get ()[0] == '\0')
 621         fprintf_filtered (stream, _("<error reading variable>"));
 622       else
 623         {
 624           /* Remove the trailing newline.  We could instead call a special
 625              routine for printing memory error messages, but this is easy
 626              enough for now.  */
 627           char *msg_text = msg.get ();
 628           size_t len = strlen (msg_text);
 629
 630           if (msg_text[len - 1] == '\n')
 631             msg_text[len - 1] = '\0';
 632           fprintf_filtered (stream, _("<error reading variable: %s>"), msg_text);
 633         }
 634     }
 635   else
 636     gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 637 }
 638
 639 /* Helper for gdbscm_apply_val_pretty_printer which calls to_string and
 640    formats the result.  */
 641
 642 static enum string_repr_result
 643 ppscm_print_string_repr (SCM printer, enum display_hint hint,
 644                          struct ui_file *stream, int recurse,
 645                          const struct value_print_options *options,
 646                          struct gdbarch *gdbarch,
 647                          const struct language_defn *language)
 648 {
 649   struct value *replacement = NULL;
 650   SCM str_scm;
 651   enum string_repr_result result = STRING_REPR_ERROR;
 652
 653   str_scm = ppscm_pretty_print_one_value (printer, &replacement,
 654                                           gdbarch, language);
 655   if (gdbscm_is_false (str_scm))
 656     {
 657       result = STRING_REPR_NONE;
 658     }
 659   else if (scm_is_eq (str_scm, SCM_BOOL_T))
 660     {
 661       struct value_print_options opts = *options;
 662
 663       gdb_assert (replacement != NULL);
 664       opts.addressprint = 0;
 665       common_val_print (replacement, stream, recurse, &opts, language);
 666       result = STRING_REPR_OK;
 667     }
 668   else if (scm_is_string (str_scm))
 669     {
 670       size_t length;
 671       gdb::unique_xmalloc_ptr<char> string
 672         = gdbscm_scm_to_string (str_scm, &length,
 673                                 target_charset (gdbarch), 0 /*!strict*/, NULL);
 674
 675       if (hint == HINT_STRING)
 676         {
 677           struct type *type = builtin_type (gdbarch)->builtin_char;
 678
 679           LA_PRINT_STRING (stream, type, (gdb_byte *) string.get (),
 680                            length, NULL, 0, options);
 681         }
 682       else
 683         {
 684           /* Alas scm_to_stringn doesn't nul-terminate the string if we
 685              ask for the length.  */
 686           size_t i;
 687
 688           for (i = 0; i < length; ++i)
 689             {
 690               if (string.get ()[i] == '\0')
 691                 fputs_filtered ("\\000", stream);
 692               else
 693                 fputc_filtered (string.get ()[i], stream);
 694             }
 695         }
 696       result = STRING_REPR_OK;
 697     }
 698   else if (lsscm_is_lazy_string (str_scm))
 699     {
 700       struct value_print_options local_opts = *options;
 701
 702       local_opts.addressprint = 0;
 703       lsscm_val_print_lazy_string (str_scm, stream, &local_opts);
 704       result = STRING_REPR_OK;
 705     }
 706   else
 707     {
 708       gdb_assert (gdbscm_is_exception (str_scm));
 709       ppscm_print_exception_unless_memory_error (str_scm, stream);
 710       result = STRING_REPR_ERROR;
 711     }
 712
 713   return result;
 714 }
 715
 716 /* Helper for gdbscm_apply_val_pretty_printer that formats children of the
 717    printer, if any exist.
 718    The caller is responsible for ensuring PRINTER is a printer smob.
 719    If PRINTED_NOTHING is true, then nothing has been printed by to_string,
 720    and format output accordingly. */
 721
 722 static void
 723 ppscm_print_children (SCM printer, enum display_hint hint,
 724                       struct ui_file *stream, int recurse,
 725                       const struct value_print_options *options,
 726                       struct gdbarch *gdbarch,
 727                       const struct language_defn *language,
 728                       int printed_nothing)
 729 {
 730   pretty_printer_worker_smob *w_smob
 731     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 732   int is_map, is_array, done_flag, pretty;
 733   unsigned int i;
 734   SCM children;
 735   SCM iter = SCM_BOOL_F; /* -Wall */
 736
 737   if (gdbscm_is_false (w_smob->children))
 738     return;
 739   if (!gdbscm_is_procedure (w_smob->children))
 740     {
 741       ppscm_print_pp_type_error
 742         (_("pretty-printer \"children\" object is not a procedure or #f"),
 743          w_smob->children);
 744       return;
 745     }
 746
 747   /* If we are printing a map or an array, we want special formatting.  */
 748   is_map = hint == HINT_MAP;
 749   is_array = hint == HINT_ARRAY;
 750
 751   children = gdbscm_safe_call_1 (w_smob->children, printer,
 752                                  gdbscm_memory_error_p);
 753   if (gdbscm_is_exception (children))
 754     {
 755       ppscm_print_exception_unless_memory_error (children, stream);
 756       goto done;
 757     }
 758   /* We combine two steps here: get children, make an iterator out of them.
 759      This simplifies things because there's no language means of creating
 760      iterators, and it's the printer object that knows how it will want its
 761      children iterated over.  */
 762   if (!itscm_is_iterator (children))
 763     {
 764       ppscm_print_pp_type_error
 765         (_("result of pretty-printer \"children\" procedure is not"
 766            " a <gdb:iterator> object"), children);
 767       goto done;
 768     }
 769   iter = children;
 770
 771   /* Use the prettyformat_arrays option if we are printing an array,
 772      and the pretty option otherwise.  */
 773   if (is_array)
 774     pretty = options->prettyformat_arrays;
 775   else
 776     {
 777       if (options->prettyformat == Val_prettyformat)
 778         pretty = 1;
 779       else
 780         pretty = options->prettyformat_structs;
 781     }
 782
 783   done_flag = 0;
 784   for (i = 0; i < options->print_max; ++i)
 785     {
 786       SCM scm_name, v_scm;
 787       SCM item = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
 788
 789       if (gdbscm_is_exception (item))
 790         {
 791           ppscm_print_exception_unless_memory_error (item, stream);
 792           break;
 793         }
 794       if (itscm_is_end_of_iteration (item))
 795         {
 796           /* Set a flag so we can know whether we printed all the
 797              available elements.  */
 798           done_flag = 1;
 799           break;
 800         }
 801
 802       if (! scm_is_pair (item))
 803         {
 804           ppscm_print_pp_type_error
 805             (_("result of pretty-printer children iterator is not a pair"
 806                " or (end-of-iteration)"),
 807              item);
 808           continue;
 809         }
 810       scm_name = scm_car (item);
 811       v_scm = scm_cdr (item);
 812       if (!scm_is_string (scm_name))
 813         {
 814           ppscm_print_pp_type_error
 815             (_("first element of pretty-printer children iterator is not"
 816                " a string"), item);
 817           continue;
 818         }
 819       gdb::unique_xmalloc_ptr<char> name
 820         = gdbscm_scm_to_c_string (scm_name);
 821
 822       /* Print initial "{".  For other elements, there are three cases:
 823          1. Maps.  Print a "," after each value element.
 824          2. Arrays.  Always print a ",".
 825          3. Other.  Always print a ",".  */
 826       if (i == 0)
 827         {
 828          if (printed_nothing)
 829            fputs_filtered ("{", stream);
 830          else
 831            fputs_filtered (" = {", stream);
 832        }
 833
 834       else if (! is_map || i % 2 == 0)
 835         fputs_filtered (pretty ? "," : ", ", stream);
 836
 837       /* In summary mode, we just want to print "= {...}" if there is
 838          a value.  */
 839       if (options->summary)
 840         {
 841           /* This increment tricks the post-loop logic to print what
 842              we want.  */
 843           ++i;
 844           /* Likewise.  */
 845           pretty = 0;
 846           break;
 847         }
 848
 849       if (! is_map || i % 2 == 0)
 850         {
 851           if (pretty)
 852             {
 853               fputs_filtered ("\n", stream);
 854               print_spaces_filtered (2 + 2 * recurse, stream);
 855             }
 856           else
 857             wrap_here (n_spaces (2 + 2 *recurse));
 858         }
 859
 860       if (is_map && i % 2 == 0)
 861         fputs_filtered ("[", stream);
 862       else if (is_array)
 863         {
 864           /* We print the index, not whatever the child method
 865              returned as the name.  */
 866           if (options->print_array_indexes)
 867             fprintf_filtered (stream, "[%d] = ", i);
 868         }
 869       else if (! is_map)
 870         {
 871           fputs_filtered (name.get (), stream);
 872           fputs_filtered (" = ", stream);
 873         }
 874
 875       if (lsscm_is_lazy_string (v_scm))
 876         {
 877           struct value_print_options local_opts = *options;
 878
 879           local_opts.addressprint = 0;
 880           lsscm_val_print_lazy_string (v_scm, stream, &local_opts);
 881         }
 882       else if (scm_is_string (v_scm))
 883         {
 884           gdb::unique_xmalloc_ptr<char> output
 885             = gdbscm_scm_to_c_string (v_scm);
 886           fputs_filtered (output.get (), stream);
 887         }
 888       else
 889         {
 890           SCM except_scm;
 891           struct value *value
 892             = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
 893                                                v_scm, &except_scm,
 894                                                gdbarch, language);
 895
 896           if (value == NULL)
 897             {
 898               ppscm_print_exception_unless_memory_error (except_scm, stream);
 899               break;
 900             }
 901           common_val_print (value, stream, recurse + 1, options, language);
 902         }
 903
 904       if (is_map && i % 2 == 0)
 905         fputs_filtered ("] = ", stream);
 906     }
 907
 908   if (i)
 909     {
 910       if (!done_flag)
 911         {
 912           if (pretty)
 913             {
 914               fputs_filtered ("\n", stream);
 915               print_spaces_filtered (2 + 2 * recurse, stream);
 916             }
 917           fputs_filtered ("...", stream);
 918         }
 919       if (pretty)
 920         {
 921           fputs_filtered ("\n", stream);
 922           print_spaces_filtered (2 * recurse, stream);
 923         }
 924       fputs_filtered ("}", stream);
 925     }
 926
 927  done:
 928   /* Play it safe, make sure ITER doesn't get GC'd.  */
 929   scm_remember_upto_here_1 (iter);
 930 }
 931
 932 /* This is the extension_language_ops.apply_val_pretty_printer "method".  */
 933
 934 enum ext_lang_rc
 935 gdbscm_apply_val_pretty_printer (const struct extension_language_defn *extlang,
 936                                  struct type *type,
 937                                  LONGEST embedded_offset, CORE_ADDR address,
 938                                  struct ui_file *stream, int recurse,
 939                                  struct value *val,
 940                                  const struct value_print_options *options,
 941                                  const struct language_defn *language)
 942 {
 943   struct gdbarch *gdbarch = get_type_arch (type);
 944   SCM exception = SCM_BOOL_F;
 945   SCM printer = SCM_BOOL_F;
 946   SCM val_obj = SCM_BOOL_F;
 947   struct value *value;
 948   enum display_hint hint;
 949   enum ext_lang_rc result = EXT_LANG_RC_NOP;
 950   enum string_repr_result print_result;
 951
 952   if (value_lazy (val))
 953     value_fetch_lazy (val);
 954
 955   /* No pretty-printer support for unavailable values.  */
 956   if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type)))
 957     return EXT_LANG_RC_NOP;
 958
 959   if (!gdb_scheme_initialized)
 960     return EXT_LANG_RC_NOP;
 961
 962   /* Instantiate the printer.  */
 963   value = value_from_component (val, type, embedded_offset);
 964
 965   val_obj = vlscm_scm_from_value (value);
 966   if (gdbscm_is_exception (val_obj))
 967     {
 968       exception = val_obj;
 969       result = EXT_LANG_RC_ERROR;
 970       goto done;
 971     }
 972
 973   printer = ppscm_find_pretty_printer (val_obj);
 974
 975   if (gdbscm_is_exception (printer))
 976     {
 977       exception = printer;
 978       result = EXT_LANG_RC_ERROR;
 979       goto done;
 980     }
 981   if (gdbscm_is_false (printer))
 982     {
 983       result = EXT_LANG_RC_NOP;
 984       goto done;
 985     }
 986   gdb_assert (ppscm_is_pretty_printer_worker (printer));
 987
 988   /* If we are printing a map, we want some special formatting.  */
 989   hint = ppscm_get_display_hint_enum (printer);
 990   if (hint == HINT_ERROR)
 991     {
 992       /* Print the error as an exception for consistency.  */
 993       SCM hint_scm = ppscm_get_display_hint_scm (printer);
 994
 995       ppscm_print_pp_type_error ("Invalid display hint", hint_scm);
 996       /* Fall through.  A bad hint doesn't stop pretty-printing.  */
 997       hint = HINT_NONE;
 998     }
 999
1000   /* Print the section.  */
1001   print_result = ppscm_print_string_repr (printer, hint, stream, recurse,
1002                                           options, gdbarch, language);
1003   if (print_result != STRING_REPR_ERROR)
1004     {
1005       ppscm_print_children (printer, hint, stream, recurse, options,
1006                             gdbarch, language,
1007                             print_result == STRING_REPR_NONE);
1008     }
1009
1010   result = EXT_LANG_RC_OK;
1011
1012  done:
1013   if (gdbscm_is_exception (exception))
1014     ppscm_print_exception_unless_memory_error (exception, stream);
1015   return result;
1016 }
1017 \f
1018 /* Initialize the Scheme pretty-printer code.  */
1019
1020 static const scheme_function pretty_printer_functions[] =
1021 {
1022   { "make-pretty-printer", 2, 0, 0,
1023     as_a_scm_t_subr (gdbscm_make_pretty_printer),
1024     "\
1025 Create a <gdb:pretty-printer> object.\n\
1026 \n\
1027   Arguments: name lookup\n\
1028     name:   a string naming the matcher\n\
1029     lookup: a procedure:\n\
1030       (pretty-printer <gdb:value>) -> <gdb:pretty-printer-worker> | #f." },
1031
1032   { "pretty-printer?", 1, 0, 0, as_a_scm_t_subr (gdbscm_pretty_printer_p),
1033     "\
1034 Return #t if the object is a <gdb:pretty-printer> object." },
1035
1036   { "pretty-printer-enabled?", 1, 0, 0,
1037     as_a_scm_t_subr (gdbscm_pretty_printer_enabled_p),
1038     "\
1039 Return #t if the pretty-printer is enabled." },
1040
1041   { "set-pretty-printer-enabled!", 2, 0, 0,
1042     as_a_scm_t_subr (gdbscm_set_pretty_printer_enabled_x),
1043     "\
1044 Set the enabled flag of the pretty-printer.\n\
1045 Returns \"unspecified\"." },
1046
1047   { "make-pretty-printer-worker", 3, 0, 0,
1048     as_a_scm_t_subr (gdbscm_make_pretty_printer_worker),
1049     "\
1050 Create a <gdb:pretty-printer-worker> object.\n\
1051 \n\
1052   Arguments: display-hint to-string children\n\
1053     display-hint: either #f or one of \"array\", \"map\", or \"string\"\n\
1054     to-string:    a procedure:\n\
1055       (pretty-printer) -> string | #f | <gdb:value>\n\
1056     children:     either #f or a procedure:\n\
1057       (pretty-printer) -> <gdb:iterator>" },
1058
1059   { "pretty-printer-worker?", 1, 0, 0,
1060     as_a_scm_t_subr (gdbscm_pretty_printer_worker_p),
1061     "\
1062 Return #t if the object is a <gdb:pretty-printer-worker> object." },
1063
1064   { "pretty-printers", 0, 0, 0, as_a_scm_t_subr (gdbscm_pretty_printers),
1065     "\
1066 Return the list of global pretty-printers." },
1067
1068   { "set-pretty-printers!", 1, 0, 0,
1069     as_a_scm_t_subr (gdbscm_set_pretty_printers_x),
1070     "\
1071 Set the list of global pretty-printers." },
1072
1073   END_FUNCTIONS
1074 };
1075
1076 void
1077 gdbscm_initialize_pretty_printers (void)
1078 {
1079   pretty_printer_smob_tag
1080     = gdbscm_make_smob_type (pretty_printer_smob_name,
1081                              sizeof (pretty_printer_smob));
1082   scm_set_smob_print (pretty_printer_smob_tag,
1083                       ppscm_print_pretty_printer_smob);
1084
1085   pretty_printer_worker_smob_tag
1086     = gdbscm_make_smob_type (pretty_printer_worker_smob_name,
1087                              sizeof (pretty_printer_worker_smob));
1088   scm_set_smob_print (pretty_printer_worker_smob_tag,
1089                       ppscm_print_pretty_printer_worker_smob);
1090
1091   gdbscm_define_functions (pretty_printer_functions, 1);
1092
1093   pretty_printer_list = SCM_EOL;
1094
1095   pp_type_error_symbol = scm_from_latin1_symbol ("gdb:pp-type-error");
1096
1097   ppscm_map_string = scm_from_latin1_string ("map");
1098   ppscm_array_string = scm_from_latin1_string ("array");
1099   ppscm_string_string = scm_from_latin1_string ("string");
1100 }