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);
 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               val_print (VALUE_TYPE (deref_val),
 294                          VALUE_CONTENTS (deref_val), 0,
 295                          VALUE_ADDRESS (deref_val), stream, format,
 296                          deref_ref, recurse + 1, pretty);
 297             }
 298           else
 299             fputs_filtered ("???", stream);
 300         }
 301       break;
 302
 303     case TYPE_CODE_UNION:
 304       if (recurse && !unionprint)
 305         {
 306           fprintf_filtered (stream, "{...}");
 307           break;
 308         }
 309       /* Fall through.  */
 310     case TYPE_CODE_STRUCT:
 311       if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
 312         {
 313           /* Print the unmangled name if desired.  */
 314           /* Print vtable entry - we only get here if NOT using
 315              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.) */
 316           /* Extract the address, assume that it is unsigned.  */
 317           print_address_demangle
 318             (extract_unsigned_integer (valaddr + embedded_offset + TYPE_FIELD_BITPOS (type, VTBL_FNADDR_OFFSET) / 8,
 319                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type, VTBL_FNADDR_OFFSET))),
 320              stream, demangle);
 321         }
 322       else
 323         {
 324           if (is_pascal_string_type (type, &length_pos, &length_size,
 325                                      &string_pos, &char_size, NULL))
 326             {
 327               len = extract_unsigned_integer (valaddr + embedded_offset + length_pos, length_size);
 328               LA_PRINT_STRING (stream, valaddr + embedded_offset + string_pos, len, char_size, 0);
 329             }
 330           else
 331             pascal_object_print_value_fields (type, valaddr + embedded_offset, address, stream, format,
 332                                               recurse, pretty, NULL, 0);
 333         }
 334       break;
 335
 336     case TYPE_CODE_ENUM:
 337       if (format)
 338         {
 339           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 340           break;
 341         }
 342       len = TYPE_NFIELDS (type);
 343       val = unpack_long (type, valaddr + embedded_offset);
 344       for (i = 0; i < len; i++)
 345         {
 346           QUIT;
 347           if (val == TYPE_FIELD_BITPOS (type, i))
 348             {
 349               break;
 350             }
 351         }
 352       if (i < len)
 353         {
 354           fputs_filtered (TYPE_FIELD_NAME (type, i), stream);
 355         }
 356       else
 357         {
 358           print_longest (stream, 'd', 0, val);
 359         }
 360       break;
 361
 362     case TYPE_CODE_FUNC:
 363       if (format)
 364         {
 365           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 366           break;
 367         }
 368       /* FIXME, we should consider, at least for ANSI C language, eliminating
 369          the distinction made between FUNCs and POINTERs to FUNCs.  */
 370       fprintf_filtered (stream, "{");
 371       type_print (type, "", stream, -1);
 372       fprintf_filtered (stream, "} ");
 373       /* Try to print what function it points to, and its address.  */
 374       print_address_demangle (address, stream, demangle);
 375       break;
 376
 377     case TYPE_CODE_BOOL:
 378       format = format ? format : output_format;
 379       if (format)
 380         print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 381       else
 382         {
 383           val = unpack_long (type, valaddr + embedded_offset);
 384           if (val == 0)
 385             fputs_filtered ("false", stream);
 386           else if (val == 1)
 387             fputs_filtered ("true", stream);
 388           else
 389             {
 390               fputs_filtered ("true (", stream);
 391               fprintf_filtered (stream, "%ld)", (long int) val);
 392             }
 393         }
 394       break;
 395
 396     case TYPE_CODE_RANGE:
 397       /* FIXME: create_range_type does not set the unsigned bit in a
 398          range type (I think it probably should copy it from the target
 399          type), so we won't print values which are too large to
 400          fit in a signed integer correctly.  */
 401       /* FIXME: Doesn't handle ranges of enums correctly.  (Can't just
 402          print with the target type, though, because the size of our type
 403          and the target type might differ).  */
 404       /* FALLTHROUGH */
 405
 406     case TYPE_CODE_INT:
 407       format = format ? format : output_format;
 408       if (format)
 409         {
 410           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 411         }
 412       else
 413         {
 414           val_print_type_code_int (type, valaddr + embedded_offset, stream);
 415         }
 416       break;
 417
 418     case TYPE_CODE_CHAR:
 419       format = format ? format : output_format;
 420       if (format)
 421         {
 422           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 423         }
 424       else
 425         {
 426           val = unpack_long (type, valaddr + embedded_offset);
 427           if (TYPE_UNSIGNED (type))
 428             fprintf_filtered (stream, "%u", (unsigned int) val);
 429           else
 430             fprintf_filtered (stream, "%d", (int) val);
 431           fputs_filtered (" ", stream);
 432           LA_PRINT_CHAR ((unsigned char) val, stream);
 433         }
 434       break;
 435
 436     case TYPE_CODE_FLT:
 437       if (format)
 438         {
 439           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 440         }
 441       else
 442         {
 443           print_floating (valaddr + embedded_offset, type, stream);
 444         }
 445       break;
 446
 447     case TYPE_CODE_BITSTRING:
 448     case TYPE_CODE_SET:
 449       elttype = TYPE_INDEX_TYPE (type);
 450       CHECK_TYPEDEF (elttype);
 451       if (TYPE_STUB (elttype))
 452         {
 453           fprintf_filtered (stream, "<incomplete type>");
 454           gdb_flush (stream);
 455           break;
 456         }
 457       else
 458         {
 459           struct type *range = elttype;
 460           LONGEST low_bound, high_bound;
 461           int i;
 462           int is_bitstring = TYPE_CODE (type) == TYPE_CODE_BITSTRING;
 463           int need_comma = 0;
 464
 465           if (is_bitstring)
 466             fputs_filtered ("B'", stream);
 467           else
 468             fputs_filtered ("[", stream);
 469
 470           i = get_discrete_bounds (range, &low_bound, &high_bound);
 471         maybe_bad_bstring:
 472           if (i < 0)
 473             {
 474               fputs_filtered ("<error value>", stream);
 475               goto done;
 476             }
 477
 478           for (i = low_bound; i <= high_bound; i++)
 479             {
 480               int element = value_bit_index (type, valaddr + embedded_offset, i);
 481               if (element < 0)
 482                 {
 483                   i = element;
 484                   goto maybe_bad_bstring;
 485                 }
 486               if (is_bitstring)
 487                 fprintf_filtered (stream, "%d", element);
 488               else if (element)
 489                 {
 490                   if (need_comma)
 491                     fputs_filtered (", ", stream);
 492                   print_type_scalar (range, i, stream);
 493                   need_comma = 1;
 494
 495                   if (i + 1 <= high_bound && value_bit_index (type, valaddr + embedded_offset, ++i))
 496                     {
 497                       int j = i;
 498                       fputs_filtered ("..", stream);
 499                       while (i + 1 <= high_bound
 500                              && value_bit_index (type, valaddr + embedded_offset, ++i))
 501                         j = i;
 502                       print_type_scalar (range, j, stream);
 503                     }
 504                 }
 505             }
 506         done:
 507           if (is_bitstring)
 508             fputs_filtered ("'", stream);
 509           else
 510             fputs_filtered ("]", stream);
 511         }
 512       break;
 513
 514     case TYPE_CODE_VOID:
 515       fprintf_filtered (stream, "void");
 516       break;
 517
 518     case TYPE_CODE_ERROR:
 519       fprintf_filtered (stream, "<error type>");
 520       break;
 521
 522     case TYPE_CODE_UNDEF:
 523       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 524          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 525          and no complete type for struct foo in that file.  */
 526       fprintf_filtered (stream, "<incomplete type>");
 527       break;
 528
 529     default:
 530       error ("Invalid pascal type code %d in symbol table.", TYPE_CODE (type));
 531     }
 532   gdb_flush (stream);
 533   return (0);
 534 }
 535 \f
 536 int
 537 pascal_value_print (struct value *val, struct ui_file *stream, int format,
 538                     enum val_prettyprint pretty)
 539 {
 540   struct type *type = VALUE_TYPE (val);
 541
 542   /* If it is a pointer, indicate what it points to.
 543
 544      Print type also if it is a reference.
 545
 546      Object pascal: if it is a member pointer, we will take care
 547      of that when we print it.  */
 548   if (TYPE_CODE (type) == TYPE_CODE_PTR ||
 549       TYPE_CODE (type) == TYPE_CODE_REF)
 550     {
 551       /* Hack:  remove (char *) for char strings.  Their
 552          type is indicated by the quoted string anyway. */
 553       if (TYPE_CODE (type) == TYPE_CODE_PTR &&
 554           TYPE_NAME (type) == NULL &&
 555           TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
 556           && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
 557         {
 558           /* Print nothing */
 559         }
 560       else
 561         {
 562           fprintf_filtered (stream, "(");
 563           type_print (type, "", stream, -1);
 564           fprintf_filtered (stream, ") ");
 565         }
 566     }
 567   return val_print (type, VALUE_CONTENTS (val), VALUE_EMBEDDED_OFFSET (val),
 568                     VALUE_ADDRESS (val) + VALUE_OFFSET (val),
 569                     stream, format, 1, 0, pretty);
 570 }
 571
 572
 573 /******************************************************************************
 574                     Inserted from cp-valprint
 575 ******************************************************************************/
 576
 577 extern int vtblprint;           /* Controls printing of vtbl's */
 578 extern int objectprint;         /* Controls looking up an object's derived type
 579                                    using what we find in its vtables.  */
 580 static int pascal_static_field_print;   /* Controls printing of static fields. */
 581
 582 static struct obstack dont_print_vb_obstack;
 583 static struct obstack dont_print_statmem_obstack;
 584
 585 static void pascal_object_print_static_field (struct type *, struct value *,
 586                                               struct ui_file *, int, int,
 587                                               enum val_prettyprint);
 588
 589 static void
 590   pascal_object_print_value (struct type *, char *, CORE_ADDR, struct ui_file *,
 591                              int, int, enum val_prettyprint, struct type **);
 592
 593 void
 594 pascal_object_print_class_method (char *valaddr, struct type *type,
 595                                   struct ui_file *stream)
 596 {
 597   struct type *domain;
 598   struct fn_field *f = NULL;
 599   int j = 0;
 600   int len2;
 601   int offset;
 602   char *kind = "";
 603   CORE_ADDR addr;
 604   struct symbol *sym;
 605   unsigned len;
 606   unsigned int i;
 607   struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
 608
 609   domain = TYPE_DOMAIN_TYPE (target_type);
 610   if (domain == (struct type *) NULL)
 611     {
 612       fprintf_filtered (stream, "<unknown>");
 613       return;
 614     }
 615   addr = unpack_pointer (lookup_pointer_type (builtin_type_void), valaddr);
 616   if (METHOD_PTR_IS_VIRTUAL (addr))
 617     {
 618       offset = METHOD_PTR_TO_VOFFSET (addr);
 619       len = TYPE_NFN_FIELDS (domain);
 620       for (i = 0; i < len; i++)
 621         {
 622           f = TYPE_FN_FIELDLIST1 (domain, i);
 623           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 624
 625           check_stub_method_group (domain, i);
 626           for (j = 0; j < len2; j++)
 627             {
 628               if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)
 629                 {
 630                   kind = "virtual ";
 631                   goto common;
 632                 }
 633             }
 634         }
 635     }
 636   else
 637     {
 638       sym = find_pc_function (addr);
 639       if (sym == 0)
 640         {
 641           error ("invalid pointer to member function");
 642         }
 643       len = TYPE_NFN_FIELDS (domain);
 644       for (i = 0; i < len; i++)
 645         {
 646           f = TYPE_FN_FIELDLIST1 (domain, i);
 647           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 648
 649           check_stub_method_group (domain, i);
 650           for (j = 0; j < len2; j++)
 651             {
 652               if (DEPRECATED_STREQ (DEPRECATED_SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))
 653                 goto common;
 654             }
 655         }
 656     }
 657 common:
 658   if (i < len)
 659     {
 660       char *demangled_name;
 661
 662       fprintf_filtered (stream, "&");
 663       fputs_filtered (kind, stream);
 664       demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),
 665                                        DMGL_ANSI | DMGL_PARAMS);
 666       if (demangled_name == NULL)
 667         fprintf_filtered (stream, "<badly mangled name %s>",
 668                           TYPE_FN_FIELD_PHYSNAME (f, j));
 669       else
 670         {
 671           fputs_filtered (demangled_name, stream);
 672           xfree (demangled_name);
 673         }
 674     }
 675   else
 676     {
 677       fprintf_filtered (stream, "(");
 678       type_print (type, "", stream, -1);
 679       fprintf_filtered (stream, ") %d", (int) addr >> 3);
 680     }
 681 }
 682
 683 /* It was changed to this after 2.4.5.  */
 684 const char pascal_vtbl_ptr_name[] =
 685 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 686
 687 /* Return truth value for assertion that TYPE is of the type
 688    "pointer to virtual function".  */
 689
 690 int
 691 pascal_object_is_vtbl_ptr_type (struct type *type)
 692 {
 693   char *typename = type_name_no_tag (type);
 694
 695   return (typename != NULL
 696           && strcmp (typename, pascal_vtbl_ptr_name) == 0);
 697 }
 698
 699 /* Return truth value for the assertion that TYPE is of the type
 700    "pointer to virtual function table".  */
 701
 702 int
 703 pascal_object_is_vtbl_member (struct type *type)
 704 {
 705   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 706     {
 707       type = TYPE_TARGET_TYPE (type);
 708       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 709         {
 710           type = TYPE_TARGET_TYPE (type);
 711           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* if not using thunks */
 712               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* if using thunks */
 713             {
 714               /* Virtual functions tables are full of pointers
 715                  to virtual functions. */
 716               return pascal_object_is_vtbl_ptr_type (type);
 717             }
 718         }
 719     }
 720   return 0;
 721 }
 722
 723 /* Mutually recursive subroutines of pascal_object_print_value and c_val_print to
 724    print out a structure's fields: pascal_object_print_value_fields and pascal_object_print_value.
 725
 726    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the
 727    same meanings as in pascal_object_print_value and c_val_print.
 728
 729    DONT_PRINT is an array of baseclass types that we
 730    should not print, or zero if called from top level.  */
 731
 732 void
 733 pascal_object_print_value_fields (struct type *type, char *valaddr,
 734                                   CORE_ADDR address, struct ui_file *stream,
 735                                   int format, int recurse,
 736                                   enum val_prettyprint pretty,
 737                                   struct type **dont_print_vb,
 738                                   int dont_print_statmem)
 739 {
 740   int i, len, n_baseclasses;
 741   struct obstack tmp_obstack;
 742   char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
 743
 744   CHECK_TYPEDEF (type);
 745
 746   fprintf_filtered (stream, "{");
 747   len = TYPE_NFIELDS (type);
 748   n_baseclasses = TYPE_N_BASECLASSES (type);
 749
 750   /* Print out baseclasses such that we don't print
 751      duplicates of virtual baseclasses.  */
 752   if (n_baseclasses > 0)
 753     pascal_object_print_value (type, valaddr, address, stream,
 754                                format, recurse + 1, pretty, dont_print_vb);
 755
 756   if (!len && n_baseclasses == 1)
 757     fprintf_filtered (stream, "<No data fields>");
 758   else
 759     {
 760       int fields_seen = 0;
 761
 762       if (dont_print_statmem == 0)
 763         {
 764           /* If we're at top level, carve out a completely fresh
 765              chunk of the obstack and use that until this particular
 766              invocation returns.  */
 767           tmp_obstack = dont_print_statmem_obstack;
 768           obstack_finish (&dont_print_statmem_obstack);
 769         }
 770
 771       for (i = n_baseclasses; i < len; i++)
 772         {
 773           /* If requested, skip printing of static fields.  */
 774           if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
 775             continue;
 776           if (fields_seen)
 777             fprintf_filtered (stream, ", ");
 778           else if (n_baseclasses > 0)
 779             {
 780               if (pretty)
 781                 {
 782                   fprintf_filtered (stream, "\n");
 783                   print_spaces_filtered (2 + 2 * recurse, stream);
 784                   fputs_filtered ("members of ", stream);
 785                   fputs_filtered (type_name_no_tag (type), stream);
 786                   fputs_filtered (": ", stream);
 787                 }
 788             }
 789           fields_seen = 1;
 790
 791           if (pretty)
 792             {
 793               fprintf_filtered (stream, "\n");
 794               print_spaces_filtered (2 + 2 * recurse, stream);
 795             }
 796           else
 797             {
 798               wrap_here (n_spaces (2 + 2 * recurse));
 799             }
 800           if (inspect_it)
 801             {
 802               if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
 803                 fputs_filtered ("\"( ptr \"", stream);
 804               else
 805                 fputs_filtered ("\"( nodef \"", stream);
 806               if (TYPE_FIELD_STATIC (type, i))
 807                 fputs_filtered ("static ", stream);
 808               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 809                                        language_cplus,
 810                                        DMGL_PARAMS | DMGL_ANSI);
 811               fputs_filtered ("\" \"", stream);
 812               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 813                                        language_cplus,
 814                                        DMGL_PARAMS | DMGL_ANSI);
 815               fputs_filtered ("\") \"", stream);
 816             }
 817           else
 818             {
 819               annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 820
 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               annotate_field_name_end ();
 827               fputs_filtered (" = ", stream);
 828               annotate_field_value ();
 829             }
 830
 831           if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
 832             {
 833               struct value *v;
 834
 835               /* Bitfields require special handling, especially due to byte
 836                  order problems.  */
 837               if (TYPE_FIELD_IGNORE (type, i))
 838                 {
 839                   fputs_filtered ("<optimized out or zero length>", stream);
 840                 }
 841               else
 842                 {
 843                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 844                                    unpack_field_as_long (type, valaddr, i));
 845
 846                   val_print (TYPE_FIELD_TYPE (type, i), VALUE_CONTENTS (v), 0, 0,
 847                              stream, format, 0, recurse + 1, pretty);
 848                 }
 849             }
 850           else
 851             {
 852               if (TYPE_FIELD_IGNORE (type, i))
 853                 {
 854                   fputs_filtered ("<optimized out or zero length>", stream);
 855                 }
 856               else if (TYPE_FIELD_STATIC (type, i))
 857                 {
 858                   /* struct value *v = value_static_field (type, i); v4.17 specific */
 859                   struct value *v;
 860                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 861                                    unpack_field_as_long (type, valaddr, i));
 862
 863                   if (v == NULL)
 864                     fputs_filtered ("<optimized out>", stream);
 865                   else
 866                     pascal_object_print_static_field (TYPE_FIELD_TYPE (type, i), v,
 867                                                 stream, format, recurse + 1,
 868                                                       pretty);
 869                 }
 870               else
 871                 {
 872                   /* val_print (TYPE_FIELD_TYPE (type, i),
 873                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 874                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 875                      stream, format, 0, recurse + 1, pretty); */
 876                   val_print (TYPE_FIELD_TYPE (type, i),
 877                              valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
 878                              address + TYPE_FIELD_BITPOS (type, i) / 8,
 879                              stream, format, 0, recurse + 1, pretty);
 880                 }
 881             }
 882           annotate_field_end ();
 883         }
 884
 885       if (dont_print_statmem == 0)
 886         {
 887           /* Free the space used to deal with the printing
 888              of the members from top level.  */
 889           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 890           dont_print_statmem_obstack = tmp_obstack;
 891         }
 892
 893       if (pretty)
 894         {
 895           fprintf_filtered (stream, "\n");
 896           print_spaces_filtered (2 * recurse, stream);
 897         }
 898     }
 899   fprintf_filtered (stream, "}");
 900 }
 901
 902 /* Special val_print routine to avoid printing multiple copies of virtual
 903    baseclasses.  */
 904
 905 void
 906 pascal_object_print_value (struct type *type, char *valaddr, CORE_ADDR address,
 907                            struct ui_file *stream, int format, int recurse,
 908                            enum val_prettyprint pretty,
 909                            struct type **dont_print_vb)
 910 {
 911   struct obstack tmp_obstack;
 912   struct type **last_dont_print
 913   = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 914   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 915
 916   if (dont_print_vb == 0)
 917     {
 918       /* If we're at top level, carve out a completely fresh
 919          chunk of the obstack and use that until this particular
 920          invocation returns.  */
 921       tmp_obstack = dont_print_vb_obstack;
 922       /* Bump up the high-water mark.  Now alpha is omega.  */
 923       obstack_finish (&dont_print_vb_obstack);
 924     }
 925
 926   for (i = 0; i < n_baseclasses; i++)
 927     {
 928       int boffset;
 929       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 930       char *basename = TYPE_NAME (baseclass);
 931       char *base_valaddr;
 932
 933       if (BASETYPE_VIA_VIRTUAL (type, i))
 934         {
 935           struct type **first_dont_print
 936           = (struct type **) obstack_base (&dont_print_vb_obstack);
 937
 938           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 939           - first_dont_print;
 940
 941           while (--j >= 0)
 942             if (baseclass == first_dont_print[j])
 943               goto flush_it;
 944
 945           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 946         }
 947
 948       boffset = baseclass_offset (type, i, valaddr, address);
 949
 950       if (pretty)
 951         {
 952           fprintf_filtered (stream, "\n");
 953           print_spaces_filtered (2 * recurse, stream);
 954         }
 955       fputs_filtered ("<", stream);
 956       /* Not sure what the best notation is in the case where there is no
 957          baseclass name.  */
 958
 959       fputs_filtered (basename ? basename : "", stream);
 960       fputs_filtered ("> = ", stream);
 961
 962       /* The virtual base class pointer might have been clobbered by the
 963          user program. Make sure that it still points to a valid memory
 964          location.  */
 965
 966       if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
 967         {
 968           /* FIXME (alloc): not safe is baseclass is really really big. */
 969           base_valaddr = (char *) alloca (TYPE_LENGTH (baseclass));
 970           if (target_read_memory (address + boffset, base_valaddr,
 971                                   TYPE_LENGTH (baseclass)) != 0)
 972             boffset = -1;
 973         }
 974       else
 975         base_valaddr = valaddr + boffset;
 976
 977       if (boffset == -1)
 978         fprintf_filtered (stream, "<invalid address>");
 979       else
 980         pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
 981                                           stream, format, recurse, pretty,
 982                      (struct type **) obstack_base (&dont_print_vb_obstack),
 983                                           0);
 984       fputs_filtered (", ", stream);
 985
 986     flush_it:
 987       ;
 988     }
 989
 990   if (dont_print_vb == 0)
 991     {
 992       /* Free the space used to deal with the printing
 993          of this type from top level.  */
 994       obstack_free (&dont_print_vb_obstack, last_dont_print);
 995       /* Reset watermark so that we can continue protecting
 996          ourselves from whatever we were protecting ourselves.  */
 997       dont_print_vb_obstack = tmp_obstack;
 998     }
 999 }
