gdb/p-valprint.c

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