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 (DEPRECATED_SYMBOL_NAME (msymbol), block,
 230                                           VAR_DOMAIN, &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 (DEPRECATED_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       int fields_seen = 0;
 759
 760       if (dont_print_statmem == 0)
 761         {
 762           /* If we're at top level, carve out a completely fresh
 763              chunk of the obstack and use that until this particular
 764              invocation returns.  */
 765           tmp_obstack = dont_print_statmem_obstack;
 766           obstack_finish (&dont_print_statmem_obstack);
 767         }
 768
 769       for (i = n_baseclasses; i < len; i++)
 770         {
 771           /* If requested, skip printing of static fields.  */
 772           if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
 773             continue;
 774           if (fields_seen)
 775             fprintf_filtered (stream, ", ");
 776           else if (n_baseclasses > 0)
 777             {
 778               if (pretty)
 779                 {
 780                   fprintf_filtered (stream, "\n");
 781                   print_spaces_filtered (2 + 2 * recurse, stream);
 782                   fputs_filtered ("members of ", stream);
 783                   fputs_filtered (type_name_no_tag (type), stream);
 784                   fputs_filtered (": ", stream);
 785                 }
 786             }
 787           fields_seen = 1;
 788
 789           if (pretty)
 790             {
 791               fprintf_filtered (stream, "\n");
 792               print_spaces_filtered (2 + 2 * recurse, stream);
 793             }
 794           else
 795             {
 796               wrap_here (n_spaces (2 + 2 * recurse));
 797             }
 798           if (inspect_it)
 799             {
 800               if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
 801                 fputs_filtered ("\"( ptr \"", stream);
 802               else
 803                 fputs_filtered ("\"( nodef \"", stream);
 804               if (TYPE_FIELD_STATIC (type, i))
 805                 fputs_filtered ("static ", stream);
 806               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 807                                        language_cplus,
 808                                        DMGL_PARAMS | DMGL_ANSI);
 809               fputs_filtered ("\" \"", stream);
 810               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 811                                        language_cplus,
 812                                        DMGL_PARAMS | DMGL_ANSI);
 813               fputs_filtered ("\") \"", stream);
 814             }
 815           else
 816             {
 817               annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 818
 819               if (TYPE_FIELD_STATIC (type, i))
 820                 fputs_filtered ("static ", stream);
 821               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 822                                        language_cplus,
 823                                        DMGL_PARAMS | DMGL_ANSI);
 824               annotate_field_name_end ();
 825               fputs_filtered (" = ", stream);
 826               annotate_field_value ();
 827             }
 828
 829           if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
 830             {
 831               struct value *v;
 832
 833               /* Bitfields require special handling, especially due to byte
 834                  order problems.  */
 835               if (TYPE_FIELD_IGNORE (type, i))
 836                 {
 837                   fputs_filtered ("<optimized out or zero length>", stream);
 838                 }
 839               else
 840                 {
 841                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 842                                    unpack_field_as_long (type, valaddr, i));
 843
 844                   val_print (TYPE_FIELD_TYPE (type, i), VALUE_CONTENTS (v), 0, 0,
 845                              stream, format, 0, recurse + 1, pretty);
 846                 }
 847             }
 848           else
 849             {
 850               if (TYPE_FIELD_IGNORE (type, i))
 851                 {
 852                   fputs_filtered ("<optimized out or zero length>", stream);
 853                 }
 854               else if (TYPE_FIELD_STATIC (type, i))
 855                 {
 856                   /* struct value *v = value_static_field (type, i); v4.17 specific */
 857                   struct value *v;
 858                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 859                                    unpack_field_as_long (type, valaddr, i));
 860
 861                   if (v == NULL)
 862                     fputs_filtered ("<optimized out>", stream);
 863                   else
 864                     pascal_object_print_static_field (TYPE_FIELD_TYPE (type, i), v,
 865                                                 stream, format, recurse + 1,
 866                                                       pretty);
 867                 }
 868               else
 869                 {
 870                   /* val_print (TYPE_FIELD_TYPE (type, i),
 871                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 872                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 873                      stream, format, 0, recurse + 1, pretty); */
 874                   val_print (TYPE_FIELD_TYPE (type, i),
 875                              valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
 876                              address + TYPE_FIELD_BITPOS (type, i) / 8,
 877                              stream, format, 0, recurse + 1, pretty);
 878                 }
 879             }
 880           annotate_field_end ();
 881         }
 882
 883       if (dont_print_statmem == 0)
 884         {
 885           /* Free the space used to deal with the printing
 886              of the members from top level.  */
 887           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 888           dont_print_statmem_obstack = tmp_obstack;
 889         }
 890
 891       if (pretty)
 892         {
 893           fprintf_filtered (stream, "\n");
 894           print_spaces_filtered (2 * recurse, stream);
 895         }
 896     }
 897   fprintf_filtered (stream, "}");
 898 }
 899
 900 /* Special val_print routine to avoid printing multiple copies of virtual
 901    baseclasses.  */
 902
 903 void
 904 pascal_object_print_value (struct type *type, char *valaddr, CORE_ADDR address,
 905                            struct ui_file *stream, int format, int recurse,
 906                            enum val_prettyprint pretty,
 907                            struct type **dont_print_vb)
 908 {
 909   struct obstack tmp_obstack;
 910   struct type **last_dont_print
 911   = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 912   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 913
 914   if (dont_print_vb == 0)
 915     {
 916       /* If we're at top level, carve out a completely fresh
 917          chunk of the obstack and use that until this particular
 918          invocation returns.  */
 919       tmp_obstack = dont_print_vb_obstack;
 920       /* Bump up the high-water mark.  Now alpha is omega.  */
 921       obstack_finish (&dont_print_vb_obstack);
 922     }
 923
 924   for (i = 0; i < n_baseclasses; i++)
 925     {
 926       int boffset;
 927       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 928       char *basename = TYPE_NAME (baseclass);
 929       char *base_valaddr;
 930
 931       if (BASETYPE_VIA_VIRTUAL (type, i))
 932         {
 933           struct type **first_dont_print
 934           = (struct type **) obstack_base (&dont_print_vb_obstack);
 935
 936           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 937           - first_dont_print;
 938
 939           while (--j >= 0)
 940             if (baseclass == first_dont_print[j])
 941               goto flush_it;
 942
 943           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 944         }
 945
 946       boffset = baseclass_offset (type, i, valaddr, address);
 947
 948       if (pretty)
 949         {
 950           fprintf_filtered (stream, "\n");
 951           print_spaces_filtered (2 * recurse, stream);
 952         }
 953       fputs_filtered ("<", stream);
 954       /* Not sure what the best notation is in the case where there is no
 955          baseclass name.  */
 956
 957       fputs_filtered (basename ? basename : "", stream);
 958       fputs_filtered ("> = ", stream);
 959
 960       /* The virtual base class pointer might have been clobbered by the
 961          user program. Make sure that it still points to a valid memory
 962          location.  */
 963
 964       if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
 965         {
 966           /* FIXME (alloc): not safe is baseclass is really really big. */
 967           base_valaddr = (char *) alloca (TYPE_LENGTH (baseclass));
 968           if (target_read_memory (address + boffset, base_valaddr,
 969                                   TYPE_LENGTH (baseclass)) != 0)
 970             boffset = -1;
 971         }
 972       else
 973         base_valaddr = valaddr + boffset;
 974
 975       if (boffset == -1)
 976         fprintf_filtered (stream, "<invalid address>");
 977       else
 978         pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
 979                                           stream, format, recurse, pretty,
 980                      (struct type **) obstack_base (&dont_print_vb_obstack),
 981                                           0);
 982       fputs_filtered (", ", stream);
 983
 984     flush_it:
 985       ;
 986     }
 987
 988   if (dont_print_vb == 0)
 989     {
 990       /* Free the space used to deal with the printing
 991          of this type from top level.  */
 992       obstack_free (&dont_print_vb_obstack, last_dont_print);
 993       /* Reset watermark so that we can continue protecting
 994          ourselves from whatever we were protecting ourselves.  */
 995       dont_print_vb_obstack = tmp_obstack;
 996     }
 997 }
 998
 999 /* Print value of a static member.
1000    To avoid infinite recursion when printing a class that contains
1001    a static instance of the class, we keep the addresses of all printed
1002    static member classes in an obstack and refuse to print them more
1003    than once.
1004
1005    VAL contains the value to print, TYPE, STREAM, RECURSE, and PRETTY
1006    have the same meanings as in c_val_print.  */
1007
1008 static void
1009 pascal_object_print_static_field (struct type *type, struct value *val,
1010                                   struct ui_file *stream, int format,
1011                                   int recurse, enum val_prettyprint pretty)
1012 {
1013   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1014     {
1015       CORE_ADDR *first_dont_print;
1016       int i;
1017
1018       first_dont_print
1019         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1020       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1021         - first_dont_print;
1022
1023       while (--i >= 0)
1024         {
1025           if (VALUE_ADDRESS (val) == first_dont_print[i])
1026             {
1027               fputs_filtered ("<same as static member of an already seen type>",
1028                               stream);
1029               return;
1030             }
1031         }
1032
1033       obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
1034                     sizeof (CORE_ADDR));
1035
1036       CHECK_TYPEDEF (type);
1037       pascal_object_print_value_fields (type, VALUE_CONTENTS (val), VALUE_ADDRESS (val),
1038                                   stream, format, recurse, pretty, NULL, 1);
1039       return;
1040     }
1041   val_print (type, VALUE_CONTENTS (val), 0, VALUE_ADDRESS (val),
1042              stream, format, 0, recurse, pretty);
1043 }
1044
1045 void
1046 pascal_object_print_class_member (char *valaddr, struct type *domain,
1047                                   struct ui_file *stream, char *prefix)
1048 {
1049
1050   /* VAL is a byte offset into the structure type DOMAIN.
1051      Find the name of the field for that offset and
1052      print it.  */
1053   int extra = 0;
1054   int bits = 0;
1055   register unsigned int i;
1056   unsigned len = TYPE_NFIELDS (domain);
1057   /* @@ Make VAL into bit offset */
1058   LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
1059   for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
1060     {
1061       int bitpos = TYPE_FIELD_BITPOS (domain, i);
1062       QUIT;
1063       if (val == bitpos)
1064         break;
1065       if (val < bitpos && i != 0)
1066         {
1067           /* Somehow pointing into a field.  */
1068           i -= 1;
1069           extra = (val - TYPE_FIELD_BITPOS (domain, i));
1070           if (extra & 0x7)
1071             bits = 1;
1072           else
1073             extra >>= 3;
1074           break;
1075         }
1076     }
1077   if (i < len)
1078     {
1079       char *name;
1080       fprintf_filtered (stream, prefix);
1081       name = type_name_no_tag (domain);
1082       if (name)
1083         fputs_filtered (name, stream);
1084       else
1085         pascal_type_print_base (domain, stream, 0, 0);
1086       fprintf_filtered (stream, "::");
1087       fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
1088       if (extra)
1089         fprintf_filtered (stream, " + %d bytes", extra);
1090       if (bits)
1091         fprintf_filtered (stream, " (offset in bits)");
1092     }
1093   else
1094     fprintf_filtered (stream, "%ld", (long int) (val >> 3));
1095 }
1096
1097
1098 void
1099 _initialize_pascal_valprint (void)
1100 {
1101   add_show_from_set
1102     (add_set_cmd ("pascal_static-members", class_support, var_boolean,
1103                   (char *) &pascal_static_field_print,
1104                   "Set printing of pascal static members.",
1105                   &setprintlist),
1106      &showprintlist);
1107   /* Turn on printing of static fields.  */
1108   pascal_static_field_print = 1;
1109
1110 }