gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2
   3    Copyright (C) 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., 51 Franklin Street, Fifth Floor,
  20    Boston, MA 02110-1301, USA.  */
  21
  22 /* This file is derived from c-valprint.c */
  23
  24 #include "defs.h"
  25 #include "gdb_obstack.h"
  26 #include "symtab.h"
  27 #include "gdbtypes.h"
  28 #include "expression.h"
  29 #include "value.h"
  30 #include "command.h"
  31 #include "gdbcmd.h"
  32 #include "gdbcore.h"
  33 #include "demangle.h"
  34 #include "valprint.h"
  35 #include "typeprint.h"
  36 #include "language.h"
  37 #include "target.h"
  38 #include "annotate.h"
  39 #include "p-lang.h"
  40 #include "cp-abi.h"
  41 #include "cp-support.h"
  42 \f
  43
  44
  45
  46 /* Print data of type TYPE located at VALADDR (within GDB), which came from
  47    the inferior at address ADDRESS, onto stdio stream STREAM according to
  48    FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
  49    target byte order.
  50
  51    If the data are a string pointer, returns the number of string characters
  52    printed.
  53
  54    If DEREF_REF is nonzero, then dereference references, otherwise just print
  55    them like pointers.
  56
  57    The PRETTY parameter controls prettyprinting.  */
  58
  59
  60 int
  61 pascal_val_print (struct type *type, const gdb_byte *valaddr,
  62                   int embedded_offset, CORE_ADDR address,
  63                   struct ui_file *stream, int format, int deref_ref,
  64                   int recurse, enum val_prettyprint pretty)
  65 {
  66   unsigned int i = 0;   /* Number of characters printed */
  67   unsigned len;
  68   struct type *elttype;
  69   unsigned eltlen;
  70   int length_pos, length_size, string_pos;
  71   int char_size;
  72   LONGEST val;
  73   CORE_ADDR addr;
  74
  75   CHECK_TYPEDEF (type);
  76   switch (TYPE_CODE (type))
  77     {
  78     case TYPE_CODE_ARRAY:
  79       if (TYPE_LENGTH (type) > 0 && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
  80         {
  81           elttype = check_typedef (TYPE_TARGET_TYPE (type));
  82           eltlen = TYPE_LENGTH (elttype);
  83           len = TYPE_LENGTH (type) / eltlen;
  84           if (prettyprint_arrays)
  85             {
  86               print_spaces_filtered (2 + 2 * recurse, stream);
  87             }
  88           /* For an array of chars, print with string syntax.  */
  89           if (eltlen == 1 &&
  90               ((TYPE_CODE (elttype) == TYPE_CODE_INT)
  91                || ((current_language->la_language == language_m2)
  92                    && (TYPE_CODE (elttype) == TYPE_CODE_CHAR)))
  93               && (format == 0 || format == 's'))
  94             {
  95               /* If requested, look for the first null char and only print
  96                  elements up to it.  */
  97               if (stop_print_at_null)
  98                 {
  99                   unsigned int temp_len;
 100
 101                   /* Look for a NULL char. */
 102                   for (temp_len = 0;
 103                        (valaddr + embedded_offset)[temp_len]
 104                        && temp_len < len && temp_len < print_max;
 105                        temp_len++);
 106                   len = temp_len;
 107                 }
 108
 109               LA_PRINT_STRING (stream, valaddr + embedded_offset, len, 1, 0);
 110               i = len;
 111             }
 112           else
 113             {
 114               fprintf_filtered (stream, "{");
 115               /* If this is a virtual function table, print the 0th
 116                  entry specially, and the rest of the members normally.  */
 117               if (pascal_object_is_vtbl_ptr_type (elttype))
 118                 {
 119                   i = 1;
 120                   fprintf_filtered (stream, "%d vtable entries", len - 1);
 121                 }
 122               else
 123                 {
 124                   i = 0;
 125                 }
 126               val_print_array_elements (type, valaddr + embedded_offset, address, stream,
 127                                      format, deref_ref, recurse, pretty, i);
 128               fprintf_filtered (stream, "}");
 129             }
 130           break;
 131         }
 132       /* Array of unspecified length: treat like pointer to first elt.  */
 133       addr = address;
 134       goto print_unpacked_pointer;
 135
 136     case TYPE_CODE_PTR:
 137       if (format && format != 's')
 138         {
 139           print_scalar_formatted (valaddr + embedded_offset, type, format, 0, stream);
 140           break;
 141         }
 142       if (vtblprint && pascal_object_is_vtbl_ptr_type (type))
 143         {
 144           /* Print the unmangled name if desired.  */
 145           /* Print vtable entry - we only get here if we ARE using
 146              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.) */
 147           /* Extract the address, assume that it is unsigned.  */
 148           print_address_demangle (extract_unsigned_integer (valaddr + embedded_offset, TYPE_LENGTH (type)),
 149                                   stream, demangle);
 150           break;
 151         }
 152       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 153       if (TYPE_CODE (elttype) == TYPE_CODE_METHOD)
 154         {
 155           pascal_object_print_class_method (valaddr + embedded_offset, type, stream);
 156         }
 157       else if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
 158         {
 159           pascal_object_print_class_member (valaddr + embedded_offset,
 160                                  TYPE_DOMAIN_TYPE (TYPE_TARGET_TYPE (type)),
 161                                             stream, "&");
 162         }
 163       else
 164         {
 165           addr = unpack_pointer (type, valaddr + embedded_offset);
 166         print_unpacked_pointer:
 167           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 168
 169           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 170             {
 171               /* Try to print what function it points to.  */
 172               print_address_demangle (addr, stream, demangle);
 173               /* Return value is irrelevant except for string pointers.  */
 174               return (0);
 175             }
 176
 177           if (addressprint && format != 's')
 178             {
 179               deprecated_print_address_numeric (addr, 1, stream);
 180             }
 181
 182           /* For a pointer to char or unsigned char, also print the string
 183              pointed to, unless pointer is null.  */
 184           if (TYPE_LENGTH (elttype) == 1
 185               && TYPE_CODE (elttype) == TYPE_CODE_INT
 186               && (format == 0 || format == 's')
 187               && addr != 0)
 188             {
 189               /* no wide string yet */
 190               i = val_print_string (addr, -1, 1, stream);
 191             }
 192           /* also for pointers to pascal strings */
 193           /* Note: this is Free Pascal specific:
 194              as GDB does not recognize stabs pascal strings
 195              Pascal strings are mapped to records
 196              with lowercase names PM  */
 197           if (is_pascal_string_type (elttype, &length_pos, &length_size,
 198                                      &string_pos, &char_size, NULL)
 199               && addr != 0)
 200             {
 201               ULONGEST string_length;
 202               void *buffer;
 203               buffer = xmalloc (length_size);
 204               read_memory (addr + length_pos, buffer, length_size);
 205               string_length = extract_unsigned_integer (buffer, length_size);
 206               xfree (buffer);
 207               i = val_print_string (addr + string_pos, string_length, char_size, stream);
 208             }
 209           else if (pascal_object_is_vtbl_member (type))
 210             {
 211               /* print vtbl's nicely */
 212               CORE_ADDR vt_address = unpack_pointer (type, valaddr + embedded_offset);
 213
 214               struct minimal_symbol *msymbol =
 215               lookup_minimal_symbol_by_pc (vt_address);
 216               if ((msymbol != NULL)
 217                   && (vt_address == SYMBOL_VALUE_ADDRESS (msymbol)))
 218                 {
 219                   fputs_filtered (" <", stream);
 220                   fputs_filtered (SYMBOL_PRINT_NAME (msymbol), stream);
 221                   fputs_filtered (">", stream);
 222                 }
 223               if (vt_address && vtblprint)
 224                 {
 225                   struct value *vt_val;
 226                   struct symbol *wsym = (struct symbol *) NULL;
 227                   struct type *wtype;
 228                   struct block *block = (struct block *) NULL;
 229                   int is_this_fld;
 230
 231                   if (msymbol != NULL)
 232                     wsym = lookup_symbol (DEPRECATED_SYMBOL_NAME (msymbol), block,
 233                                           VAR_DOMAIN, &is_this_fld, NULL);
 234
 235                   if (wsym)
 236                     {
 237                       wtype = SYMBOL_TYPE (wsym);
 238                     }
 239                   else
 240                     {
 241                       wtype = TYPE_TARGET_TYPE (type);
 242                     }
 243                   vt_val = value_at (wtype, vt_address);
 244                   common_val_print (vt_val, stream, format, deref_ref,
 245                                     recurse + 1, pretty);
 246                   if (pretty)
 247                     {
 248                       fprintf_filtered (stream, "\n");
 249                       print_spaces_filtered (2 + 2 * recurse, stream);
 250                     }
 251                 }
 252             }
 253
 254           /* Return number of characters printed, including the terminating
 255              '\0' if we reached the end.  val_print_string takes care including
 256              the terminating '\0' if necessary.  */
 257           return i;
 258         }
 259       break;
 260
 261     case TYPE_CODE_MEMBER:
 262       error (_("not implemented: member type in pascal_val_print"));
 263       break;
 264
 265     case TYPE_CODE_REF:
 266       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 267       if (TYPE_CODE (elttype) == TYPE_CODE_MEMBER)
 268         {
 269           pascal_object_print_class_member (valaddr + embedded_offset,
 270                                             TYPE_DOMAIN_TYPE (elttype),
 271                                             stream, "");
 272           break;
 273         }
 274       if (addressprint)
 275         {
 276           fprintf_filtered (stream, "@");
 277           /* Extract the address, assume that it is unsigned.  */
 278           deprecated_print_address_numeric
 279             (extract_unsigned_integer (valaddr + embedded_offset,
 280                                        TARGET_PTR_BIT / HOST_CHAR_BIT),
 281              1, stream);
 282           if (deref_ref)
 283             fputs_filtered (": ", stream);
 284         }
 285       /* De-reference the reference.  */
 286       if (deref_ref)
 287         {
 288           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 289             {
 290               struct value *deref_val =
 291               value_at
 292               (TYPE_TARGET_TYPE (type),
 293                unpack_pointer (lookup_pointer_type (builtin_type_void),
 294                                valaddr + embedded_offset));
 295               common_val_print (deref_val, stream, format, deref_ref,
 296                                 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 common_val_print (val, stream, format, 1, 0, pretty);
 568 }
 569
 570
 571 /******************************************************************************
 572                     Inserted from cp-valprint
 573 ******************************************************************************/
 574
 575 extern int vtblprint;           /* Controls printing of vtbl's */
 576 extern int objectprint;         /* Controls looking up an object's derived type
 577                                    using what we find in its vtables.  */
 578 static int pascal_static_field_print;   /* Controls printing of static fields. */
 579 static void
 580 show_pascal_static_field_print (struct ui_file *file, int from_tty,
 581                                 struct cmd_list_element *c, const char *value)
 582 {
 583   fprintf_filtered (file, _("Printing of pascal static members is %s.\n"),
 584                     value);
 585 }
 586
 587 static struct obstack dont_print_vb_obstack;
 588 static struct obstack dont_print_statmem_obstack;
 589
 590 static void pascal_object_print_static_field (struct value *,
 591                                               struct ui_file *, int, int,
 592                                               enum val_prettyprint);
 593
 594 static void pascal_object_print_value (struct type *, const gdb_byte *,
 595                                        CORE_ADDR, struct ui_file *,
 596                                        int, int, enum val_prettyprint,
 597                                        struct type **);
 598
 599 void
 600 pascal_object_print_class_method (const gdb_byte *valaddr, struct type *type,
 601                                   struct ui_file *stream)
 602 {
 603   struct type *domain;
 604   struct fn_field *f = NULL;
 605   int j = 0;
 606   int len2;
 607   int offset;
 608   char *kind = "";
 609   CORE_ADDR addr;
 610   struct symbol *sym;
 611   unsigned len;
 612   unsigned int i;
 613   struct type *target_type = check_typedef (TYPE_TARGET_TYPE (type));
 614
 615   domain = TYPE_DOMAIN_TYPE (target_type);
 616   if (domain == (struct type *) NULL)
 617     {
 618       fprintf_filtered (stream, "<unknown>");
 619       return;
 620     }
 621   addr = unpack_pointer (lookup_pointer_type (builtin_type_void), valaddr);
 622   if (METHOD_PTR_IS_VIRTUAL (addr))
 623     {
 624       offset = METHOD_PTR_TO_VOFFSET (addr);
 625       len = TYPE_NFN_FIELDS (domain);
 626       for (i = 0; i < len; i++)
 627         {
 628           f = TYPE_FN_FIELDLIST1 (domain, i);
 629           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 630
 631           check_stub_method_group (domain, i);
 632           for (j = 0; j < len2; j++)
 633             {
 634               if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)
 635                 {
 636                   kind = "virtual ";
 637                   goto common;
 638                 }
 639             }
 640         }
 641     }
 642   else
 643     {
 644       sym = find_pc_function (addr);
 645       if (sym == 0)
 646         {
 647           error (_("invalid pointer to member function"));
 648         }
 649       len = TYPE_NFN_FIELDS (domain);
 650       for (i = 0; i < len; i++)
 651         {
 652           f = TYPE_FN_FIELDLIST1 (domain, i);
 653           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 654
 655           check_stub_method_group (domain, i);
 656           for (j = 0; j < len2; j++)
 657             {
 658               if (DEPRECATED_STREQ (DEPRECATED_SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))
 659                 goto common;
 660             }
 661         }
 662     }
 663 common:
 664   if (i < len)
 665     {
 666       char *demangled_name;
 667
 668       fprintf_filtered (stream, "&");
 669       fputs_filtered (kind, stream);
 670       demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),
 671                                        DMGL_ANSI | DMGL_PARAMS);
 672       if (demangled_name == NULL)
 673         fprintf_filtered (stream, "<badly mangled name %s>",
 674                           TYPE_FN_FIELD_PHYSNAME (f, j));
 675       else
 676         {
 677           fputs_filtered (demangled_name, stream);
 678           xfree (demangled_name);
 679         }
 680     }
 681   else
 682     {
 683       fprintf_filtered (stream, "(");
 684       type_print (type, "", stream, -1);
 685       fprintf_filtered (stream, ") %d", (int) addr >> 3);
 686     }
 687 }
 688
 689 /* It was changed to this after 2.4.5.  */
 690 const char pascal_vtbl_ptr_name[] =
 691 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 692
 693 /* Return truth value for assertion that TYPE is of the type
 694    "pointer to virtual function".  */
 695
 696 int
 697 pascal_object_is_vtbl_ptr_type (struct type *type)
 698 {
 699   char *typename = type_name_no_tag (type);
 700
 701   return (typename != NULL
 702           && strcmp (typename, pascal_vtbl_ptr_name) == 0);
 703 }
 704
 705 /* Return truth value for the assertion that TYPE is of the type
 706    "pointer to virtual function table".  */
 707
 708 int
 709 pascal_object_is_vtbl_member (struct type *type)
 710 {
 711   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 712     {
 713       type = TYPE_TARGET_TYPE (type);
 714       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 715         {
 716           type = TYPE_TARGET_TYPE (type);
 717           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* if not using thunks */
 718               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* if using thunks */
 719             {
 720               /* Virtual functions tables are full of pointers
 721                  to virtual functions. */
 722               return pascal_object_is_vtbl_ptr_type (type);
 723             }
 724         }
 725     }
 726   return 0;
 727 }
 728
 729 /* Mutually recursive subroutines of pascal_object_print_value and
 730    c_val_print to print out a structure's fields:
 731    pascal_object_print_value_fields and pascal_object_print_value.
 732
 733    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the
 734    same meanings as in pascal_object_print_value and c_val_print.
 735
 736    DONT_PRINT is an array of baseclass types that we
 737    should not print, or zero if called from top level.  */
 738
 739 void
 740 pascal_object_print_value_fields (struct type *type, const gdb_byte *valaddr,
 741                                   CORE_ADDR address, struct ui_file *stream,
 742                                   int format, int recurse,
 743                                   enum val_prettyprint pretty,
 744                                   struct type **dont_print_vb,
 745                                   int dont_print_statmem)
 746 {
 747   int i, len, n_baseclasses;
 748   struct obstack tmp_obstack;
 749   char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
 750
 751   CHECK_TYPEDEF (type);
 752
 753   fprintf_filtered (stream, "{");
 754   len = TYPE_NFIELDS (type);
 755   n_baseclasses = TYPE_N_BASECLASSES (type);
 756
 757   /* Print out baseclasses such that we don't print
 758      duplicates of virtual baseclasses.  */
 759   if (n_baseclasses > 0)
 760     pascal_object_print_value (type, valaddr, address, stream,
 761                                format, recurse + 1, pretty, dont_print_vb);
 762
 763   if (!len && n_baseclasses == 1)
 764     fprintf_filtered (stream, "<No data fields>");
 765   else
 766     {
 767       int fields_seen = 0;
 768
 769       if (dont_print_statmem == 0)
 770         {
 771           /* If we're at top level, carve out a completely fresh
 772              chunk of the obstack and use that until this particular
 773              invocation returns.  */
 774           tmp_obstack = dont_print_statmem_obstack;
 775           obstack_finish (&dont_print_statmem_obstack);
 776         }
 777
 778       for (i = n_baseclasses; i < len; i++)
 779         {
 780           /* If requested, skip printing of static fields.  */
 781           if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
 782             continue;
 783           if (fields_seen)
 784             fprintf_filtered (stream, ", ");
 785           else if (n_baseclasses > 0)
 786             {
 787               if (pretty)
 788                 {
 789                   fprintf_filtered (stream, "\n");
 790                   print_spaces_filtered (2 + 2 * recurse, stream);
 791                   fputs_filtered ("members of ", stream);
 792                   fputs_filtered (type_name_no_tag (type), stream);
 793                   fputs_filtered (": ", stream);
 794                 }
 795             }
 796           fields_seen = 1;
 797
 798           if (pretty)
 799             {
 800               fprintf_filtered (stream, "\n");
 801               print_spaces_filtered (2 + 2 * recurse, stream);
 802             }
 803           else
 804             {
 805               wrap_here (n_spaces (2 + 2 * recurse));
 806             }
 807           if (inspect_it)
 808             {
 809               if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
 810                 fputs_filtered ("\"( ptr \"", stream);
 811               else
 812                 fputs_filtered ("\"( nodef \"", stream);
 813               if (TYPE_FIELD_STATIC (type, i))
 814                 fputs_filtered ("static ", stream);
 815               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 816                                        language_cplus,
 817                                        DMGL_PARAMS | DMGL_ANSI);
 818               fputs_filtered ("\" \"", stream);
 819               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 820                                        language_cplus,
 821                                        DMGL_PARAMS | DMGL_ANSI);
 822               fputs_filtered ("\") \"", stream);
 823             }
 824           else
 825             {
 826               annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 827
 828               if (TYPE_FIELD_STATIC (type, i))
 829                 fputs_filtered ("static ", stream);
 830               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 831                                        language_cplus,
 832                                        DMGL_PARAMS | DMGL_ANSI);
 833               annotate_field_name_end ();
 834               fputs_filtered (" = ", stream);
 835               annotate_field_value ();
 836             }
 837
 838           if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
 839             {
 840               struct value *v;
 841
 842               /* Bitfields require special handling, especially due to byte
 843                  order problems.  */
 844               if (TYPE_FIELD_IGNORE (type, i))
 845                 {
 846                   fputs_filtered ("<optimized out or zero length>", stream);
 847                 }
 848               else
 849                 {
 850                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 851                                    unpack_field_as_long (type, valaddr, i));
 852
 853                   common_val_print (v, stream, format, 0, recurse + 1, pretty);
 854                 }
 855             }
 856           else
 857             {
 858               if (TYPE_FIELD_IGNORE (type, i))
 859                 {
 860                   fputs_filtered ("<optimized out or zero length>", stream);
 861                 }
 862               else if (TYPE_FIELD_STATIC (type, i))
 863                 {
 864                   /* struct value *v = value_static_field (type, i); v4.17 specific */
 865                   struct value *v;
 866                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 867                                    unpack_field_as_long (type, valaddr, i));
 868
 869                   if (v == NULL)
 870                     fputs_filtered ("<optimized out>", stream);
 871                   else
 872                     pascal_object_print_static_field (v, stream, format,
 873                                                       recurse + 1, pretty);
 874                 }
 875               else
 876                 {
 877                   /* val_print (TYPE_FIELD_TYPE (type, i),
 878                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 879                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 880                      stream, format, 0, recurse + 1, pretty); */
 881                   val_print (TYPE_FIELD_TYPE (type, i),
 882                              valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
 883                              address + TYPE_FIELD_BITPOS (type, i) / 8,
 884                              stream, format, 0, recurse + 1, pretty);
 885                 }
 886             }
 887           annotate_field_end ();
 888         }
 889
 890       if (dont_print_statmem == 0)
 891         {
 892           /* Free the space used to deal with the printing
 893              of the members from top level.  */
 894           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 895           dont_print_statmem_obstack = tmp_obstack;
 896         }
 897
 898       if (pretty)
 899         {
 900           fprintf_filtered (stream, "\n");
 901           print_spaces_filtered (2 * recurse, stream);
 902         }
 903     }
 904   fprintf_filtered (stream, "}");
 905 }
 906
 907 /* Special val_print routine to avoid printing multiple copies of virtual
 908    baseclasses.  */
 909
 910 void
 911 pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
 912                            CORE_ADDR address, struct ui_file *stream,
 913                            int format, int recurse,
 914                            enum val_prettyprint pretty,
 915                            struct type **dont_print_vb)
 916 {
 917   struct obstack tmp_obstack;
 918   struct type **last_dont_print
 919   = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 920   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 921
 922   if (dont_print_vb == 0)
 923     {
 924       /* If we're at top level, carve out a completely fresh
 925          chunk of the obstack and use that until this particular
 926          invocation returns.  */
 927       tmp_obstack = dont_print_vb_obstack;
 928       /* Bump up the high-water mark.  Now alpha is omega.  */
 929       obstack_finish (&dont_print_vb_obstack);
 930     }
 931
 932   for (i = 0; i < n_baseclasses; i++)
 933     {
 934       int boffset;
 935       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 936       char *basename = TYPE_NAME (baseclass);
 937       const gdb_byte *base_valaddr;
 938
 939       if (BASETYPE_VIA_VIRTUAL (type, i))
 940         {
 941           struct type **first_dont_print
 942           = (struct type **) obstack_base (&dont_print_vb_obstack);
 943
 944           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 945           - first_dont_print;
 946
 947           while (--j >= 0)
 948             if (baseclass == first_dont_print[j])
 949               goto flush_it;
 950
 951           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 952         }
 953
 954       boffset = baseclass_offset (type, i, valaddr, address);
 955
 956       if (pretty)
 957         {
 958           fprintf_filtered (stream, "\n");
 959           print_spaces_filtered (2 * recurse, stream);
 960         }
 961       fputs_filtered ("<", stream);
 962       /* Not sure what the best notation is in the case where there is no
 963          baseclass name.  */
 964
 965       fputs_filtered (basename ? basename : "", stream);
 966       fputs_filtered ("> = ", stream);
 967
 968       /* The virtual base class pointer might have been clobbered by the
 969          user program. Make sure that it still points to a valid memory
 970          location.  */
 971
 972       if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
 973         {
 974           /* FIXME (alloc): not safe is baseclass is really really big. */
 975           gdb_byte *buf = alloca (TYPE_LENGTH (baseclass));
 976           base_valaddr = buf;
 977           if (target_read_memory (address + boffset, buf,
 978                                   TYPE_LENGTH (baseclass)) != 0)
 979             boffset = -1;
 980         }
 981       else
 982         base_valaddr = valaddr + boffset;
 983
 984       if (boffset == -1)
 985         fprintf_filtered (stream, "<invalid address>");
 986       else
 987         pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
 988                                           stream, format, recurse, pretty,
 989                      (struct type **) obstack_base (&dont_print_vb_obstack),
 990                                           0);
 991       fputs_filtered (", ", stream);
 992
 993     flush_it:
 994       ;
 995     }
 996
 997   if (dont_print_vb == 0)
 998     {
 999       /* Free the space used to deal with the printing
1000          of this type from top level.  */
1001       obstack_free (&dont_print_vb_obstack, last_dont_print);
1002       /* Reset watermark so that we can continue protecting
1003          ourselves from whatever we were protecting ourselves.  */
1004       dont_print_vb_obstack = tmp_obstack;
1005     }
1006 }
1007
1008 /* Print value of a static member.
1009    To avoid infinite recursion when printing a class that contains
1010    a static instance of the class, we keep the addresses of all printed
1011    static member classes in an obstack and refuse to print them more
1012    than once.
1013
1014    VAL contains the value to print, STREAM, RECURSE, and PRETTY
1015    have the same meanings as in c_val_print.  */
1016
1017 static void
1018 pascal_object_print_static_field (struct value *val,
1019                                   struct ui_file *stream, int format,
1020                                   int recurse, enum val_prettyprint pretty)
1021 {
1022   struct type *type = value_type (val);
1023
1024   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1025     {
1026       CORE_ADDR *first_dont_print;
1027       int i;
1028
1029       first_dont_print
1030         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1031       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1032         - first_dont_print;
1033
1034       while (--i >= 0)
1035         {
1036           if (VALUE_ADDRESS (val) == first_dont_print[i])
1037             {
1038               fputs_filtered ("<same as static member of an already seen type>",
1039                               stream);
1040               return;
1041             }
1042         }
1043
1044       obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
1045                     sizeof (CORE_ADDR));
1046
1047       CHECK_TYPEDEF (type);
1048       pascal_object_print_value_fields (type, value_contents (val), VALUE_ADDRESS (val),
1049                                   stream, format, recurse, pretty, NULL, 1);
1050       return;
1051     }
1052   common_val_print (val, stream, format, 0, recurse, pretty);
1053 }
1054
1055 void
1056 pascal_object_print_class_member (const gdb_byte *valaddr, struct type *domain,
1057                                   struct ui_file *stream, char *prefix)
1058 {
1059
1060   /* VAL is a byte offset into the structure type DOMAIN.
1061      Find the name of the field for that offset and
1062      print it.  */
1063   int extra = 0;
1064   int bits = 0;
1065   unsigned int i;
1066   unsigned len = TYPE_NFIELDS (domain);
1067   /* @@ Make VAL into bit offset */
1068   LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
1069   for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
1070     {
1071       int bitpos = TYPE_FIELD_BITPOS (domain, i);
1072       QUIT;
1073       if (val == bitpos)
1074         break;
1075       if (val < bitpos && i != 0)
1076         {
1077           /* Somehow pointing into a field.  */
1078           i -= 1;
1079           extra = (val - TYPE_FIELD_BITPOS (domain, i));
1080           if (extra & 0x7)
1081             bits = 1;
1082           else
1083             extra >>= 3;
1084           break;
1085         }
1086     }
1087   if (i < len)
1088     {
1089       char *name;
1090       fputs_filtered (prefix, stream);
1091       name = type_name_no_tag (domain);
1092       if (name)
1093         fputs_filtered (name, stream);
1094       else
1095         pascal_type_print_base (domain, stream, 0, 0);
1096       fprintf_filtered (stream, "::");
1097       fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
1098       if (extra)
1099         fprintf_filtered (stream, " + %d bytes", extra);
1100       if (bits)
1101         fprintf_filtered (stream, " (offset in bits)");
1102     }
1103   else
1104     fprintf_filtered (stream, "%ld", (long int) (val >> 3));
1105 }
1106
1107 extern initialize_file_ftype _initialize_pascal_valprint; /* -Wmissing-prototypes */
1108
1109 void
1110 _initialize_pascal_valprint (void)
1111 {
1112   add_setshow_boolean_cmd ("pascal_static-members", class_support,
1113                            &pascal_static_field_print, _("\
1114 Set printing of pascal static members."), _("\
1115 Show printing of pascal static members."), NULL,
1116                            NULL,
1117                            show_pascal_static_field_print,
1118                            &setprintlist, &showprintlist);
1119   /* Turn on printing of static fields.  */
1120   pascal_static_field_print = 1;
1121
1122 }