gdb/guile/scm-pretty-print.c

   1 /* GDB/Scheme pretty-printing.
   2
   3    Copyright (C) 2008-2014 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   char *msg = xstrprintf ("%s: ~S", message);
 331   struct cleanup *cleanup = make_cleanup (xfree, msg);
 332   SCM exception
 333     = gdbscm_make_error (pp_type_error_symbol,
 334                          NULL /* func */, msg,
 335                          scm_list_1 (object), scm_list_1 (object));
 336
 337   do_cleanups (cleanup);
 338
 339   return exception;
 340 }
 341
 342 /* Print MESSAGE as an exception (meaning it is controlled by
 343    "guile print-stack").
 344    Called from the printer code when the Scheme code returns an invalid type
 345    for something.  */
 346
 347 static void
 348 ppscm_print_pp_type_error (const char *message, SCM object)
 349 {
 350   SCM exception = ppscm_make_pp_type_error_exception (message, object);
 351
 352   gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 353 }
 354
 355 /* Helper function for find_pretty_printer which iterates over a list,
 356    calls each function and inspects output.  This will return a
 357    <gdb:pretty-printer> object if one recognizes VALUE.  If no printer is
 358    found, it will return #f.  On error, it will return a <gdb:exception>
 359    object.
 360
 361    Note: This has to be efficient and careful.
 362    We don't want to excessively slow down printing of values, but any kind of
 363    random crud can appear in the pretty-printer list, and we can't crash
 364    because of it.  */
 365
 366 static SCM
 367 ppscm_search_pp_list (SCM list, SCM value)
 368 {
 369   SCM orig_list = list;
 370
 371   if (scm_is_null (list))
 372     return SCM_BOOL_F;
 373   if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
 374     {
 375       return ppscm_make_pp_type_error_exception
 376         (_("pretty-printer list is not a list"), list);
 377     }
 378
 379   for ( ; scm_is_pair (list); list = scm_cdr (list))
 380     {
 381       SCM matcher = scm_car (list);
 382       SCM worker;
 383       pretty_printer_smob *pp_smob;
 384       int rc;
 385
 386       if (!ppscm_is_pretty_printer (matcher))
 387         {
 388           return ppscm_make_pp_type_error_exception
 389             (_("pretty-printer list contains non-pretty-printer object"),
 390              matcher);
 391         }
 392
 393       pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
 394
 395       /* Skip if disabled.  */
 396       if (gdbscm_is_false (pp_smob->enabled))
 397         continue;
 398
 399       if (!gdbscm_is_procedure (pp_smob->lookup))
 400         {
 401           return ppscm_make_pp_type_error_exception
 402             (_("invalid lookup object in pretty-printer matcher"),
 403              pp_smob->lookup);
 404         }
 405
 406       worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
 407                                    value, gdbscm_memory_error_p);
 408       if (!gdbscm_is_false (worker))
 409         {
 410           if (gdbscm_is_exception (worker))
 411             return worker;
 412           if (ppscm_is_pretty_printer_worker (worker))
 413             return worker;
 414           return ppscm_make_pp_type_error_exception
 415             (_("invalid result from pretty-printer lookup"), worker);
 416         }
 417     }
 418
 419   if (!scm_is_null (list))
 420     {
 421       return ppscm_make_pp_type_error_exception
 422         (_("pretty-printer list is not a list"), orig_list);
 423     }
 424
 425   return SCM_BOOL_F;
 426 }
 427
 428 /* Subroutine of find_pretty_printer to simplify it.
 429    Look for a pretty-printer to print VALUE in all objfiles.
 430    If there's an error an exception smob is returned.
 431    The result is #f, if no pretty-printer was found.
 432    Otherwise the result is the pretty-printer smob.  */
 433
 434 static SCM
 435 ppscm_find_pretty_printer_from_objfiles (SCM value)
 436 {
 437   struct objfile *objfile;
 438
 439   ALL_OBJFILES (objfile)
 440   {
 441     objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
 442     SCM pp = ppscm_search_pp_list (ofscm_objfile_smob_pretty_printers (o_smob),
 443                                    value);
 444
 445     /* Note: This will return if pp is a <gdb:exception> object,
 446        which is what we want.  */
 447     if (gdbscm_is_true (pp))
 448       return pp;
 449   }
 450
 451   return SCM_BOOL_F;
 452 }
 453
 454 /* Subroutine of find_pretty_printer to simplify it.
 455    Look for a pretty-printer to print VALUE in the current program space.
 456    If there's an error an exception smob is returned.
 457    The result is #f, if no pretty-printer was found.
 458    Otherwise the result is the pretty-printer smob.  */
 459
 460 static SCM
 461 ppscm_find_pretty_printer_from_progspace (SCM value)
 462 {
 463   pspace_smob *p_smob = psscm_pspace_smob_from_pspace (current_program_space);
 464   SCM pp
 465     = ppscm_search_pp_list (psscm_pspace_smob_pretty_printers (p_smob), value);
 466
 467   return pp;
 468 }
 469
 470 /* Subroutine of find_pretty_printer to simplify it.
 471    Look for a pretty-printer to print VALUE in the gdb module.
 472    If there's an error a Scheme exception is returned.
 473    The result is #f, if no pretty-printer was found.
 474    Otherwise the result is the pretty-printer smob.  */
 475
 476 static SCM
 477 ppscm_find_pretty_printer_from_gdb (SCM value)
 478 {
 479   SCM pp = ppscm_search_pp_list (pretty_printer_list, value);
 480
 481   return pp;
 482 }
 483
 484 /* Find the pretty-printing constructor function for VALUE.  If no
 485    pretty-printer exists, return #f.  If one exists, return the
 486    gdb:pretty-printer smob that implements it.  On error, an exception smob
 487    is returned.
 488
 489    Note: In the end it may be better to call out to Scheme once, and then
 490    do all of the lookup from Scheme.  TBD.  */
 491
 492 static SCM
 493 ppscm_find_pretty_printer (SCM value)
 494 {
 495   SCM pp;
 496
 497   /* Look at the pretty-printer list for each objfile
 498      in the current program-space.  */
 499   pp = ppscm_find_pretty_printer_from_objfiles (value);
 500   /* Note: This will return if function is a <gdb:exception> object,
 501      which is what we want.  */
 502   if (gdbscm_is_true (pp))
 503     return pp;
 504
 505   /* Look at the pretty-printer list for the current program-space.  */
 506   pp = ppscm_find_pretty_printer_from_progspace (value);
 507   /* Note: This will return if function is a <gdb:exception> object,
 508      which is what we want.  */
 509   if (gdbscm_is_true (pp))
 510     return pp;
 511
 512   /* Look at the pretty-printer list in the gdb module.  */
 513   pp = ppscm_find_pretty_printer_from_gdb (value);
 514   return pp;
 515 }
 516
 517 /* Pretty-print a single value, via the PRINTER, which must be a
 518    <gdb:pretty-printer-worker> object.
 519    The caller is responsible for ensuring PRINTER is valid.
 520    If the function returns a string, an SCM containing the string
 521    is returned.  If the function returns #f that means the pretty
 522    printer returned #f as a value.  Otherwise, if the function returns a
 523    <gdb:value> object, *OUT_VALUE is set to the value and #t is returned.
 524    It is an error if the printer returns #t.
 525    On error, an exception smob is returned.  */
 526
 527 static SCM
 528 ppscm_pretty_print_one_value (SCM printer, struct value **out_value,
 529                               struct gdbarch *gdbarch,
 530                               const struct language_defn *language)
 531 {
 532   volatile struct gdb_exception except;
 533   SCM result = SCM_BOOL_F;
 534
 535   *out_value = NULL;
 536   TRY_CATCH (except, RETURN_MASK_ALL)
 537     {
 538       int rc;
 539       pretty_printer_worker_smob *w_smob
 540         = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 541
 542       result = gdbscm_safe_call_1 (w_smob->to_string, printer,
 543                                    gdbscm_memory_error_p);
 544       if (gdbscm_is_false (result))
 545         ; /* Done.  */
 546       else if (scm_is_string (result)
 547                || lsscm_is_lazy_string (result))
 548         ; /* Done.  */
 549       else if (vlscm_is_value (result))
 550         {
 551           SCM except_scm;
 552
 553           *out_value
 554             = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
 555                                                result, &except_scm,
 556                                                gdbarch, language);
 557           if (*out_value != NULL)
 558             result = SCM_BOOL_T;
 559           else
 560             result = except_scm;
 561         }
 562       else if (gdbscm_is_exception (result))
 563         ; /* Done.  */
 564       else
 565         {
 566           /* Invalid result from to-string.  */
 567           result = ppscm_make_pp_type_error_exception
 568             (_("invalid result from pretty-printer to-string"), result);
 569         }
 570     }
 571
 572   return result;
 573 }
 574
 575 /* Return the display hint for PRINTER as a Scheme object.
 576    The caller is responsible for ensuring PRINTER is a
 577    <gdb:pretty-printer-worker> object.  */
 578
 579 static SCM
 580 ppscm_get_display_hint_scm (SCM printer)
 581 {
 582   pretty_printer_worker_smob *w_smob
 583     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 584
 585   return w_smob->display_hint;
 586 }
 587
 588 /* Return the display hint for the pretty-printer PRINTER.
 589    The caller is responsible for ensuring PRINTER is a
 590    <gdb:pretty-printer-worker> object.
 591    Returns the display hint or #f if the hint is not a string.  */
 592
 593 static enum display_hint
 594 ppscm_get_display_hint_enum (SCM printer)
 595 {
 596   SCM hint = ppscm_get_display_hint_scm (printer);
 597
 598   if (gdbscm_is_false (hint))
 599     return HINT_NONE;
 600   if (scm_is_string (hint))
 601     {
 602       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_array_string)))
 603         return HINT_STRING;
 604       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_map_string)))
 605         return HINT_STRING;
 606       if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_string_string)))
 607         return HINT_STRING;
 608       return HINT_ERROR;
 609     }
 610   return HINT_ERROR;
 611 }
 612
 613 /* A wrapper for gdbscm_print_gdb_exception that ignores memory errors.
 614    EXCEPTION is a <gdb:exception> object.  */
 615
 616 static void
 617 ppscm_print_exception_unless_memory_error (SCM exception,
 618                                            struct ui_file *stream)
 619 {
 620   if (gdbscm_memory_error_p (gdbscm_exception_key (exception)))
 621     {
 622       char *msg = gdbscm_exception_message_to_string (exception);
 623       struct cleanup *cleanup = make_cleanup (xfree, msg);
 624
 625       /* This "shouldn't happen", but play it safe.  */
 626       if (msg == NULL || *msg == '\0')
 627         fprintf_filtered (stream, _("<error reading variable>"));
 628       else
 629         {
 630           /* Remove the trailing newline.  We could instead call a special
 631              routine for printing memory error messages, but this is easy
 632              enough for now.  */
 633           size_t len = strlen (msg);
 634
 635           if (msg[len - 1] == '\n')
 636             msg[len - 1] = '\0';
 637           fprintf_filtered (stream, _("<error reading variable: %s>"), msg);
 638         }
 639
 640       do_cleanups (cleanup);
 641     }
 642   else
 643     gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
 644 }
 645
 646 /* Helper for gdbscm_apply_val_pretty_printer which calls to_string and
 647    formats the result.  */
 648
 649 static enum string_repr_result
 650 ppscm_print_string_repr (SCM printer, enum display_hint hint,
 651                          struct ui_file *stream, int recurse,
 652                          const struct value_print_options *options,
 653                          struct gdbarch *gdbarch,
 654                          const struct language_defn *language)
 655 {
 656   struct value *replacement = NULL;
 657   SCM str_scm;
 658   enum string_repr_result result = STRING_REPR_ERROR;
 659
 660   str_scm = ppscm_pretty_print_one_value (printer, &replacement,
 661                                           gdbarch, language);
 662   if (gdbscm_is_false (str_scm))
 663     {
 664       result = STRING_REPR_NONE;
 665     }
 666   else if (scm_is_eq (str_scm, SCM_BOOL_T))
 667     {
 668       struct value_print_options opts = *options;
 669
 670       gdb_assert (replacement != NULL);
 671       opts.addressprint = 0;
 672       common_val_print (replacement, stream, recurse, &opts, language);
 673       result = STRING_REPR_OK;
 674     }
 675   else if (scm_is_string (str_scm))
 676     {
 677       struct cleanup *cleanup;
 678       size_t length;
 679       char *string
 680         = gdbscm_scm_to_string (str_scm, &length,
 681                                 target_charset (gdbarch), 0 /*!strict*/, NULL);
 682
 683       cleanup = make_cleanup (xfree, string);
 684       if (hint == HINT_STRING)
 685         {
 686           struct type *type = builtin_type (gdbarch)->builtin_char;
 687
 688           LA_PRINT_STRING (stream, type, (gdb_byte *) string,
 689                            length, NULL, 0, options);
 690         }
 691       else
 692         {
 693           /* Alas scm_to_stringn doesn't nul-terminate the string if we
 694              ask for the length.  */
 695           size_t i;
 696
 697           for (i = 0; i < length; ++i)
 698             {
 699               if (string[i] == '\0')
 700                 fputs_filtered ("\\000", stream);
 701               else
 702                 fputc_filtered (string[i], stream);
 703             }
 704         }
 705       result = STRING_REPR_OK;
 706       do_cleanups (cleanup);
 707     }
 708   else if (lsscm_is_lazy_string (str_scm))
 709     {
 710       struct value_print_options local_opts = *options;
 711
 712       local_opts.addressprint = 0;
 713       lsscm_val_print_lazy_string (str_scm, stream, &local_opts);
 714       result = STRING_REPR_OK;
 715     }
 716   else
 717     {
 718       gdb_assert (gdbscm_is_exception (str_scm));
 719       ppscm_print_exception_unless_memory_error (str_scm, stream);
 720       result = STRING_REPR_ERROR;
 721     }
 722
 723   return result;
 724 }
 725
 726 /* Helper for gdbscm_apply_val_pretty_printer that formats children of the
 727    printer, if any exist.
 728    The caller is responsible for ensuring PRINTER is a printer smob.
 729    If PRINTED_NOTHING is true, then nothing has been printed by to_string,
 730    and format output accordingly. */
 731
 732 static void
 733 ppscm_print_children (SCM printer, enum display_hint hint,
 734                       struct ui_file *stream, int recurse,
 735                       const struct value_print_options *options,
 736                       struct gdbarch *gdbarch,
 737                       const struct language_defn *language,
 738                       int printed_nothing)
 739 {
 740   pretty_printer_worker_smob *w_smob
 741     = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
 742   int is_map, is_array, done_flag, pretty;
 743   unsigned int i;
 744   SCM children, status;
 745   SCM iter = SCM_BOOL_F; /* -Wall */
 746   struct cleanup *cleanups;
 747
 748   if (gdbscm_is_false (w_smob->children))
 749     return;
 750   if (!gdbscm_is_procedure (w_smob->children))
 751     {
 752       ppscm_print_pp_type_error
 753         (_("pretty-printer \"children\" object is not a procedure or #f"),
 754          w_smob->children);
 755       return;
 756     }
 757
 758   cleanups = make_cleanup (null_cleanup, NULL);
 759
 760   /* If we are printing a map or an array, we want special formatting.  */
 761   is_map = hint == HINT_MAP;
 762   is_array = hint == HINT_ARRAY;
 763
 764   children = gdbscm_safe_call_1 (w_smob->children, printer,
 765                                  gdbscm_memory_error_p);
 766   if (gdbscm_is_exception (children))
 767     {
 768       ppscm_print_exception_unless_memory_error (children, stream);
 769       goto done;
 770     }
 771   /* We combine two steps here: get children, make an iterator out of them.
 772      This simplifies things because there's no language means of creating
 773      iterators, and it's the printer object that knows how it will want its
 774      children iterated over.  */
 775   if (!itscm_is_iterator (children))
 776     {
 777       ppscm_print_pp_type_error
 778         (_("result of pretty-printer \"children\" procedure is not"
 779            " a <gdb:iterator> object"), children);
 780       goto done;
 781     }
 782   iter = children;
 783
 784   /* Use the prettyformat_arrays option if we are printing an array,
 785      and the pretty option otherwise.  */
 786   if (is_array)
 787     pretty = options->prettyformat_arrays;
 788   else
 789     {
 790       if (options->prettyformat == Val_prettyformat)
 791         pretty = 1;
 792       else
 793         pretty = options->prettyformat_structs;
 794     }
 795
 796   done_flag = 0;
 797   for (i = 0; i < options->print_max; ++i)
 798     {
 799       int rc;
 800       SCM scm_name, v_scm;
 801       char *name;
 802       SCM item = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
 803       struct cleanup *inner_cleanup = make_cleanup (null_cleanup, NULL);
 804
 805       if (gdbscm_is_exception (item))
 806         {
 807           ppscm_print_exception_unless_memory_error (item, stream);
 808           break;
 809         }
 810       if (itscm_is_end_of_iteration (item))
 811         {
 812           /* Set a flag so we can know whether we printed all the
 813              available elements.  */
 814           done_flag = 1;
 815           break;
 816         }
 817
 818       if (! scm_is_pair (item))
 819         {
 820           ppscm_print_pp_type_error
 821             (_("result of pretty-printer children iterator is not a pair"
 822                " or (end-of-iteration)"),
 823              item);
 824           continue;
 825         }
 826       scm_name = scm_car (item);
 827       v_scm = scm_cdr (item);
 828       if (!scm_is_string (scm_name))
 829         {
 830           ppscm_print_pp_type_error
 831             (_("first element of pretty-printer children iterator is not"
 832                " a string"), item);
 833           continue;
 834         }
 835       name = gdbscm_scm_to_c_string (scm_name);
 836       make_cleanup (xfree, name);
 837
 838       /* Print initial "{".  For other elements, there are three cases:
 839          1. Maps.  Print a "," after each value element.
 840          2. Arrays.  Always print a ",".
 841          3. Other.  Always print a ",".  */
 842       if (i == 0)
 843         {
 844          if (printed_nothing)
 845            fputs_filtered ("{", stream);
 846          else
 847            fputs_filtered (" = {", stream);
 848        }
 849
 850       else if (! is_map || i % 2 == 0)
 851         fputs_filtered (pretty ? "," : ", ", stream);
 852
 853       /* In summary mode, we just want to print "= {...}" if there is
 854          a value.  */
 855       if (options->summary)
 856         {
 857           /* This increment tricks the post-loop logic to print what
 858              we want.  */
 859           ++i;
 860           /* Likewise.  */
 861           pretty = 0;
 862           break;
 863         }
 864
 865       if (! is_map || i % 2 == 0)
 866         {
 867           if (pretty)
 868             {
 869               fputs_filtered ("\n", stream);
 870               print_spaces_filtered (2 + 2 * recurse, stream);
 871             }
 872           else
 873             wrap_here (n_spaces (2 + 2 *recurse));
 874         }
 875
 876       if (is_map && i % 2 == 0)
 877         fputs_filtered ("[", stream);
 878       else if (is_array)
 879         {
 880           /* We print the index, not whatever the child method
 881              returned as the name.  */
 882           if (options->print_array_indexes)
 883             fprintf_filtered (stream, "[%d] = ", i);
 884         }
 885       else if (! is_map)
 886         {
 887           fputs_filtered (name, stream);
 888           fputs_filtered (" = ", stream);
 889         }
 890
 891       if (lsscm_is_lazy_string (v_scm))
 892         {
 893           struct value_print_options local_opts = *options;
 894
 895           local_opts.addressprint = 0;
 896           lsscm_val_print_lazy_string (v_scm, stream, &local_opts);
 897         }
 898       else if (scm_is_string (v_scm))
 899         {
 900           char *output = gdbscm_scm_to_c_string (v_scm);
 901
 902           fputs_filtered (output, stream);
 903           xfree (output);
 904         }
 905       else
 906         {
 907           SCM except_scm;
 908           struct value *value
 909             = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
 910                                                v_scm, &except_scm,
 911                                                gdbarch, language);
 912
 913           if (value == NULL)
 914             {
 915               ppscm_print_exception_unless_memory_error (except_scm, stream);
 916               break;
 917             }
 918           common_val_print (value, stream, recurse + 1, options, language);
 919         }
 920
 921       if (is_map && i % 2 == 0)
 922         fputs_filtered ("] = ", stream);
 923
 924       do_cleanups (inner_cleanup);
 925     }
 926
 927   if (i)
 928     {
 929       if (!done_flag)
 930         {
 931           if (pretty)
 932             {
 933               fputs_filtered ("\n", stream);
 934               print_spaces_filtered (2 + 2 * recurse, stream);
 935             }
 936           fputs_filtered ("...", stream);
 937         }
 938       if (pretty)
 939         {
 940           fputs_filtered ("\n", stream);
 941           print_spaces_filtered (2 * recurse, stream);
 942         }
 943       fputs_filtered ("}", stream);
 944     }
 945
 946  done:
 947   do_cleanups (cleanups);
 948
 949   /* Play it safe, make sure ITER doesn't get GC'd.  */
 950   scm_remember_upto_here_1 (iter);
 951 }
 952
 953 /* This is the extension_language_ops.apply_val_pretty_printer "method".  */
 954
 955 enum ext_lang_rc
 956 gdbscm_apply_val_pretty_printer (const struct extension_language_defn *extlang,
 957                                  struct type *type, const gdb_byte *valaddr,
 958                                  int embedded_offset, CORE_ADDR address,
 959                                  struct ui_file *stream, int recurse,
 960                                  const struct value *val,
 961                                  const struct value_print_options *options,
 962                                  const struct language_defn *language)
 963 {
 964   struct gdbarch *gdbarch = get_type_arch (type);
 965   SCM exception = SCM_BOOL_F;
 966   SCM printer = SCM_BOOL_F;
 967   SCM val_obj = SCM_BOOL_F;
 968   struct value *value;
 969   enum display_hint hint;
 970   struct cleanup *cleanups;
 971   int result = EXT_LANG_RC_NOP;
 972   enum string_repr_result print_result;
 973
 974   /* No pretty-printer support for unavailable values.  */
 975   if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type)))
 976     return EXT_LANG_RC_NOP;
 977
 978   if (!gdb_scheme_initialized)
 979     return EXT_LANG_RC_NOP;
 980
 981   cleanups = make_cleanup (null_cleanup, NULL);
 982
 983   /* Instantiate the printer.  */
 984   if (valaddr)
 985     valaddr += embedded_offset;
 986   value = value_from_contents_and_address (type, valaddr,
 987                                            address + embedded_offset);
 988
 989   set_value_component_location (value, val);
 990   /* set_value_component_location resets the address, so we may
 991      need to set it again.  */
 992   if (VALUE_LVAL (value) != lval_internalvar
 993       && VALUE_LVAL (value) != lval_internalvar_component
 994       && VALUE_LVAL (value) != lval_computed)
 995     set_value_address (value, address + embedded_offset);
 996
 997   val_obj = vlscm_scm_from_value (value);
 998   if (gdbscm_is_exception (val_obj))
 999     {
1000       exception = val_obj;
1001       result = EXT_LANG_RC_ERROR;
1002       goto done;
1003     }
1004
1005   printer = ppscm_find_pretty_printer (val_obj);
1006
1007   if (gdbscm_is_exception (printer))
1008     {
1009       exception = printer;
1010       result = EXT_LANG_RC_ERROR;
1011       goto done;
1012     }
1013   if (gdbscm_is_false (printer))
1014     {
1015       result = EXT_LANG_RC_NOP;
1016       goto done;
1017     }
1018   gdb_assert (ppscm_is_pretty_printer_worker (printer));
1019
1020   /* If we are printing a map, we want some special formatting.  */
1021   hint = ppscm_get_display_hint_enum (printer);
1022   if (hint == HINT_ERROR)
1023     {
1024       /* Print the error as an exception for consistency.  */
1025       SCM hint_scm = ppscm_get_display_hint_scm (printer);
1026
1027       ppscm_print_pp_type_error ("Invalid display hint", hint_scm);
1028       /* Fall through.  A bad hint doesn't stop pretty-printing.  */
1029       hint = HINT_NONE;
1030     }
1031
1032   /* Print the section.  */
1033   print_result = ppscm_print_string_repr (printer, hint, stream, recurse,
1034                                           options, gdbarch, language);
1035   if (print_result != STRING_REPR_ERROR)
1036     {
1037       ppscm_print_children (printer, hint, stream, recurse, options,
1038                             gdbarch, language,
1039                             print_result == STRING_REPR_NONE);
1040     }
1041
1042   result = EXT_LANG_RC_OK;
1043
1044  done:
1045   if (gdbscm_is_exception (exception))
1046     ppscm_print_exception_unless_memory_error (exception, stream);
1047   do_cleanups (cleanups);
1048   return result;
1049 }
1050 \f
1051 /* Initialize the Scheme pretty-printer code.  */
1052
1053 static const scheme_function pretty_printer_functions[] =
1054 {
1055   { "make-pretty-printer", 2, 0, 0, gdbscm_make_pretty_printer,
1056     "\
1057 Create a <gdb:pretty-printer> object.\n\
1058 \n\
1059   Arguments: name lookup\n\
1060     name:   a string naming the matcher\n\
1061     lookup: a procedure:\n\
1062       (pretty-printer <gdb:value>) -> <gdb:pretty-printer-worker> | #f." },
1063
1064   { "pretty-printer?", 1, 0, 0, gdbscm_pretty_printer_p,
1065     "\
1066 Return #t if the object is a <gdb:pretty-printer> object." },
1067
1068   { "pretty-printer-enabled?", 1, 0, 0, gdbscm_pretty_printer_enabled_p,
1069     "\
1070 Return #t if the pretty-printer is enabled." },
1071
1072   { "set-pretty-printer-enabled!", 2, 0, 0,
1073     gdbscm_set_pretty_printer_enabled_x,
1074     "\
1075 Set the enabled flag of the pretty-printer.\n\
1076 Returns \"unspecified\"." },
1077
1078   { "make-pretty-printer-worker", 3, 0, 0, gdbscm_make_pretty_printer_worker,
1079     "\
1080 Create a <gdb:pretty-printer-worker> object.\n\
1081 \n\
1082   Arguments: display-hint to-string children\n\
1083     display-hint: either #f or one of \"array\", \"map\", or \"string\"\n\
1084     to-string:    a procedure:\n\
1085       (pretty-printer) -> string | #f | <gdb:value>\n\
1086     children:     either #f or a procedure:\n\
1087       (pretty-printer) -> <gdb:iterator>" },
1088
1089   { "pretty-printer-worker?", 1, 0, 0, gdbscm_pretty_printer_worker_p,
1090     "\
1091 Return #t if the object is a <gdb:pretty-printer-worker> object." },
1092
1093   { "pretty-printers", 0, 0, 0, gdbscm_pretty_printers,
1094     "\
1095 Return the list of global pretty-printers." },
1096
1097   { "set-pretty-printers!", 1, 0, 0,
1098     gdbscm_set_pretty_printers_x,
1099     "\
1100 Set the list of global pretty-printers." },
1101
1102   END_FUNCTIONS
1103 };
1104
1105 void
1106 gdbscm_initialize_pretty_printers (void)
1107 {
1108   pretty_printer_smob_tag
1109     = gdbscm_make_smob_type (pretty_printer_smob_name,
1110                              sizeof (pretty_printer_smob));
1111   scm_set_smob_print (pretty_printer_smob_tag,
1112                       ppscm_print_pretty_printer_smob);
1113
1114   pretty_printer_worker_smob_tag
1115     = gdbscm_make_smob_type (pretty_printer_worker_smob_name,
1116                              sizeof (pretty_printer_worker_smob));
1117   scm_set_smob_print (pretty_printer_worker_smob_tag,
1118                       ppscm_print_pretty_printer_worker_smob);
1119
1120   gdbscm_define_functions (pretty_printer_functions, 1);
1121
1122   pretty_printer_list = SCM_EOL;
1123
1124   pp_type_error_symbol = scm_from_latin1_symbol ("gdb:pp-type-error");
1125
1126   ppscm_map_string = scm_from_latin1_string ("map");
1127   ppscm_array_string = scm_from_latin1_string ("array");
1128   ppscm_string_string = scm_from_latin1_string ("string");
1129 }