gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000-2023 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 "gdbsupport/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 value *, struct ui_file *,
  46                                               int,
  47                                               const struct value_print_options *,
  48                                               struct type **, int);
  49
  50 /* Decorations for Pascal.  */
  51
  52 static const struct generic_val_print_decorations p_decorations =
  53 {
  54   "",
  55   " + ",
  56   " * I",
  57   "true",
  58   "false",
  59   "void",
  60   "{",
  61   "}"
  62 };
  63
  64 /* See p-lang.h.  */
  65
  66 void
  67 pascal_language::value_print_inner (struct value *val,
  68                                     struct ui_file *stream, int recurse,
  69                                     const struct value_print_options *options) const
  70
  71 {
  72   struct type *type = check_typedef (value_type (val));
  73   struct gdbarch *gdbarch = type->arch ();
  74   enum bfd_endian byte_order = type_byte_order (type);
  75   unsigned int i = 0;   /* Number of characters printed */
  76   unsigned len;
  77   struct type *elttype;
  78   unsigned eltlen;
  79   int length_pos, length_size, string_pos;
  80   struct type *char_type;
  81   CORE_ADDR addr;
  82   int want_space = 0;
  83   const gdb_byte *valaddr = value_contents_for_printing (val).data ();
  84
  85   switch (type->code ())
  86     {
  87     case TYPE_CODE_ARRAY:
  88       {
  89         LONGEST low_bound, high_bound;
  90
  91         if (get_array_bounds (type, &low_bound, &high_bound))
  92           {
  93             len = high_bound - low_bound + 1;
  94             elttype = check_typedef (type->target_type ());
  95             eltlen = elttype->length ();
  96             /* If 's' format is used, try to print out as string.
  97                If no format is given, print as string if element type
  98                is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
  99             if (options->format == 's'
 100                 || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
 101                     && elttype->code () == TYPE_CODE_CHAR
 102                     && options->format == 0))
 103               {
 104                 /* If requested, look for the first null char and only print
 105                    elements up to it.  */
 106                 if (options->stop_print_at_null)
 107                   {
 108                     unsigned int temp_len;
 109
 110                     /* Look for a NULL char.  */
 111                     for (temp_len = 0;
 112                          extract_unsigned_integer (valaddr + temp_len * eltlen,
 113                                                    eltlen, byte_order)
 114                            && temp_len < len && temp_len < options->print_max;
 115                          temp_len++);
 116                     len = temp_len;
 117                   }
 118
 119                 printstr (stream, type->target_type (), valaddr, len,
 120                           NULL, 0, options);
 121                 i = len;
 122               }
 123             else
 124               {
 125                 gdb_printf (stream, "{");
 126                 /* If this is a virtual function table, print the 0th
 127                    entry specially, and the rest of the members normally.  */
 128                 if (pascal_object_is_vtbl_ptr_type (elttype))
 129                   {
 130                     i = 1;
 131                     gdb_printf (stream, "%d vtable entries", len - 1);
 132                   }
 133                 else
 134                   {
 135                     i = 0;
 136                   }
 137                 value_print_array_elements (val, stream, recurse, options, i);
 138                 gdb_printf (stream, "}");
 139               }
 140             break;
 141           }
 142         /* Array of unspecified length: treat like pointer to first elt.  */
 143         addr = value_address (val);
 144       }
 145       goto print_unpacked_pointer;
 146
 147     case TYPE_CODE_PTR:
 148       if (options->format && options->format != 's')
 149         {
 150           value_print_scalar_formatted (val, options, 0, stream);
 151           break;
 152         }
 153       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 154         {
 155           /* Print the unmangled name if desired.  */
 156           /* Print vtable entry - we only get here if we ARE using
 157              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
 158           /* Extract the address, assume that it is unsigned.  */
 159           addr = extract_unsigned_integer (valaddr,
 160                                            type->length (), byte_order);
 161           print_address_demangle (options, gdbarch, addr, stream, demangle);
 162           break;
 163         }
 164       check_typedef (type->target_type ());
 165
 166       addr = unpack_pointer (type, valaddr);
 167     print_unpacked_pointer:
 168       elttype = check_typedef (type->target_type ());
 169
 170       if (elttype->code () == TYPE_CODE_FUNC)
 171         {
 172           /* Try to print what function it points to.  */
 173           print_address_demangle (options, gdbarch, addr, stream, demangle);
 174           return;
 175         }
 176
 177       if (options->addressprint && options->format != 's')
 178         {
 179           gdb_puts (paddress (gdbarch, addr), stream);
 180           want_space = 1;
 181         }
 182
 183       /* For a pointer to char or unsigned char, also print the string
 184          pointed to, unless pointer is null.  */
 185       if (((elttype->length () == 1
 186            && (elttype->code () == TYPE_CODE_INT
 187                || elttype->code () == TYPE_CODE_CHAR))
 188            || ((elttype->length () == 2 || elttype->length () == 4)
 189                && elttype->code () == TYPE_CODE_CHAR))
 190           && (options->format == 0 || options->format == 's')
 191           && addr != 0)
 192         {
 193           if (want_space)
 194             gdb_puts (" ", stream);
 195           /* No wide string yet.  */
 196           i = val_print_string (elttype, NULL, addr, -1, stream, options);
 197         }
 198       /* Also for pointers to pascal strings.  */
 199       /* Note: this is Free Pascal specific:
 200          as GDB does not recognize stabs pascal strings
 201          Pascal strings are mapped to records
 202          with lowercase names PM.  */
 203       if (pascal_is_string_type (elttype, &length_pos, &length_size,
 204                                  &string_pos, &char_type, NULL) > 0
 205           && addr != 0)
 206         {
 207           ULONGEST string_length;
 208           gdb_byte *buffer;
 209
 210           if (want_space)
 211             gdb_puts (" ", stream);
 212           buffer = (gdb_byte *) xmalloc (length_size);
 213           read_memory (addr + length_pos, buffer, length_size);
 214           string_length = extract_unsigned_integer (buffer, length_size,
 215                                                     byte_order);
 216           xfree (buffer);
 217           i = val_print_string (char_type, NULL,
 218                                 addr + string_pos, string_length,
 219                                 stream, options);
 220         }
 221       else if (pascal_object_is_vtbl_member (type))
 222         {
 223           /* Print vtbl's nicely.  */
 224           CORE_ADDR vt_address = unpack_pointer (type, valaddr);
 225           struct bound_minimal_symbol msymbol =
 226             lookup_minimal_symbol_by_pc (vt_address);
 227
 228           /* If 'symbol_print' is set, we did the work above.  */
 229           if (!options->symbol_print
 230               && (msymbol.minsym != NULL)
 231               && (vt_address == msymbol.value_address ()))
 232             {
 233               if (want_space)
 234                 gdb_puts (" ", stream);
 235               gdb_puts ("<", stream);
 236               gdb_puts (msymbol.minsym->print_name (), stream);
 237               gdb_puts (">", stream);
 238               want_space = 1;
 239             }
 240           if (vt_address && options->vtblprint)
 241             {
 242               struct value *vt_val;
 243               struct symbol *wsym = NULL;
 244               struct type *wtype;
 245
 246               if (want_space)
 247                 gdb_puts (" ", stream);
 248
 249               if (msymbol.minsym != NULL)
 250                 {
 251                   const char *search_name = msymbol.minsym->search_name ();
 252                   wsym = lookup_symbol_search_name (search_name, NULL,
 253                                                     VAR_DOMAIN).symbol;
 254                 }
 255
 256               if (wsym)
 257                 {
 258                   wtype = wsym->type ();
 259                 }
 260               else
 261                 {
 262                   wtype = type->target_type ();
 263                 }
 264               vt_val = value_at (wtype, vt_address);
 265               common_val_print (vt_val, stream, recurse + 1, options,
 266                                 current_language);
 267               if (options->prettyformat)
 268                 {
 269                   gdb_printf (stream, "\n");
 270                   print_spaces (2 + 2 * recurse, stream);
 271                 }
 272             }
 273         }
 274
 275       return;
 276
 277     case TYPE_CODE_REF:
 278     case TYPE_CODE_ENUM:
 279     case TYPE_CODE_FLAGS:
 280     case TYPE_CODE_FUNC:
 281     case TYPE_CODE_RANGE:
 282     case TYPE_CODE_INT:
 283     case TYPE_CODE_FLT:
 284     case TYPE_CODE_VOID:
 285     case TYPE_CODE_ERROR:
 286     case TYPE_CODE_UNDEF:
 287     case TYPE_CODE_BOOL:
 288     case TYPE_CODE_CHAR:
 289       generic_value_print (val, stream, recurse, options, &p_decorations);
 290       break;
 291
 292     case TYPE_CODE_UNION:
 293       if (recurse && !options->unionprint)
 294         {
 295           gdb_printf (stream, "{...}");
 296           break;
 297         }
 298       /* Fall through.  */
 299     case TYPE_CODE_STRUCT:
 300       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 301         {
 302           /* Print the unmangled name if desired.  */
 303           /* Print vtable entry - we only get here if NOT using
 304              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
 305           /* Extract the address, assume that it is unsigned.  */
 306           print_address_demangle
 307             (options, gdbarch,
 308              extract_unsigned_integer
 309                (valaddr + type->field (VTBL_FNADDR_OFFSET).loc_bitpos () / 8,
 310                 type->field (VTBL_FNADDR_OFFSET).type ()->length (),
 311                 byte_order),
 312              stream, demangle);
 313         }
 314       else
 315         {
 316           if (pascal_is_string_type (type, &length_pos, &length_size,
 317                                      &string_pos, &char_type, NULL) > 0)
 318             {
 319               len = extract_unsigned_integer (valaddr + length_pos,
 320                                               length_size, byte_order);
 321               printstr (stream, char_type, valaddr + string_pos, len,
 322                         NULL, 0, options);
 323             }
 324           else
 325             pascal_object_print_value_fields (val, stream, recurse,
 326                                               options, NULL, 0);
 327         }
 328       break;
 329
 330     case TYPE_CODE_SET:
 331       elttype = type->index_type ();
 332       elttype = check_typedef (elttype);
 333       if (elttype->is_stub ())
 334         {
 335           fprintf_styled (stream, metadata_style.style (), "<incomplete type>");
 336           break;
 337         }
 338       else
 339         {
 340           struct type *range = elttype;
 341           LONGEST low_bound, high_bound;
 342           int need_comma = 0;
 343
 344           gdb_puts ("[", stream);
 345
 346           int bound_info = (get_discrete_bounds (range, &low_bound, &high_bound)
 347                             ? 0 : -1);
 348           if (low_bound == 0 && high_bound == -1 && type->length () > 0)
 349             {
 350               /* If we know the size of the set type, we can figure out the
 351               maximum value.  */
 352               bound_info = 0;
 353               high_bound = type->length () * TARGET_CHAR_BIT - 1;
 354               range->bounds ()->high.set_const_val (high_bound);
 355             }
 356         maybe_bad_bstring:
 357           if (bound_info < 0)
 358             {
 359               fputs_styled ("<error value>", metadata_style.style (), stream);
 360               goto done;
 361             }
 362
 363           for (i = low_bound; i <= high_bound; i++)
 364             {
 365               int element = value_bit_index (type, valaddr, i);
 366
 367               if (element < 0)
 368                 {
 369                   i = element;
 370                   goto maybe_bad_bstring;
 371                 }
 372               if (element)
 373                 {
 374                   if (need_comma)
 375                     gdb_puts (", ", stream);
 376                   print_type_scalar (range, i, stream);
 377                   need_comma = 1;
 378
 379                   if (i + 1 <= high_bound
 380                       && value_bit_index (type, valaddr, ++i))
 381                     {
 382                       int j = i;
 383
 384                       gdb_puts ("..", stream);
 385                       while (i + 1 <= high_bound
 386                              && value_bit_index (type, valaddr, ++i))
 387                         j = i;
 388                       print_type_scalar (range, j, stream);
 389                     }
 390                 }
 391             }
 392         done:
 393           gdb_puts ("]", stream);
 394         }
 395       break;
 396
 397     default:
 398       error (_("Invalid pascal type code %d in symbol table."),
 399              type->code ());
 400     }
 401 }
 402
 403 \f
 404 void
 405 pascal_language::value_print (struct value *val, struct ui_file *stream,
 406                               const struct value_print_options *options) const
 407 {
 408   struct type *type = value_type (val);
 409   struct value_print_options opts = *options;
 410
 411   opts.deref_ref = 1;
 412
 413   /* If it is a pointer, indicate what it points to.
 414
 415      Print type also if it is a reference.
 416
 417      Object pascal: if it is a member pointer, we will take care
 418      of that when we print it.  */
 419   if (type->code () == TYPE_CODE_PTR
 420       || type->code () == TYPE_CODE_REF)
 421     {
 422       /* Hack:  remove (char *) for char strings.  Their
 423          type is indicated by the quoted string anyway.  */
 424       if (type->code () == TYPE_CODE_PTR
 425           && type->name () == NULL
 426           && type->target_type ()->name () != NULL
 427           && strcmp (type->target_type ()->name (), "char") == 0)
 428         {
 429           /* Print nothing.  */
 430         }
 431       else
 432         {
 433           gdb_printf (stream, "(");
 434           type_print (type, "", stream, -1);
 435           gdb_printf (stream, ") ");
 436         }
 437     }
 438   common_val_print (val, stream, 0, &opts, current_language);
 439 }
 440
 441
 442 static void
 443 show_pascal_static_field_print (struct ui_file *file, int from_tty,
 444                                 struct cmd_list_element *c, const char *value)
 445 {
 446   gdb_printf (file, _("Printing of pascal static members is %s.\n"),
 447               value);
 448 }
 449
 450 static struct obstack dont_print_vb_obstack;
 451 static struct obstack dont_print_statmem_obstack;
 452
 453 static void pascal_object_print_static_field (struct value *,
 454                                               struct ui_file *, int,
 455                                               const struct value_print_options *);
 456
 457 static void pascal_object_print_value (struct value *, struct ui_file *, int,
 458                                        const struct value_print_options *,
 459                                        struct type **);
 460
 461 /* It was changed to this after 2.4.5.  */
 462 const char pascal_vtbl_ptr_name[] =
 463 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 464
 465 /* Return truth value for assertion that TYPE is of the type
 466    "pointer to virtual function".  */
 467
 468 int
 469 pascal_object_is_vtbl_ptr_type (struct type *type)
 470 {
 471   const char *type_name = type->name ();
 472
 473   return (type_name != NULL
 474           && strcmp (type_name, pascal_vtbl_ptr_name) == 0);
 475 }
 476
 477 /* Return truth value for the assertion that TYPE is of the type
 478    "pointer to virtual function table".  */
 479
 480 int
 481 pascal_object_is_vtbl_member (struct type *type)
 482 {
 483   if (type->code () == TYPE_CODE_PTR)
 484     {
 485       type = type->target_type ();
 486       if (type->code () == TYPE_CODE_ARRAY)
 487         {
 488           type = type->target_type ();
 489           if (type->code () == TYPE_CODE_STRUCT /* If not using
 490                                                            thunks.  */
 491               || type->code () == TYPE_CODE_PTR)        /* If using thunks.  */
 492             {
 493               /* Virtual functions tables are full of pointers
 494                  to virtual functions.  */
 495               return pascal_object_is_vtbl_ptr_type (type);
 496             }
 497         }
 498     }
 499   return 0;
 500 }
 501
 502 /* Helper function for print pascal objects.
 503
 504    VAL, STREAM, RECURSE, and OPTIONS have the same meanings as in
 505    pascal_object_print_value and c_value_print.
 506
 507    DONT_PRINT is an array of baseclass types that we
 508    should not print, or zero if called from top level.  */
 509
 510 static void
 511 pascal_object_print_value_fields (struct value *val, struct ui_file *stream,
 512                                   int recurse,
 513                                   const struct value_print_options *options,
 514                                   struct type **dont_print_vb,
 515                                   int dont_print_statmem)
 516 {
 517   int i, len, n_baseclasses;
 518   char *last_dont_print
 519     = (char *) obstack_next_free (&dont_print_statmem_obstack);
 520
 521   struct type *type = check_typedef (value_type (val));
 522
 523   gdb_printf (stream, "{");
 524   len = type->num_fields ();
 525   n_baseclasses = TYPE_N_BASECLASSES (type);
 526
 527   /* Print out baseclasses such that we don't print
 528      duplicates of virtual baseclasses.  */
 529   if (n_baseclasses > 0)
 530     pascal_object_print_value (val, stream, recurse + 1,
 531                                options, dont_print_vb);
 532
 533   if (!len && n_baseclasses == 1)
 534     fprintf_styled (stream, metadata_style.style (), "<No data fields>");
 535   else
 536     {
 537       struct obstack tmp_obstack = dont_print_statmem_obstack;
 538       int fields_seen = 0;
 539       const gdb_byte *valaddr = value_contents_for_printing (val).data ();
 540
 541       if (dont_print_statmem == 0)
 542         {
 543           /* If we're at top level, carve out a completely fresh
 544              chunk of the obstack and use that until this particular
 545              invocation returns.  */
 546           obstack_finish (&dont_print_statmem_obstack);
 547         }
 548
 549       for (i = n_baseclasses; i < len; i++)
 550         {
 551           /* If requested, skip printing of static fields.  */
 552           if (!options->pascal_static_field_print
 553               && field_is_static (&type->field (i)))
 554             continue;
 555           if (fields_seen)
 556             gdb_printf (stream, ", ");
 557           else if (n_baseclasses > 0)
 558             {
 559               if (options->prettyformat)
 560                 {
 561                   gdb_printf (stream, "\n");
 562                   print_spaces (2 + 2 * recurse, stream);
 563                   gdb_puts ("members of ", stream);
 564                   gdb_puts (type->name (), stream);
 565                   gdb_puts (": ", stream);
 566                 }
 567             }
 568           fields_seen = 1;
 569
 570           if (options->prettyformat)
 571             {
 572               gdb_printf (stream, "\n");
 573               print_spaces (2 + 2 * recurse, stream);
 574             }
 575           else
 576             {
 577               stream->wrap_here (2 + 2 * recurse);
 578             }
 579
 580           annotate_field_begin (type->field (i).type ());
 581
 582           if (field_is_static (&type->field (i)))
 583             {
 584               gdb_puts ("static ", stream);
 585               fprintf_symbol (stream,
 586                               type->field (i).name (),
 587                               current_language->la_language,
 588                               DMGL_PARAMS | DMGL_ANSI);
 589             }
 590           else
 591             fputs_styled (type->field (i).name (),
 592                           variable_name_style.style (), stream);
 593           annotate_field_name_end ();
 594           gdb_puts (" = ", stream);
 595           annotate_field_value ();
 596
 597           if (!field_is_static (&type->field (i))
 598               && TYPE_FIELD_PACKED (type, i))
 599             {
 600               struct value *v;
 601
 602               /* Bitfields require special handling, especially due to byte
 603                  order problems.  */
 604               if (TYPE_FIELD_IGNORE (type, i))
 605                 {
 606                   fputs_styled ("<optimized out or zero length>",
 607                                 metadata_style.style (), stream);
 608                 }
 609               else if (value_bits_synthetic_pointer
 610                          (val, type->field (i).loc_bitpos (),
 611                           TYPE_FIELD_BITSIZE (type, i)))
 612                 {
 613                   fputs_styled (_("<synthetic pointer>"),
 614                                 metadata_style.style (), stream);
 615                 }
 616               else
 617                 {
 618                   struct value_print_options opts = *options;
 619
 620                   v = value_field_bitfield (type, i, valaddr, 0, val);
 621
 622                   opts.deref_ref = 0;
 623                   common_val_print (v, stream, recurse + 1, &opts,
 624                                     current_language);
 625                 }
 626             }
 627           else
 628             {
 629               if (TYPE_FIELD_IGNORE (type, i))
 630                 {
 631                   fputs_styled ("<optimized out or zero length>",
 632                                 metadata_style.style (), stream);
 633                 }
 634               else if (field_is_static (&type->field (i)))
 635                 {
 636                   /* struct value *v = value_static_field (type, i);
 637                      v4.17 specific.  */
 638                   struct value *v;
 639
 640                   v = value_field_bitfield (type, i, valaddr, 0, val);
 641
 642                   if (v == NULL)
 643                     val_print_optimized_out (NULL, stream);
 644                   else
 645                     pascal_object_print_static_field (v, stream, recurse + 1,
 646                                                       options);
 647                 }
 648               else
 649                 {
 650                   struct value_print_options opts = *options;
 651
 652                   opts.deref_ref = 0;
 653
 654                   struct value *v = value_primitive_field (val, 0, i,
 655                                                            value_type (val));
 656                   common_val_print (v, stream, recurse + 1, &opts,
 657                                     current_language);
 658                 }
 659             }
 660           annotate_field_end ();
 661         }
 662
 663       if (dont_print_statmem == 0)
 664         {
 665           /* Free the space used to deal with the printing
 666              of the members from top level.  */
 667           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 668           dont_print_statmem_obstack = tmp_obstack;
 669         }
 670
 671       if (options->prettyformat)
 672         {
 673           gdb_printf (stream, "\n");
 674           print_spaces (2 * recurse, stream);
 675         }
 676     }
 677   gdb_printf (stream, "}");
 678 }
 679
 680 /* Special val_print routine to avoid printing multiple copies of virtual
 681    baseclasses.  */
 682
 683 static void
 684 pascal_object_print_value (struct value *val, struct ui_file *stream,
 685                            int recurse,
 686                            const struct value_print_options *options,
 687                            struct type **dont_print_vb)
 688 {
 689   struct type **last_dont_print
 690     = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 691   struct obstack tmp_obstack = dont_print_vb_obstack;
 692   struct type *type = check_typedef (value_type (val));
 693   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 694
 695   if (dont_print_vb == 0)
 696     {
 697       /* If we're at top level, carve out a completely fresh
 698          chunk of the obstack and use that until this particular
 699          invocation returns.  */
 700       /* Bump up the high-water mark.  Now alpha is omega.  */
 701       obstack_finish (&dont_print_vb_obstack);
 702     }
 703
 704   for (i = 0; i < n_baseclasses; i++)
 705     {
 706       LONGEST boffset = 0;
 707       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 708       const char *basename = baseclass->name ();
 709       int skip = 0;
 710
 711       if (BASETYPE_VIA_VIRTUAL (type, i))
 712         {
 713           struct type **first_dont_print
 714             = (struct type **) obstack_base (&dont_print_vb_obstack);
 715
 716           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 717             - first_dont_print;
 718
 719           while (--j >= 0)
 720             if (baseclass == first_dont_print[j])
 721               goto flush_it;
 722
 723           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 724         }
 725
 726       struct value *base_value;
 727       try
 728         {
 729           base_value = value_primitive_field (val, 0, i, type);
 730         }
 731       catch (const gdb_exception_error &ex)
 732         {
 733           base_value = nullptr;
 734           if (ex.error == NOT_AVAILABLE_ERROR)
 735             skip = -1;
 736           else
 737             skip = 1;
 738         }
 739
 740       if (skip == 0)
 741         {
 742           /* The virtual base class pointer might have been clobbered by the
 743              user program. Make sure that it still points to a valid memory
 744              location.  */
 745
 746           if (boffset < 0 || boffset >= type->length ())
 747             {
 748               CORE_ADDR address= value_address (val);
 749               gdb::byte_vector buf (baseclass->length ());
 750
 751               if (target_read_memory (address + boffset, buf.data (),
 752                                       baseclass->length ()) != 0)
 753                 skip = 1;
 754               base_value = value_from_contents_and_address (baseclass,
 755                                                             buf.data (),
 756                                                             address + boffset);
 757               baseclass = value_type (base_value);
 758               boffset = 0;
 759             }
 760         }
 761
 762       if (options->prettyformat)
 763         {
 764           gdb_printf (stream, "\n");
 765           print_spaces (2 * recurse, stream);
 766         }
 767       gdb_puts ("<", stream);
 768       /* Not sure what the best notation is in the case where there is no
 769          baseclass name.  */
 770
 771       gdb_puts (basename ? basename : "", stream);
 772       gdb_puts ("> = ", stream);
 773
 774       if (skip < 0)
 775         val_print_unavailable (stream);
 776       else if (skip > 0)
 777         val_print_invalid_address (stream);
 778       else
 779         pascal_object_print_value_fields
 780           (base_value, stream, recurse, options,
 781            (struct type **) obstack_base (&dont_print_vb_obstack),
 782            0);
 783       gdb_puts (", ", stream);
 784
 785     flush_it:
 786       ;
 787     }
 788
 789   if (dont_print_vb == 0)
 790     {
 791       /* Free the space used to deal with the printing
 792          of this type from top level.  */
 793       obstack_free (&dont_print_vb_obstack, last_dont_print);
 794       /* Reset watermark so that we can continue protecting
 795          ourselves from whatever we were protecting ourselves.  */
 796       dont_print_vb_obstack = tmp_obstack;
 797     }
 798 }
 799
 800 /* Print value of a static member.
 801    To avoid infinite recursion when printing a class that contains
 802    a static instance of the class, we keep the addresses of all printed
 803    static member classes in an obstack and refuse to print them more
 804    than once.
 805
 806    VAL contains the value to print, STREAM, RECURSE, and OPTIONS
 807    have the same meanings as in c_val_print.  */
 808
 809 static void
 810 pascal_object_print_static_field (struct value *val,
 811                                   struct ui_file *stream,
 812                                   int recurse,
 813                                   const struct value_print_options *options)
 814 {
 815   struct type *type = value_type (val);
 816   struct value_print_options opts;
 817
 818   if (value_entirely_optimized_out (val))
 819     {
 820       val_print_optimized_out (val, stream);
 821       return;
 822     }
 823
 824   if (type->code () == TYPE_CODE_STRUCT)
 825     {
 826       CORE_ADDR *first_dont_print, addr;
 827       int i;
 828
 829       first_dont_print
 830         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
 831       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
 832         - first_dont_print;
 833
 834       while (--i >= 0)
 835         {
 836           if (value_address (val) == first_dont_print[i])
 837             {
 838               fputs_styled (_("\
 839 <same as static member of an already seen type>"),
 840                             metadata_style.style (), stream);
 841               return;
 842             }
 843         }
 844
 845       addr = value_address (val);
 846       obstack_grow (&dont_print_statmem_obstack, (char *) &addr,
 847                     sizeof (CORE_ADDR));
 848
 849       type = check_typedef (type);
 850       pascal_object_print_value_fields (val, stream, recurse,
 851                                         options, NULL, 1);
 852       return;
 853     }
 854
 855   opts = *options;
 856   opts.deref_ref = 0;
 857   common_val_print (val, stream, recurse, &opts, current_language);
 858 }
 859
 860 void _initialize_pascal_valprint ();
 861 void
 862 _initialize_pascal_valprint ()
 863 {
 864   add_setshow_boolean_cmd ("pascal_static-members", class_support,
 865                            &user_print_options.pascal_static_field_print, _("\
 866 Set printing of pascal static members."), _("\
 867 Show printing of pascal static members."), NULL,
 868                            NULL,
 869                            show_pascal_static_field_print,
 870                            &setprintlist, &showprintlist);
 871 }