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
   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_valid (val, TYPE_FIELD_BITPOS (type, i),
 783                                           TYPE_FIELD_BITSIZE (type, i)))
 784                 {
 785                   fputs_filtered (_("<value optimized out>"), stream);
 786                 }
 787               else
 788                 {
 789                   struct value_print_options opts = *options;
 790
 791                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 792                                    unpack_field_as_long (type, valaddr, i));
 793
 794                   opts.deref_ref = 0;
 795                   common_val_print (v, stream, recurse + 1, &opts,
 796                                     current_language);
 797                 }
 798             }
 799           else
 800             {
 801               if (TYPE_FIELD_IGNORE (type, i))
 802                 {
 803                   fputs_filtered ("<optimized out or zero length>", stream);
 804                 }
 805               else if (field_is_static (&TYPE_FIELD (type, i)))
 806                 {
 807                   /* struct value *v = value_static_field (type, i); v4.17 specific */
 808                   struct value *v;
 809
 810                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 811                                    unpack_field_as_long (type, valaddr, i));
 812
 813                   if (v == NULL)
 814                     fputs_filtered ("<optimized out>", stream);
 815                   else
 816                     pascal_object_print_static_field (v, stream, recurse + 1,
 817                                                       options);
 818                 }
 819               else
 820                 {
 821                   struct value_print_options opts = *options;
 822
 823                   opts.deref_ref = 0;
 824                   /* val_print (TYPE_FIELD_TYPE (type, i),
 825                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 826                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 827                      stream, format, 0, recurse + 1, pretty); */
 828                   val_print (TYPE_FIELD_TYPE (type, i),
 829                              valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
 830                              address + TYPE_FIELD_BITPOS (type, i) / 8,
 831                              stream, recurse + 1, val, &opts,
 832                              current_language);
 833                 }
 834             }
 835           annotate_field_end ();
 836         }
 837
 838       if (dont_print_statmem == 0)
 839         {
 840           /* Free the space used to deal with the printing
 841              of the members from top level.  */
 842           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 843           dont_print_statmem_obstack = tmp_obstack;
 844         }
 845
 846       if (options->pretty)
 847         {
 848           fprintf_filtered (stream, "\n");
 849           print_spaces_filtered (2 * recurse, stream);
 850         }
 851     }
 852   fprintf_filtered (stream, "}");
 853 }
 854
 855 /* Special val_print routine to avoid printing multiple copies of virtual
 856    baseclasses.  */
 857
 858 static void
 859 pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
 860                            CORE_ADDR address, struct ui_file *stream,
 861                            int recurse,
 862                            const struct value *val,
 863                            const struct value_print_options *options,
 864                            struct type **dont_print_vb)
 865 {
 866   struct type **last_dont_print
 867     = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 868   struct obstack tmp_obstack = dont_print_vb_obstack;
 869   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 870
 871   if (dont_print_vb == 0)
 872     {
 873       /* If we're at top level, carve out a completely fresh
 874          chunk of the obstack and use that until this particular
 875          invocation returns.  */
 876       /* Bump up the high-water mark.  Now alpha is omega.  */
 877       obstack_finish (&dont_print_vb_obstack);
 878     }
 879
 880   for (i = 0; i < n_baseclasses; i++)
 881     {
 882       int boffset;
 883       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 884       char *basename = type_name_no_tag (baseclass);
 885       const gdb_byte *base_valaddr;
 886
 887       if (BASETYPE_VIA_VIRTUAL (type, i))
 888         {
 889           struct type **first_dont_print
 890             = (struct type **) obstack_base (&dont_print_vb_obstack);
 891
 892           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 893             - first_dont_print;
 894
 895           while (--j >= 0)
 896             if (baseclass == first_dont_print[j])
 897               goto flush_it;
 898
 899           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 900         }
 901
 902       boffset = baseclass_offset (type, i, valaddr, address);
 903
 904       if (options->pretty)
 905         {
 906           fprintf_filtered (stream, "\n");
 907           print_spaces_filtered (2 * recurse, stream);
 908         }
 909       fputs_filtered ("<", stream);
 910       /* Not sure what the best notation is in the case where there is no
 911          baseclass name.  */
 912
 913       fputs_filtered (basename ? basename : "", stream);
 914       fputs_filtered ("> = ", stream);
 915
 916       /* The virtual base class pointer might have been clobbered by the
 917          user program. Make sure that it still points to a valid memory
 918          location.  */
 919
 920       if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
 921         {
 922           /* FIXME (alloc): not safe is baseclass is really really big. */
 923           gdb_byte *buf = alloca (TYPE_LENGTH (baseclass));
 924
 925           base_valaddr = buf;
 926           if (target_read_memory (address + boffset, buf,
 927                                   TYPE_LENGTH (baseclass)) != 0)
 928             boffset = -1;
 929         }
 930       else
 931         base_valaddr = valaddr + boffset;
 932
 933       if (boffset == -1)
 934         fprintf_filtered (stream, "<invalid address>");
 935       else
 936         pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
 937                                           stream, recurse, val, options,
 938                      (struct type **) obstack_base (&dont_print_vb_obstack),
 939                                           0);
 940       fputs_filtered (", ", stream);
 941
 942     flush_it:
 943       ;
 944     }
 945
 946   if (dont_print_vb == 0)
 947     {
 948       /* Free the space used to deal with the printing
 949          of this type from top level.  */
 950       obstack_free (&dont_print_vb_obstack, last_dont_print);
 951       /* Reset watermark so that we can continue protecting
 952          ourselves from whatever we were protecting ourselves.  */
 953       dont_print_vb_obstack = tmp_obstack;
 954     }
 955 }
 956
 957 /* Print value of a static member.
 958    To avoid infinite recursion when printing a class that contains
 959    a static instance of the class, we keep the addresses of all printed
 960    static member classes in an obstack and refuse to print them more
 961    than once.
 962
 963    VAL contains the value to print, STREAM, RECURSE, and OPTIONS
 964    have the same meanings as in c_val_print.  */
 965
 966 static void
 967 pascal_object_print_static_field (struct value *val,
 968                                   struct ui_file *stream,
 969                                   int recurse,
 970                                   const struct value_print_options *options)
 971 {
 972   struct type *type = value_type (val);
 973   struct value_print_options opts;
 974
 975   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
 976     {
 977       CORE_ADDR *first_dont_print, addr;
 978       int i;
 979
 980       first_dont_print
 981         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
 982       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
 983         - first_dont_print;
 984
 985       while (--i >= 0)
 986         {
 987           if (value_address (val) == first_dont_print[i])
 988             {
 989               fputs_filtered ("<same as static member of an already seen type>",
 990                               stream);
 991               return;
 992             }
 993         }
 994
 995       addr = value_address (val);
 996       obstack_grow (&dont_print_statmem_obstack, (char *) &addr,
 997                     sizeof (CORE_ADDR));
 998
 999       CHECK_TYPEDEF (type);
1000       pascal_object_print_value_fields (type, value_contents (val), addr,
1001                                         stream, recurse, NULL, options,
1002                                         NULL, 1);
1003       return;
1004     }
1005
1006   opts = *options;
1007   opts.deref_ref = 0;
1008   common_val_print (val, stream, recurse, &opts, current_language);
1009 }
1010
1011 extern initialize_file_ftype _initialize_pascal_valprint; /* -Wmissing-prototypes */
1012
1013 void
1014 _initialize_pascal_valprint (void)
1015 {
1016   add_setshow_boolean_cmd ("pascal_static-members", class_support,
1017                            &user_print_options.pascal_static_field_print, _("\
1018 Set printing of pascal static members."), _("\
1019 Show printing of pascal static members."), NULL,
1020                            NULL,
1021                            show_pascal_static_field_print,
1022                            &setprintlist, &showprintlist);
1023 }