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