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