gdb/p-valprint.c

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