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