gdb/p-valprint.c

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