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