gdb/p-valprint.c

   1 /* Support for printing Pascal values for GDB, the GNU debugger.
   2
   3    Copyright (C) 2000-2020 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 3 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, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* This file is derived from c-valprint.c */
  21
  22 #include "defs.h"
  23 #include "gdb_obstack.h"
  24 #include "symtab.h"
  25 #include "gdbtypes.h"
  26 #include "expression.h"
  27 #include "value.h"
  28 #include "command.h"
  29 #include "gdbcmd.h"
  30 #include "gdbcore.h"
  31 #include "demangle.h"
  32 #include "valprint.h"
  33 #include "typeprint.h"
  34 #include "language.h"
  35 #include "target.h"
  36 #include "annotate.h"
  37 #include "p-lang.h"
  38 #include "cp-abi.h"
  39 #include "cp-support.h"
  40 #include "objfiles.h"
  41 #include "gdbsupport/byte-vector.h"
  42 #include "cli/cli-style.h"
  43 \f
  44
  45 static void pascal_object_print_value_fields (struct type *, const gdb_byte *,
  46                                               LONGEST,
  47                                               CORE_ADDR, struct ui_file *,
  48                                               int,
  49                                               struct value *,
  50                                               const struct value_print_options *,
  51                                               struct type **, int);
  52
  53 /* Decorations for Pascal.  */
  54
  55 static const struct generic_val_print_decorations p_decorations =
  56 {
  57   "",
  58   " + ",
  59   " * I",
  60   "true",
  61   "false",
  62   "void",
  63   "{",
  64   "}"
  65 };
  66
  67 /* See val_print for a description of the various parameters of this
  68    function; they are identical.  */
  69
  70 void
  71 pascal_val_print (struct type *type,
  72                   int embedded_offset, CORE_ADDR address,
  73                   struct ui_file *stream, int recurse,
  74                   struct value *original_value,
  75                   const struct value_print_options *options)
  76 {
  77   struct gdbarch *gdbarch = get_type_arch (type);
  78   enum bfd_endian byte_order = type_byte_order (type);
  79   unsigned int i = 0;   /* Number of characters printed */
  80   unsigned len;
  81   struct type *elttype;
  82   unsigned eltlen;
  83   int length_pos, length_size, string_pos;
  84   struct type *char_type;
  85   CORE_ADDR addr;
  86   int want_space = 0;
  87   const gdb_byte *valaddr = value_contents_for_printing (original_value);
  88
  89   type = check_typedef (type);
  90   switch (TYPE_CODE (type))
  91     {
  92     case TYPE_CODE_ARRAY:
  93       {
  94         LONGEST low_bound, high_bound;
  95
  96         if (get_array_bounds (type, &low_bound, &high_bound))
  97           {
  98             len = high_bound - low_bound + 1;
  99             elttype = check_typedef (TYPE_TARGET_TYPE (type));
 100             eltlen = TYPE_LENGTH (elttype);
 101             if (options->prettyformat_arrays)
 102               {
 103                 print_spaces_filtered (2 + 2 * recurse, stream);
 104               }
 105             /* If 's' format is used, try to print out as string.
 106                If no format is given, print as string if element type
 107                is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
 108             if (options->format == 's'
 109                 || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
 110                     && TYPE_CODE (elttype) == TYPE_CODE_CHAR
 111                     && options->format == 0))
 112               {
 113                 /* If requested, look for the first null char and only print
 114                    elements up to it.  */
 115                 if (options->stop_print_at_null)
 116                   {
 117                     unsigned int temp_len;
 118
 119                     /* Look for a NULL char.  */
 120                     for (temp_len = 0;
 121                          extract_unsigned_integer (valaddr + embedded_offset +
 122                                                    temp_len * eltlen, eltlen,
 123                                                    byte_order)
 124                            && temp_len < len && temp_len < options->print_max;
 125                          temp_len++);
 126                     len = temp_len;
 127                   }
 128
 129                 LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
 130                                  valaddr + embedded_offset, len, NULL, 0,
 131                                  options);
 132                 i = len;
 133               }
 134             else
 135               {
 136                 fprintf_filtered (stream, "{");
 137                 /* If this is a virtual function table, print the 0th
 138                    entry specially, and the rest of the members normally.  */
 139                 if (pascal_object_is_vtbl_ptr_type (elttype))
 140                   {
 141                     i = 1;
 142                     fprintf_filtered (stream, "%d vtable entries", len - 1);
 143                   }
 144                 else
 145                   {
 146                     i = 0;
 147                   }
 148                 val_print_array_elements (type, embedded_offset,
 149                                           address, stream, recurse,
 150                                           original_value, options, i);
 151                 fprintf_filtered (stream, "}");
 152               }
 153             break;
 154           }
 155         /* Array of unspecified length: treat like pointer to first elt.  */
 156         addr = address + embedded_offset;
 157       }
 158       goto print_unpacked_pointer;
 159
 160     case TYPE_CODE_PTR:
 161       if (options->format && options->format != 's')
 162         {
 163           val_print_scalar_formatted (type, embedded_offset,
 164                                       original_value, options, 0, stream);
 165           break;
 166         }
 167       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 168         {
 169           /* Print the unmangled name if desired.  */
 170           /* Print vtable entry - we only get here if we ARE using
 171              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
 172           /* Extract the address, assume that it is unsigned.  */
 173           addr = extract_unsigned_integer (valaddr + embedded_offset,
 174                                            TYPE_LENGTH (type), byte_order);
 175           print_address_demangle (options, gdbarch, addr, stream, demangle);
 176           break;
 177         }
 178       check_typedef (TYPE_TARGET_TYPE (type));
 179
 180       addr = unpack_pointer (type, valaddr + embedded_offset);
 181     print_unpacked_pointer:
 182       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 183
 184       if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 185         {
 186           /* Try to print what function it points to.  */
 187           print_address_demangle (options, gdbarch, addr, stream, demangle);
 188           return;
 189         }
 190
 191       if (options->addressprint && options->format != 's')
 192         {
 193           fputs_filtered (paddress (gdbarch, addr), stream);
 194           want_space = 1;
 195         }
 196
 197       /* For a pointer to char or unsigned char, also print the string
 198          pointed to, unless pointer is null.  */
 199       if (((TYPE_LENGTH (elttype) == 1
 200            && (TYPE_CODE (elttype) == TYPE_CODE_INT
 201               || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 202           || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
 203               && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 204           && (options->format == 0 || options->format == 's')
 205           && addr != 0)
 206         {
 207           if (want_space)
 208             fputs_filtered (" ", stream);
 209           /* No wide string yet.  */
 210           i = val_print_string (elttype, NULL, addr, -1, stream, options);
 211         }
 212       /* Also for pointers to pascal strings.  */
 213       /* Note: this is Free Pascal specific:
 214          as GDB does not recognize stabs pascal strings
 215          Pascal strings are mapped to records
 216          with lowercase names PM.  */
 217       if (is_pascal_string_type (elttype, &length_pos, &length_size,
 218                                  &string_pos, &char_type, NULL)
 219           && addr != 0)
 220         {
 221           ULONGEST string_length;
 222           gdb_byte *buffer;
 223
 224           if (want_space)
 225             fputs_filtered (" ", stream);
 226           buffer = (gdb_byte *) xmalloc (length_size);
 227           read_memory (addr + length_pos, buffer, length_size);
 228           string_length = extract_unsigned_integer (buffer, length_size,
 229                                                     byte_order);
 230           xfree (buffer);
 231           i = val_print_string (char_type, NULL,
 232                                 addr + string_pos, string_length,
 233                                 stream, options);
 234         }
 235       else if (pascal_object_is_vtbl_member (type))
 236         {
 237           /* Print vtbl's nicely.  */
 238           CORE_ADDR vt_address = unpack_pointer (type,
 239                                                  valaddr + embedded_offset);
 240           struct bound_minimal_symbol msymbol =
 241             lookup_minimal_symbol_by_pc (vt_address);
 242
 243           /* If 'symbol_print' is set, we did the work above.  */
 244           if (!options->symbol_print
 245               && (msymbol.minsym != NULL)
 246               && (vt_address == BMSYMBOL_VALUE_ADDRESS (msymbol)))
 247             {
 248               if (want_space)
 249                 fputs_filtered (" ", stream);
 250               fputs_filtered ("<", stream);
 251               fputs_filtered (msymbol.minsym->print_name (), stream);
 252               fputs_filtered (">", stream);
 253               want_space = 1;
 254             }
 255           if (vt_address && options->vtblprint)
 256             {
 257               struct value *vt_val;
 258               struct symbol *wsym = NULL;
 259               struct type *wtype;
 260
 261               if (want_space)
 262                 fputs_filtered (" ", stream);
 263
 264               if (msymbol.minsym != NULL)
 265                 {
 266                   const char *search_name = msymbol.minsym->search_name ();
 267                   wsym = lookup_symbol_search_name (search_name, NULL,
 268                                                     VAR_DOMAIN).symbol;
 269                 }
 270
 271               if (wsym)
 272                 {
 273                   wtype = SYMBOL_TYPE (wsym);
 274                 }
 275               else
 276                 {
 277                   wtype = TYPE_TARGET_TYPE (type);
 278                 }
 279               vt_val = value_at (wtype, vt_address);
 280               common_val_print (vt_val, stream, recurse + 1, options,
 281                                 current_language);
 282               if (options->prettyformat)
 283                 {
 284                   fprintf_filtered (stream, "\n");
 285                   print_spaces_filtered (2 + 2 * recurse, stream);
 286                 }
 287             }
 288         }
 289
 290       return;
 291
 292     case TYPE_CODE_REF:
 293     case TYPE_CODE_ENUM:
 294     case TYPE_CODE_FLAGS:
 295     case TYPE_CODE_FUNC:
 296     case TYPE_CODE_RANGE:
 297     case TYPE_CODE_INT:
 298     case TYPE_CODE_FLT:
 299     case TYPE_CODE_VOID:
 300     case TYPE_CODE_ERROR:
 301     case TYPE_CODE_UNDEF:
 302     case TYPE_CODE_BOOL:
 303     case TYPE_CODE_CHAR:
 304       generic_val_print (type, embedded_offset, address,
 305                          stream, recurse, original_value, options,
 306                          &p_decorations);
 307       break;
 308
 309     case TYPE_CODE_UNION:
 310       if (recurse && !options->unionprint)
 311         {
 312           fprintf_filtered (stream, "{...}");
 313           break;
 314         }
 315       /* Fall through.  */
 316     case TYPE_CODE_STRUCT:
 317       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 318         {
 319           /* Print the unmangled name if desired.  */
 320           /* Print vtable entry - we only get here if NOT using
 321              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
 322           /* Extract the address, assume that it is unsigned.  */
 323           print_address_demangle
 324             (options, gdbarch,
 325              extract_unsigned_integer (valaddr + embedded_offset
 326                                        + TYPE_FIELD_BITPOS (type,
 327                                                             VTBL_FNADDR_OFFSET) / 8,
 328                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type,
 329                                                                      VTBL_FNADDR_OFFSET)),
 330                                        byte_order),
 331              stream, demangle);
 332         }
 333       else
 334         {
 335           if (is_pascal_string_type (type, &length_pos, &length_size,
 336                                      &string_pos, &char_type, NULL))
 337             {
 338               len = extract_unsigned_integer (valaddr + embedded_offset
 339                                               + length_pos, length_size,
 340                                               byte_order);
 341               LA_PRINT_STRING (stream, char_type,
 342                                valaddr + embedded_offset + string_pos,
 343                                len, NULL, 0, options);
 344             }
 345           else
 346             pascal_object_print_value_fields (type, valaddr, embedded_offset,
 347                                               address, stream, recurse,
 348                                               original_value, options,
 349                                               NULL, 0);
 350         }
 351       break;
 352
 353     case TYPE_CODE_SET:
 354       elttype = TYPE_INDEX_TYPE (type);
 355       elttype = check_typedef (elttype);
 356       if (TYPE_STUB (elttype))
 357         {
 358           fprintf_styled (stream, metadata_style.style (), "<incomplete type>");
 359           break;
 360         }
 361       else
 362         {
 363           struct type *range = elttype;
 364           LONGEST low_bound, high_bound;
 365           int need_comma = 0;
 366
 367           fputs_filtered ("[", stream);
 368
 369           int bound_info = get_discrete_bounds (range, &low_bound, &high_bound);
 370           if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
 371             {
 372               /* If we know the size of the set type, we can figure out the
 373               maximum value.  */
 374               bound_info = 0;
 375               high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
 376               TYPE_HIGH_BOUND (range) = high_bound;
 377             }
 378         maybe_bad_bstring:
 379           if (bound_info < 0)
 380             {
 381               fputs_styled ("<error value>", metadata_style.style (), stream);
 382               goto done;
 383             }
 384
 385           for (i = low_bound; i <= high_bound; i++)
 386             {
 387               int element = value_bit_index (type,
 388                                              valaddr + embedded_offset, i);
 389
 390               if (element < 0)
 391                 {
 392                   i = element;
 393                   goto maybe_bad_bstring;
 394                 }
 395               if (element)
 396                 {
 397                   if (need_comma)
 398                     fputs_filtered (", ", stream);
 399                   print_type_scalar (range, i, stream);
 400                   need_comma = 1;
 401
 402                   if (i + 1 <= high_bound
 403                       && value_bit_index (type,
 404                                           valaddr + embedded_offset, ++i))
 405                     {
 406                       int j = i;
 407
 408                       fputs_filtered ("..", stream);
 409                       while (i + 1 <= high_bound
 410                              && value_bit_index (type,
 411                                                  valaddr + embedded_offset,
 412                                                  ++i))
 413                         j = i;
 414                       print_type_scalar (range, j, stream);
 415                     }
 416                 }
 417             }
 418         done:
 419           fputs_filtered ("]", stream);
 420         }
 421       break;
 422
 423     default:
 424       error (_("Invalid pascal type code %d in symbol table."),
 425              TYPE_CODE (type));
 426     }
 427 }
 428
 429 /* See p-lang.h.  */
 430
 431 void
 432 pascal_value_print_inner (struct value *val, struct ui_file *stream,
 433                           int recurse,
 434                           const struct value_print_options *options)
 435
 436 {
 437   struct type *type = check_typedef (value_type (val));
 438   struct gdbarch *gdbarch = get_type_arch (type);
 439   enum bfd_endian byte_order = type_byte_order (type);
 440   unsigned int i = 0;   /* Number of characters printed */
 441   unsigned len;
 442   struct type *elttype;
 443   unsigned eltlen;
 444   int length_pos, length_size, string_pos;
 445   struct type *char_type;
 446   CORE_ADDR addr;
 447   int want_space = 0;
 448   const gdb_byte *valaddr = value_contents_for_printing (val);
 449
 450   switch (TYPE_CODE (type))
 451     {
 452     case TYPE_CODE_ARRAY:
 453       {
 454         LONGEST low_bound, high_bound;
 455
 456         if (get_array_bounds (type, &low_bound, &high_bound))
 457           {
 458             len = high_bound - low_bound + 1;
 459             elttype = check_typedef (TYPE_TARGET_TYPE (type));
 460             eltlen = TYPE_LENGTH (elttype);
 461             if (options->prettyformat_arrays)
 462               {
 463                 print_spaces_filtered (2 + 2 * recurse, stream);
 464               }
 465             /* If 's' format is used, try to print out as string.
 466                If no format is given, print as string if element type
 467                is of TYPE_CODE_CHAR and element size is 1,2 or 4.  */
 468             if (options->format == 's'
 469                 || ((eltlen == 1 || eltlen == 2 || eltlen == 4)
 470                     && TYPE_CODE (elttype) == TYPE_CODE_CHAR
 471                     && options->format == 0))
 472               {
 473                 /* If requested, look for the first null char and only print
 474                    elements up to it.  */
 475                 if (options->stop_print_at_null)
 476                   {
 477                     unsigned int temp_len;
 478
 479                     /* Look for a NULL char.  */
 480                     for (temp_len = 0;
 481                          extract_unsigned_integer (valaddr + temp_len * eltlen,
 482                                                    eltlen, byte_order)
 483                            && temp_len < len && temp_len < options->print_max;
 484                          temp_len++);
 485                     len = temp_len;
 486                   }
 487
 488                 LA_PRINT_STRING (stream, TYPE_TARGET_TYPE (type),
 489                                  valaddr, len, NULL, 0, options);
 490                 i = len;
 491               }
 492             else
 493               {
 494                 fprintf_filtered (stream, "{");
 495                 /* If this is a virtual function table, print the 0th
 496                    entry specially, and the rest of the members normally.  */
 497                 if (pascal_object_is_vtbl_ptr_type (elttype))
 498                   {
 499                     i = 1;
 500                     fprintf_filtered (stream, "%d vtable entries", len - 1);
 501                   }
 502                 else
 503                   {
 504                     i = 0;
 505                   }
 506                 value_print_array_elements (val, stream, recurse, options, i);
 507                 fprintf_filtered (stream, "}");
 508               }
 509             break;
 510           }
 511         /* Array of unspecified length: treat like pointer to first elt.  */
 512         addr = value_address (val);
 513       }
 514       goto print_unpacked_pointer;
 515
 516     case TYPE_CODE_PTR:
 517       if (options->format && options->format != 's')
 518         {
 519           value_print_scalar_formatted (val, options, 0, stream);
 520           break;
 521         }
 522       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 523         {
 524           /* Print the unmangled name if desired.  */
 525           /* Print vtable entry - we only get here if we ARE using
 526              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_STRUCT.)  */
 527           /* Extract the address, assume that it is unsigned.  */
 528           addr = extract_unsigned_integer (valaddr,
 529                                            TYPE_LENGTH (type), byte_order);
 530           print_address_demangle (options, gdbarch, addr, stream, demangle);
 531           break;
 532         }
 533       check_typedef (TYPE_TARGET_TYPE (type));
 534
 535       addr = unpack_pointer (type, valaddr);
 536     print_unpacked_pointer:
 537       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 538
 539       if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 540         {
 541           /* Try to print what function it points to.  */
 542           print_address_demangle (options, gdbarch, addr, stream, demangle);
 543           return;
 544         }
 545
 546       if (options->addressprint && options->format != 's')
 547         {
 548           fputs_filtered (paddress (gdbarch, addr), stream);
 549           want_space = 1;
 550         }
 551
 552       /* For a pointer to char or unsigned char, also print the string
 553          pointed to, unless pointer is null.  */
 554       if (((TYPE_LENGTH (elttype) == 1
 555            && (TYPE_CODE (elttype) == TYPE_CODE_INT
 556               || TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 557           || ((TYPE_LENGTH (elttype) == 2 || TYPE_LENGTH (elttype) == 4)
 558               && TYPE_CODE (elttype) == TYPE_CODE_CHAR))
 559           && (options->format == 0 || options->format == 's')
 560           && addr != 0)
 561         {
 562           if (want_space)
 563             fputs_filtered (" ", stream);
 564           /* No wide string yet.  */
 565           i = val_print_string (elttype, NULL, addr, -1, stream, options);
 566         }
 567       /* Also for pointers to pascal strings.  */
 568       /* Note: this is Free Pascal specific:
 569          as GDB does not recognize stabs pascal strings
 570          Pascal strings are mapped to records
 571          with lowercase names PM.  */
 572       if (is_pascal_string_type (elttype, &length_pos, &length_size,
 573                                  &string_pos, &char_type, NULL)
 574           && addr != 0)
 575         {
 576           ULONGEST string_length;
 577           gdb_byte *buffer;
 578
 579           if (want_space)
 580             fputs_filtered (" ", stream);
 581           buffer = (gdb_byte *) xmalloc (length_size);
 582           read_memory (addr + length_pos, buffer, length_size);
 583           string_length = extract_unsigned_integer (buffer, length_size,
 584                                                     byte_order);
 585           xfree (buffer);
 586           i = val_print_string (char_type, NULL,
 587                                 addr + string_pos, string_length,
 588                                 stream, options);
 589         }
 590       else if (pascal_object_is_vtbl_member (type))
 591         {
 592           /* Print vtbl's nicely.  */
 593           CORE_ADDR vt_address = unpack_pointer (type, valaddr);
 594           struct bound_minimal_symbol msymbol =
 595             lookup_minimal_symbol_by_pc (vt_address);
 596
 597           /* If 'symbol_print' is set, we did the work above.  */
 598           if (!options->symbol_print
 599               && (msymbol.minsym != NULL)
 600               && (vt_address == BMSYMBOL_VALUE_ADDRESS (msymbol)))
 601             {
 602               if (want_space)
 603                 fputs_filtered (" ", stream);
 604               fputs_filtered ("<", stream);
 605               fputs_filtered (msymbol.minsym->print_name (), stream);
 606               fputs_filtered (">", stream);
 607               want_space = 1;
 608             }
 609           if (vt_address && options->vtblprint)
 610             {
 611               struct value *vt_val;
 612               struct symbol *wsym = NULL;
 613               struct type *wtype;
 614
 615               if (want_space)
 616                 fputs_filtered (" ", stream);
 617
 618               if (msymbol.minsym != NULL)
 619                 {
 620                   const char *search_name = msymbol.minsym->search_name ();
 621                   wsym = lookup_symbol_search_name (search_name, NULL,
 622                                                     VAR_DOMAIN).symbol;
 623                 }
 624
 625               if (wsym)
 626                 {
 627                   wtype = SYMBOL_TYPE (wsym);
 628                 }
 629               else
 630                 {
 631                   wtype = TYPE_TARGET_TYPE (type);
 632                 }
 633               vt_val = value_at (wtype, vt_address);
 634               common_val_print (vt_val, stream, recurse + 1, options,
 635                                 current_language);
 636               if (options->prettyformat)
 637                 {
 638                   fprintf_filtered (stream, "\n");
 639                   print_spaces_filtered (2 + 2 * recurse, stream);
 640                 }
 641             }
 642         }
 643
 644       return;
 645
 646     case TYPE_CODE_REF:
 647     case TYPE_CODE_ENUM:
 648     case TYPE_CODE_FLAGS:
 649     case TYPE_CODE_FUNC:
 650     case TYPE_CODE_RANGE:
 651     case TYPE_CODE_INT:
 652     case TYPE_CODE_FLT:
 653     case TYPE_CODE_VOID:
 654     case TYPE_CODE_ERROR:
 655     case TYPE_CODE_UNDEF:
 656     case TYPE_CODE_BOOL:
 657     case TYPE_CODE_CHAR:
 658       generic_value_print (val, stream, recurse, options, &p_decorations);
 659       break;
 660
 661     case TYPE_CODE_UNION:
 662       if (recurse && !options->unionprint)
 663         {
 664           fprintf_filtered (stream, "{...}");
 665           break;
 666         }
 667       /* Fall through.  */
 668     case TYPE_CODE_STRUCT:
 669       if (options->vtblprint && pascal_object_is_vtbl_ptr_type (type))
 670         {
 671           /* Print the unmangled name if desired.  */
 672           /* Print vtable entry - we only get here if NOT using
 673              -fvtable_thunks.  (Otherwise, look under TYPE_CODE_PTR.)  */
 674           /* Extract the address, assume that it is unsigned.  */
 675           print_address_demangle
 676             (options, gdbarch,
 677              extract_unsigned_integer (valaddr
 678                                        + TYPE_FIELD_BITPOS (type,
 679                                                             VTBL_FNADDR_OFFSET) / 8,
 680                                        TYPE_LENGTH (TYPE_FIELD_TYPE (type,
 681                                                                      VTBL_FNADDR_OFFSET)),
 682                                        byte_order),
 683              stream, demangle);
 684         }
 685       else
 686         {
 687           if (is_pascal_string_type (type, &length_pos, &length_size,
 688                                      &string_pos, &char_type, NULL))
 689             {
 690               len = extract_unsigned_integer (valaddr + length_pos,
 691                                               length_size, byte_order);
 692               LA_PRINT_STRING (stream, char_type, valaddr + string_pos,
 693                                len, NULL, 0, options);
 694             }
 695           else
 696             pascal_object_print_value_fields (type, valaddr, 0,
 697                                               value_address (val), stream,
 698                                               recurse, val, options,
 699                                               NULL, 0);
 700         }
 701       break;
 702
 703     case TYPE_CODE_SET:
 704       elttype = TYPE_INDEX_TYPE (type);
 705       elttype = check_typedef (elttype);
 706       if (TYPE_STUB (elttype))
 707         {
 708           fprintf_styled (stream, metadata_style.style (), "<incomplete type>");
 709           break;
 710         }
 711       else
 712         {
 713           struct type *range = elttype;
 714           LONGEST low_bound, high_bound;
 715           int need_comma = 0;
 716
 717           fputs_filtered ("[", stream);
 718
 719           int bound_info = get_discrete_bounds (range, &low_bound, &high_bound);
 720           if (low_bound == 0 && high_bound == -1 && TYPE_LENGTH (type) > 0)
 721             {
 722               /* If we know the size of the set type, we can figure out the
 723               maximum value.  */
 724               bound_info = 0;
 725               high_bound = TYPE_LENGTH (type) * TARGET_CHAR_BIT - 1;
 726               TYPE_HIGH_BOUND (range) = high_bound;
 727             }
 728         maybe_bad_bstring:
 729           if (bound_info < 0)
 730             {
 731               fputs_styled ("<error value>", metadata_style.style (), stream);
 732               goto done;
 733             }
 734
 735           for (i = low_bound; i <= high_bound; i++)
 736             {
 737               int element = value_bit_index (type, valaddr, i);
 738
 739               if (element < 0)
 740                 {
 741                   i = element;
 742                   goto maybe_bad_bstring;
 743                 }
 744               if (element)
 745                 {
 746                   if (need_comma)
 747                     fputs_filtered (", ", stream);
 748                   print_type_scalar (range, i, stream);
 749                   need_comma = 1;
 750
 751                   if (i + 1 <= high_bound
 752                       && value_bit_index (type, valaddr, ++i))
 753                     {
 754                       int j = i;
 755
 756                       fputs_filtered ("..", stream);
 757                       while (i + 1 <= high_bound
 758                              && value_bit_index (type, valaddr, ++i))
 759                         j = i;
 760                       print_type_scalar (range, j, stream);
 761                     }
 762                 }
 763             }
 764         done:
 765           fputs_filtered ("]", stream);
 766         }
 767       break;
 768
 769     default:
 770       error (_("Invalid pascal type code %d in symbol table."),
 771              TYPE_CODE (type));
 772     }
 773 }
 774
 775 \f
 776 void
 777 pascal_value_print (struct value *val, struct ui_file *stream,
 778                     const struct value_print_options *options)
 779 {
 780   struct type *type = value_type (val);
 781   struct value_print_options opts = *options;
 782
 783   opts.deref_ref = 1;
 784
 785   /* If it is a pointer, indicate what it points to.
 786
 787      Print type also if it is a reference.
 788
 789      Object pascal: if it is a member pointer, we will take care
 790      of that when we print it.  */
 791   if (TYPE_CODE (type) == TYPE_CODE_PTR
 792       || TYPE_CODE (type) == TYPE_CODE_REF)
 793     {
 794       /* Hack:  remove (char *) for char strings.  Their
 795          type is indicated by the quoted string anyway.  */
 796       if (TYPE_CODE (type) == TYPE_CODE_PTR
 797           && TYPE_NAME (type) == NULL
 798           && TYPE_NAME (TYPE_TARGET_TYPE (type)) != NULL
 799           && strcmp (TYPE_NAME (TYPE_TARGET_TYPE (type)), "char") == 0)
 800         {
 801           /* Print nothing.  */
 802         }
 803       else
 804         {
 805           fprintf_filtered (stream, "(");
 806           type_print (type, "", stream, -1);
 807           fprintf_filtered (stream, ") ");
 808         }
 809     }
 810   common_val_print (val, stream, 0, &opts, current_language);
 811 }
 812
 813
 814 static void
 815 show_pascal_static_field_print (struct ui_file *file, int from_tty,
 816                                 struct cmd_list_element *c, const char *value)
 817 {
 818   fprintf_filtered (file, _("Printing of pascal static members is %s.\n"),
 819                     value);
 820 }
 821
 822 static struct obstack dont_print_vb_obstack;
 823 static struct obstack dont_print_statmem_obstack;
 824
 825 static void pascal_object_print_static_field (struct value *,
 826                                               struct ui_file *, int,
 827                                               const struct value_print_options *);
 828
 829 static void pascal_object_print_value (struct type *, const gdb_byte *,
 830                                        LONGEST,
 831                                        CORE_ADDR, struct ui_file *, int,
 832                                        struct value *,
 833                                        const struct value_print_options *,
 834                                        struct type **);
 835
 836 /* It was changed to this after 2.4.5.  */
 837 const char pascal_vtbl_ptr_name[] =
 838 {'_', '_', 'v', 't', 'b', 'l', '_', 'p', 't', 'r', '_', 't', 'y', 'p', 'e', 0};
 839
 840 /* Return truth value for assertion that TYPE is of the type
 841    "pointer to virtual function".  */
 842
 843 int
 844 pascal_object_is_vtbl_ptr_type (struct type *type)
 845 {
 846   const char *type_name = TYPE_NAME (type);
 847
 848   return (type_name != NULL
 849           && strcmp (type_name, pascal_vtbl_ptr_name) == 0);
 850 }
 851
 852 /* Return truth value for the assertion that TYPE is of the type
 853    "pointer to virtual function table".  */
 854
 855 int
 856 pascal_object_is_vtbl_member (struct type *type)
 857 {
 858   if (TYPE_CODE (type) == TYPE_CODE_PTR)
 859     {
 860       type = TYPE_TARGET_TYPE (type);
 861       if (TYPE_CODE (type) == TYPE_CODE_ARRAY)
 862         {
 863           type = TYPE_TARGET_TYPE (type);
 864           if (TYPE_CODE (type) == TYPE_CODE_STRUCT      /* If not using
 865                                                            thunks.  */
 866               || TYPE_CODE (type) == TYPE_CODE_PTR)     /* If using thunks.  */
 867             {
 868               /* Virtual functions tables are full of pointers
 869                  to virtual functions.  */
 870               return pascal_object_is_vtbl_ptr_type (type);
 871             }
 872         }
 873     }
 874   return 0;
 875 }
 876
 877 /* Mutually recursive subroutines of pascal_object_print_value and
 878    c_val_print to print out a structure's fields:
 879    pascal_object_print_value_fields and pascal_object_print_value.
 880
 881    TYPE, VALADDR, ADDRESS, STREAM, RECURSE, and OPTIONS have the
 882    same meanings as in pascal_object_print_value and c_val_print.
 883
 884    DONT_PRINT is an array of baseclass types that we
 885    should not print, or zero if called from top level.  */
 886
 887 static void
 888 pascal_object_print_value_fields (struct type *type, const gdb_byte *valaddr,
 889                                   LONGEST offset,
 890                                   CORE_ADDR address, struct ui_file *stream,
 891                                   int recurse,
 892                                   struct value *val,
 893                                   const struct value_print_options *options,
 894                                   struct type **dont_print_vb,
 895                                   int dont_print_statmem)
 896 {
 897   int i, len, n_baseclasses;
 898   char *last_dont_print
 899     = (char *) obstack_next_free (&dont_print_statmem_obstack);
 900
 901   type = check_typedef (type);
 902
 903   fprintf_filtered (stream, "{");
 904   len = TYPE_NFIELDS (type);
 905   n_baseclasses = TYPE_N_BASECLASSES (type);
 906
 907   /* Print out baseclasses such that we don't print
 908      duplicates of virtual baseclasses.  */
 909   if (n_baseclasses > 0)
 910     pascal_object_print_value (type, valaddr, offset, address,
 911                                stream, recurse + 1, val,
 912                                options, dont_print_vb);
 913
 914   if (!len && n_baseclasses == 1)
 915     fprintf_styled (stream, metadata_style.style (), "<No data fields>");
 916   else
 917     {
 918       struct obstack tmp_obstack = dont_print_statmem_obstack;
 919       int fields_seen = 0;
 920
 921       if (dont_print_statmem == 0)
 922         {
 923           /* If we're at top level, carve out a completely fresh
 924              chunk of the obstack and use that until this particular
 925              invocation returns.  */
 926           obstack_finish (&dont_print_statmem_obstack);
 927         }
 928
 929       for (i = n_baseclasses; i < len; i++)
 930         {
 931           /* If requested, skip printing of static fields.  */
 932           if (!options->pascal_static_field_print
 933               && field_is_static (&TYPE_FIELD (type, i)))
 934             continue;
 935           if (fields_seen)
 936             fprintf_filtered (stream, ", ");
 937           else if (n_baseclasses > 0)
 938             {
 939               if (options->prettyformat)
 940                 {
 941                   fprintf_filtered (stream, "\n");
 942                   print_spaces_filtered (2 + 2 * recurse, stream);
 943                   fputs_filtered ("members of ", stream);
 944                   fputs_filtered (TYPE_NAME (type), stream);
 945                   fputs_filtered (": ", stream);
 946                 }
 947             }
 948           fields_seen = 1;
 949
 950           if (options->prettyformat)
 951             {
 952               fprintf_filtered (stream, "\n");
 953               print_spaces_filtered (2 + 2 * recurse, stream);
 954             }
 955           else
 956             {
 957               wrap_here (n_spaces (2 + 2 * recurse));
 958             }
 959
 960           annotate_field_begin (TYPE_FIELD_TYPE (type, i));
 961
 962           if (field_is_static (&TYPE_FIELD (type, i)))
 963             {
 964               fputs_filtered ("static ", stream);
 965               fprintf_symbol_filtered (stream,
 966                                        TYPE_FIELD_NAME (type, i),
 967                                        current_language->la_language,
 968                                        DMGL_PARAMS | DMGL_ANSI);
 969             }
 970           else
 971             fputs_styled (TYPE_FIELD_NAME (type, i),
 972                           variable_name_style.style (), stream);
 973           annotate_field_name_end ();
 974           fputs_filtered (" = ", stream);
 975           annotate_field_value ();
 976
 977           if (!field_is_static (&TYPE_FIELD (type, i))
 978               && TYPE_FIELD_PACKED (type, i))
 979             {
 980               struct value *v;
 981
 982               /* Bitfields require special handling, especially due to byte
 983                  order problems.  */
 984               if (TYPE_FIELD_IGNORE (type, i))
 985                 {
 986                   fputs_styled ("<optimized out or zero length>",
 987                                 metadata_style.style (), stream);
 988                 }
 989               else if (value_bits_synthetic_pointer (val,
 990                                                      TYPE_FIELD_BITPOS (type,
 991                                                                         i),
 992                                                      TYPE_FIELD_BITSIZE (type,
 993                                                                          i)))
 994                 {
 995                   fputs_styled (_("<synthetic pointer>"),
 996                                 metadata_style.style (), stream);
 997                 }
 998               else
 999                 {
1000                   struct value_print_options opts = *options;
1001
1002                   v = value_field_bitfield (type, i, valaddr, offset, val);
1003
1004                   opts.deref_ref = 0;
1005                   common_val_print (v, stream, recurse + 1, &opts,
1006                                     current_language);
1007                 }
1008             }
1009           else
1010             {
1011               if (TYPE_FIELD_IGNORE (type, i))
1012                 {
1013                   fputs_styled ("<optimized out or zero length>",
1014                                 metadata_style.style (), stream);
1015                 }
1016               else if (field_is_static (&TYPE_FIELD (type, i)))
1017                 {
1018                   /* struct value *v = value_static_field (type, i);
1019                      v4.17 specific.  */
1020                   struct value *v;
1021
1022                   v = value_field_bitfield (type, i, valaddr, offset, val);
1023
1024                   if (v == NULL)
1025                     val_print_optimized_out (NULL, stream);
1026                   else
1027                     pascal_object_print_static_field (v, stream, recurse + 1,
1028                                                       options);
1029                 }
1030               else
1031                 {
1032                   struct value_print_options opts = *options;
1033
1034                   opts.deref_ref = 0;
1035                   /* val_print (TYPE_FIELD_TYPE (type, i),
1036                      valaddr + TYPE_FIELD_BITPOS (type, i) / 8,
1037                      address + TYPE_FIELD_BITPOS (type, i) / 8, 0,
1038                      stream, format, 0, recurse + 1, pretty); */
1039                   val_print (TYPE_FIELD_TYPE (type, i),
1040                              offset + TYPE_FIELD_BITPOS (type, i) / 8,
1041                              address, stream, recurse + 1, val, &opts,
1042                              current_language);
1043                 }
1044             }
1045           annotate_field_end ();
1046         }
1047
1048       if (dont_print_statmem == 0)
1049         {
1050           /* Free the space used to deal with the printing
1051              of the members from top level.  */
1052           obstack_free (&dont_print_statmem_obstack, last_dont_print);
1053           dont_print_statmem_obstack = tmp_obstack;
1054         }
1055
1056       if (options->prettyformat)
1057         {
1058           fprintf_filtered (stream, "\n");
1059           print_spaces_filtered (2 * recurse, stream);
1060         }
1061     }
1062   fprintf_filtered (stream, "}");
1063 }
1064
1065 /* Special val_print routine to avoid printing multiple copies of virtual
1066    baseclasses.  */
1067
1068 static void
1069 pascal_object_print_value (struct type *type, const gdb_byte *valaddr,
1070                            LONGEST offset,
1071                            CORE_ADDR address, struct ui_file *stream,
1072                            int recurse,
1073                            struct value *val,
1074                            const struct value_print_options *options,
1075                            struct type **dont_print_vb)
1076 {
1077   struct type **last_dont_print
1078     = (struct type **) obstack_next_free (&dont_print_vb_obstack);
1079   struct obstack tmp_obstack = dont_print_vb_obstack;
1080   int i, n_baseclasses = TYPE_N_BASECLASSES (type);
1081
1082   if (dont_print_vb == 0)
1083     {
1084       /* If we're at top level, carve out a completely fresh
1085          chunk of the obstack and use that until this particular
1086          invocation returns.  */
1087       /* Bump up the high-water mark.  Now alpha is omega.  */
1088       obstack_finish (&dont_print_vb_obstack);
1089     }
1090
1091   for (i = 0; i < n_baseclasses; i++)
1092     {
1093       LONGEST boffset = 0;
1094       struct type *baseclass = check_typedef (TYPE_BASECLASS (type, i));
1095       const char *basename = TYPE_NAME (baseclass);
1096       const gdb_byte *base_valaddr = NULL;
1097       LONGEST thisoffset;
1098       int skip = 0;
1099       gdb::byte_vector buf;
1100
1101       if (BASETYPE_VIA_VIRTUAL (type, i))
1102         {
1103           struct type **first_dont_print
1104             = (struct type **) obstack_base (&dont_print_vb_obstack);
1105
1106           int j = (struct type **) obstack_next_free (&dont_print_vb_obstack)
1107             - first_dont_print;
1108
1109           while (--j >= 0)
1110             if (baseclass == first_dont_print[j])
1111               goto flush_it;
1112
1113           obstack_ptr_grow (&dont_print_vb_obstack, baseclass);
1114         }
1115
1116       thisoffset = offset;
1117
1118       try
1119         {
1120           boffset = baseclass_offset (type, i, valaddr, offset, address, val);
1121         }
1122       catch (const gdb_exception_error &ex)
1123         {
1124           if (ex.error == NOT_AVAILABLE_ERROR)
1125             skip = -1;
1126           else
1127             skip = 1;
1128         }
1129
1130       if (skip == 0)
1131         {
1132           /* The virtual base class pointer might have been clobbered by the
1133              user program. Make sure that it still points to a valid memory
1134              location.  */
1135
1136           if (boffset < 0 || boffset >= TYPE_LENGTH (type))
1137             {
1138               buf.resize (TYPE_LENGTH (baseclass));
1139
1140               base_valaddr = buf.data ();
1141               if (target_read_memory (address + boffset, buf.data (),
1142                                       TYPE_LENGTH (baseclass)) != 0)
1143                 skip = 1;
1144               address = address + boffset;
1145               thisoffset = 0;
1146               boffset = 0;
1147             }
1148           else
1149             base_valaddr = valaddr;
1150         }
1151
1152       if (options->prettyformat)
1153         {
1154           fprintf_filtered (stream, "\n");
1155           print_spaces_filtered (2 * recurse, stream);
1156         }
1157       fputs_filtered ("<", stream);
1158       /* Not sure what the best notation is in the case where there is no
1159          baseclass name.  */
1160
1161       fputs_filtered (basename ? basename : "", stream);
1162       fputs_filtered ("> = ", stream);
1163
1164       if (skip < 0)
1165         val_print_unavailable (stream);
1166       else if (skip > 0)
1167         val_print_invalid_address (stream);
1168       else
1169         pascal_object_print_value_fields (baseclass, base_valaddr,
1170                                           thisoffset + boffset, address,
1171                                           stream, recurse, val, options,
1172                      (struct type **) obstack_base (&dont_print_vb_obstack),
1173                                           0);
1174       fputs_filtered (", ", stream);
1175
1176     flush_it:
1177       ;
1178     }
1179
1180   if (dont_print_vb == 0)
1181     {
1182       /* Free the space used to deal with the printing
1183          of this type from top level.  */
1184       obstack_free (&dont_print_vb_obstack, last_dont_print);
1185       /* Reset watermark so that we can continue protecting
1186          ourselves from whatever we were protecting ourselves.  */
1187       dont_print_vb_obstack = tmp_obstack;
1188     }
1189 }
1190
1191 /* Print value of a static member.
1192    To avoid infinite recursion when printing a class that contains
1193    a static instance of the class, we keep the addresses of all printed
1194    static member classes in an obstack and refuse to print them more
1195    than once.
1196
1197    VAL contains the value to print, STREAM, RECURSE, and OPTIONS
1198    have the same meanings as in c_val_print.  */
1199
1200 static void
1201 pascal_object_print_static_field (struct value *val,
1202                                   struct ui_file *stream,
1203                                   int recurse,
1204                                   const struct value_print_options *options)
1205 {
1206   struct type *type = value_type (val);
1207   struct value_print_options opts;
1208
1209   if (value_entirely_optimized_out (val))
1210     {
1211       val_print_optimized_out (val, stream);
1212       return;
1213     }
1214
1215   if (TYPE_CODE (type) == TYPE_CODE_STRUCT)
1216     {
1217       CORE_ADDR *first_dont_print, addr;
1218       int i;
1219
1220       first_dont_print
1221         = (CORE_ADDR *) obstack_base (&dont_print_statmem_obstack);
1222       i = (CORE_ADDR *) obstack_next_free (&dont_print_statmem_obstack)
1223         - first_dont_print;
1224
1225       while (--i >= 0)
1226         {
1227           if (value_address (val) == first_dont_print[i])
1228             {
1229               fputs_styled (_("\
1230 <same as static member of an already seen type>"),
1231                             metadata_style.style (), stream);
1232               return;
1233             }
1234         }
1235
1236       addr = value_address (val);
1237       obstack_grow (&dont_print_statmem_obstack, (char *) &addr,
1238                     sizeof (CORE_ADDR));
1239
1240       type = check_typedef (type);
1241       pascal_object_print_value_fields (type,
1242                                         value_contents_for_printing (val),
1243                                         value_embedded_offset (val),
1244                                         addr,
1245                                         stream, recurse,
1246                                         val, options, NULL, 1);
1247       return;
1248     }
1249
1250   opts = *options;
1251   opts.deref_ref = 0;
1252   common_val_print (val, stream, recurse, &opts, current_language);
1253 }
1254
1255 void _initialize_pascal_valprint ();
1256 void
1257 _initialize_pascal_valprint ()
1258 {
1259   add_setshow_boolean_cmd ("pascal_static-members", class_support,
1260                            &user_print_options.pascal_static_field_print, _("\
1261 Set printing of pascal static members."), _("\
1262 Show printing of pascal static members."), NULL,
1263                            NULL,
1264                            show_pascal_static_field_print,
1265                            &setprintlist, &showprintlist);
1266 }