1000
1001 /* Print value of a static member.
1002    To avoid infinite recursion when printing a class that contains
1003    a static instance of the class, we keep the addresses of all printed
1004    static member classes in an obstack and refuse to print them more
1005    than once.
1006
1007    VAL contains the value to print, TYPE, STREAM, RECURSE, and PRETTY
1008    have the same meanings as in c_val_print.  */
1009
1010 static void
1011 pascal_object_print_static_field (struct type *type, struct value *val,
1012                                   struct ui_file *stream, int format,
1013                                   int recurse, enum val_prettyprint pretty)
1014 {
1015   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1016     {
1017       CORE_ADDR *first_dont_print;
1018       int i;
1019
1020       first_dont_print
1021         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1022       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1023         - first_dont_print;
1024
1025       while (--i >= 0)
1026         {
1027           if (VALUE_ADDRESS (val) == first_dont_print[i])
1028             {
1029               fputs_filtered ("<same as static member of an already seen type>",
1030                               stream);
1031               return;
1032             }
1033         }
1034
1035       obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
1036                     sizeof (CORE_ADDR));
1037
1038       CHECK_TYPEDEF (type);
1039       pascal_object_print_value_fields (type, VALUE_CONTENTS (val), VALUE_ADDRESS (val),
1040                                   stream, format, recurse, pretty, NULL, 1);
1041       return;
1042     }
1043   val_print (type, VALUE_CONTENTS (val), 0, VALUE_ADDRESS (val),
1044              stream, format, 0, recurse, pretty);
1045 }
1046
1047 void
1048 pascal_object_print_class_member (char *valaddr, struct type *domain,
1049                                   struct ui_file *stream, char *prefix)
1050 {
1051
1052   /* VAL is a byte offset into the structure type DOMAIN.
1053      Find the name of the field for that offset and
1054      print it.  */
1055   int extra = 0;
1056   int bits = 0;
1057   unsigned int i;
1058   unsigned len = TYPE_NFIELDS (domain);
1059   /* @@ Make VAL into bit offset */
1060   LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
1061   for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
1062     {
1063       int bitpos = TYPE_FIELD_BITPOS (domain, i);
1064       QUIT;
1065       if (val == bitpos)
1066         break;
1067       if (val < bitpos && i != 0)
1068         {
1069           /* Somehow pointing into a field.  */
1070           i -= 1;
1071           extra = (val - TYPE_FIELD_BITPOS (domain, i));
1072           if (extra & 0x7)
1073             bits = 1;
1074           else
1075             extra >>= 3;
1076           break;
1077         }
1078     }
1079   if (i < len)
1080     {
1081       char *name;
1082       fputs_filtered (prefix, stream);
1083       name = type_name_no_tag (domain);
1084       if (name)
1085         fputs_filtered (name, stream);
1086       else
1087         pascal_type_print_base (domain, stream, 0, 0);
1088       fprintf_filtered (stream, "::");
1089       fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
1090       if (extra)
1091         fprintf_filtered (stream, " + %d bytes", extra);
1092       if (bits)
1093         fprintf_filtered (stream, " (offset in bits)");
1094     }
1095   else
1096     fprintf_filtered (stream, "%ld", (long int) (val >> 3));
1097 }
1098
1099 extern initialize_file_ftype _initialize_pascal_valprint; /* -Wmissing-prototypes */
1100
1101 void
1102 _initialize_pascal_valprint (void)
1103 {
1104   deprecated_add_show_from_set
1105     (add_set_cmd ("pascal_static-members", class_support, var_boolean,
1106                   (char *) &pascal_static_field_print,
1107                   "Set printing of pascal static members.",
1108                   &setprintlist),
1109      &showprintlist);
1110   /* Turn on printing of static fields.  */
1111   pascal_static_field_print = 1;
1112
1113 }