gdb/p-valprint.c

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