contrib/gdb/gdb/p-valprint.c

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