gdb/p-valprint.c

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