gdb/p-valprint.c

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