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