gdb/p-valprint.c

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