contrib/gdb-6.2.1/gdb/p-valprint.c

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