gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000, 2001, 2003, 2005, 2006
   4    Free Software Foundation, 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 2 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, write to the Free Software
  20    Foundation, Inc., 51 Franklin Street, Fifth Floor,
  21    Boston, MA 02110-1301, USA.  */
  22
  23 /* This file is derived from c-valprint.c */
  24
  25 #include "defs.h"
  26 #include "gdb_obstack.h"
  27 #include "symtab.h"
  28 #include "gdbtypes.h"
  29 #include "expression.h"
  30 #include "value.h"
  31 #include "command.h"
  32 #include "gdbcmd.h"
  33 #include "gdbcore.h"
  34 #include "demangle.h"
  35 #include "valprint.h"
  36 #include "typeprint.h"
  37 #include "language.h"
  38 #include "target.h"
  39 #include "annotate.h"
  40 #include "p-lang.h"
  41 #include "cp-abi.h"
  42 #include "cp-support.h"
  43 \f
  44
  45
  46
  47 /* Print data of type TYPE located at VALADDR (within GDB), which came from
  48    the inferior at address ADDRESS, onto stdio stream STREAM according to
  49    FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
  50    target byte order.
  51
  52    If the data are a string pointer, returns the number of string characters
  53    printed.
  54
  55    If DEREF_REF is nonzero, then dereference references, otherwise just print
  56    them like pointers.
  57
  58    The PRETTY parameter controls prettyprinting.  */
  59
  60
  61 int
  62 pascal_val_print (struct type *type, const gdb_byte *valaddr,
  63                   int embedded_offset, CORE_ADDR address,
  64                   struct ui_file *stream, int format, int deref_ref,
  65                   int recurse, enum val_prettyprint pretty)
  66 {
  67   unsigned int i = 0;   /* Number of characters printed */
  68   unsigned len;
  69   struct type *elttype;
  70   unsigned eltlen;
  71   int length_pos, length_size, string_pos;
  72   int char_size;
  73   LONGEST val;
  74   CORE_ADDR addr;
  75
  76   CHECK_TYPEDEF (type);
  77   switch (TYPE_CODE (type))
  78     {
  79     case TYPE_CODE_ARRAY:
  80       if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
  81         {
  82           elttype = check_typedef (TYPE_TARGET_TYPE (type));
  83           eltlen = TYPE_LENGTH (elttype);
  84           len = TYPE_LENGTH (type) / eltlen;
  85           if (prettyprint_arrays)
  86             {
  87               print_spaces_filtered (2 + 2 * recurse, stream);
  88             }
  89           /* For an array of chars, print with string syntax.  */
  90           if (eltlen == 1 &&
  91               ((TYPE_CODE (elttype) == TYPE_CODE_INT)
  92                || ((current_language->la_language == language_m2)
  93                    && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
  94               && (format == 0 || format == 's'))
  95             {
  96               /* If requested, look for the first null char and only print
  97                  elements up to it.  */
  98               if (stop_print_at_null)
  99                 {
 100                   unsigned int temp_len;
 101
 102                   /* Look for a NULL char. */
 103                   for (temp_len = 0;
 104                        (valaddr + embedded_offset)[temp_len]
 105                        && temp_len < len && temp_len < print_max;
 106                        temp_len++);
 107                   len = temp_len;
 108                 }
 109
 110               LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
 111               i = len;
 112             }
 113           else
 114             {
 115               fprintf_filtered (stream, "{");
 116               /* If this is a virtual function table, print the 0th
 117                  entry specially, and the rest of the members normally.  */
 118               if (pascal_object_is_vtbl_ptr_type (elttype))
 119                 {
 120                   i = 1;
 121                   fprintf_filtered (stream, "%d vtable entries", len - 1);
 122                 }
 123               else
 124                 {
 125                   i = 0;
 126                 }
 127               val_print_array_elements (type, valaddr + embedded_offset, address, stream,
 128                                      format, deref_ref, recurse, pretty, i);
 129               fprintf_filtered (stream, "}");
 130             }
 131           break;
 132         }
 133       /* Array of unspecified length: treat like pointer to first elt.  */
 134       addr = address;
 135       goto print_unpacked_pointer;
 136
 137     case TYPE_CODE_PTR:
 138       if (format && format != 's')
 139         {
 140           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 141           break;
 142         }
 143       if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
 144         {
 145           /* Print the unmangled name if desired.  */
 146           /* Print vtable entry - we only get here if we ARE using
 147              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.) */
 148           /* Extract the address, assume that it is unsigned.  */
 149           print_address_demangle (extract_unsigned_integer (valaddr + embedded_offset, TYPE_LENGTH (type)),
 150                                   stream, demangle);
 151           break;
 152         }
 153       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 154       if (TYPE_CODE (elttype) == TYPE_CODE_METHOD)
 155         {
 156           pascal_object_print_class_method (valaddr + embedded_offset, type, stream);
 157         }
 158       else if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
 159         {
 160           pascal_object_print_class_member (valaddr + embedded_offset,
 161                                  TYPE_DOMAIN_TYPE (TYPE_TARGET_TYPE (type)),
 162                                             stream, "&");
 163         }
 164       else
 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 (addr, stream, demangle);
 174               /* Return value is irrelevant except for string pointers.  */
 175               return (0);
 176             }
 177
 178           if (addressprint && format != 's')
 179             {
 180               deprecated_print_address_numeric (addr, 1, stream);
 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               && (format == 0 || format == 's')
 188               && addr != 0)
 189             {
 190               /* no wide string yet */
 191               i = val_print_string (addr, -1, 1, stream);
 192             }
 193           /* also for pointers to pascal strings */
 194           /* Note: this is Free Pascal specific:
 195              as GDB does not recognize stabs pascal strings
 196              Pascal strings are mapped to records
 197              with lowercase names PM  */
 198           if (is_pascal_string_type (elttype, &length_pos, &length_size,
 199                                      &string_pos, &char_size, NULL)
 200               && addr != 0)
 201             {
 202               ULONGEST string_length;
 203               void *buffer;
 204               buffer = xmalloc (length_size);
 205               read_memory (addr + length_pos, buffer, length_size);
 206               string_length = extract_unsigned_integer (buffer, length_size);
 207               xfree (buffer);
 208               i = val_print_string (addr + string_pos, string_length, char_size, stream);
 209             }
 210           else if (pascal_object_is_vtbl_member (type))
 211             {
 212               /* print vtbl's nicely */
 213               CORE_ADDR vt_address = unpack_pointer (type, valaddr + embedded_offset);
 214
 215               struct minimal_symbol *msymbol =
 216               lookup_minimal_symbol_by_pc (vt_address);
 217               if ((msymbol != NULL)
 218                   && (vt_address == SYMBOL_VALUE_ADDRESS (msymbol)))
 219                 {
 220                   fputs_filtered (" <", stream);
 221                   fputs_filtered (SYMBOL_PRINT_NAME (msymbol), stream);
 222                   fputs_filtered (">", stream);
 223                 }
 224               if (vt_address && vtblprint)
 225                 {
 226                   struct value *vt_val;
 227                   struct symbol *wsym = (struct symbol *) NULL;
 228                   struct type *wtype;
 229                   struct block *block = (struct block *) NULL;
 230                   int is_this_fld;
 231
 232                   if (msymbol != NULL)
 233                     wsym = lookup_symbol (DEPRECATED_SYMBOL_NAME (msymbol), block,
 234                                           VAR_DOMAIN, &is_this_fld, NULL);
 235
 236                   if (wsym)
 237                     {
 238                       wtype = SYMBOL_TYPE (wsym);
 239                     }
 240                   else
 241                     {
 242                       wtype = TYPE_TARGET_TYPE (type);
 243                     }
 244                   vt_val = value_at (wtype, vt_address);
 245                   common_val_print (vt_val, stream, format, deref_ref,
 246                                     recurse + 1, pretty);
 247                   if (pretty)
 248                     {
 249                       fprintf_filtered (stream, "\n");
 250                       print_spaces_filtered (2 + 2 * recurse, stream);
 251                     }
 252                 }
 253             }
 254
 255           /* Return number of characters printed, including the terminating
 256              '\0' if we reached the end.  val_print_string takes care including
 257              the terminating '\0' if necessary.  */
 258           return i;
 259         }
 260       break;
 261
 262     case TYPE_CODE_MEMBER:
 263       error (_("not implemented: member type in pascal_val_print"));
 264       break;
 265
 266     case TYPE_CODE_REF:
 267       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 268       if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
 269         {
 270           pascal_object_print_class_member (valaddr + embedded_offset,
 271                                             TYPE_DOMAIN_TYPE (elttype),
 272                                             stream, "");
 273           break;
 274         }
 275       if (addressprint)
 276         {
 277           fprintf_filtered (stream, "@");
 278           /* Extract the address, assume that it is unsigned.  */
 279           deprecated_print_address_numeric
 280             (extract_unsigned_integer (valaddr + embedded_offset,
 281                                        TARGET_PTR_BIT / HOST_CHAR_BIT),
 282              1, stream);
 283           if (deref_ref)
 284             fputs_filtered (": ", stream);
 285         }
 286       /* De-reference the reference.  */
 287       if (deref_ref)
 288         {
 289           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 290             {
 291               struct value *deref_val =
 292               value_at
 293               (TYPE_TARGET_TYPE (type),
 294                unpack_pointer (lookup_pointer_type (builtin_type_void),
 295                                valaddr + embedded_offset));
 296               common_val_print (deref_val, stream, format, deref_ref,
 297                                 recurse + 1, pretty);
 298             }
 299           else
 300             fputs_filtered ("???", stream);
 301         }
 302       break;
 303
 304     case TYPE_CODE_UNION:
 305       if (recurse && !unionprint)
 306         {
 307           fprintf_filtered (stream, "{...}");
 308           break;
 309         }
 310       /* Fall through.  */
 311     case TYPE_CODE_STRUCT:
 312       if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
 313         {
 314           /* Print the unmangled name if desired.  */
 315           /* Print vtable entry - we only get here if NOT using
 316              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.) */
 317           /* Extract the address, assume that it is unsigned.  */
 318           print_address_demangle
 319             (extract_unsigned_integer (valaddr + embedded_offset + TYPE_FIELD_BITPOS (type, VTBL_FNADDR_OFFSET) / 8,
 320                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type, VTBL_FNADDR_OFFSET))),
 321              stream, demangle);
 322         }
 323       else
 324         {
 325           if (is_pascal_string_type (type, &length_pos, &length_size,
 326                                      &string_pos, &char_size, NULL))
 327             {
 328               len = extract_unsigned_integer (valaddr + embedded_offset + length_pos, length_size);
 329               LA_PRINT_STRING (stream, valaddr + embedded_offset + string_pos, len, char_size, 0);
 330             }
 331           else
 332             pascal_object_print_value_fields (type, valaddr + embedded_offset, address, stream, format,
 333                                               recurse, pretty, NULL, 0);
 334         }
 335       break;
 336
 337     case TYPE_CODE_ENUM:
 338       if (format)
 339         {
 340           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 341           break;
 342         }
 343       len = TYPE_NFIELDS (type);
 344       val = unpack_long (type, valaddr + embedded_offset);
 345       for (i = 0; i < len; i++)
 346         {
 347           QUIT;
 348           if (val == TYPE_FIELD_BITPOS (type, i))
 349             {
 350               break;
 351             }
 352         }
 353       if (i < len)
 354         {
 355           fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
 356         }
 357       else
 358         {
 359           print_longest (stream, 'd', 0, val);
 360         }
 361       break;
 362
 363     case TYPE_CODE_FLAGS:
 364       if (format)
 365           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 366       else
 367         val_print_type_code_flags (type, valaddr + embedded_offset, stream);
 368       break;
 369
 370     case TYPE_CODE_FUNC:
 371       if (format)
 372         {
 373           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 374           break;
 375         }
 376       /* FIXME, we should consider, at least for ANSI C language, eliminating
 377          the distinction made between FUNCs and POINTERs to FUNCs.  */
 378       fprintf_filtered (stream, "{");
 379       type_print (type, "", stream, -1);
 380       fprintf_filtered (stream, "} ");
 381       /* Try to print what function it points to, and its address.  */
 382       print_address_demangle (address, stream, demangle);
 383       break;
 384
 385     case TYPE_CODE_BOOL:
 386       format = format ? format : output_format;
 387       if (format)
 388         print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 389       else
 390         {
 391           val = unpack_long (type, valaddr + embedded_offset);
 392           if (val == 0)
 393             fputs_filtered ("false", stream);
 394           else if (val == 1)
 395             fputs_filtered ("true", stream);
 396           else
 397             {
 398               fputs_filtered ("true (", stream);
 399               fprintf_filtered (stream, "%ld)", (long int) val);
 400             }
 401         }
 402       break;
 403
 404     case TYPE_CODE_RANGE:
 405       /* FIXME: create_range_type does not set the unsigned bit in a
 406          range type (I think it probably should copy it from the target
 407          type), so we won't print values which are too large to
 408          fit in a signed integer correctly.  */
 409       /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
 410          print with the target type, though, because the size of our type
 411          and the target type might differ).  */
 412       /* FALLTHROUGH */
 413
 414     case TYPE_CODE_INT:
 415       format = format ? format : output_format;
 416       if (format)
 417         {
 418           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 419         }
 420       else
 421         {
 422           val_print_type_code_int (type, valaddr + embedded_offset, stream);
 423         }
 424       break;
 425
 426     case TYPE_CODE_CHAR:
 427       format = format ? format : output_format;
 428       if (format)
 429         {
 430           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 431         }
 432       else
 433         {
 434           val = unpack_long (type, valaddr + embedded_offset);
 435           if (TYPE_UNSIGNED (type))
 436             fprintf_filtered (stream, "%u", (unsigned int) val);
 437           else
 438             fprintf_filtered (stream, "%d", (int) val);
 439           fputs_filtered (" ", stream);
 440           LA_PRINT_CHAR ((unsigned char) val, stream);
 441         }
 442       break;
 443
 444     case TYPE_CODE_FLT:
 445       if (format)
 446         {
 447           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 448         }
 449       else
 450         {
 451           print_floating (valaddr + embedded_offset, type, stream);
 452         }
 453       break;
 454
 455     case TYPE_CODE_BITSTRING:
 456     case TYPE_CODE_SET:
 457       elttype = TYPE_INDEX_TYPE (type);
 458       CHECK_TYPEDEF (elttype);
 459       if (TYPE_STUB (elttype))
 460         {
 461           fprintf_filtered (stream, "<incomplete type>");
 462           gdb_flush (stream);
 463           break;
 464         }
 465       else
 466         {
 467           struct type *range = elttype;
 468           LONGEST low_bound, high_bound;
 469           int i;
 470           int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
 471           int need_comma = 0;
 472
 473           if (is_bitstring)
 474             fputs_filtered ("B'", stream);
 475           else
 476             fputs_filtered ("[", stream);
 477
 478           i = get_discrete_bounds (range, &low_bound, &high_bound);
 479         maybe_bad_bstring:
 480           if (i < 0)
 481             {
 482               fputs_filtered ("<error value>", stream);
 483               goto done;
 484             }
 485
 486           for (i = low_bound; i <= high_bound; i++)
 487             {
 488               int element = value_bit_index (type, valaddr + embedded_offset, i);
 489               if (element < 0)
 490                 {
 491                   i = element;
 492                   goto maybe_bad_bstring;
 493                 }
 494               if (is_bitstring)
 495                 fprintf_filtered (stream, "%d", element);
 496               else if (element)
 497                 {
 498                   if (need_comma)
 499                     fputs_filtered (", ", stream);
 500                   print_type_scalar (range, i, stream);
 501                   need_comma = 1;
 502
 503                   if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
 504                     {
 505                       int j = i;
 506                       fputs_filtered ("..", stream);
 507                       while (i + 1 <= high_bound
 508                              && value_bit_index (type, valaddr + embedded_offset, ++i))
 509                         j = i;
 510                       print_type_scalar (range, j, stream);
 511                     }
 512                 }
 513             }
 514         done:
 515           if (is_bitstring)
 516             fputs_filtered ("'", stream);
 517           else
 518             fputs_filtered ("]", stream);
 519         }
 520       break;
 521
 522     case TYPE_CODE_VOID:
 523       fprintf_filtered (stream, "void");
 524       break;
 525
 526     case TYPE_CODE_ERROR:
 527       fprintf_filtered (stream, "<error type>");
 528       break;
 529
 530     case TYPE_CODE_UNDEF:
 531       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 532          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 533          and no complete type for struct foo in that file.  */
 534       fprintf_filtered (stream, "<incomplete type>");
 535       break;
 536
 537     default:
 538       error (_("Invalid pascal type code %d in symbol table."), TYPE_CODE (type));
 539     }
 540   gdb_flush (stream);
 541   return (0);
 542 }
 543 \f
 544 int
 545 pascal_value_print (struct value *val, struct ui_file *stream, int format,
 546                     enum val_prettyprint pretty)
 547 {
 548   struct type *type = value_type (val);
 549
 550   /* If it is a pointer, indicate what it points to.
 551
 552      Print type also if it is a reference.
 553
 554      Object pascal: if it is a member pointer, we will take care
 555      of that when we print it.  */
 556   if (TYPE_CODE (type) == TYPE_CODE_PTR ||
 557       TYPE_CODE (type) == TYPE_CODE_REF)
 558     {
 559       /* Hack:  remove (char *) for char strings.  Their
 560          type is indicated by the quoted string anyway. */
 561       if (TYPE_CODE (type) == TYPE_CODE_PTR &&
 562           TYPE_NAME (type) == NULL &&
 563           TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
 564           && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
 565         {
 566           /* Print nothing */
 567         }
 568       else
 569         {
 570           fprintf_filtered (stream, "(");
 571           type_print (type, "", stream, -1);
 572           fprintf_filtered (stream, ") ");
 573         }
 574     }
 575   return common_val_print (val, stream, format, 1, 0, pretty);
 576 }
 577
 578
 579 /******************************************************************************
 580                     Inserted from cp-valprint
 581 ******************************************************************************/
 582
 583 extern int vtblprint;           /* Controls printing of vtbl's */
 584 extern int objectprint;         /* Controls looking up an object's derived type
 585                                    using what we find in its vtables.  */
 586 static int pascal_static_field_print;   /* Controls printing of static fields. */
 587 static void
 588 show_pascal_static_field_print (struct ui_file *file, int from_tty,
 589                                 struct cmd_list_element *c, const char *value)
 590 {
 591   fprintf_filtered (file, _("Printing of pascal static members is %s.\n"),
 592                     value);
 593 }
 594
 595 static struct obstack dont_print_vb_obstack;
 596 static struct obstack dont_print_statmem_obstack;
 597
 598 static void pascal_object_print_static_field (struct value *,
 599                                               struct ui_file *, int, int,
 600                                               enum val_prettyprint);
 601
 602 static void pascal_object_print_value (struct type *, const gdb_byte *,
 603                                        CORE_ADDR, struct ui_file *,
 604                                        int, int, enum val_prettyprint,
 605                                        struct type **);
 606
 607 void
 608 pascal_object_print_class_method (const gdb_byte *valaddr, struct type *type,
 609                                   struct ui_file *stream)
 610 {
 611   struct type *domain;
 612   struct fn_field *f = NULL;
 613   int j = 0;
 614   int len2;
 615   int offset;
 616   char *kind = "";
 617   CORE_ADDR addr;
 618   struct symbol *sym;
 619   unsigned len;
 620   unsigned int i;
 621   struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
 622
 623   domain = TYPE_DOMAIN_TYPE (target_type);
 624   if (domain == (struct type *) NULL)
 625     {
 626       fprintf_filtered (stream, "<unknown>");
 627       return;
 628     }
 629   addr = unpack_pointer (lookup_pointer_type (builtin_type_void), valaddr);
 630   if (METHOD_PTR_IS_VIRTUAL (addr))
 631     {
 632       offset = METHOD_PTR_TO_VOFFSET (addr);
 633       len = TYPE_NFN_FIELDS (domain);
 634       for (i = 0; i < len; i++)
 635         {
 636           f = TYPE_FN_FIELDLIST1 (domain, i);
 637           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 638
 639           check_stub_method_group (domain, i);
 640           for (j = 0; j < len2; j++)
 641             {
 642               if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)
 643                 {
 644                   kind = "virtual ";
 645                   goto common;
 646                 }
 647             }
 648         }
 649     }
 650   else
 651     {
 652       sym = find_pc_function (addr);
 653       if (sym == 0)
 654         {
 655           error (_("invalid pointer to member function"));
 656         }
 657       len = TYPE_NFN_FIELDS (domain);
 658       for (i = 0; i < len; i++)
 659         {
 660           f = TYPE_FN_FIELDLIST1 (domain, i);
 661           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 662
 663           check_stub_method_group (domain, i);
 664           for (j = 0; j < len2; j++)
 665             {
 666               if (DEPRECATED_STREQ (DEPRECATED_SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))
 667                 goto common;
 668             }
 669         }
 670     }
 671 common:
 672   if (i < len)
 673     {
 674       char *demangled_name;
 675
 676       fprintf_filtered (stream, "&");
 677       fputs_filtered (kind, stream);
 678       demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),
 679                                        DMGL_ANSI | DMGL_PARAMS);
 680       if (demangled_name == NULL)
 681         fprintf_filtered (stream, "<badly mangled name %s>",
 682                           TYPE_FN_FIELD_PHYSNAME (f, j));
 683       else
 684         {
 685           fputs_filtered (demangled_name, stream);
 686           xfree (demangled_name);
 687         }
 688     }
 689   else
 690     {
 691       fprintf_filtered (stream, "(");
 692       type_print (type, "", stream, -1);
 693       fprintf_filtered (stream, ") %d", (int) addr >> 3);
 694     }
 695 }
 696
 697 /* It was changed to this after 2.4.5.  */
 698 const char pascal_vtbl_ptr_name[] =
 699 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 700
 701 /* Return truth value for assertion that TYPE is of the type
 702    "pointer to virtual function".  */
 703
 704 int
 705 pascal_object_is_vtbl_ptr_type (struct type *type)
 706 {
 707   char *typename = type_name_no_tag (type);
 708
 709   return (typename != NULL
 710           && strcmp (typename, pascal_vtbl_ptr_name) == 0);
 711 }
 712
 713 /* Return truth value for the assertion that TYPE is of the type
 714    "pointer to virtual function table".  */
 715
 716 int
 717 pascal_object_is_vtbl_member (struct type *type)
 718 {
 719   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 720     {
 721       type = TYPE_TARGET_TYPE (type);
 722       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 723         {
 724           type = TYPE_TARGET_TYPE (type);
 725           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* if not using thunks */
 726               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* if using thunks */
 727             {
 728               /* Virtual functions tables are full of pointers
 729                  to virtual functions. */
 730               return pascal_object_is_vtbl_ptr_type (type);
 731             }
 732         }
 733     }
 734   return 0;
 735 }
 736
 737 /* Mutually recursive subroutines of pascal_object_print_value and
 738    c_val_print to print out a structure's fields:
 739    pascal_object_print_value_fields and pascal_object_print_value.
 740
 741    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the
 742    same meanings as in pascal_object_print_value and c_val_print.
 743
 744    DONT_PRINT is an array of baseclass types that we
 745    should not print, or zero if called from top level.  */
 746
 747 void
 748 pascal_object_print_value_fields (struct type *type, const gdb_byte *valaddr,
 749                                   CORE_ADDR address, struct ui_file *stream,
 750                                   int format, int recurse,
 751                                   enum val_prettyprint pretty,
 752                                   struct type **dont_print_vb,
 753                                   int dont_print_statmem)
 754 {
 755   int i, len, n_baseclasses;
 756   struct obstack tmp_obstack;
 757   char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
 758
 759   CHECK_TYPEDEF (type);
 760
 761   fprintf_filtered (stream, "{");
 762   len = TYPE_NFIELDS (type);
 763   n_baseclasses = TYPE_N_BASECLASSES (type);
 764
 765   /* Print out baseclasses such that we don't print
 766      duplicates of virtual baseclasses.  */
 767   if (n_baseclasses > 0)
 768     pascal_object_print_value (type, valaddr, address, stream,
 769                                format, recurse + 1, pretty, dont_print_vb);
 770
 771   if (!len && n_baseclasses == 1)
 772     fprintf_filtered (stream, "<No data fields>");
 773   else
 774     {
 775       int fields_seen = 0;
 776
 777       if (dont_print_statmem == 0)
 778         {
 779           /* If we're at top level, carve out a completely fresh
 780              chunk of the obstack and use that until this particular
 781              invocation returns.  */
 782           tmp_obstack = dont_print_statmem_obstack;
 783           obstack_finish (&dont_print_statmem_obstack);
 784         }
 785
 786       for (i = n_baseclasses; i < len; i++)
 787         {
 788           /* If requested, skip printing of static fields.  */
 789           if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
 790             continue;
 791           if (fields_seen)
 792             fprintf_filtered (stream, ", ");
 793           else if (n_baseclasses > 0)
 794             {
 795               if (pretty)
 796                 {
 797                   fprintf_filtered (stream, "\n");
 798                   print_spaces_filtered (2 + 2 * recurse, stream);
 799                   fputs_filtered ("members of ", stream);
 800                   fputs_filtered (type_name_no_tag (type), stream);
 801                   fputs_filtered (": ", stream);
 802                 }
 803             }
 804           fields_seen = 1;
 805
 806           if (pretty)
 807             {
 808               fprintf_filtered (stream, "\n");
 809               print_spaces_filtered (2 + 2 * recurse, stream);
 810             }
 811           else
 812             {
 813               wrap_here (n_spaces (2 + 2 * recurse));
 814             }
 815           if (inspect_it)
 816             {
 817               if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
 818                 fputs_filtered ("\"( ptr \"", stream);
 819               else
 820                 fputs_filtered ("\"( nodef \"", stream);
 821               if (TYPE_FIELD_STATIC (type, i))
 822                 fputs_filtered ("static ", stream);
 823               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 824                                        language_cplus,
 825                                        DMGL_PARAMS | DMGL_ANSI);
 826               fputs_filtered ("\" \"", stream);
 827               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 828                                        language_cplus,
 829                                        DMGL_PARAMS | DMGL_ANSI);
 830               fputs_filtered ("\") \"", stream);
 831             }
 832           else
 833             {
 834               annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 835
 836               if (TYPE_FIELD_STATIC (type, i))
 837                 fputs_filtered ("static ", stream);
 838               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 839                                        language_cplus,
 840                                        DMGL_PARAMS | DMGL_ANSI);
 841               annotate_field_name_end ();
 842               fputs_filtered (" = ", stream);
 843               annotate_field_value ();
 844             }
 845
 846           if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
 847             {
 848               struct value *v;
 849
 850               /* Bitfields require special handling, especially due to byte
 851                  order problems.  */
 852               if (TYPE_FIELD_IGNORE (type, i))
 853                 {
 854                   fputs_filtered ("<optimized out or zero length>", stream);
 855                 }
 856               else
 857                 {
 858                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 859                                    unpack_field_as_long (type, valaddr, i));
 860
 861                   common_val_print (v, stream, format, 0, recurse + 1, pretty);
 862                 }
 863             }
 864           else
 865             {
 866               if (TYPE_FIELD_IGNORE (type, i))
 867                 {
 868                   fputs_filtered ("<optimized out or zero length>", stream);
 869                 }
 870               else if (TYPE_FIELD_STATIC (type, i))
 871                 {
 872                   /* struct value *v = value_static_field (type, i); v4.17 specific */
 873                   struct value *v;
 874                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 875                                    unpack_field_as_long (type, valaddr, i));
 876
 877                   if (v == NULL)
 878                     fputs_filtered ("<optimized out>", stream);
 879                   else
 880                     pascal_object_print_static_field (v, stream, format,
 881                                                       recurse + 1, pretty);
 882                 }
 883               else
 884                 {
 885                   /* val_print (TYPE_FIELD_TYPE (type, i),
 886                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 887                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 888                      stream, format, 0, recurse + 1, pretty); */
 889                   val_print (TYPE_FIELD_TYPE (type, i),
 890                              valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
 891                              address + TYPE_FIELD_BITPOS (type, i) / 8,
 892                              stream, format, 0, recurse + 1, pretty);
 893                 }
 894             }
 895           annotate_field_end ();
 896         }
 897
 898       if (dont_print_statmem == 0)
 899         {
 900           /* Free the space used to deal with the printing
 901              of the members from top level.  */
 902           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 903           dont_print_statmem_obstack = tmp_obstack;
 904         }
 905
 906       if (pretty)
 907         {
 908           fprintf_filtered (stream, "\n");
 909           print_spaces_filtered (2 * recurse, stream);
 910         }
 911     }
 912   fprintf_filtered (stream, "}");
 913 }
 914
 915 /* Special val_print routine to avoid printing multiple copies of virtual
 916    baseclasses.  */
 917
 918 static void
 919 pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
 920                            CORE_ADDR address, struct ui_file *stream,
 921                            int format, int recurse,
 922                            enum val_prettyprint pretty,
 923                            struct type **dont_print_vb)
 924 {
 925   struct obstack tmp_obstack;
 926   struct type **last_dont_print
 927   = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 928   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 929
 930   if (dont_print_vb == 0)
 931     {
 932       /* If we're at top level, carve out a completely fresh
 933          chunk of the obstack and use that until this particular
 934          invocation returns.  */
 935       tmp_obstack = dont_print_vb_obstack;
 936       /* Bump up the high-water mark.  Now alpha is omega.  */
 937       obstack_finish (&dont_print_vb_obstack);
 938     }
 939
 940   for (i = 0; i < n_baseclasses; i++)
 941     {
 942       int boffset;
 943       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 944       char *basename = TYPE_NAME (baseclass);
 945       const gdb_byte *base_valaddr;
 946
 947       if (BASETYPE_VIA_VIRTUAL (type, i))
 948         {
 949           struct type **first_dont_print
 950           = (struct type **) obstack_base (&dont_print_vb_obstack);
 951
 952           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 953           - first_dont_print;
 954
 955           while (--j >= 0)
 956             if (baseclass == first_dont_print[j])
 957               goto flush_it;
 958
 959           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 960         }
 961
 962       boffset = baseclass_offset (type, i, valaddr, address);
 963
 964       if (pretty)
 965         {
 966           fprintf_filtered (stream, "\n");
 967           print_spaces_filtered (2 * recurse, stream);
 968         }
 969       fputs_filtered ("<", stream);
 970       /* Not sure what the best notation is in the case where there is no
 971          baseclass name.  */
 972
 973       fputs_filtered (basename ? basename : "", stream);
 974       fputs_filtered ("> = ", stream);
 975
 976       /* The virtual base class pointer might have been clobbered by the
 977          user program. Make sure that it still points to a valid memory
 978          location.  */
 979
 980       if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
 981         {
 982           /* FIXME (alloc): not safe is baseclass is really really big. */
 983           gdb_byte *buf = alloca (TYPE_LENGTH (baseclass));
 984           base_valaddr = buf;
 985           if (target_read_memory (address + boffset, buf,
 986                                   TYPE_LENGTH (baseclass)) != 0)
 987             boffset = -1;
 988         }
 989       else
 990         base_valaddr = valaddr + boffset;
 991
 992       if (boffset == -1)
 993         fprintf_filtered (stream, "<invalid address>");
 994       else
 995         pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
 996                                           stream, format, recurse, pretty,
 997                      (struct type **) obstack_base (&dont_print_vb_obstack),
 998                                           0);
 999       fputs_filtered (", ", stream);
1000
1001     flush_it:
1002       ;
1003     }
1004
1005   if (dont_print_vb == 0)
1006     {
1007       /* Free the space used to deal with the printing
1008          of this type from top level.  */
1009       obstack_free (&dont_print_vb_obstack, last_dont_print);
1010       /* Reset watermark so that we can continue protecting
1011          ourselves from whatever we were protecting ourselves.  */
1012       dont_print_vb_obstack = tmp_obstack;
1013     }
1014 }
1015
1016 /* Print value of a static member.
1017    To avoid infinite recursion when printing a class that contains
1018    a static instance of the class, we keep the addresses of all printed
1019    static member classes in an obstack and refuse to print them more
1020    than once.
1021
1022    VAL contains the value to print, STREAM, RECURSE, and PRETTY
1023    have the same meanings as in c_val_print.  */
1024
1025 static void
1026 pascal_object_print_static_field (struct value *val,
1027                                   struct ui_file *stream, int format,
1028                                   int recurse, enum val_prettyprint pretty)
1029 {
1030   struct type *type = value_type (val);
1031
1032   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1033     {
1034       CORE_ADDR *first_dont_print;
1035       int i;
1036
1037       first_dont_print
1038         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1039       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1040         - first_dont_print;
1041
1042       while (--i >= 0)
1043         {
1044           if (VALUE_ADDRESS (val) == first_dont_print[i])
1045             {
1046               fputs_filtered ("<same as static member of an already seen type>",
1047                               stream);
1048               return;
1049             }
1050         }
1051
1052       obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
1053                     sizeof (CORE_ADDR));
1054
1055       CHECK_TYPEDEF (type);
1056       pascal_object_print_value_fields (type, value_contents (val), VALUE_ADDRESS (val),
1057                                   stream, format, recurse, pretty, NULL, 1);
1058       return;
1059     }
1060   common_val_print (val, stream, format, 0, recurse, pretty);
1061 }
1062
1063 void
1064 pascal_object_print_class_member (const gdb_byte *valaddr, struct type *domain,
1065                                   struct ui_file *stream, char *prefix)
1066 {
1067
1068   /* VAL is a byte offset into the structure type DOMAIN.
1069      Find the name of the field for that offset and
1070      print it.  */
1071   int extra = 0;
1072   int bits = 0;
1073   unsigned int i;
1074   unsigned len = TYPE_NFIELDS (domain);
1075   /* @@ Make VAL into bit offset */
1076   LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
1077   for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
1078     {
1079       int bitpos = TYPE_FIELD_BITPOS (domain, i);
1080       QUIT;
1081       if (val == bitpos)
1082         break;
1083       if (val < bitpos && i != 0)
1084         {
1085           /* Somehow pointing into a field.  */
1086           i -= 1;
1087           extra = (val - TYPE_FIELD_BITPOS (domain, i));
1088           if (extra & 0x7)
1089             bits = 1;
1090           else
1091             extra >>= 3;
1092           break;
1093         }
1094     }
1095   if (i < len)
1096     {
1097       char *name;
1098       fputs_filtered (prefix, stream);
1099       name = type_name_no_tag (domain);
1100       if (name)
1101         fputs_filtered (name, stream);
1102       else
1103         pascal_type_print_base (domain, stream, 0, 0);
1104       fprintf_filtered (stream, "::");
1105       fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
1106       if (extra)
1107         fprintf_filtered (stream, " + %d bytes", extra);
1108       if (bits)
1109         fprintf_filtered (stream, " (offset in bits)");
1110     }
1111   else
1112     fprintf_filtered (stream, "%ld", (long int) (val >> 3));
1113 }
1114
1115 extern initialize_file_ftype _initialize_pascal_valprint; /* -Wmissing-prototypes */
1116
1117 void
1118 _initialize_pascal_valprint (void)
1119 {
1120   add_setshow_boolean_cmd ("pascal_static-members", class_support,
1121                            &pascal_static_field_print, _("\
1122 Set printing of pascal static members."), _("\
1123 Show printing of pascal static members."), NULL,
1124                            NULL,
1125                            show_pascal_static_field_print,
1126                            &setprintlist, &showprintlist);
1127   /* Turn on printing of static fields.  */
1128   pascal_static_field_print = 1;
1129
1130 }