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