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