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 (const gdb_exception &except)
 562     {
 563     }
 564
 565   return result;
 566 }
 567
 568 /* Return the display hint for PRINTER as a Scheme object.
 569    The caller is responsible for ensuring PRINTER is a
 570    <gdb:pretty-printer-worker> object.  */
 571
 572 static SCM
 573 ppscm_get_display_hint_scm (SCM printer)
 574 {
 575   pretty_printer_worker_smob *w_smob
 576     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 577
 578   return w_smob->display_hint;
 579 }
 580
 581 /* Return the display hint for the pretty-printer PRINTER.
 582    The caller is responsible for ensuring PRINTER is a
 583    <gdb:pretty-printer-worker> object.
 584    Returns the display hint or #f if the hint is not a string.  */
 585
 586 static enum display_hint
 587 ppscm_get_display_hint_enum (SCM printer)
 588 {
 589   SCM hint = ppscm_get_display_hint_scm (printer);
 590
 591   if (gdbscm_is_false (hint))
 592     return HINT_NONE;
 593   if (scm_is_string (hint))
 594     {
 595       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_array_string)))
 596         return HINT_STRING;
 597       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_map_string)))
 598         return HINT_STRING;
 599       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_string_string)))
 600         return HINT_STRING;
 601       return HINT_ERROR;
 602     }
 603   return HINT_ERROR;
 604 }
 605
 606 /* A wrapper for gdbscm_print_gdb_exception that ignores memory errors.
 607    EXCEPTION is a <gdb:exception> object.  */
 608
 609 static void
 610 ppscm_print_exception_unless_memory_error (SCM exception,
 611                                            struct ui_file *stream)
 612 {
 613   if (gdbscm_memory_error_p (gdbscm_exception_key (exception)))
 614     {
 615       gdb::unique_xmalloc_ptr<char> msg
 616         = gdbscm_exception_message_to_string (exception);
 617
 618       /* This "shouldn't happen", but play it safe.  */
 619       if (msg == NULL || msg.get ()[0] == '\0')
 620         fprintf_filtered (stream, _("<error reading variable>"));
 621       else
 622         {
 623           /* Remove the trailing newline.  We could instead call a special
 624              routine for printing memory error messages, but this is easy
 625              enough for now.  */
 626           char *msg_text = msg.get ();
 627           size_t len = strlen (msg_text);
 628
 629           if (msg_text[len - 1] == '\n')
 630             msg_text[len - 1] = '\0';
 631           fprintf_filtered (stream, _("<error reading variable: %s>"), msg_text);
 632         }
 633     }
 634   else
 635     gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 636 }
 637
 638 /* Helper for gdbscm_apply_val_pretty_printer which calls to_string and
 639    formats the result.  */
 640
 641 static enum string_repr_result
 642 ppscm_print_string_repr (SCM printer, enum display_hint hint,
 643                          struct ui_file *stream, int recurse,
 644                          const struct value_print_options *options,
 645                          struct gdbarch *gdbarch,
 646                          const struct language_defn *language)
 647 {
 648   struct value *replacement = NULL;
 649   SCM str_scm;
 650   enum string_repr_result result = STRING_REPR_ERROR;
 651
 652   str_scm = ppscm_pretty_print_one_value (printer, &replacement,
 653                                           gdbarch, language);
 654   if (gdbscm_is_false (str_scm))
 655     {
 656       result = STRING_REPR_NONE;
 657     }
 658   else if (scm_is_eq (str_scm, SCM_BOOL_T))
 659     {
 660       struct value_print_options opts = *options;
 661
 662       gdb_assert (replacement != NULL);
 663       opts.addressprint = 0;
 664       common_val_print (replacement, stream, recurse, &opts, language);
 665       result = STRING_REPR_OK;
 666     }
 667   else if (scm_is_string (str_scm))
 668     {
 669       size_t length;
 670       gdb::unique_xmalloc_ptr<char> string
 671         = gdbscm_scm_to_string (str_scm, &length,
 672                                 target_charset (gdbarch), 0 /*!strict*/, NULL);
 673
 674       if (hint == HINT_STRING)
 675         {
 676           struct type *type = builtin_type (gdbarch)->builtin_char;
 677
 678           LA_PRINT_STRING (stream, type, (gdb_byte *) string.get (),
 679                            length, NULL, 0, options);
 680         }
 681       else
 682         {
 683           /* Alas scm_to_stringn doesn't nul-terminate the string if we
 684              ask for the length.  */
 685           size_t i;
 686
 687           for (i = 0; i < length; ++i)
 688             {
 689               if (string.get ()[i] == '\0')
 690                 fputs_filtered ("\\000", stream);
 691               else
 692                 fputc_filtered (string.get ()[i], stream);
 693             }
 694         }
 695       result = STRING_REPR_OK;
 696     }
 697   else if (lsscm_is_lazy_string (str_scm))
 698     {
 699       struct value_print_options local_opts = *options;
 700
 701       local_opts.addressprint = 0;
 702       lsscm_val_print_lazy_string (str_scm, stream, &local_opts);
 703       result = STRING_REPR_OK;
 704     }
 705   else
 706     {
 707       gdb_assert (gdbscm_is_exception (str_scm));
 708       ppscm_print_exception_unless_memory_error (str_scm, stream);
 709       result = STRING_REPR_ERROR;
 710     }
 711
 712   return result;
 713 }
 714
 715 /* Helper for gdbscm_apply_val_pretty_printer that formats children of the
 716    printer, if any exist.
 717    The caller is responsible for ensuring PRINTER is a printer smob.
 718    If PRINTED_NOTHING is true, then nothing has been printed by to_string,
 719    and format output accordingly. */
 720
 721 static void
 722 ppscm_print_children (SCM printer, enum display_hint hint,
 723                       struct ui_file *stream, int recurse,
 724                       const struct value_print_options *options,
 725                       struct gdbarch *gdbarch,
 726                       const struct language_defn *language,
 727                       int printed_nothing)
 728 {
 729   pretty_printer_worker_smob *w_smob
 730     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 731   int is_map, is_array, done_flag, pretty;
 732   unsigned int i;
 733   SCM children;
 734   SCM iter = SCM_BOOL_F; /* -Wall */
 735
 736   if (gdbscm_is_false (w_smob->children))
 737     return;
 738   if (!gdbscm_is_procedure (w_smob->children))
 739     {
 740       ppscm_print_pp_type_error
 741         (_("pretty-printer \"children\" object is not a procedure or #f"),
 742          w_smob->children);
 743       return;
 744     }
 745
 746   /* If we are printing a map or an array, we want special formatting.  */
 747   is_map = hint == HINT_MAP;
 748   is_array = hint == HINT_ARRAY;
 749
 750   children = gdbscm_safe_call_1 (w_smob->children, printer,
 751                                  gdbscm_memory_error_p);
 752   if (gdbscm_is_exception (children))
 753     {
 754       ppscm_print_exception_unless_memory_error (children, stream);
 755       goto done;
 756     }
 757   /* We combine two steps here: get children, make an iterator out of them.
 758      This simplifies things because there's no language means of creating
 759      iterators, and it's the printer object that knows how it will want its
 760      children iterated over.  */
 761   if (!itscm_is_iterator (children))
 762     {
 763       ppscm_print_pp_type_error
 764         (_("result of pretty-printer \"children\" procedure is not"
 765            " a <gdb:iterator> object"), children);
 766       goto done;
 767     }
 768   iter = children;
 769
 770   /* Use the prettyformat_arrays option if we are printing an array,
 771      and the pretty option otherwise.  */
 772   if (is_array)
 773     pretty = options->prettyformat_arrays;
 774   else
 775     {
 776       if (options->prettyformat == Val_prettyformat)
 777         pretty = 1;
 778       else
 779         pretty = options->prettyformat_structs;
 780     }
 781
 782   done_flag = 0;
 783   for (i = 0; i < options->print_max; ++i)
 784     {
 785       SCM scm_name, v_scm;
 786       SCM item = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
 787
 788       if (gdbscm_is_exception (item))
 789         {
 790           ppscm_print_exception_unless_memory_error (item, stream);
 791           break;
 792         }
 793       if (itscm_is_end_of_iteration (item))
 794         {
 795           /* Set a flag so we can know whether we printed all the
 796              available elements.  */
 797           done_flag = 1;
 798           break;
 799         }
 800
 801       if (! scm_is_pair (item))
 802         {
 803           ppscm_print_pp_type_error
 804             (_("result of pretty-printer children iterator is not a pair"
 805                " or (end-of-iteration)"),
 806              item);
 807           continue;
 808         }
 809       scm_name = scm_car (item);
 810       v_scm = scm_cdr (item);
 811       if (!scm_is_string (scm_name))
 812         {
 813           ppscm_print_pp_type_error
 814             (_("first element of pretty-printer children iterator is not"
 815                " a string"), item);
 816           continue;
 817         }
 818       gdb::unique_xmalloc_ptr<char> name
 819         = gdbscm_scm_to_c_string (scm_name);
 820
 821       /* Print initial "{".  For other elements, there are three cases:
 822          1. Maps.  Print a "," after each value element.
 823          2. Arrays.  Always print a ",".
 824          3. Other.  Always print a ",".  */
 825       if (i == 0)
 826         {
 827          if (printed_nothing)
 828            fputs_filtered ("{", stream);
 829          else
 830            fputs_filtered (" = {", stream);
 831        }
 832
 833       else if (! is_map || i % 2 == 0)
 834         fputs_filtered (pretty ? "," : ", ", stream);
 835
 836       /* In summary mode, we just want to print "= {...}" if there is
 837          a value.  */
 838       if (options->summary)
 839         {
 840           /* This increment tricks the post-loop logic to print what
 841              we want.  */
 842           ++i;
 843           /* Likewise.  */
 844           pretty = 0;
 845           break;
 846         }
 847
 848       if (! is_map || i % 2 == 0)
 849         {
 850           if (pretty)
 851             {
 852               fputs_filtered ("\n", stream);
 853               print_spaces_filtered (2 + 2 * recurse, stream);
 854             }
 855           else
 856             wrap_here (n_spaces (2 + 2 *recurse));
 857         }
 858
 859       if (is_map && i % 2 == 0)
 860         fputs_filtered ("[", stream);
 861       else if (is_array)
 862         {
 863           /* We print the index, not whatever the child method
 864              returned as the name.  */
 865           if (options->print_array_indexes)
 866             fprintf_filtered (stream, "[%d] = ", i);
 867         }
 868       else if (! is_map)
 869         {
 870           fputs_filtered (name.get (), stream);
 871           fputs_filtered (" = ", stream);
 872         }
 873
 874       if (lsscm_is_lazy_string (v_scm))
 875         {
 876           struct value_print_options local_opts = *options;
 877
 878           local_opts.addressprint = 0;
 879           lsscm_val_print_lazy_string (v_scm, stream, &local_opts);
 880         }
 881       else if (scm_is_string (v_scm))
 882         {
 883           gdb::unique_xmalloc_ptr<char> output
 884             = gdbscm_scm_to_c_string (v_scm);
 885           fputs_filtered (output.get (), stream);
 886         }
 887       else
 888         {
 889           SCM except_scm;
 890           struct value *value
 891             = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
 892                                                v_scm, &except_scm,
 893                                                gdbarch, language);
 894
 895           if (value == NULL)
 896             {
 897               ppscm_print_exception_unless_memory_error (except_scm, stream);
 898               break;
 899             }
 900           else
 901             {
 902               /* When printing the key of a map we allow one additional
 903                  level of depth.  This means the key will print before the
 904                  value does.  */
 905               struct value_print_options opt = *options;
 906               if (is_map && i % 2 == 0
 907                   && opt.max_depth != -1
 908                   && opt.max_depth < INT_MAX)
 909                 ++opt.max_depth;
 910               common_val_print (value, stream, recurse + 1, &opt, language);
 911             }
 912         }
 913
 914       if (is_map && i % 2 == 0)
 915         fputs_filtered ("] = ", stream);
 916     }
 917
 918   if (i)
 919     {
 920       if (!done_flag)
 921         {
 922           if (pretty)
 923             {
 924               fputs_filtered ("\n", stream);
 925               print_spaces_filtered (2 + 2 * recurse, stream);
 926             }
 927           fputs_filtered ("...", stream);
 928         }
 929       if (pretty)
 930         {
 931           fputs_filtered ("\n", stream);
 932           print_spaces_filtered (2 * recurse, stream);
 933         }
 934       fputs_filtered ("}", stream);
 935     }
 936
 937  done:
 938   /* Play it safe, make sure ITER doesn't get GC'd.  */
 939   scm_remember_upto_here_1 (iter);
 940 }
 941
 942 /* This is the extension_language_ops.apply_val_pretty_printer "method".  */
 943
 944 enum ext_lang_rc
 945 gdbscm_apply_val_pretty_printer (const struct extension_language_defn *extlang,
 946                                  struct type *type,
 947                                  LONGEST embedded_offset, CORE_ADDR address,
 948                                  struct ui_file *stream, int recurse,
 949                                  struct value *val,
 950                                  const struct value_print_options *options,
 951                                  const struct language_defn *language)
 952 {
 953   struct gdbarch *gdbarch = get_type_arch (type);
 954   SCM exception = SCM_BOOL_F;
 955   SCM printer = SCM_BOOL_F;
 956   SCM val_obj = SCM_BOOL_F;
 957   struct value *value;
 958   enum display_hint hint;
 959   enum ext_lang_rc result = EXT_LANG_RC_NOP;
 960   enum string_repr_result print_result;
 961
 962   if (value_lazy (val))
 963     value_fetch_lazy (val);
 964
 965   /* No pretty-printer support for unavailable values.  */
 966   if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type)))
 967     return EXT_LANG_RC_NOP;
 968
 969   if (!gdb_scheme_initialized)
 970     return EXT_LANG_RC_NOP;
 971
 972   /* Instantiate the printer.  */
 973   value = value_from_component (val, type, embedded_offset);
 974
 975   val_obj = vlscm_scm_from_value (value);
 976   if (gdbscm_is_exception (val_obj))
 977     {
 978       exception = val_obj;
 979       result = EXT_LANG_RC_ERROR;
 980       goto done;
 981     }
 982
 983   printer = ppscm_find_pretty_printer (val_obj);
 984
 985   if (gdbscm_is_exception (printer))
 986     {
 987       exception = printer;
 988       result = EXT_LANG_RC_ERROR;
 989       goto done;
 990     }
 991   if (gdbscm_is_false (printer))
 992     {
 993       result = EXT_LANG_RC_NOP;
 994       goto done;
 995     }
 996   gdb_assert (ppscm_is_pretty_printer_worker (printer));
 997
 998   if (val_print_check_max_depth (stream, recurse, options, language))
 999     {
1000       result = EXT_LANG_RC_OK;
1001       goto done;
1002     }
1003
1004   /* If we are printing a map, we want some special formatting.  */
1005   hint = ppscm_get_display_hint_enum (printer);
1006   if (hint == HINT_ERROR)
1007     {
1008       /* Print the error as an exception for consistency.  */
1009       SCM hint_scm = ppscm_get_display_hint_scm (printer);
1010
1011       ppscm_print_pp_type_error ("Invalid display hint", hint_scm);
1012       /* Fall through.  A bad hint doesn't stop pretty-printing.  */
1013       hint = HINT_NONE;
1014     }
1015
1016   /* Print the section.  */
1017   print_result = ppscm_print_string_repr (printer, hint, stream, recurse,
1018                                           options, gdbarch, language);
1019   if (print_result != STRING_REPR_ERROR)
1020     {
1021       ppscm_print_children (printer, hint, stream, recurse, options,
1022                             gdbarch, language,
1023                             print_result == STRING_REPR_NONE);
1024     }
1025
1026   result = EXT_LANG_RC_OK;
1027
1028  done:
1029   if (gdbscm_is_exception (exception))
1030     ppscm_print_exception_unless_memory_error (exception, stream);
1031   return result;
1032 }
1033 \f
1034 /* Initialize the Scheme pretty-printer code.  */
1035
1036 static const scheme_function pretty_printer_functions[] =
1037 {
1038   { "make-pretty-printer", 2, 0, 0,
1039     as_a_scm_t_subr (gdbscm_make_pretty_printer),
1040     "\
1041 Create a <gdb:pretty-printer> object.\n\
1042 \n\
1043   Arguments: name lookup\n\
1044     name:   a string naming the matcher\n\
1045     lookup: a procedure:\n\
1046       (pretty-printer <gdb:value>) -> <gdb:pretty-printer-worker> | #f." },
1047
1048   { "pretty-printer?", 1, 0, 0, as_a_scm_t_subr (gdbscm_pretty_printer_p),
1049     "\
1050 Return #t if the object is a <gdb:pretty-printer> object." },
1051
1052   { "pretty-printer-enabled?", 1, 0, 0,
1053     as_a_scm_t_subr (gdbscm_pretty_printer_enabled_p),
1054     "\
1055 Return #t if the pretty-printer is enabled." },
1056
1057   { "set-pretty-printer-enabled!", 2, 0, 0,
1058     as_a_scm_t_subr (gdbscm_set_pretty_printer_enabled_x),
1059     "\
1060 Set the enabled flag of the pretty-printer.\n\
1061 Returns \"unspecified\"." },
1062
1063   { "make-pretty-printer-worker", 3, 0, 0,
1064     as_a_scm_t_subr (gdbscm_make_pretty_printer_worker),
1065     "\
1066 Create a <gdb:pretty-printer-worker> object.\n\
1067 \n\
1068   Arguments: display-hint to-string children\n\
1069     display-hint: either #f or one of \"array\", \"map\", or \"string\"\n\
1070     to-string:    a procedure:\n\
1071       (pretty-printer) -> string | #f | <gdb:value>\n\
1072     children:     either #f or a procedure:\n\
1073       (pretty-printer) -> <gdb:iterator>" },
1074
1075   { "pretty-printer-worker?", 1, 0, 0,
1076     as_a_scm_t_subr (gdbscm_pretty_printer_worker_p),
1077     "\
1078 Return #t if the object is a <gdb:pretty-printer-worker> object." },
1079
1080   { "pretty-printers", 0, 0, 0, as_a_scm_t_subr (gdbscm_pretty_printers),
1081     "\
1082 Return the list of global pretty-printers." },
1083
1084   { "set-pretty-printers!", 1, 0, 0,
1085     as_a_scm_t_subr (gdbscm_set_pretty_printers_x),
1086     "\
1087 Set the list of global pretty-printers." },
1088
1089   END_FUNCTIONS
1090 };
1091
1092 void
1093 gdbscm_initialize_pretty_printers (void)
1094 {
1095   pretty_printer_smob_tag
1096     = gdbscm_make_smob_type (pretty_printer_smob_name,
1097                              sizeof (pretty_printer_smob));
1098   scm_set_smob_print (pretty_printer_smob_tag,
1099                       ppscm_print_pretty_printer_smob);
1100
1101   pretty_printer_worker_smob_tag
1102     = gdbscm_make_smob_type (pretty_printer_worker_smob_name,
1103                              sizeof (pretty_printer_worker_smob));
1104   scm_set_smob_print (pretty_printer_worker_smob_tag,
1105                       ppscm_print_pretty_printer_worker_smob);
1106
1107   gdbscm_define_functions (pretty_printer_functions, 1);
1108
1109   pretty_printer_list = SCM_EOL;
1110
1111   pp_type_error_symbol = scm_from_latin1_symbol ("gdb:pp-type-error");
1112
1113   ppscm_map_string = scm_from_latin1_string ("map");
1114   ppscm_array_string = scm_from_latin1_string ("array");
1115   ppscm_string_string = scm_from_latin1_string ("string");
1116 }