gdb/p-valprint.c

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