gdb/p-valprint.c

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