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