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