gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000-2020 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* This file is derived from c-valprint.c */
  21
  22 #include "defs.h"
  23 #include "gdb_obstack.h"
  24 #include "symtab.h"
  25 #include "gdbtypes.h"
  26 #include "expression.h"
  27 #include "value.h"
  28 #include "command.h"
  29 #include "gdbcmd.h"
  30 #include "gdbcore.h"
  31 #include "demangle.h"
  32 #include "valprint.h"
  33 #include "typeprint.h"
  34 #include "language.h"
  35 #include "target.h"
  36 #include "annotate.h"
  37 #include "p-lang.h"
  38 #include "cp-abi.h"
  39 #include "cp-support.h"
  40 #include "objfiles.h"
  41 #include "gdbsupport/byte-vector.h"
  42 #include "cli/cli-style.h"
  43 \f
  44
  45 static void pascal_object_print_value_fields (struct type *, const gdb_byte *,
  46                                               LONGEST,
  47                                               CORE_ADDR, struct ui_file *,
  48                                               int,
  49                                               struct value *,
  50                                               const struct value_print_options *,
  51                                               struct type **, int);
  52
  53 static void pascal_object_print_value_fields (struct value *, struct ui_file *,
  54                                               int,
  55                                               const struct value_print_options *,
  56                                               struct type **, int);
  57
  58 /* Decorations for Pascal.  */
  59
  60 static const struct generic_val_print_decorations p_decorations =
  61 {
  62   "",
  63   " + ",
  64   " * I",
  65   "true",
  66   "false",
  67   "void",
  68   "{",
  69   "}"
  70 };
  71
  72 /* See val_print for a description of the various parameters of this
  73    function; they are identical.  */
  74
  75 void
  76 pascal_val_print (struct type *type,
  77                   int embedded_offset, CORE_ADDR address,
  78                   struct ui_file *stream, int recurse,
  79                   struct value *original_value,
  80                   const struct value_print_options *options)
  81 {
  82   struct gdbarch *gdbarch = get_type_arch (type);
  83   enum bfd_endian byte_order = type_byte_order (type);
  84   unsigned int i = 0;   /* Number of characters printed */
  85   unsigned len;
  86   struct type *elttype;
  87   unsigned eltlen;
  88   int length_pos, length_size, string_pos;
  89   struct type *char_type;
  90   CORE_ADDR addr;
  91   int want_space = 0;
  92   const gdb_byte *valaddr = value_contents_for_printing (original_value);
  93
  94   type = check_typedef (type);
  95   switch (TYPE_CODE (type))
  96     {
  97     case TYPE_CODE_ARRAY:
  98       {
  99         LONGEST low_bound, high_bound;
 100
 101         if (get_array_bounds (type, &low_bound, &high_bound))
 102           {
 103             len = high_bound - low_bound + 1;
 104             elttype = check_typedef (TYPE_TARGET_TYPE (type));
 105             eltlen = TYPE_LENGTH (elttype);
 106             if (options->prettyformat_arrays)
 107               {
 108                 print_spaces_filtered (2 + 2 * recurse, stream);
 109               }
 110             /* If 's' format is used, try to print out as string.
 111                If no format is given, print as string if element type
 112                is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
 113             if (options->format == 's'
 114                 || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
 115                     && TYPE_CODE (elttype) == TYPE_CODE_CHAR
 116                     && options->format == 0))
 117               {
 118                 /* If requested, look for the first null char and only print
 119                    elements up to it.  */
 120                 if (options->stop_print_at_null)
 121                   {
 122                     unsigned int temp_len;
 123
 124                     /* Look for a NULL char.  */
 125                     for (temp_len = 0;
 126                          extract_unsigned_integer (valaddr + embedded_offset +
 127                                                    temp_len * eltlen, eltlen,
 128                                                    byte_order)
 129                            && temp_len < len && temp_len < options->print_max;
 130                          temp_len++);
 131                     len = temp_len;
 132                   }
 133
 134                 LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
 135                                  valaddr + embedded_offset, len, NULL, 0,
 136                                  options);
 137                 i = len;
 138               }
 139             else
 140               {
 141                 fprintf_filtered (stream, "{");
 142                 /* If this is a virtual function table, print the 0th
 143                    entry specially, and the rest of the members normally.  */
 144                 if (pascal_object_is_vtbl_ptr_type (elttype))
 145                   {
 146                     i = 1;
 147                     fprintf_filtered (stream, "%d vtable entries", len - 1);
 148                   }
 149                 else
 150                   {
 151                     i = 0;
 152                   }
 153                 val_print_array_elements (type, embedded_offset,
 154                                           address, stream, recurse,
 155                                           original_value, options, i);
 156                 fprintf_filtered (stream, "}");
 157               }
 158             break;
 159           }
 160         /* Array of unspecified length: treat like pointer to first elt.  */
 161         addr = address + embedded_offset;
 162       }
 163       goto print_unpacked_pointer;
 164
 165     case TYPE_CODE_PTR:
 166       if (options->format && options->format != 's')
 167         {
 168           val_print_scalar_formatted (type, embedded_offset,
 169                                       original_value, options, 0, stream);
 170           break;
 171         }
 172       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 173         {
 174           /* Print the unmangled name if desired.  */
 175           /* Print vtable entry - we only get here if we ARE using
 176              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
 177           /* Extract the address, assume that it is unsigned.  */
 178           addr = extract_unsigned_integer (valaddr + embedded_offset,
 179                                            TYPE_LENGTH (type), byte_order);
 180           print_address_demangle (options, gdbarch, addr, stream, demangle);
 181           break;
 182         }
 183       check_typedef (TYPE_TARGET_TYPE (type));
 184
 185       addr = unpack_pointer (type, valaddr + embedded_offset);
 186     print_unpacked_pointer:
 187       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 188
 189       if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 190         {
 191           /* Try to print what function it points to.  */
 192           print_address_demangle (options, gdbarch, addr, stream, demangle);
 193           return;
 194         }
 195
 196       if (options->addressprint && options->format != 's')
 197         {
 198           fputs_filtered (paddress (gdbarch, addr), stream);
 199           want_space = 1;
 200         }
 201
 202       /* For a pointer to char or unsigned char, also print the string
 203          pointed to, unless pointer is null.  */
 204       if (((TYPE_LENGTH (elttype) == 1
 205            && (TYPE_CODE (elttype) == TYPE_CODE_INT
 206               || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 207           || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
 208               && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 209           && (options->format == 0 || options->format == 's')
 210           && addr != 0)
 211         {
 212           if (want_space)
 213             fputs_filtered (" ", stream);
 214           /* No wide string yet.  */
 215           i = val_print_string (elttype, NULL, addr, -1, stream, options);
 216         }
 217       /* Also for pointers to pascal strings.  */
 218       /* Note: this is Free Pascal specific:
 219          as GDB does not recognize stabs pascal strings
 220          Pascal strings are mapped to records
 221          with lowercase names PM.  */
 222       if (is_pascal_string_type (elttype, &length_pos, &length_size,
 223                                  &string_pos, &char_type, NULL)
 224           && addr != 0)
 225         {
 226           ULONGEST string_length;
 227           gdb_byte *buffer;
 228
 229           if (want_space)
 230             fputs_filtered (" ", stream);
 231           buffer = (gdb_byte *) xmalloc (length_size);
 232           read_memory (addr + length_pos, buffer, length_size);
 233           string_length = extract_unsigned_integer (buffer, length_size,
 234                                                     byte_order);
 235           xfree (buffer);
 236           i = val_print_string (char_type, NULL,
 237                                 addr + string_pos, string_length,
 238                                 stream, options);
 239         }
 240       else if (pascal_object_is_vtbl_member (type))
 241         {
 242           /* Print vtbl's nicely.  */
 243           CORE_ADDR vt_address = unpack_pointer (type,
 244                                                  valaddr + embedded_offset);
 245           struct bound_minimal_symbol msymbol =
 246             lookup_minimal_symbol_by_pc (vt_address);
 247
 248           /* If 'symbol_print' is set, we did the work above.  */
 249           if (!options->symbol_print
 250               && (msymbol.minsym != NULL)
 251               && (vt_address == BMSYMBOL_VALUE_ADDRESS (msymbol)))
 252             {
 253               if (want_space)
 254                 fputs_filtered (" ", stream);
 255               fputs_filtered ("<", stream);
 256               fputs_filtered (msymbol.minsym->print_name (), stream);
 257               fputs_filtered (">", stream);
 258               want_space = 1;
 259             }
 260           if (vt_address && options->vtblprint)
 261             {
 262               struct value *vt_val;
 263               struct symbol *wsym = NULL;
 264               struct type *wtype;
 265
 266               if (want_space)
 267                 fputs_filtered (" ", stream);
 268
 269               if (msymbol.minsym != NULL)
 270                 {
 271                   const char *search_name = msymbol.minsym->search_name ();
 272                   wsym = lookup_symbol_search_name (search_name, NULL,
 273                                                     VAR_DOMAIN).symbol;
 274                 }
 275
 276               if (wsym)
 277                 {
 278                   wtype = SYMBOL_TYPE (wsym);
 279                 }
 280               else
 281                 {
 282                   wtype = TYPE_TARGET_TYPE (type);
 283                 }
 284               vt_val = value_at (wtype, vt_address);
 285               common_val_print (vt_val, stream, recurse + 1, options,
 286                                 current_language);
 287               if (options->prettyformat)
 288                 {
 289                   fprintf_filtered (stream, "\n");
 290                   print_spaces_filtered (2 + 2 * recurse, stream);
 291                 }
 292             }
 293         }
 294
 295       return;
 296
 297     case TYPE_CODE_REF:
 298     case TYPE_CODE_ENUM:
 299     case TYPE_CODE_FLAGS:
 300     case TYPE_CODE_FUNC:
 301     case TYPE_CODE_RANGE:
 302     case TYPE_CODE_INT:
 303     case TYPE_CODE_FLT:
 304     case TYPE_CODE_VOID:
 305     case TYPE_CODE_ERROR:
 306     case TYPE_CODE_UNDEF:
 307     case TYPE_CODE_BOOL:
 308     case TYPE_CODE_CHAR:
 309       generic_val_print (type, embedded_offset, address,
 310                          stream, recurse, original_value, options,
 311                          &p_decorations);
 312       break;
 313
 314     case TYPE_CODE_UNION:
 315       if (recurse && !options->unionprint)
 316         {
 317           fprintf_filtered (stream, "{...}");
 318           break;
 319         }
 320       /* Fall through.  */
 321     case TYPE_CODE_STRUCT:
 322       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 323         {
 324           /* Print the unmangled name if desired.  */
 325           /* Print vtable entry - we only get here if NOT using
 326              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
 327           /* Extract the address, assume that it is unsigned.  */
 328           print_address_demangle
 329             (options, gdbarch,
 330              extract_unsigned_integer (valaddr + embedded_offset
 331                                        + TYPE_FIELD_BITPOS (type,
 332                                                             VTBL_FNADDR_OFFSET) / 8,
 333                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type,
 334                                                                      VTBL_FNADDR_OFFSET)),
 335                                        byte_order),
 336              stream, demangle);
 337         }
 338       else
 339         {
 340           if (is_pascal_string_type (type, &length_pos, &length_size,
 341                                      &string_pos, &char_type, NULL))
 342             {
 343               len = extract_unsigned_integer (valaddr + embedded_offset
 344                                               + length_pos, length_size,
 345                                               byte_order);
 346               LA_PRINT_STRING (stream, char_type,
 347                                valaddr + embedded_offset + string_pos,
 348                                len, NULL, 0, options);
 349             }
 350           else
 351             pascal_object_print_value_fields (type, valaddr, embedded_offset,
 352                                               address, stream, recurse,
 353                                               original_value, options,
 354                                               NULL, 0);
 355         }
 356       break;
 357
 358     case TYPE_CODE_SET:
 359       elttype = TYPE_INDEX_TYPE (type);
 360       elttype = check_typedef (elttype);
 361       if (TYPE_STUB (elttype))
 362         {
 363           fprintf_styled (stream, metadata_style.style (), "<incomplete type>");
 364           break;
 365         }
 366       else
 367         {
 368           struct type *range = elttype;
 369           LONGEST low_bound, high_bound;
 370           int need_comma = 0;
 371
 372           fputs_filtered ("[", stream);
 373
 374           int bound_info = get_discrete_bounds (range, &low_bound, &high_bound);
 375           if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
 376             {
 377               /* If we know the size of the set type, we can figure out the
 378               maximum value.  */
 379               bound_info = 0;
 380               high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
 381               TYPE_HIGH_BOUND (range) = high_bound;
 382             }
 383         maybe_bad_bstring:
 384           if (bound_info < 0)
 385             {
 386               fputs_styled ("<error value>", metadata_style.style (), stream);
 387               goto done;
 388             }
 389
 390           for (i = low_bound; i <= high_bound; i++)
 391             {
 392               int element = value_bit_index (type,
 393                                              valaddr + embedded_offset, i);
 394
 395               if (element < 0)
 396                 {
 397                   i = element;
 398                   goto maybe_bad_bstring;
 399                 }
 400               if (element)
 401                 {
 402                   if (need_comma)
 403                     fputs_filtered (", ", stream);
 404                   print_type_scalar (range, i, stream);
 405                   need_comma = 1;
 406
 407                   if (i + 1 <= high_bound
 408                       && value_bit_index (type,
 409                                           valaddr + embedded_offset, ++i))
 410                     {
 411                       int j = i;
 412
 413                       fputs_filtered ("..", stream);
 414                       while (i + 1 <= high_bound
 415                              && value_bit_index (type,
 416                                                  valaddr + embedded_offset,
 417                                                  ++i))
 418                         j = i;
 419                       print_type_scalar (range, j, stream);
 420                     }
 421                 }
 422             }
 423         done:
 424           fputs_filtered ("]", stream);
 425         }
 426       break;
 427
 428     default:
 429       error (_("Invalid pascal type code %d in symbol table."),
 430              TYPE_CODE (type));
 431     }
 432 }
 433
 434 /* See p-lang.h.  */
 435
 436 void
 437 pascal_value_print_inner (struct value *val, struct ui_file *stream,
 438                           int recurse,
 439                           const struct value_print_options *options)
 440
 441 {
 442   struct type *type = check_typedef (value_type (val));
 443   struct gdbarch *gdbarch = get_type_arch (type);
 444   enum bfd_endian byte_order = type_byte_order (type);
 445   unsigned int i = 0;   /* Number of characters printed */
 446   unsigned len;
 447   struct type *elttype;
 448   unsigned eltlen;
 449   int length_pos, length_size, string_pos;
 450   struct type *char_type;
 451   CORE_ADDR addr;
 452   int want_space = 0;
 453   const gdb_byte *valaddr = value_contents_for_printing (val);
 454
 455   switch (TYPE_CODE (type))
 456     {
 457     case TYPE_CODE_ARRAY:
 458       {
 459         LONGEST low_bound, high_bound;
 460
 461         if (get_array_bounds (type, &low_bound, &high_bound))
 462           {
 463             len = high_bound - low_bound + 1;
 464             elttype = check_typedef (TYPE_TARGET_TYPE (type));
 465             eltlen = TYPE_LENGTH (elttype);
 466             if (options->prettyformat_arrays)
 467               {
 468                 print_spaces_filtered (2 + 2 * recurse, stream);
 469               }
 470             /* If 's' format is used, try to print out as string.
 471                If no format is given, print as string if element type
 472                is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
 473             if (options->format == 's'
 474                 || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
 475                     && TYPE_CODE (elttype) == TYPE_CODE_CHAR
 476                     && options->format == 0))
 477               {
 478                 /* If requested, look for the first null char and only print
 479                    elements up to it.  */
 480                 if (options->stop_print_at_null)
 481                   {
 482                     unsigned int temp_len;
 483
 484                     /* Look for a NULL char.  */
 485                     for (temp_len = 0;
 486                          extract_unsigned_integer (valaddr + temp_len * eltlen,
 487                                                    eltlen, byte_order)
 488                            && temp_len < len && temp_len < options->print_max;
 489                          temp_len++);
 490                     len = temp_len;
 491                   }
 492
 493                 LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
 494                                  valaddr, len, NULL, 0, options);
 495                 i = len;
 496               }
 497             else
 498               {
 499                 fprintf_filtered (stream, "{");
 500                 /* If this is a virtual function table, print the 0th
 501                    entry specially, and the rest of the members normally.  */
 502                 if (pascal_object_is_vtbl_ptr_type (elttype))
 503                   {
 504                     i = 1;
 505                     fprintf_filtered (stream, "%d vtable entries", len - 1);
 506                   }
 507                 else
 508                   {
 509                     i = 0;
 510                   }
 511                 value_print_array_elements (val, stream, recurse, options, i);
 512                 fprintf_filtered (stream, "}");
 513               }
 514             break;
 515           }
 516         /* Array of unspecified length: treat like pointer to first elt.  */
 517         addr = value_address (val);
 518       }
 519       goto print_unpacked_pointer;
 520
 521     case TYPE_CODE_PTR:
 522       if (options->format && options->format != 's')
 523         {
 524           value_print_scalar_formatted (val, options, 0, stream);
 525           break;
 526         }
 527       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 528         {
 529           /* Print the unmangled name if desired.  */
 530           /* Print vtable entry - we only get here if we ARE using
 531              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
 532           /* Extract the address, assume that it is unsigned.  */
 533           addr = extract_unsigned_integer (valaddr,
 534                                            TYPE_LENGTH (type), byte_order);
 535           print_address_demangle (options, gdbarch, addr, stream, demangle);
 536           break;
 537         }
 538       check_typedef (TYPE_TARGET_TYPE (type));
 539
 540       addr = unpack_pointer (type, valaddr);
 541     print_unpacked_pointer:
 542       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 543
 544       if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 545         {
 546           /* Try to print what function it points to.  */
 547           print_address_demangle (options, gdbarch, addr, stream, demangle);
 548           return;
 549         }
 550
 551       if (options->addressprint && options->format != 's')
 552         {
 553           fputs_filtered (paddress (gdbarch, addr), stream);
 554           want_space = 1;
 555         }
 556
 557       /* For a pointer to char or unsigned char, also print the string
 558          pointed to, unless pointer is null.  */
 559       if (((TYPE_LENGTH (elttype) == 1
 560            && (TYPE_CODE (elttype) == TYPE_CODE_INT
 561               || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 562           || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
 563               && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 564           && (options->format == 0 || options->format == 's')
 565           && addr != 0)
 566         {
 567           if (want_space)
 568             fputs_filtered (" ", stream);
 569           /* No wide string yet.  */
 570           i = val_print_string (elttype, NULL, addr, -1, stream, options);
 571         }
 572       /* Also for pointers to pascal strings.  */
 573       /* Note: this is Free Pascal specific:
 574          as GDB does not recognize stabs pascal strings
 575          Pascal strings are mapped to records
 576          with lowercase names PM.  */
 577       if (is_pascal_string_type (elttype, &length_pos, &length_size,
 578                                  &string_pos, &char_type, NULL)
 579           && addr != 0)
 580         {
 581           ULONGEST string_length;
 582           gdb_byte *buffer;
 583
 584           if (want_space)
 585             fputs_filtered (" ", stream);
 586           buffer = (gdb_byte *) xmalloc (length_size);
 587           read_memory (addr + length_pos, buffer, length_size);
 588           string_length = extract_unsigned_integer (buffer, length_size,
 589                                                     byte_order);
 590           xfree (buffer);
 591           i = val_print_string (char_type, NULL,
 592                                 addr + string_pos, string_length,
 593                                 stream, options);
 594         }
 595       else if (pascal_object_is_vtbl_member (type))
 596         {
 597           /* Print vtbl's nicely.  */
 598           CORE_ADDR vt_address = unpack_pointer (type, valaddr);
 599           struct bound_minimal_symbol msymbol =
 600             lookup_minimal_symbol_by_pc (vt_address);
 601
 602           /* If 'symbol_print' is set, we did the work above.  */
 603           if (!options->symbol_print
 604               && (msymbol.minsym != NULL)
 605               && (vt_address == BMSYMBOL_VALUE_ADDRESS (msymbol)))
 606             {
 607               if (want_space)
 608                 fputs_filtered (" ", stream);
 609               fputs_filtered ("<", stream);
 610               fputs_filtered (msymbol.minsym->print_name (), stream);
 611               fputs_filtered (">", stream);
 612               want_space = 1;
 613             }
 614           if (vt_address && options->vtblprint)
 615             {
 616               struct value *vt_val;
 617               struct symbol *wsym = NULL;
 618               struct type *wtype;
 619
 620               if (want_space)
 621                 fputs_filtered (" ", stream);
 622
 623               if (msymbol.minsym != NULL)
 624                 {
 625                   const char *search_name = msymbol.minsym->search_name ();
 626                   wsym = lookup_symbol_search_name (search_name, NULL,
 627                                                     VAR_DOMAIN).symbol;
 628                 }
 629
 630               if (wsym)
 631                 {
 632                   wtype = SYMBOL_TYPE (wsym);
 633                 }
 634               else
 635                 {
 636                   wtype = TYPE_TARGET_TYPE (type);
 637                 }
 638               vt_val = value_at (wtype, vt_address);
 639               common_val_print (vt_val, stream, recurse + 1, options,
 640                                 current_language);
 641               if (options->prettyformat)
 642                 {
 643                   fprintf_filtered (stream, "\n");
 644                   print_spaces_filtered (2 + 2 * recurse, stream);
 645                 }
 646             }
 647         }
 648
 649       return;
 650
 651     case TYPE_CODE_REF:
 652     case TYPE_CODE_ENUM:
 653     case TYPE_CODE_FLAGS:
 654     case TYPE_CODE_FUNC:
 655     case TYPE_CODE_RANGE:
 656     case TYPE_CODE_INT:
 657     case TYPE_CODE_FLT:
 658     case TYPE_CODE_VOID:
 659     case TYPE_CODE_ERROR:
 660     case TYPE_CODE_UNDEF:
 661     case TYPE_CODE_BOOL:
 662     case TYPE_CODE_CHAR:
 663       generic_value_print (val, stream, recurse, options, &p_decorations);
 664       break;
 665
 666     case TYPE_CODE_UNION:
 667       if (recurse && !options->unionprint)
 668         {
 669           fprintf_filtered (stream, "{...}");
 670           break;
 671         }
 672       /* Fall through.  */
 673     case TYPE_CODE_STRUCT:
 674       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 675         {
 676           /* Print the unmangled name if desired.  */
 677           /* Print vtable entry - we only get here if NOT using
 678              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
 679           /* Extract the address, assume that it is unsigned.  */
 680           print_address_demangle
 681             (options, gdbarch,
 682              extract_unsigned_integer (valaddr
 683                                        + TYPE_FIELD_BITPOS (type,
 684                                                             VTBL_FNADDR_OFFSET) / 8,
 685                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type,
 686                                                                      VTBL_FNADDR_OFFSET)),
 687                                        byte_order),
 688              stream, demangle);
 689         }
 690       else
 691         {
 692           if (is_pascal_string_type (type, &length_pos, &length_size,
 693                                      &string_pos, &char_type, NULL))
 694             {
 695               len = extract_unsigned_integer (valaddr + length_pos,
 696                                               length_size, byte_order);
 697               LA_PRINT_STRING (stream, char_type, valaddr + string_pos,
 698                                len, NULL, 0, options);
 699             }
 700           else
 701             pascal_object_print_value_fields (type, valaddr, 0,
 702                                               value_address (val), stream,
 703                                               recurse, val, options,
 704                                               NULL, 0);
 705         }
 706       break;
 707
 708     case TYPE_CODE_SET:
 709       elttype = TYPE_INDEX_TYPE (type);
 710       elttype = check_typedef (elttype);
 711       if (TYPE_STUB (elttype))
 712         {
 713           fprintf_styled (stream, metadata_style.style (), "<incomplete type>");
 714           break;
 715         }
 716       else
 717         {
 718           struct type *range = elttype;
 719           LONGEST low_bound, high_bound;
 720           int need_comma = 0;
 721
 722           fputs_filtered ("[", stream);
 723
 724           int bound_info = get_discrete_bounds (range, &low_bound, &high_bound);
 725           if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
 726             {
 727               /* If we know the size of the set type, we can figure out the
 728               maximum value.  */
 729               bound_info = 0;
 730               high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
 731               TYPE_HIGH_BOUND (range) = high_bound;
 732             }
 733         maybe_bad_bstring:
 734           if (bound_info < 0)
 735             {
 736               fputs_styled ("<error value>", metadata_style.style (), stream);
 737               goto done;
 738             }
 739
 740           for (i = low_bound; i <= high_bound; i++)
 741             {
 742               int element = value_bit_index (type, valaddr, i);
 743
 744               if (element < 0)
 745                 {
 746                   i = element;
 747                   goto maybe_bad_bstring;
 748                 }
 749               if (element)
 750                 {
 751                   if (need_comma)
 752                     fputs_filtered (", ", stream);
 753                   print_type_scalar (range, i, stream);
 754                   need_comma = 1;
 755
 756                   if (i + 1 <= high_bound
 757                       && value_bit_index (type, valaddr, ++i))
 758                     {
 759                       int j = i;
 760
 761                       fputs_filtered ("..", stream);
 762                       while (i + 1 <= high_bound
 763                              && value_bit_index (type, valaddr, ++i))
 764                         j = i;
 765                       print_type_scalar (range, j, stream);
 766                     }
 767                 }
 768             }
 769         done:
 770           fputs_filtered ("]", stream);
 771         }
 772       break;
 773
 774     default:
 775       error (_("Invalid pascal type code %d in symbol table."),
 776              TYPE_CODE (type));
 777     }
 778 }
 779
 780 \f
 781 void
 782 pascal_value_print (struct value *val, struct ui_file *stream,
 783                     const struct value_print_options *options)
 784 {
 785   struct type *type = value_type (val);
 786   struct value_print_options opts = *options;
 787
 788   opts.deref_ref = 1;
 789
 790   /* If it is a pointer, indicate what it points to.
 791
 792      Print type also if it is a reference.
 793
 794      Object pascal: if it is a member pointer, we will take care
 795      of that when we print it.  */
 796   if (TYPE_CODE (type) == TYPE_CODE_PTR
 797       || TYPE_CODE (type) == TYPE_CODE_REF)
 798     {
 799       /* Hack:  remove (char *) for char strings.  Their
 800          type is indicated by the quoted string anyway.  */
 801       if (TYPE_CODE (type) == TYPE_CODE_PTR
 802           && TYPE_NAME (type) == NULL
 803           && TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
 804           && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
 805         {
 806           /* Print nothing.  */
 807         }
 808       else
 809         {
 810           fprintf_filtered (stream, "(");
 811           type_print (type, "", stream, -1);
 812           fprintf_filtered (stream, ") ");
 813         }
 814     }
 815   common_val_print (val, stream, 0, &opts, current_language);
 816 }
 817
 818
 819 static void
 820 show_pascal_static_field_print (struct ui_file *file, int from_tty,
 821                                 struct cmd_list_element *c, const char *value)
 822 {
 823   fprintf_filtered (file, _("Printing of pascal static members is %s.\n"),
 824                     value);
 825 }
 826
 827 static struct obstack dont_print_vb_obstack;
 828 static struct obstack dont_print_statmem_obstack;
 829
 830 static void pascal_object_print_static_field (struct value *,
 831                                               struct ui_file *, int,
 832                                               const struct value_print_options *);
 833
 834 static void pascal_object_print_value (struct type *, const gdb_byte *,
 835                                        LONGEST,
 836                                        CORE_ADDR, struct ui_file *, int,
 837                                        struct value *,
 838                                        const struct value_print_options *,
 839                                        struct type **);
 840
 841 static void pascal_object_print_value (struct value *, struct ui_file *, int,
 842                                        const struct value_print_options *,
 843                                        struct type **);
 844
 845 /* It was changed to this after 2.4.5.  */
 846 const char pascal_vtbl_ptr_name[] =
 847 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 848
 849 /* Return truth value for assertion that TYPE is of the type
 850    "pointer to virtual function".  */
 851
 852 int
 853 pascal_object_is_vtbl_ptr_type (struct type *type)
 854 {
 855   const char *type_name = TYPE_NAME (type);
 856
 857   return (type_name != NULL
 858           && strcmp (type_name, pascal_vtbl_ptr_name) == 0);
 859 }
 860
 861 /* Return truth value for the assertion that TYPE is of the type
 862    "pointer to virtual function table".  */
 863
 864 int
 865 pascal_object_is_vtbl_member (struct type *type)
 866 {
 867   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 868     {
 869       type = TYPE_TARGET_TYPE (type);
 870       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 871         {
 872           type = TYPE_TARGET_TYPE (type);
 873           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* If not using
 874                                                            thunks.  */
 875               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* If using thunks.  */
 876             {
 877               /* Virtual functions tables are full of pointers
 878                  to virtual functions.  */
 879               return pascal_object_is_vtbl_ptr_type (type);
 880             }
 881         }
 882     }
 883   return 0;
 884 }
 885
 886 /* Mutually recursive subroutines of pascal_object_print_value and
 887    c_val_print to print out a structure's fields:
 888    pascal_object_print_value_fields and pascal_object_print_value.
 889
 890    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and OPTIONS have the
 891    same meanings as in pascal_object_print_value and c_val_print.
 892
 893    DONT_PRINT is an array of baseclass types that we
 894    should not print, or zero if called from top level.  */
 895
 896 static void
 897 pascal_object_print_value_fields (struct type *type, const gdb_byte *valaddr,
 898                                   LONGEST offset,
 899                                   CORE_ADDR address, struct ui_file *stream,
 900                                   int recurse,
 901                                   struct value *val,
 902                                   const struct value_print_options *options,
 903                                   struct type **dont_print_vb,
 904                                   int dont_print_statmem)
 905 {
 906   int i, len, n_baseclasses;
 907   char *last_dont_print
 908     = (char *) obstack_next_free (&dont_print_statmem_obstack);
 909
 910   type = check_typedef (type);
 911
 912   fprintf_filtered (stream, "{");
 913   len = TYPE_NFIELDS (type);
 914   n_baseclasses = TYPE_N_BASECLASSES (type);
 915
 916   /* Print out baseclasses such that we don't print
 917      duplicates of virtual baseclasses.  */
 918   if (n_baseclasses > 0)
 919     pascal_object_print_value (type, valaddr, offset, address,
 920                                stream, recurse + 1, val,
 921                                options, dont_print_vb);
 922
 923   if (!len && n_baseclasses == 1)
 924     fprintf_styled (stream, metadata_style.style (), "<No data fields>");
 925   else
 926     {
 927       struct obstack tmp_obstack = dont_print_statmem_obstack;
 928       int fields_seen = 0;
 929
 930       if (dont_print_statmem == 0)
 931         {
 932           /* If we're at top level, carve out a completely fresh
 933              chunk of the obstack and use that until this particular
 934              invocation returns.  */
 935           obstack_finish (&dont_print_statmem_obstack);
 936         }
 937
 938       for (i = n_baseclasses; i < len; i++)
 939         {
 940           /* If requested, skip printing of static fields.  */
 941           if (!options->pascal_static_field_print
 942               && field_is_static (&TYPE_FIELD (type, i)))
 943             continue;
 944           if (fields_seen)
 945             fprintf_filtered (stream, ", ");
 946           else if (n_baseclasses > 0)
 947             {
 948               if (options->prettyformat)
 949                 {
 950                   fprintf_filtered (stream, "\n");
 951                   print_spaces_filtered (2 + 2 * recurse, stream);
 952                   fputs_filtered ("members of ", stream);
 953                   fputs_filtered (TYPE_NAME (type), stream);
 954                   fputs_filtered (": ", stream);
 955                 }
 956             }
 957           fields_seen = 1;
 958
 959           if (options->prettyformat)
 960             {
 961               fprintf_filtered (stream, "\n");
 962               print_spaces_filtered (2 + 2 * recurse, stream);
 963             }
 964           else
 965             {
 966               wrap_here (n_spaces (2 + 2 * recurse));
 967             }
 968
 969           annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 970
 971           if (field_is_static (&TYPE_FIELD (type, i)))
 972             {
 973               fputs_filtered ("static ", stream);
 974               fprintf_symbol_filtered (stream,
 975                                        TYPE_FIELD_NAME (type, i),
 976                                        current_language->la_language,
 977                                        DMGL_PARAMS | DMGL_ANSI);
 978             }
 979           else
 980             fputs_styled (TYPE_FIELD_NAME (type, i),
 981                           variable_name_style.style (), stream);
 982           annotate_field_name_end ();
 983           fputs_filtered (" = ", stream);
 984           annotate_field_value ();
 985
 986           if (!field_is_static (&TYPE_FIELD (type, i))
 987               && TYPE_FIELD_PACKED (type, i))
 988             {
 989               struct value *v;
 990
 991               /* Bitfields require special handling, especially due to byte
 992                  order problems.  */
 993               if (TYPE_FIELD_IGNORE (type, i))
 994                 {
 995                   fputs_styled ("<optimized out or zero length>",
 996                                 metadata_style.style (), stream);
 997                 }
 998               else if (value_bits_synthetic_pointer (val,
 999                                                      TYPE_FIELD_BITPOS (type,
1000                                                                         i),
1001                                                      TYPE_FIELD_BITSIZE (type,
1002                                                                          i)))
1003                 {
1004                   fputs_styled (_("<synthetic pointer>"),
1005                                 metadata_style.style (), stream);
1006                 }
1007               else
1008                 {
1009                   struct value_print_options opts = *options;
1010
1011                   v = value_field_bitfield (type, i, valaddr, offset, val);
1012
1013                   opts.deref_ref = 0;
1014                   common_val_print (v, stream, recurse + 1, &opts,
1015                                     current_language);
1016                 }
1017             }
1018           else
1019             {
1020               if (TYPE_FIELD_IGNORE (type, i))
1021                 {
1022                   fputs_styled ("<optimized out or zero length>",
1023                                 metadata_style.style (), stream);
1024                 }
1025               else if (field_is_static (&TYPE_FIELD (type, i)))
1026                 {
1027                   /* struct value *v = value_static_field (type, i);
1028                      v4.17 specific.  */
1029                   struct value *v;
1030
1031                   v = value_field_bitfield (type, i, valaddr, offset, val);
1032
1033                   if (v == NULL)
1034                     val_print_optimized_out (NULL, stream);
1035                   else
1036                     pascal_object_print_static_field (v, stream, recurse + 1,
1037                                                       options);
1038                 }
1039               else
1040                 {
1041                   struct value_print_options opts = *options;
1042
1043                   opts.deref_ref = 0;
1044                   /* val_print (TYPE_FIELD_TYPE (type, i),
1045                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
1046                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
1047                      stream, format, 0, recurse + 1, pretty); */
1048                   val_print (TYPE_FIELD_TYPE (type, i),
1049                              offset + TYPE_FIELD_BITPOS (type, i) / 8,
1050                              address, stream, recurse + 1, val, &opts,
1051                              current_language);
1052                 }
1053             }
1054           annotate_field_end ();
1055         }
1056
1057       if (dont_print_statmem == 0)
1058         {
1059           /* Free the space used to deal with the printing
1060              of the members from top level.  */
1061           obstack_free (&dont_print_statmem_obstack, last_dont_print);
1062           dont_print_statmem_obstack = tmp_obstack;
1063         }
1064
1065       if (options->prettyformat)
1066         {
1067           fprintf_filtered (stream, "\n");
1068           print_spaces_filtered (2 * recurse, stream);
1069         }
1070     }
1071   fprintf_filtered (stream, "}");
1072 }
1073
1074 /* Mutually recursive subroutines of pascal_object_print_value and
1075    pascal_value_print to print out a structure's fields:
1076    pascal_object_print_value_fields and pascal_object_print_value.
1077
1078    VAL, STREAM, RECURSE, and OPTIONS have the same meanings as in
1079    pascal_object_print_value and c_value_print.
1080
1081    DONT_PRINT is an array of baseclass types that we
1082    should not print, or zero if called from top level.  */
1083
1084 static void
1085 pascal_object_print_value_fields (struct value *val, struct ui_file *stream,
1086                                   int recurse,
1087                                   const struct value_print_options *options,
1088                                   struct type **dont_print_vb,
1089                                   int dont_print_statmem)
1090 {
1091   int i, len, n_baseclasses;
1092   char *last_dont_print
1093     = (char *) obstack_next_free (&dont_print_statmem_obstack);
1094
1095   struct type *type = check_typedef (value_type (val));
1096
1097   fprintf_filtered (stream, "{");
1098   len = TYPE_NFIELDS (type);
1099   n_baseclasses = TYPE_N_BASECLASSES (type);
1100
1101   /* Print out baseclasses such that we don't print
1102      duplicates of virtual baseclasses.  */
1103   if (n_baseclasses > 0)
1104     pascal_object_print_value (val, stream, recurse + 1,
1105                                options, dont_print_vb);
1106
1107   if (!len && n_baseclasses == 1)
1108     fprintf_styled (stream, metadata_style.style (), "<No data fields>");
1109   else
1110     {
1111       struct obstack tmp_obstack = dont_print_statmem_obstack;
1112       int fields_seen = 0;
1113       const gdb_byte *valaddr = value_contents_for_printing (val);
1114
1115       if (dont_print_statmem == 0)
1116         {
1117           /* If we're at top level, carve out a completely fresh
1118              chunk of the obstack and use that until this particular
1119              invocation returns.  */
1120           obstack_finish (&dont_print_statmem_obstack);
1121         }
1122
1123       for (i = n_baseclasses; i < len; i++)
1124         {
1125           /* If requested, skip printing of static fields.  */
1126           if (!options->pascal_static_field_print
1127               && field_is_static (&TYPE_FIELD (type, i)))
1128             continue;
1129           if (fields_seen)
1130             fprintf_filtered (stream, ", ");
1131           else if (n_baseclasses > 0)
1132             {
1133               if (options->prettyformat)
1134                 {
1135                   fprintf_filtered (stream, "\n");
1136                   print_spaces_filtered (2 + 2 * recurse, stream);
1137                   fputs_filtered ("members of ", stream);
1138                   fputs_filtered (TYPE_NAME (type), stream);
1139                   fputs_filtered (": ", stream);
1140                 }
1141             }
1142           fields_seen = 1;
1143
1144           if (options->prettyformat)
1145             {
1146               fprintf_filtered (stream, "\n");
1147               print_spaces_filtered (2 + 2 * recurse, stream);
1148             }
1149           else
1150             {
1151               wrap_here (n_spaces (2 + 2 * recurse));
1152             }
1153
1154           annotate_field_begin (TYPE_FIELD_TYPE (type, i));
1155
1156           if (field_is_static (&TYPE_FIELD (type, i)))
1157             {
1158               fputs_filtered ("static ", stream);
1159               fprintf_symbol_filtered (stream,
1160                                        TYPE_FIELD_NAME (type, i),
1161                                        current_language->la_language,
1162                                        DMGL_PARAMS | DMGL_ANSI);
1163             }
1164           else
1165             fputs_styled (TYPE_FIELD_NAME (type, i),
1166                           variable_name_style.style (), stream);
1167           annotate_field_name_end ();
1168           fputs_filtered (" = ", stream);
1169           annotate_field_value ();
1170
1171           if (!field_is_static (&TYPE_FIELD (type, i))
1172               && TYPE_FIELD_PACKED (type, i))
1173             {
1174               struct value *v;
1175
1176               /* Bitfields require special handling, especially due to byte
1177                  order problems.  */
1178               if (TYPE_FIELD_IGNORE (type, i))
1179                 {
1180                   fputs_styled ("<optimized out or zero length>",
1181                                 metadata_style.style (), stream);
1182                 }
1183               else if (value_bits_synthetic_pointer (val,
1184                                                      TYPE_FIELD_BITPOS (type,
1185                                                                         i),
1186                                                      TYPE_FIELD_BITSIZE (type,
1187                                                                          i)))
1188                 {
1189                   fputs_styled (_("<synthetic pointer>"),
1190                                 metadata_style.style (), stream);
1191                 }
1192               else
1193                 {
1194                   struct value_print_options opts = *options;
1195
1196                   v = value_field_bitfield (type, i, valaddr, 0, val);
1197
1198                   opts.deref_ref = 0;
1199                   common_val_print (v, stream, recurse + 1, &opts,
1200                                     current_language);
1201                 }
1202             }
1203           else
1204             {
1205               if (TYPE_FIELD_IGNORE (type, i))
1206                 {
1207                   fputs_styled ("<optimized out or zero length>",
1208                                 metadata_style.style (), stream);
1209                 }
1210               else if (field_is_static (&TYPE_FIELD (type, i)))
1211                 {
1212                   /* struct value *v = value_static_field (type, i);
1213                      v4.17 specific.  */
1214                   struct value *v;
1215
1216                   v = value_field_bitfield (type, i, valaddr, 0, val);
1217
1218                   if (v == NULL)
1219                     val_print_optimized_out (NULL, stream);
1220                   else
1221                     pascal_object_print_static_field (v, stream, recurse + 1,
1222                                                       options);
1223                 }
1224               else
1225                 {
1226                   struct value_print_options opts = *options;
1227
1228                   opts.deref_ref = 0;
1229
1230                   struct value *v = value_primitive_field (val, 0, i,
1231                                                            value_type (val));
1232                   common_val_print (v, stream, recurse + 1, &opts,
1233                                     current_language);
1234                 }
1235             }
1236           annotate_field_end ();
1237         }
1238
1239       if (dont_print_statmem == 0)
1240         {
1241           /* Free the space used to deal with the printing
1242              of the members from top level.  */
1243           obstack_free (&dont_print_statmem_obstack, last_dont_print);
1244           dont_print_statmem_obstack = tmp_obstack;
1245         }
1246
1247       if (options->prettyformat)
1248         {
1249           fprintf_filtered (stream, "\n");
1250           print_spaces_filtered (2 * recurse, stream);
1251         }
1252     }
1253   fprintf_filtered (stream, "}");
1254 }
1255
1256 /* Special val_print routine to avoid printing multiple copies of virtual
1257    baseclasses.  */
1258
1259 static void
1260 pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
1261                            LONGEST offset,
1262                            CORE_ADDR address, struct ui_file *stream,
1263                            int recurse,
1264                            struct value *val,
1265                            const struct value_print_options *options,
1266                            struct type **dont_print_vb)
1267 {
1268   struct type **last_dont_print
1269     = (struct type **) obstack_next_free (&dont_print_vb_obstack);
1270   struct obstack tmp_obstack = dont_print_vb_obstack;
1271   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
1272
1273   if (dont_print_vb == 0)
1274     {
1275       /* If we're at top level, carve out a completely fresh
1276          chunk of the obstack and use that until this particular
1277          invocation returns.  */
1278       /* Bump up the high-water mark.  Now alpha is omega.  */
1279       obstack_finish (&dont_print_vb_obstack);
1280     }
1281
1282   for (i = 0; i < n_baseclasses; i++)
1283     {
1284       LONGEST boffset = 0;
1285       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
1286       const char *basename = TYPE_NAME (baseclass);
1287       const gdb_byte *base_valaddr = NULL;
1288       LONGEST thisoffset;
1289       int skip = 0;
1290       gdb::byte_vector buf;
1291
1292       if (BASETYPE_VIA_VIRTUAL (type, i))
1293         {
1294           struct type **first_dont_print
1295             = (struct type **) obstack_base (&dont_print_vb_obstack);
1296
1297           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
1298             - first_dont_print;
1299
1300           while (--j >= 0)
1301             if (baseclass == first_dont_print[j])
1302               goto flush_it;
1303
1304           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
1305         }
1306
1307       thisoffset = offset;
1308
1309       try
1310         {
1311           boffset = baseclass_offset (type, i, valaddr, offset, address, val);
1312         }
1313       catch (const gdb_exception_error &ex)
1314         {
1315           if (ex.error == NOT_AVAILABLE_ERROR)
1316             skip = -1;
1317           else
1318             skip = 1;
1319         }
1320
1321       if (skip == 0)
1322         {
1323           /* The virtual base class pointer might have been clobbered by the
1324              user program. Make sure that it still points to a valid memory
1325              location.  */
1326
1327           if (boffset < 0 || boffset >= TYPE_LENGTH (type))
1328             {
1329               buf.resize (TYPE_LENGTH (baseclass));
1330
1331               base_valaddr = buf.data ();
1332               if (target_read_memory (address + boffset, buf.data (),
1333                                       TYPE_LENGTH (baseclass)) != 0)
1334                 skip = 1;
1335               address = address + boffset;
1336               thisoffset = 0;
1337               boffset = 0;
1338             }
1339           else
1340             base_valaddr = valaddr;
1341         }
1342
1343       if (options->prettyformat)
1344         {
1345           fprintf_filtered (stream, "\n");
1346           print_spaces_filtered (2 * recurse, stream);
1347         }
1348       fputs_filtered ("<", stream);
1349       /* Not sure what the best notation is in the case where there is no
1350          baseclass name.  */
1351
1352       fputs_filtered (basename ? basename : "", stream);
1353       fputs_filtered ("> = ", stream);
1354
1355       if (skip < 0)
1356         val_print_unavailable (stream);
1357       else if (skip > 0)
1358         val_print_invalid_address (stream);
1359       else
1360         pascal_object_print_value_fields (baseclass, base_valaddr,
1361                                           thisoffset + boffset, address,
1362                                           stream, recurse, val, options,
1363                      (struct type **) obstack_base (&dont_print_vb_obstack),
1364                                           0);
1365       fputs_filtered (", ", stream);
1366
1367     flush_it:
1368       ;
1369     }
1370
1371   if (dont_print_vb == 0)
1372     {
1373       /* Free the space used to deal with the printing
1374          of this type from top level.  */
1375       obstack_free (&dont_print_vb_obstack, last_dont_print);
1376       /* Reset watermark so that we can continue protecting
1377          ourselves from whatever we were protecting ourselves.  */
1378       dont_print_vb_obstack = tmp_obstack;
1379     }
1380 }
1381
1382 /* Special val_print routine to avoid printing multiple copies of virtual
1383    baseclasses.  */
1384
1385 static void
1386 pascal_object_print_value (struct value *val, struct ui_file *stream,
1387                            int recurse,
1388                            const struct value_print_options *options,
1389                            struct type **dont_print_vb)
1390 {
1391   struct type **last_dont_print
1392     = (struct type **) obstack_next_free (&dont_print_vb_obstack);
1393   struct obstack tmp_obstack = dont_print_vb_obstack;
1394   struct type *type = check_typedef (value_type (val));
1395   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
1396
1397   if (dont_print_vb == 0)
1398     {
1399       /* If we're at top level, carve out a completely fresh
1400          chunk of the obstack and use that until this particular
1401          invocation returns.  */
1402       /* Bump up the high-water mark.  Now alpha is omega.  */
1403       obstack_finish (&dont_print_vb_obstack);
1404     }
1405
1406   for (i = 0; i < n_baseclasses; i++)
1407     {
1408       LONGEST boffset = 0;
1409       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
1410       const char *basename = TYPE_NAME (baseclass);
1411       int skip = 0;
1412
1413       if (BASETYPE_VIA_VIRTUAL (type, i))
1414         {
1415           struct type **first_dont_print
1416             = (struct type **) obstack_base (&dont_print_vb_obstack);
1417
1418           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
1419             - first_dont_print;
1420
1421           while (--j >= 0)
1422             if (baseclass == first_dont_print[j])
1423               goto flush_it;
1424
1425           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
1426         }
1427
1428       struct value *base_value;
1429       try
1430         {
1431           base_value = value_primitive_field (val, 0, i, type);
1432         }
1433       catch (const gdb_exception_error &ex)
1434         {
1435           if (ex.error == NOT_AVAILABLE_ERROR)
1436             skip = -1;
1437           else
1438             skip = 1;
1439         }
1440
1441       if (skip == 0)
1442         {
1443           /* The virtual base class pointer might have been clobbered by the
1444              user program. Make sure that it still points to a valid memory
1445              location.  */
1446
1447           if (boffset < 0 || boffset >= TYPE_LENGTH (type))
1448             {
1449               CORE_ADDR address= value_address (val);
1450               gdb::byte_vector buf (TYPE_LENGTH (baseclass));
1451
1452               if (target_read_memory (address + boffset, buf.data (),
1453                                       TYPE_LENGTH (baseclass)) != 0)
1454                 skip = 1;
1455               base_value = value_from_contents_and_address (baseclass,
1456                                                             buf.data (),
1457                                                             address + boffset);
1458               baseclass = value_type (base_value);
1459               boffset = 0;
1460             }
1461         }
1462
1463       if (options->prettyformat)
1464         {
1465           fprintf_filtered (stream, "\n");
1466           print_spaces_filtered (2 * recurse, stream);
1467         }
1468       fputs_filtered ("<", stream);
1469       /* Not sure what the best notation is in the case where there is no
1470          baseclass name.  */
1471
1472       fputs_filtered (basename ? basename : "", stream);
1473       fputs_filtered ("> = ", stream);
1474
1475       if (skip < 0)
1476         val_print_unavailable (stream);
1477       else if (skip > 0)
1478         val_print_invalid_address (stream);
1479       else
1480         pascal_object_print_value_fields
1481           (base_value, stream, recurse, options,
1482            (struct type **) obstack_base (&dont_print_vb_obstack),
1483            0);
1484       fputs_filtered (", ", stream);
1485
1486     flush_it:
1487       ;
1488     }
1489
1490   if (dont_print_vb == 0)
1491     {
1492       /* Free the space used to deal with the printing
1493          of this type from top level.  */
1494       obstack_free (&dont_print_vb_obstack, last_dont_print);
1495       /* Reset watermark so that we can continue protecting
1496          ourselves from whatever we were protecting ourselves.  */
1497       dont_print_vb_obstack = tmp_obstack;
1498     }
1499 }
1500
1501 /* Print value of a static member.
1502    To avoid infinite recursion when printing a class that contains
1503    a static instance of the class, we keep the addresses of all printed
1504    static member classes in an obstack and refuse to print them more
1505    than once.
1506
1507    VAL contains the value to print, STREAM, RECURSE, and OPTIONS
1508    have the same meanings as in c_val_print.  */
1509
1510 static void
1511 pascal_object_print_static_field (struct value *val,
1512                                   struct ui_file *stream,
1513                                   int recurse,
1514                                   const struct value_print_options *options)
1515 {
1516   struct type *type = value_type (val);
1517   struct value_print_options opts;
1518
1519   if (value_entirely_optimized_out (val))
1520     {
1521       val_print_optimized_out (val, stream);
1522       return;
1523     }
1524
1525   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1526     {
1527       CORE_ADDR *first_dont_print, addr;
1528       int i;
1529
1530       first_dont_print
1531         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1532       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1533         - first_dont_print;
1534
1535       while (--i >= 0)
1536         {
1537           if (value_address (val) == first_dont_print[i])
1538             {
1539               fputs_styled (_("\
1540 <same as static member of an already seen type>"),
1541                             metadata_style.style (), stream);
1542               return;
1543             }
1544         }
1545
1546       addr = value_address (val);
1547       obstack_grow (&dont_print_statmem_obstack, (char *) &addr,
1548                     sizeof (CORE_ADDR));
1549
1550       type = check_typedef (type);
1551       pascal_object_print_value_fields (type,
1552                                         value_contents_for_printing (val),
1553                                         value_embedded_offset (val),
1554                                         addr,
1555                                         stream, recurse,
1556                                         val, options, NULL, 1);
1557       return;
1558     }
1559
1560   opts = *options;
1561   opts.deref_ref = 0;
1562   common_val_print (val, stream, recurse, &opts, current_language);
1563 }
1564
1565 void _initialize_pascal_valprint ();
1566 void
1567 _initialize_pascal_valprint ()
1568 {
1569   add_setshow_boolean_cmd ("pascal_static-members", class_support,
1570                            &user_print_options.pascal_static_field_print, _("\
1571 Set printing of pascal static members."), _("\
1572 Show printing of pascal static members."), NULL,
1573                            NULL,
1574                            show_pascal_static_field_print,
1575                            &setprintlist, &showprintlist);
1576 }