gdb/guile/scm-pretty-print.c

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