gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000-2001, 2003, 2005-2012 Free Software Foundation,
   4    Inc.
   5
   6    This file is part of GDB.
   7
   8    This program is free software; you can redistribute it and/or modify
   9    it under the terms of the GNU General Public License as published by
  10    the Free Software Foundation; either version 3 of the License, or
  11    (at your option) any later version.
  12
  13    This program is distributed in the hope that it will be useful,
  14    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16    GNU General Public License for more details.
  17
  18    You should have received a copy of the GNU General Public License
  19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21 /* This file is derived from c-valprint.c */
  22
  23 #include "defs.h"
  24 #include "gdb_obstack.h"
  25 #include "symtab.h"
  26 #include "gdbtypes.h"
  27 #include "expression.h"
  28 #include "value.h"
  29 #include "command.h"
  30 #include "gdbcmd.h"
  31 #include "gdbcore.h"
  32 #include "demangle.h"
  33 #include "valprint.h"
  34 #include "typeprint.h"
  35 #include "language.h"
  36 #include "target.h"
  37 #include "annotate.h"
  38 #include "p-lang.h"
  39 #include "cp-abi.h"
  40 #include "cp-support.h"
  41 #include "exceptions.h"
  42 \f
  43
  44 /* See val_print for a description of the various parameters of this
  45    function; they are identical.  The semantics of the return value is
  46    also identical to val_print.  */
  47
  48 int
  49 pascal_val_print (struct type *type, const gdb_byte *valaddr,
  50                   int embedded_offset, CORE_ADDR address,
  51                   struct ui_file *stream, int recurse,
  52                   const struct value *original_value,
  53                   const struct value_print_options *options)
  54 {
  55   struct gdbarch *gdbarch = get_type_arch (type);
  56   enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
  57   unsigned int i = 0;   /* Number of characters printed */
  58   unsigned len;
  59   LONGEST low_bound, high_bound;
  60   struct type *elttype;
  61   unsigned eltlen;
  62   int length_pos, length_size, string_pos;
  63   struct type *char_type;
  64   LONGEST val;
  65   CORE_ADDR addr;
  66
  67   CHECK_TYPEDEF (type);
  68   switch (TYPE_CODE (type))
  69     {
  70     case TYPE_CODE_ARRAY:
  71       if (get_array_bounds (type, &low_bound, &high_bound))
  72         {
  73           len = high_bound - low_bound + 1;
  74           elttype = check_typedef (TYPE_TARGET_TYPE (type));
  75           eltlen = TYPE_LENGTH (elttype);
  76           if (options->prettyprint_arrays)
  77             {
  78               print_spaces_filtered (2 + 2 * recurse, stream);
  79             }
  80           /* If 's' format is used, try to print out as string.
  81              If no format is given, print as string if element type
  82              is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
  83           if (options->format == 's'
  84               || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
  85                   && TYPE_CODE (elttype) == TYPE_CODE_CHAR
  86                   && options->format == 0))
  87             {
  88               /* If requested, look for the first null char and only print
  89                  elements up to it.  */
  90               if (options->stop_print_at_null)
  91                 {
  92                   unsigned int temp_len;
  93
  94                   /* Look for a NULL char.  */
  95                   for (temp_len = 0;
  96                        extract_unsigned_integer (valaddr + embedded_offset +
  97                                                  temp_len * eltlen, eltlen,
  98                                                  byte_order)
  99                        && temp_len < len && temp_len < options->print_max;
 100                        temp_len++);
 101                   len = temp_len;
 102                 }
 103
 104               LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
 105                                valaddr + embedded_offset, len, NULL, 0,
 106                                options);
 107               i = len;
 108             }
 109           else
 110             {
 111               fprintf_filtered (stream, "{");
 112               /* If this is a virtual function table, print the 0th
 113                  entry specially, and the rest of the members normally.  */
 114               if (pascal_object_is_vtbl_ptr_type (elttype))
 115                 {
 116                   i = 1;
 117                   fprintf_filtered (stream, "%d vtable entries", len - 1);
 118                 }
 119               else
 120                 {
 121                   i = 0;
 122                 }
 123               val_print_array_elements (type, valaddr, embedded_offset,
 124                                         address, stream, recurse,
 125                                         original_value, options, i);
 126               fprintf_filtered (stream, "}");
 127             }
 128           break;
 129         }
 130       /* Array of unspecified length: treat like pointer to first elt.  */
 131       addr = address + embedded_offset;
 132       goto print_unpacked_pointer;
 133
 134     case TYPE_CODE_PTR:
 135       if (options->format && options->format != 's')
 136         {
 137           val_print_scalar_formatted (type, valaddr, embedded_offset,
 138                                       original_value, options, 0, stream);
 139           break;
 140         }
 141       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 142         {
 143           /* Print the unmangled name if desired.  */
 144           /* Print vtable entry - we only get here if we ARE using
 145              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
 146           /* Extract the address, assume that it is unsigned.  */
 147           addr = extract_unsigned_integer (valaddr + embedded_offset,
 148                                            TYPE_LENGTH (type), byte_order);
 149           print_address_demangle (gdbarch, addr, stream, demangle);
 150           break;
 151         }
 152       check_typedef (TYPE_TARGET_TYPE (type));
 153
 154       addr = unpack_pointer (type, valaddr + embedded_offset);
 155     print_unpacked_pointer:
 156       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 157
 158       if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 159         {
 160           /* Try to print what function it points to.  */
 161           print_address_demangle (gdbarch, addr, stream, demangle);
 162           /* Return value is irrelevant except for string pointers.  */
 163           return (0);
 164         }
 165
 166       if (options->addressprint && options->format != 's')
 167         {
 168           fputs_filtered (paddress (gdbarch, addr), stream);
 169         }
 170
 171       /* For a pointer to char or unsigned char, also print the string
 172          pointed to, unless pointer is null.  */
 173       if (((TYPE_LENGTH (elttype) == 1
 174            && (TYPE_CODE (elttype) == TYPE_CODE_INT
 175               || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 176           || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
 177               && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 178           && (options->format == 0 || options->format == 's')
 179           && addr != 0)
 180         {
 181           /* No wide string yet.  */
 182           i = val_print_string (elttype, NULL, addr, -1, stream, options);
 183         }
 184       /* Also for pointers to pascal strings.  */
 185       /* Note: this is Free Pascal specific:
 186          as GDB does not recognize stabs pascal strings
 187          Pascal strings are mapped to records
 188          with lowercase names PM.  */
 189       if (is_pascal_string_type (elttype, &length_pos, &length_size,
 190                                  &string_pos, &char_type, NULL)
 191           && addr != 0)
 192         {
 193           ULONGEST string_length;
 194           void *buffer;
 195
 196           buffer = xmalloc (length_size);
 197           read_memory (addr + length_pos, buffer, length_size);
 198           string_length = extract_unsigned_integer (buffer, length_size,
 199                                                     byte_order);
 200           xfree (buffer);
 201           i = val_print_string (char_type, NULL,
 202                                 addr + string_pos, string_length,
 203                                 stream, options);
 204         }
 205       else if (pascal_object_is_vtbl_member (type))
 206         {
 207           /* Print vtbl's nicely.  */
 208           CORE_ADDR vt_address = unpack_pointer (type,
 209                                                  valaddr + embedded_offset);
 210           struct minimal_symbol *msymbol =
 211             lookup_minimal_symbol_by_pc (vt_address);
 212
 213           if ((msymbol != NULL)
 214               && (vt_address == SYMBOL_VALUE_ADDRESS (msymbol)))
 215             {
 216               fputs_filtered (" <", stream);
 217               fputs_filtered (SYMBOL_PRINT_NAME (msymbol), stream);
 218               fputs_filtered (">", stream);
 219             }
 220           if (vt_address && options->vtblprint)
 221             {
 222               struct value *vt_val;
 223               struct symbol *wsym = (struct symbol *) NULL;
 224               struct type *wtype;
 225               struct block *block = (struct block *) NULL;
 226               int is_this_fld;
 227
 228               if (msymbol != NULL)
 229                 wsym = lookup_symbol (SYMBOL_LINKAGE_NAME (msymbol), block,
 230                                       VAR_DOMAIN, &is_this_fld);
 231
 232               if (wsym)
 233                 {
 234                   wtype = SYMBOL_TYPE (wsym);
 235                 }
 236               else
 237                 {
 238                   wtype = TYPE_TARGET_TYPE (type);
 239                 }
 240               vt_val = value_at (wtype, vt_address);
 241               common_val_print (vt_val, stream, recurse + 1, options,
 242                                 current_language);
 243               if (options->pretty)
 244                 {
 245                   fprintf_filtered (stream, "\n");
 246                   print_spaces_filtered (2 + 2 * recurse, stream);
 247                 }
 248             }
 249         }
 250
 251       /* Return number of characters printed, including the terminating
 252          '\0' if we reached the end.  val_print_string takes care including
 253          the terminating '\0' if necessary.  */
 254       return i;
 255
 256       break;
 257
 258     case TYPE_CODE_REF:
 259       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 260       if (options->addressprint)
 261         {
 262           CORE_ADDR addr
 263             = extract_typed_address (valaddr + embedded_offset, type);
 264
 265           fprintf_filtered (stream, "@");
 266           fputs_filtered (paddress (gdbarch, addr), stream);
 267           if (options->deref_ref)
 268             fputs_filtered (": ", stream);
 269         }
 270       /* De-reference the reference.  */
 271       if (options->deref_ref)
 272         {
 273           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 274             {
 275               struct value *deref_val;
 276
 277               deref_val = coerce_ref_if_computed (original_value);
 278               if (deref_val != NULL)
 279                 {
 280                   /* More complicated computed references are not supported.  */
 281                   gdb_assert (embedded_offset == 0);
 282                 }
 283               else
 284                 deref_val = value_at (TYPE_TARGET_TYPE (type),
 285                                       unpack_pointer (type,
 286                                                       (valaddr
 287                                                        + embedded_offset)));
 288
 289               common_val_print (deref_val, stream, recurse + 1, options,
 290                                 current_language);
 291             }
 292           else
 293             fputs_filtered ("???", stream);
 294         }
 295       break;
 296
 297     case TYPE_CODE_UNION:
 298       if (recurse && !options->unionprint)
 299         {
 300           fprintf_filtered (stream, "{...}");
 301           break;
 302         }
 303       /* Fall through.  */
 304     case TYPE_CODE_STRUCT:
 305       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 306         {
 307           /* Print the unmangled name if desired.  */
 308           /* Print vtable entry - we only get here if NOT using
 309              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
 310           /* Extract the address, assume that it is unsigned.  */
 311           print_address_demangle
 312             (gdbarch,
 313              extract_unsigned_integer (valaddr + embedded_offset
 314                                        + TYPE_FIELD_BITPOS (type,
 315                                                             VTBL_FNADDR_OFFSET) / 8,
 316                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type,
 317                                                                      VTBL_FNADDR_OFFSET)),
 318                                        byte_order),
 319              stream, demangle);
 320         }
 321       else
 322         {
 323           if (is_pascal_string_type (type, &length_pos, &length_size,
 324                                      &string_pos, &char_type, NULL))
 325             {
 326               len = extract_unsigned_integer (valaddr + embedded_offset
 327                                               + length_pos, length_size,
 328                                               byte_order);
 329               LA_PRINT_STRING (stream, char_type,
 330                                valaddr + embedded_offset + string_pos,
 331                                len, NULL, 0, options);
 332             }
 333           else
 334             pascal_object_print_value_fields (type, valaddr, embedded_offset,
 335                                               address, stream, recurse,
 336                                               original_value, options,
 337                                               NULL, 0);
 338         }
 339       break;
 340
 341     case TYPE_CODE_ENUM:
 342       if (options->format)
 343         {
 344           val_print_scalar_formatted (type, valaddr, embedded_offset,
 345                                       original_value, options, 0, stream);
 346           break;
 347         }
 348       len = TYPE_NFIELDS (type);
 349       val = unpack_long (type, valaddr + embedded_offset);
 350       for (i = 0; i < len; i++)
 351         {
 352           QUIT;
 353           if (val == TYPE_FIELD_BITPOS (type, i))
 354             {
 355               break;
 356             }
 357         }
 358       if (i < len)
 359         {
 360           fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
 361         }
 362       else
 363         {
 364           print_longest (stream, 'd', 0, val);
 365         }
 366       break;
 367
 368     case TYPE_CODE_FLAGS:
 369       if (options->format)
 370         val_print_scalar_formatted (type, valaddr, embedded_offset,
 371                                     original_value, options, 0, stream);
 372       else
 373         val_print_type_code_flags (type, valaddr + embedded_offset, stream);
 374       break;
 375
 376     case TYPE_CODE_FUNC:
 377       if (options->format)
 378         {
 379           val_print_scalar_formatted (type, valaddr, embedded_offset,
 380                                       original_value, options, 0, stream);
 381           break;
 382         }
 383       /* FIXME, we should consider, at least for ANSI C language, eliminating
 384          the distinction made between FUNCs and POINTERs to FUNCs.  */
 385       fprintf_filtered (stream, "{");
 386       type_print (type, "", stream, -1);
 387       fprintf_filtered (stream, "} ");
 388       /* Try to print what function it points to, and its address.  */
 389       print_address_demangle (gdbarch, address, stream, demangle);
 390       break;
 391
 392     case TYPE_CODE_BOOL:
 393       if (options->format || options->output_format)
 394         {
 395           struct value_print_options opts = *options;
 396
 397           opts.format = (options->format ? options->format
 398                          : options->output_format);
 399           val_print_scalar_formatted (type, valaddr, embedded_offset,
 400                                       original_value, &opts, 0, stream);
 401         }
 402       else
 403         {
 404           val = unpack_long (type, valaddr + embedded_offset);
 405           if (val == 0)
 406             fputs_filtered ("false", stream);
 407           else if (val == 1)
 408             fputs_filtered ("true", stream);
 409           else
 410             {
 411               fputs_filtered ("true (", stream);
 412               fprintf_filtered (stream, "%ld)", (long int) val);
 413             }
 414         }
 415       break;
 416
 417     case TYPE_CODE_RANGE:
 418       /* FIXME: create_range_type does not set the unsigned bit in a
 419          range type (I think it probably should copy it from the target
 420          type), so we won't print values which are too large to
 421          fit in a signed integer correctly.  */
 422       /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
 423          print with the target type, though, because the size of our type
 424          and the target type might differ).  */
 425       /* FALLTHROUGH */
 426
 427     case TYPE_CODE_INT:
 428       if (options->format || options->output_format)
 429         {
 430           struct value_print_options opts = *options;
 431
 432           opts.format = (options->format ? options->format
 433                          : options->output_format);
 434           val_print_scalar_formatted (type, valaddr, embedded_offset,
 435                                       original_value, &opts, 0, stream);
 436         }
 437       else
 438         {
 439           val_print_type_code_int (type, valaddr + embedded_offset, stream);
 440         }
 441       break;
 442
 443     case TYPE_CODE_CHAR:
 444       if (options->format || options->output_format)
 445         {
 446           struct value_print_options opts = *options;
 447
 448           opts.format = (options->format ? options->format
 449                          : options->output_format);
 450           val_print_scalar_formatted (type, valaddr, embedded_offset,
 451                                       original_value, &opts, 0, stream);
 452         }
 453       else
 454         {
 455           val = unpack_long (type, valaddr + embedded_offset);
 456           if (TYPE_UNSIGNED (type))
 457             fprintf_filtered (stream, "%u", (unsigned int) val);
 458           else
 459             fprintf_filtered (stream, "%d", (int) val);
 460           fputs_filtered (" ", stream);
 461           LA_PRINT_CHAR ((unsigned char) val, type, stream);
 462         }
 463       break;
 464
 465     case TYPE_CODE_FLT:
 466       if (options->format)
 467         {
 468           val_print_scalar_formatted (type, valaddr, embedded_offset,
 469                                       original_value, options, 0, stream);
 470         }
 471       else
 472         {
 473           print_floating (valaddr + embedded_offset, type, stream);
 474         }
 475       break;
 476
 477     case TYPE_CODE_BITSTRING:
 478     case TYPE_CODE_SET:
 479       elttype = TYPE_INDEX_TYPE (type);
 480       CHECK_TYPEDEF (elttype);
 481       if (TYPE_STUB (elttype))
 482         {
 483           fprintf_filtered (stream, "<incomplete type>");
 484           gdb_flush (stream);
 485           break;
 486         }
 487       else
 488         {
 489           struct type *range = elttype;
 490           LONGEST low_bound, high_bound;
 491           int i;
 492           int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
 493           int need_comma = 0;
 494
 495           if (is_bitstring)
 496             fputs_filtered ("B'", stream);
 497           else
 498             fputs_filtered ("[", stream);
 499
 500           i = get_discrete_bounds (range, &low_bound, &high_bound);
 501           if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
 502             {
 503               /* If we know the size of the set type, we can figure out the
 504               maximum value.  */
 505               i = 0;
 506               high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
 507               TYPE_HIGH_BOUND (range) = high_bound;
 508             }
 509         maybe_bad_bstring:
 510           if (i < 0)
 511             {
 512               fputs_filtered ("<error value>", stream);
 513               goto done;
 514             }
 515
 516           for (i = low_bound; i <= high_bound; i++)
 517             {
 518               int element = value_bit_index (type,
 519                                              valaddr + embedded_offset, i);
 520
 521               if (element < 0)
 522                 {
 523                   i = element;
 524                   goto maybe_bad_bstring;
 525                 }
 526               if (is_bitstring)
 527                 fprintf_filtered (stream, "%d", element);
 528               else if (element)
 529                 {
 530                   if (need_comma)
 531                     fputs_filtered (", ", stream);
 532                   print_type_scalar (range, i, stream);
 533                   need_comma = 1;
 534
 535                   if (i + 1 <= high_bound
 536                       && value_bit_index (type,
 537                                           valaddr + embedded_offset, ++i))
 538                     {
 539                       int j = i;
 540
 541                       fputs_filtered ("..", stream);
 542                       while (i + 1 <= high_bound
 543                              && value_bit_index (type,
 544                                                  valaddr + embedded_offset,
 545                                                  ++i))
 546                         j = i;
 547                       print_type_scalar (range, j, stream);
 548                     }
 549                 }
 550             }
 551         done:
 552           if (is_bitstring)
 553             fputs_filtered ("'", stream);
 554           else
 555             fputs_filtered ("]", stream);
 556         }
 557       break;
 558
 559     case TYPE_CODE_VOID:
 560       fprintf_filtered (stream, "void");
 561       break;
 562
 563     case TYPE_CODE_ERROR:
 564       fprintf_filtered (stream, "%s", TYPE_ERROR_NAME (type));
 565       break;
 566
 567     case TYPE_CODE_UNDEF:
 568       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 569          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 570          and no complete type for struct foo in that file.  */
 571       fprintf_filtered (stream, "<incomplete type>");
 572       break;
 573
 574     default:
 575       error (_("Invalid pascal type code %d in symbol table."),
 576              TYPE_CODE (type));
 577     }
 578   gdb_flush (stream);
 579   return (0);
 580 }
 581 \f
 582 void
 583 pascal_value_print (struct value *val, struct ui_file *stream,
 584                     const struct value_print_options *options)
 585 {
 586   struct type *type = value_type (val);
 587   struct value_print_options opts = *options;
 588
 589   opts.deref_ref = 1;
 590
 591   /* If it is a pointer, indicate what it points to.
 592
 593      Print type also if it is a reference.
 594
 595      Object pascal: if it is a member pointer, we will take care
 596      of that when we print it.  */
 597   if (TYPE_CODE (type) == TYPE_CODE_PTR
 598       || TYPE_CODE (type) == TYPE_CODE_REF)
 599     {
 600       /* Hack:  remove (char *) for char strings.  Their
 601          type is indicated by the quoted string anyway.  */
 602       if (TYPE_CODE (type) == TYPE_CODE_PTR
 603           && TYPE_NAME (type) == NULL
 604           && TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
 605           && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
 606         {
 607           /* Print nothing.  */
 608         }
 609       else
 610         {
 611           fprintf_filtered (stream, "(");
 612           type_print (type, "", stream, -1);
 613           fprintf_filtered (stream, ") ");
 614         }
 615     }
 616   common_val_print (val, stream, 0, &opts, current_language);
 617 }
 618
 619
 620 static void
 621 show_pascal_static_field_print (struct ui_file *file, int from_tty,
 622                                 struct cmd_list_element *c, const char *value)
 623 {
 624   fprintf_filtered (file, _("Printing of pascal static members is %s.\n"),
 625                     value);
 626 }
 627
 628 static struct obstack dont_print_vb_obstack;
 629 static struct obstack dont_print_statmem_obstack;
 630
 631 static void pascal_object_print_static_field (struct value *,
 632                                               struct ui_file *, int,
 633                                               const struct value_print_options *);
 634
 635 static void pascal_object_print_value (struct type *, const gdb_byte *,
 636                                        int,
 637                                        CORE_ADDR, struct ui_file *, int,
 638                                        const struct value *,
 639                                        const struct value_print_options *,
 640                                        struct type **);
 641
 642 /* It was changed to this after 2.4.5.  */
 643 const char pascal_vtbl_ptr_name[] =
 644 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 645
 646 /* Return truth value for assertion that TYPE is of the type
 647    "pointer to virtual function".  */
 648
 649 int
 650 pascal_object_is_vtbl_ptr_type (struct type *type)
 651 {
 652   const char *typename = type_name_no_tag (type);
 653
 654   return (typename != NULL
 655           && strcmp (typename, pascal_vtbl_ptr_name) == 0);
 656 }
 657
 658 /* Return truth value for the assertion that TYPE is of the type
 659    "pointer to virtual function table".  */
 660
 661 int
 662 pascal_object_is_vtbl_member (struct type *type)
 663 {
 664   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 665     {
 666       type = TYPE_TARGET_TYPE (type);
 667       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 668         {
 669           type = TYPE_TARGET_TYPE (type);
 670           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* If not using
 671                                                            thunks.  */
 672               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* If using thunks.  */
 673             {
 674               /* Virtual functions tables are full of pointers
 675                  to virtual functions.  */
 676               return pascal_object_is_vtbl_ptr_type (type);
 677             }
 678         }
 679     }
 680   return 0;
 681 }
 682
 683 /* Mutually recursive subroutines of pascal_object_print_value and
 684    c_val_print to print out a structure's fields:
 685    pascal_object_print_value_fields and pascal_object_print_value.
 686
 687    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and OPTIONS have the
 688    same meanings as in pascal_object_print_value and c_val_print.
 689
 690    DONT_PRINT is an array of baseclass types that we
 691    should not print, or zero if called from top level.  */
 692
 693 void
 694 pascal_object_print_value_fields (struct type *type, const gdb_byte *valaddr,
 695                                   int offset,
 696                                   CORE_ADDR address, struct ui_file *stream,
 697                                   int recurse,
 698                                   const struct value *val,
 699                                   const struct value_print_options *options,
 700                                   struct type **dont_print_vb,
 701                                   int dont_print_statmem)
 702 {
 703   int i, len, n_baseclasses;
 704   char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
 705
 706   CHECK_TYPEDEF (type);
 707
 708   fprintf_filtered (stream, "{");
 709   len = TYPE_NFIELDS (type);
 710   n_baseclasses = TYPE_N_BASECLASSES (type);
 711
 712   /* Print out baseclasses such that we don't print
 713      duplicates of virtual baseclasses.  */
 714   if (n_baseclasses > 0)
 715     pascal_object_print_value (type, valaddr, offset, address,
 716                                stream, recurse + 1, val,
 717                                options, dont_print_vb);
 718
 719   if (!len && n_baseclasses == 1)
 720     fprintf_filtered (stream, "<No data fields>");
 721   else
 722     {
 723       struct obstack tmp_obstack = dont_print_statmem_obstack;
 724       int fields_seen = 0;
 725
 726       if (dont_print_statmem == 0)
 727         {
 728           /* If we're at top level, carve out a completely fresh
 729              chunk of the obstack and use that until this particular
 730              invocation returns.  */
 731           obstack_finish (&dont_print_statmem_obstack);
 732         }
 733
 734       for (i = n_baseclasses; i < len; i++)
 735         {
 736           /* If requested, skip printing of static fields.  */
 737           if (!options->pascal_static_field_print
 738               && field_is_static (&TYPE_FIELD (type, i)))
 739             continue;
 740           if (fields_seen)
 741             fprintf_filtered (stream, ", ");
 742           else if (n_baseclasses > 0)
 743             {
 744               if (options->pretty)
 745                 {
 746                   fprintf_filtered (stream, "\n");
 747                   print_spaces_filtered (2 + 2 * recurse, stream);
 748                   fputs_filtered ("members of ", stream);
 749                   fputs_filtered (type_name_no_tag (type), stream);
 750                   fputs_filtered (": ", stream);
 751                 }
 752             }
 753           fields_seen = 1;
 754
 755           if (options->pretty)
 756             {
 757               fprintf_filtered (stream, "\n");
 758               print_spaces_filtered (2 + 2 * recurse, stream);
 759             }
 760           else
 761             {
 762               wrap_here (n_spaces (2 + 2 * recurse));
 763             }
 764           if (options->inspect_it)
 765             {
 766               if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
 767                 fputs_filtered ("\"( ptr \"", stream);
 768               else
 769                 fputs_filtered ("\"( nodef \"", stream);
 770               if (field_is_static (&TYPE_FIELD (type, i)))
 771                 fputs_filtered ("static ", stream);
 772               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 773                                        language_cplus,
 774                                        DMGL_PARAMS | DMGL_ANSI);
 775               fputs_filtered ("\" \"", stream);
 776               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 777                                        language_cplus,
 778                                        DMGL_PARAMS | DMGL_ANSI);
 779               fputs_filtered ("\") \"", stream);
 780             }
 781           else
 782             {
 783               annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 784
 785               if (field_is_static (&TYPE_FIELD (type, i)))
 786                 fputs_filtered ("static ", stream);
 787               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 788                                        language_cplus,
 789                                        DMGL_PARAMS | DMGL_ANSI);
 790               annotate_field_name_end ();
 791               fputs_filtered (" = ", stream);
 792               annotate_field_value ();
 793             }
 794
 795           if (!field_is_static (&TYPE_FIELD (type, i))
 796               && TYPE_FIELD_PACKED (type, i))
 797             {
 798               struct value *v;
 799
 800               /* Bitfields require special handling, especially due to byte
 801                  order problems.  */
 802               if (TYPE_FIELD_IGNORE (type, i))
 803                 {
 804                   fputs_filtered ("<optimized out or zero length>", stream);
 805                 }
 806               else if (value_bits_synthetic_pointer (val,
 807                                                      TYPE_FIELD_BITPOS (type,
 808                                                                         i),
 809                                                      TYPE_FIELD_BITSIZE (type,
 810                                                                          i)))
 811                 {
 812                   fputs_filtered (_("<synthetic pointer>"), stream);
 813                 }
 814               else if (!value_bits_valid (val, TYPE_FIELD_BITPOS (type, i),
 815                                           TYPE_FIELD_BITSIZE (type, i)))
 816                 {
 817                   val_print_optimized_out (stream);
 818                 }
 819               else
 820                 {
 821                   struct value_print_options opts = *options;
 822
 823                   v = value_field_bitfield (type, i, valaddr, offset, val);
 824
 825                   opts.deref_ref = 0;
 826                   common_val_print (v, stream, recurse + 1, &opts,
 827                                     current_language);
 828                 }
 829             }
 830           else
 831             {
 832               if (TYPE_FIELD_IGNORE (type, i))
 833                 {
 834                   fputs_filtered ("<optimized out or zero length>", stream);
 835                 }
 836               else if (field_is_static (&TYPE_FIELD (type, i)))
 837                 {
 838                   /* struct value *v = value_static_field (type, i);
 839                      v4.17 specific.  */
 840                   struct value *v;
 841
 842                   v = value_field_bitfield (type, i, valaddr, offset, val);
 843
 844                   if (v == NULL)
 845                     val_print_optimized_out (stream);
 846                   else
 847                     pascal_object_print_static_field (v, stream, recurse + 1,
 848                                                       options);
 849                 }
 850               else
 851                 {
 852                   struct value_print_options opts = *options;
 853
 854                   opts.deref_ref = 0;
 855                   /* val_print (TYPE_FIELD_TYPE (type, i),
 856                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 857                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 858                      stream, format, 0, recurse + 1, pretty); */
 859                   val_print (TYPE_FIELD_TYPE (type, i),
 860                              valaddr, offset + TYPE_FIELD_BITPOS (type, i) / 8,
 861                              address, stream, recurse + 1, val, &opts,
 862                              current_language);
 863                 }
 864             }
 865           annotate_field_end ();
 866         }
 867
 868       if (dont_print_statmem == 0)
 869         {
 870           /* Free the space used to deal with the printing
 871              of the members from top level.  */
 872           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 873           dont_print_statmem_obstack = tmp_obstack;
 874         }
 875
 876       if (options->pretty)
 877         {
 878           fprintf_filtered (stream, "\n");
 879           print_spaces_filtered (2 * recurse, stream);
 880         }
 881     }
 882   fprintf_filtered (stream, "}");
 883 }
 884
 885 /* Special val_print routine to avoid printing multiple copies of virtual
 886    baseclasses.  */
 887
 888 static void
 889 pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
 890                            int offset,
 891                            CORE_ADDR address, struct ui_file *stream,
 892                            int recurse,
 893                            const struct value *val,
 894                            const struct value_print_options *options,
 895                            struct type **dont_print_vb)
 896 {
 897   struct type **last_dont_print
 898     = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 899   struct obstack tmp_obstack = dont_print_vb_obstack;
 900   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 901
 902   if (dont_print_vb == 0)
 903     {
 904       /* If we're at top level, carve out a completely fresh
 905          chunk of the obstack and use that until this particular
 906          invocation returns.  */
 907       /* Bump up the high-water mark.  Now alpha is omega.  */
 908       obstack_finish (&dont_print_vb_obstack);
 909     }
 910
 911   for (i = 0; i < n_baseclasses; i++)
 912     {
 913       int boffset = 0;
 914       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 915       const char *basename = type_name_no_tag (baseclass);
 916       const gdb_byte *base_valaddr = NULL;
 917       int thisoffset;
 918       volatile struct gdb_exception ex;
 919       int skip = 0;
 920
 921       if (BASETYPE_VIA_VIRTUAL (type, i))
 922         {
 923           struct type **first_dont_print
 924             = (struct type **) obstack_base (&dont_print_vb_obstack);
 925
 926           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 927             - first_dont_print;
 928
 929           while (--j >= 0)
 930             if (baseclass == first_dont_print[j])
 931               goto flush_it;
 932
 933           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 934         }
 935
 936       thisoffset = offset;
 937
 938       TRY_CATCH (ex, RETURN_MASK_ERROR)
 939         {
 940           boffset = baseclass_offset (type, i, valaddr, offset, address, val);
 941         }
 942       if (ex.reason < 0 && ex.error == NOT_AVAILABLE_ERROR)
 943         skip = -1;
 944       else if (ex.reason < 0)
 945         skip = 1;
 946       else
 947         {
 948           skip = 0;
 949
 950           /* The virtual base class pointer might have been clobbered by the
 951              user program. Make sure that it still points to a valid memory
 952              location.  */
 953
 954           if (boffset < 0 || boffset >= TYPE_LENGTH (type))
 955             {
 956               /* FIXME (alloc): not safe is baseclass is really really big. */
 957               gdb_byte *buf = alloca (TYPE_LENGTH (baseclass));
 958
 959               base_valaddr = buf;
 960               if (target_read_memory (address + boffset, buf,
 961                                       TYPE_LENGTH (baseclass)) != 0)
 962                 skip = 1;
 963               address = address + boffset;
 964               thisoffset = 0;
 965               boffset = 0;
 966             }
 967           else
 968             base_valaddr = valaddr;
 969         }
 970
 971       if (options->pretty)
 972         {
 973           fprintf_filtered (stream, "\n");
 974           print_spaces_filtered (2 * recurse, stream);
 975         }
 976       fputs_filtered ("<", stream);
 977       /* Not sure what the best notation is in the case where there is no
 978          baseclass name.  */
 979
 980       fputs_filtered (basename ? basename : "", stream);
 981       fputs_filtered ("> = ", stream);
 982
 983       if (skip < 0)
 984         val_print_unavailable (stream);
 985       else if (skip > 0)
 986         val_print_invalid_address (stream);
 987       else
 988         pascal_object_print_value_fields (baseclass, base_valaddr,
 989                                           thisoffset + boffset, address,
 990                                           stream, recurse, val, options,
 991                      (struct type **) obstack_base (&dont_print_vb_obstack),
 992                                           0);
 993       fputs_filtered (", ", stream);
 994
 995     flush_it:
 996       ;
 997     }
 998
 999   if (dont_print_vb == 0)
1000     {
1001       /* Free the space used to deal with the printing
1002          of this type from top level.  */
1003       obstack_free (&dont_print_vb_obstack, last_dont_print);
1004       /* Reset watermark so that we can continue protecting
1005          ourselves from whatever we were protecting ourselves.  */
1006       dont_print_vb_obstack = tmp_obstack;
1007     }
1008 }
1009
1010 /* Print value of a static member.
1011    To avoid infinite recursion when printing a class that contains
1012    a static instance of the class, we keep the addresses of all printed
1013    static member classes in an obstack and refuse to print them more
1014    than once.
1015
1016    VAL contains the value to print, STREAM, RECURSE, and OPTIONS
1017    have the same meanings as in c_val_print.  */
1018
1019 static void
1020 pascal_object_print_static_field (struct value *val,
1021                                   struct ui_file *stream,
1022                                   int recurse,
1023                                   const struct value_print_options *options)
1024 {
1025   struct type *type = value_type (val);
1026   struct value_print_options opts;
1027
1028   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1029     {
1030       CORE_ADDR *first_dont_print, addr;
1031       int i;
1032
1033       first_dont_print
1034         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1035       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1036         - first_dont_print;
1037
1038       while (--i >= 0)
1039         {
1040           if (value_address (val) == first_dont_print[i])
1041             {
1042               fputs_filtered ("\
1043 <same as static member of an already seen type>",
1044                               stream);
1045               return;
1046             }
1047         }
1048
1049       addr = value_address (val);
1050       obstack_grow (&dont_print_statmem_obstack, (char *) &addr,
1051                     sizeof (CORE_ADDR));
1052
1053       CHECK_TYPEDEF (type);
1054       pascal_object_print_value_fields (type,
1055                                         value_contents_for_printing (val),
1056                                         value_embedded_offset (val),
1057                                         addr,
1058                                         stream, recurse,
1059                                         val, options, NULL, 1);
1060       return;
1061     }
1062
1063   opts = *options;
1064   opts.deref_ref = 0;
1065   common_val_print (val, stream, recurse, &opts, current_language);
1066 }
1067
1068 /* -Wmissing-prototypes */
1069 extern initialize_file_ftype _initialize_pascal_valprint;
1070
1071 void
1072 _initialize_pascal_valprint (void)
1073 {
1074   add_setshow_boolean_cmd ("pascal_static-members", class_support,
1075                            &user_print_options.pascal_static_field_print, _("\
1076 Set printing of pascal static members."), _("\
1077 Show printing of pascal static members."), NULL,
1078                            NULL,
1079                            show_pascal_static_field_print,
1080                            &setprintlist, &showprintlist);
1081 }