gdb/p-valprint.c

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