gdb/p-valprint.c

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