gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2    Copyright 2000, 2001
   3    Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 2 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program; if not, write to the Free Software
  19    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  20
  21 /* This file is derived from c-valprint.c */
  22
  23 #include "defs.h"
  24 #include "gdb_obstack.h"
  25 #include "symtab.h"
  26 #include "gdbtypes.h"
  27 #include "expression.h"
  28 #include "value.h"
  29 #include "command.h"
  30 #include "gdbcmd.h"
  31 #include "gdbcore.h"
  32 #include "demangle.h"
  33 #include "valprint.h"
  34 #include "typeprint.h"
  35 #include "language.h"
  36 #include "target.h"
  37 #include "annotate.h"
  38 #include "p-lang.h"
  39 #include "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_SOURCE_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           for (j = 0; j < len2; j++)
 624             {
 625               QUIT;
 626               if (TYPE_FN_FIELD_VOFFSET (f, j) == offset)
 627                 {
 628                   if (TYPE_FN_FIELD_STUB (f, j))
 629                     check_stub_method (domain, i, j);
 630                   kind = "virtual ";
 631                   goto common;
 632                 }
 633             }
 634         }
 635     }
 636   else
 637     {
 638       sym = find_pc_function (addr);
 639       if (sym == 0)
 640         {
 641           error ("invalid pointer to member function");
 642         }
 643       len = TYPE_NFN_FIELDS (domain);
 644       for (i = 0; i < len; i++)
 645         {
 646           f = TYPE_FN_FIELDLIST1 (domain, i);
 647           len2 = TYPE_FN_FIELDLIST_LENGTH (domain, i);
 648
 649           for (j = 0; j < len2; j++)
 650             {
 651               QUIT;
 652               if (TYPE_FN_FIELD_STUB (f, j))
 653                 check_stub_method (domain, i, j);
 654               if (STREQ (SYMBOL_NAME (sym), TYPE_FN_FIELD_PHYSNAME (f, j)))
 655                 {
 656                   goto common;
 657                 }
 658             }
 659         }
 660     }
 661 common:
 662   if (i < len)
 663     {
 664       char *demangled_name;
 665
 666       fprintf_filtered (stream, "&");
 667       fprintf_filtered (stream, kind);
 668       demangled_name = cplus_demangle (TYPE_FN_FIELD_PHYSNAME (f, j),
 669                                        DMGL_ANSI | DMGL_PARAMS);
 670       if (demangled_name == NULL)
 671         fprintf_filtered (stream, "<badly mangled name %s>",
 672                           TYPE_FN_FIELD_PHYSNAME (f, j));
 673       else
 674         {
 675           fputs_filtered (demangled_name, stream);
 676           xfree (demangled_name);
 677         }
 678     }
 679   else
 680     {
 681       fprintf_filtered (stream, "(");
 682       type_print (type, "", stream, -1);
 683       fprintf_filtered (stream, ") %d", (int) addr >> 3);
 684     }
 685 }
 686
 687 /* It was changed to this after 2.4.5.  */
 688 const char pascal_vtbl_ptr_name[] =
 689 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 690
 691 /* Return truth value for assertion that TYPE is of the type
 692    "pointer to virtual function".  */
 693
 694 int
 695 pascal_object_is_vtbl_ptr_type (struct type *type)
 696 {
 697   char *typename = type_name_no_tag (type);
 698
 699   return (typename != NULL
 700           && (STREQ (typename, pascal_vtbl_ptr_name)));
 701 }
 702
 703 /* Return truth value for the assertion that TYPE is of the type
 704    "pointer to virtual function table".  */
 705
 706 int
 707 pascal_object_is_vtbl_member (struct type *type)
 708 {
 709   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 710     {
 711       type = TYPE_TARGET_TYPE (type);
 712       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 713         {
 714           type = TYPE_TARGET_TYPE (type);
 715           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* if not using thunks */
 716               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* if using thunks */
 717             {
 718               /* Virtual functions tables are full of pointers
 719                  to virtual functions. */
 720               return pascal_object_is_vtbl_ptr_type (type);
 721             }
 722         }
 723     }
 724   return 0;
 725 }
 726
 727 /* Mutually recursive subroutines of pascal_object_print_value and c_val_print to
 728    print out a structure's fields: pascal_object_print_value_fields and pascal_object_print_value.
 729
 730    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and PRETTY have the
 731    same meanings as in pascal_object_print_value and c_val_print.
 732
 733    DONT_PRINT is an array of baseclass types that we
 734    should not print, or zero if called from top level.  */
 735
 736 void
 737 pascal_object_print_value_fields (struct type *type, char *valaddr,
 738                                   CORE_ADDR address, struct ui_file *stream,
 739                                   int format, int recurse,
 740                                   enum val_prettyprint pretty,
 741                                   struct type **dont_print_vb,
 742                                   int dont_print_statmem)
 743 {
 744   int i, len, n_baseclasses;
 745   struct obstack tmp_obstack;
 746   char *last_dont_print = obstack_next_free (&dont_print_statmem_obstack);
 747
 748   CHECK_TYPEDEF (type);
 749
 750   fprintf_filtered (stream, "{");
 751   len = TYPE_NFIELDS (type);
 752   n_baseclasses = TYPE_N_BASECLASSES (type);
 753
 754   /* Print out baseclasses such that we don't print
 755      duplicates of virtual baseclasses.  */
 756   if (n_baseclasses > 0)
 757     pascal_object_print_value (type, valaddr, address, stream,
 758                                format, recurse + 1, pretty, dont_print_vb);
 759
 760   if (!len && n_baseclasses == 1)
 761     fprintf_filtered (stream, "<No data fields>");
 762   else
 763     {
 764       extern int inspect_it;
 765       int fields_seen = 0;
 766
 767       if (dont_print_statmem == 0)
 768         {
 769           /* If we're at top level, carve out a completely fresh
 770              chunk of the obstack and use that until this particular
 771              invocation returns.  */
 772           tmp_obstack = dont_print_statmem_obstack;
 773           obstack_finish (&dont_print_statmem_obstack);
 774         }
 775
 776       for (i = n_baseclasses; i < len; i++)
 777         {
 778           /* If requested, skip printing of static fields.  */
 779           if (!pascal_static_field_print && TYPE_FIELD_STATIC (type, i))
 780             continue;
 781           if (fields_seen)
 782             fprintf_filtered (stream, ", ");
 783           else if (n_baseclasses > 0)
 784             {
 785               if (pretty)
 786                 {
 787                   fprintf_filtered (stream, "\n");
 788                   print_spaces_filtered (2 + 2 * recurse, stream);
 789                   fputs_filtered ("members of ", stream);
 790                   fputs_filtered (type_name_no_tag (type), stream);
 791                   fputs_filtered (": ", stream);
 792                 }
 793             }
 794           fields_seen = 1;
 795
 796           if (pretty)
 797             {
 798               fprintf_filtered (stream, "\n");
 799               print_spaces_filtered (2 + 2 * recurse, stream);
 800             }
 801           else
 802             {
 803               wrap_here (n_spaces (2 + 2 * recurse));
 804             }
 805           if (inspect_it)
 806             {
 807               if (TYPE_CODE (TYPE_FIELD_TYPE (type, i)) == TYPE_CODE_PTR)
 808                 fputs_filtered ("\"( ptr \"", stream);
 809               else
 810                 fputs_filtered ("\"( nodef \"", stream);
 811               if (TYPE_FIELD_STATIC (type, i))
 812                 fputs_filtered ("static ", stream);
 813               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 814                                        language_cplus,
 815                                        DMGL_PARAMS | DMGL_ANSI);
 816               fputs_filtered ("\" \"", stream);
 817               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 818                                        language_cplus,
 819                                        DMGL_PARAMS | DMGL_ANSI);
 820               fputs_filtered ("\") \"", stream);
 821             }
 822           else
 823             {
 824               annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 825
 826               if (TYPE_FIELD_STATIC (type, i))
 827                 fputs_filtered ("static ", stream);
 828               fprintf_symbol_filtered (stream, TYPE_FIELD_NAME (type, i),
 829                                        language_cplus,
 830                                        DMGL_PARAMS | DMGL_ANSI);
 831               annotate_field_name_end ();
 832               fputs_filtered (" = ", stream);
 833               annotate_field_value ();
 834             }
 835
 836           if (!TYPE_FIELD_STATIC (type, i) && TYPE_FIELD_PACKED (type, i))
 837             {
 838               struct value *v;
 839
 840               /* Bitfields require special handling, especially due to byte
 841                  order problems.  */
 842               if (TYPE_FIELD_IGNORE (type, i))
 843                 {
 844                   fputs_filtered ("<optimized out or zero length>", stream);
 845                 }
 846               else
 847                 {
 848                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 849                                    unpack_field_as_long (type, valaddr, i));
 850
 851                   val_print (TYPE_FIELD_TYPE (type, i), VALUE_CONTENTS (v), 0, 0,
 852                              stream, format, 0, recurse + 1, pretty);
 853                 }
 854             }
 855           else
 856             {
 857               if (TYPE_FIELD_IGNORE (type, i))
 858                 {
 859                   fputs_filtered ("<optimized out or zero length>", stream);
 860                 }
 861               else if (TYPE_FIELD_STATIC (type, i))
 862                 {
 863                   /* struct value *v = value_static_field (type, i); v4.17 specific */
 864                   struct value *v;
 865                   v = value_from_longest (TYPE_FIELD_TYPE (type, i),
 866                                    unpack_field_as_long (type, valaddr, i));
 867
 868                   if (v == NULL)
 869                     fputs_filtered ("<optimized out>", stream);
 870                   else
 871                     pascal_object_print_static_field (TYPE_FIELD_TYPE (type, i), v,
 872                                                 stream, format, recurse + 1,
 873                                                       pretty);
 874                 }
 875               else
 876                 {
 877                   /* val_print (TYPE_FIELD_TYPE (type, i),
 878                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
 879                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
 880                      stream, format, 0, recurse + 1, pretty); */
 881                   val_print (TYPE_FIELD_TYPE (type, i),
 882                              valaddr, TYPE_FIELD_BITPOS (type, i) / 8,
 883                              address + TYPE_FIELD_BITPOS (type, i) / 8,
 884                              stream, format, 0, recurse + 1, pretty);
 885                 }
 886             }
 887           annotate_field_end ();
 888         }
 889
 890       if (dont_print_statmem == 0)
 891         {
 892           /* Free the space used to deal with the printing
 893              of the members from top level.  */
 894           obstack_free (&dont_print_statmem_obstack, last_dont_print);
 895           dont_print_statmem_obstack = tmp_obstack;
 896         }
 897
 898       if (pretty)
 899         {
 900           fprintf_filtered (stream, "\n");
 901           print_spaces_filtered (2 * recurse, stream);
 902         }
 903     }
 904   fprintf_filtered (stream, "}");
 905 }
 906
 907 /* Special val_print routine to avoid printing multiple copies of virtual
 908    baseclasses.  */
 909
 910 void
 911 pascal_object_print_value (struct type *type, char *valaddr, CORE_ADDR address,
 912                            struct ui_file *stream, int format, int recurse,
 913                            enum val_prettyprint pretty,
 914                            struct type **dont_print_vb)
 915 {
 916   struct obstack tmp_obstack;
 917   struct type **last_dont_print
 918   = (struct type **) obstack_next_free (&dont_print_vb_obstack);
 919   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
 920
 921   if (dont_print_vb == 0)
 922     {
 923       /* If we're at top level, carve out a completely fresh
 924          chunk of the obstack and use that until this particular
 925          invocation returns.  */
 926       tmp_obstack = dont_print_vb_obstack;
 927       /* Bump up the high-water mark.  Now alpha is omega.  */
 928       obstack_finish (&dont_print_vb_obstack);
 929     }
 930
 931   for (i = 0; i < n_baseclasses; i++)
 932     {
 933       int boffset;
 934       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
 935       char *basename = TYPE_NAME (baseclass);
 936       char *base_valaddr;
 937
 938       if (BASETYPE_VIA_VIRTUAL (type, i))
 939         {
 940           struct type **first_dont_print
 941           = (struct type **) obstack_base (&dont_print_vb_obstack);
 942
 943           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
 944           - first_dont_print;
 945
 946           while (--j >= 0)
 947             if (baseclass == first_dont_print[j])
 948               goto flush_it;
 949
 950           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
 951         }
 952
 953       boffset = baseclass_offset (type, i, valaddr, address);
 954
 955       if (pretty)
 956         {
 957           fprintf_filtered (stream, "\n");
 958           print_spaces_filtered (2 * recurse, stream);
 959         }
 960       fputs_filtered ("<", stream);
 961       /* Not sure what the best notation is in the case where there is no
 962          baseclass name.  */
 963
 964       fputs_filtered (basename ? basename : "", stream);
 965       fputs_filtered ("> = ", stream);
 966
 967       /* The virtual base class pointer might have been clobbered by the
 968          user program. Make sure that it still points to a valid memory
 969          location.  */
 970
 971       if (boffset != -1 && (boffset < 0 || boffset >= TYPE_LENGTH (type)))
 972         {
 973           /* FIXME (alloc): not safe is baseclass is really really big. */
 974           base_valaddr = (char *) alloca (TYPE_LENGTH (baseclass));
 975           if (target_read_memory (address + boffset, base_valaddr,
 976                                   TYPE_LENGTH (baseclass)) != 0)
 977             boffset = -1;
 978         }
 979       else
 980         base_valaddr = valaddr + boffset;
 981
 982       if (boffset == -1)
 983         fprintf_filtered (stream, "<invalid address>");
 984       else
 985         pascal_object_print_value_fields (baseclass, base_valaddr, address + boffset,
 986                                           stream, format, recurse, pretty,
 987                      (struct type **) obstack_base (&dont_print_vb_obstack),
 988                                           0);
 989       fputs_filtered (", ", stream);
 990
 991     flush_it:
 992       ;
 993     }
 994
 995   if (dont_print_vb == 0)
 996     {
 997       /* Free the space used to deal with the printing
 998          of this type from top level.  */
 999       obstack_free (&dont_print_vb_obstack, last_dont_print);
1000       /* Reset watermark so that we can continue protecting
1001          ourselves from whatever we were protecting ourselves.  */
1002       dont_print_vb_obstack = tmp_obstack;
1003     }
1004 }
1005
1006 /* Print value of a static member.
1007    To avoid infinite recursion when printing a class that contains
1008    a static instance of the class, we keep the addresses of all printed
1009    static member classes in an obstack and refuse to print them more
1010    than once.
1011
1012    VAL contains the value to print, TYPE, STREAM, RECURSE, and PRETTY
1013    have the same meanings as in c_val_print.  */
1014
1015 static void
1016 pascal_object_print_static_field (struct type *type, struct value *val,
1017                                   struct ui_file *stream, int format,
1018                                   int recurse, enum val_prettyprint pretty)
1019 {
1020   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1021     {
1022       CORE_ADDR *first_dont_print;
1023       int i;
1024
1025       first_dont_print
1026         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1027       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1028         - first_dont_print;
1029
1030       while (--i >= 0)
1031         {
1032           if (VALUE_ADDRESS (val) == first_dont_print[i])
1033             {
1034               fputs_filtered ("<same as static member of an already seen type>",
1035                               stream);
1036               return;
1037             }
1038         }
1039
1040       obstack_grow (&dont_print_statmem_obstack, (char *) &VALUE_ADDRESS (val),
1041                     sizeof (CORE_ADDR));
1042
1043       CHECK_TYPEDEF (type);
1044       pascal_object_print_value_fields (type, VALUE_CONTENTS (val), VALUE_ADDRESS (val),
1045                                   stream, format, recurse, pretty, NULL, 1);
1046       return;
1047     }
1048   val_print (type, VALUE_CONTENTS (val), 0, VALUE_ADDRESS (val),
1049              stream, format, 0, recurse, pretty);
1050 }
1051
1052 void
1053 pascal_object_print_class_member (char *valaddr, struct type *domain,
1054                                   struct ui_file *stream, char *prefix)
1055 {
1056
1057   /* VAL is a byte offset into the structure type DOMAIN.
1058      Find the name of the field for that offset and
1059      print it.  */
1060   int extra = 0;
1061   int bits = 0;
1062   register unsigned int i;
1063   unsigned len = TYPE_NFIELDS (domain);
1064   /* @@ Make VAL into bit offset */
1065   LONGEST val = unpack_long (builtin_type_int, valaddr) << 3;
1066   for (i = TYPE_N_BASECLASSES (domain); i < len; i++)
1067     {
1068       int bitpos = TYPE_FIELD_BITPOS (domain, i);
1069       QUIT;
1070       if (val == bitpos)
1071         break;
1072       if (val < bitpos && i != 0)
1073         {
1074           /* Somehow pointing into a field.  */
1075           i -= 1;
1076           extra = (val - TYPE_FIELD_BITPOS (domain, i));
1077           if (extra & 0x7)
1078             bits = 1;
1079           else
1080             extra >>= 3;
1081           break;
1082         }
1083     }
1084   if (i < len)
1085     {
1086       char *name;
1087       fprintf_filtered (stream, prefix);
1088       name = type_name_no_tag (domain);
1089       if (name)
1090         fputs_filtered (name, stream);
1091       else
1092         pascal_type_print_base (domain, stream, 0, 0);
1093       fprintf_filtered (stream, "::");
1094       fputs_filtered (TYPE_FIELD_NAME (domain, i), stream);
1095       if (extra)
1096         fprintf_filtered (stream, " + %d bytes", extra);
1097       if (bits)
1098         fprintf_filtered (stream, " (offset in bits)");
1099     }
1100   else
1101     fprintf_filtered (stream, "%ld", (long int) (val >> 3));
1102 }
1103
1104
1105 void
1106 _initialize_pascal_valprint (void)
1107 {
1108   add_show_from_set
1109     (add_set_cmd ("pascal_static-members", class_support, var_boolean,
1110                   (char *) &pascal_static_field_print,
1111                   "Set printing of pascal static members.",
1112                   &setprintlist),
1113      &showprintlist);
1114   /* Turn on printing of static fields.  */
1115   pascal_static_field_print = 1;
1116
1117 }