gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2020 Free Software Foundation, Inc.
   4
   5    Contributed by Motorola.  Adapted from the C definitions by Farooq Butt
   6    (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
   7
   8    This file is part of GDB.
   9
  10    This program is free software; you can redistribute it and/or modify
  11    it under the terms of the GNU General Public License as published by
  12    the Free Software Foundation; either version 3 of the License, or
  13    (at your option) any later version.
  14
  15    This program is distributed in the hope that it will be useful,
  16    but WITHOUT ANY WARRANTY; without even the implied warranty of
  17    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18    GNU General Public License for more details.
  19
  20    You should have received a copy of the GNU General Public License
  21    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  22
  23 #include "defs.h"
  24 #include "symtab.h"
  25 #include "gdbtypes.h"
  26 #include "expression.h"
  27 #include "value.h"
  28 #include "valprint.h"
  29 #include "language.h"
  30 #include "f-lang.h"
  31 #include "frame.h"
  32 #include "gdbcore.h"
  33 #include "command.h"
  34 #include "block.h"
  35 #include "dictionary.h"
  36 #include "cli/cli-style.h"
  37 #include "gdbarch.h"
  38
  39 static void f77_get_dynamic_length_of_aggregate (struct type *);
  40
  41 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
  42
  43 /* Array which holds offsets to be applied to get a row's elements
  44    for a given array.  Array also holds the size of each subarray.  */
  45
  46 LONGEST
  47 f77_get_lowerbound (struct type *type)
  48 {
  49   if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
  50     error (_("Lower bound may not be '*' in F77"));
  51
  52   return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
  53 }
  54
  55 LONGEST
  56 f77_get_upperbound (struct type *type)
  57 {
  58   if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
  59     {
  60       /* We have an assumed size array on our hands.  Assume that
  61          upper_bound == lower_bound so that we show at least 1 element.
  62          If the user wants to see more elements, let him manually ask for 'em
  63          and we'll subscript the array and show him.  */
  64
  65       return f77_get_lowerbound (type);
  66     }
  67
  68   return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
  69 }
  70
  71 /* Obtain F77 adjustable array dimensions.  */
  72
  73 static void
  74 f77_get_dynamic_length_of_aggregate (struct type *type)
  75 {
  76   int upper_bound = -1;
  77   int lower_bound = 1;
  78
  79   /* Recursively go all the way down into a possibly multi-dimensional
  80      F77 array and get the bounds.  For simple arrays, this is pretty
  81      easy but when the bounds are dynamic, we must be very careful
  82      to add up all the lengths correctly.  Not doing this right
  83      will lead to horrendous-looking arrays in parameter lists.
  84
  85      This function also works for strings which behave very
  86      similarly to arrays.  */
  87
  88   if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
  89       || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
  90     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
  91
  92   /* Recursion ends here, start setting up lengths.  */
  93   lower_bound = f77_get_lowerbound (type);
  94   upper_bound = f77_get_upperbound (type);
  95
  96   /* Patch in a valid length value.  */
  97
  98   TYPE_LENGTH (type) =
  99     (upper_bound - lower_bound + 1)
 100     * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 101 }
 102
 103 /* Actual function which prints out F77 arrays, Valaddr == address in
 104    the superior.  Address == the address in the inferior.  */
 105
 106 static void
 107 f77_print_array_1 (int nss, int ndimensions, struct type *type,
 108                    const gdb_byte *valaddr,
 109                    int embedded_offset, CORE_ADDR address,
 110                    struct ui_file *stream, int recurse,
 111                    const struct value *val,
 112                    const struct value_print_options *options,
 113                    int *elts)
 114 {
 115   struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
 116   CORE_ADDR addr = address + embedded_offset;
 117   LONGEST lowerbound, upperbound;
 118   LONGEST i;
 119
 120   get_discrete_bounds (range_type, &lowerbound, &upperbound);
 121
 122   if (nss != ndimensions)
 123     {
 124       struct gdbarch *gdbarch = get_type_arch (type);
 125       size_t dim_size = type_length_units (TYPE_TARGET_TYPE (type));
 126       int unit_size = gdbarch_addressable_memory_unit_size (gdbarch);
 127       size_t byte_stride = TYPE_ARRAY_BIT_STRIDE (type) / (unit_size * 8);
 128       if (byte_stride == 0)
 129         byte_stride = dim_size;
 130       size_t offs = 0;
 131
 132       for (i = lowerbound;
 133            (i < upperbound + 1 && (*elts) < options->print_max);
 134            i++)
 135         {
 136           struct value *subarray = value_from_contents_and_address
 137             (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
 138              + offs, addr + offs);
 139
 140           fprintf_filtered (stream, "( ");
 141           f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),
 142                              value_contents_for_printing (subarray),
 143                              value_embedded_offset (subarray),
 144                              value_address (subarray),
 145                              stream, recurse, subarray, options, elts);
 146           offs += byte_stride;
 147           fprintf_filtered (stream, ") ");
 148         }
 149       if (*elts >= options->print_max && i < upperbound)
 150         fprintf_filtered (stream, "...");
 151     }
 152   else
 153     {
 154       for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
 155            i++, (*elts)++)
 156         {
 157           struct value *elt = value_subscript ((struct value *)val, i);
 158
 159           val_print (value_type (elt),
 160                      value_embedded_offset (elt),
 161                      value_address (elt), stream, recurse,
 162                      elt, options, current_language);
 163
 164           if (i != upperbound)
 165             fprintf_filtered (stream, ", ");
 166
 167           if ((*elts == options->print_max - 1)
 168               && (i != upperbound))
 169             fprintf_filtered (stream, "...");
 170         }
 171     }
 172 }
 173
 174 /* This function gets called to print an F77 array, we set up some
 175    stuff and then immediately call f77_print_array_1().  */
 176
 177 static void
 178 f77_print_array (struct type *type, const gdb_byte *valaddr,
 179                  int embedded_offset,
 180                  CORE_ADDR address, struct ui_file *stream,
 181                  int recurse,
 182                  const struct value *val,
 183                  const struct value_print_options *options)
 184 {
 185   int ndimensions;
 186   int elts = 0;
 187
 188   ndimensions = calc_f77_array_dims (type);
 189
 190   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 191     error (_("\
 192 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 193            ndimensions, MAX_FORTRAN_DIMS);
 194
 195   f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
 196                      address, stream, recurse, val, options, &elts);
 197 }
 198 \f
 199
 200 /* Decorations for Fortran.  */
 201
 202 static const struct generic_val_print_decorations f_decorations =
 203 {
 204   "(",
 205   ",",
 206   ")",
 207   ".TRUE.",
 208   ".FALSE.",
 209   "void",
 210   "{",
 211   "}"
 212 };
 213
 214 /* See val_print for a description of the various parameters of this
 215    function; they are identical.  */
 216
 217 void
 218 f_val_print (struct type *type, int embedded_offset,
 219              CORE_ADDR address, struct ui_file *stream, int recurse,
 220              struct value *original_value,
 221              const struct value_print_options *options)
 222 {
 223   struct gdbarch *gdbarch = get_type_arch (type);
 224   int printed_field = 0; /* Number of fields printed.  */
 225   struct type *elttype;
 226   CORE_ADDR addr;
 227   int index;
 228   const gdb_byte *valaddr =value_contents_for_printing (original_value);
 229
 230   type = check_typedef (type);
 231   switch (TYPE_CODE (type))
 232     {
 233     case TYPE_CODE_STRING:
 234       f77_get_dynamic_length_of_aggregate (type);
 235       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 236                        valaddr + embedded_offset,
 237                        TYPE_LENGTH (type), NULL, 0, options);
 238       break;
 239
 240     case TYPE_CODE_ARRAY:
 241       if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
 242         {
 243           fprintf_filtered (stream, "(");
 244           f77_print_array (type, valaddr, embedded_offset,
 245                            address, stream, recurse, original_value, options);
 246           fprintf_filtered (stream, ")");
 247         }
 248       else
 249         {
 250           struct type *ch_type = TYPE_TARGET_TYPE (type);
 251
 252           f77_get_dynamic_length_of_aggregate (type);
 253           LA_PRINT_STRING (stream, ch_type,
 254                            valaddr + embedded_offset,
 255                            TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
 256                            NULL, 0, options);
 257         }
 258       break;
 259
 260     case TYPE_CODE_PTR:
 261       if (options->format && options->format != 's')
 262         {
 263           val_print_scalar_formatted (type, embedded_offset,
 264                                       original_value, options, 0, stream);
 265           break;
 266         }
 267       else
 268         {
 269           int want_space = 0;
 270
 271           addr = unpack_pointer (type, valaddr + embedded_offset);
 272           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 273
 274           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 275             {
 276               /* Try to print what function it points to.  */
 277               print_function_pointer_address (options, gdbarch, addr, stream);
 278               return;
 279             }
 280
 281           if (options->symbol_print)
 282             want_space = print_address_demangle (options, gdbarch, addr,
 283                                                  stream, demangle);
 284           else if (options->addressprint && options->format != 's')
 285             {
 286               fputs_filtered (paddress (gdbarch, addr), stream);
 287               want_space = 1;
 288             }
 289
 290           /* For a pointer to char or unsigned char, also print the string
 291              pointed to, unless pointer is null.  */
 292           if (TYPE_LENGTH (elttype) == 1
 293               && TYPE_CODE (elttype) == TYPE_CODE_INT
 294               && (options->format == 0 || options->format == 's')
 295               && addr != 0)
 296             {
 297               if (want_space)
 298                 fputs_filtered (" ", stream);
 299               val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
 300                                 stream, options);
 301             }
 302           return;
 303         }
 304       break;
 305
 306     case TYPE_CODE_INT:
 307       if (options->format || options->output_format)
 308         {
 309           struct value_print_options opts = *options;
 310
 311           opts.format = (options->format ? options->format
 312                          : options->output_format);
 313           val_print_scalar_formatted (type, embedded_offset,
 314                                       original_value, &opts, 0, stream);
 315         }
 316       else
 317         val_print_scalar_formatted (type, embedded_offset,
 318                                     original_value, options, 0, stream);
 319       break;
 320
 321     case TYPE_CODE_STRUCT:
 322     case TYPE_CODE_UNION:
 323       /* Starting from the Fortran 90 standard, Fortran supports derived
 324          types.  */
 325       fprintf_filtered (stream, "( ");
 326       for (index = 0; index < TYPE_NFIELDS (type); index++)
 327         {
 328           struct value *field = value_field
 329             ((struct value *)original_value, index);
 330
 331           struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, index));
 332
 333
 334           if (TYPE_CODE (field_type) != TYPE_CODE_FUNC)
 335             {
 336               const char *field_name;
 337
 338               if (printed_field > 0)
 339                 fputs_filtered (", ", stream);
 340
 341               field_name = TYPE_FIELD_NAME (type, index);
 342               if (field_name != NULL)
 343                 {
 344                   fputs_styled (field_name, variable_name_style.style (),
 345                                 stream);
 346                   fputs_filtered (" = ", stream);
 347                 }
 348
 349               val_print (value_type (field),
 350                          value_embedded_offset (field),
 351                          value_address (field), stream, recurse + 1,
 352                          field, options, current_language);
 353
 354               ++printed_field;
 355             }
 356          }
 357       fprintf_filtered (stream, " )");
 358       break;
 359
 360     case TYPE_CODE_BOOL:
 361       if (options->format || options->output_format)
 362         {
 363           struct value_print_options opts = *options;
 364           opts.format = (options->format ? options->format
 365                          : options->output_format);
 366           val_print_scalar_formatted (type, embedded_offset,
 367                                       original_value, &opts, 0, stream);
 368         }
 369       else
 370         {
 371           int unit_size = gdbarch_addressable_memory_unit_size (gdbarch);
 372           LONGEST val
 373             = unpack_long (type, valaddr + embedded_offset * unit_size);
 374           /* The Fortran standard doesn't specify how logical types are
 375              represented.  Different compilers use different non zero
 376              values to represent logical true.  */
 377           if (val == 0)
 378             fputs_filtered (f_decorations.false_name, stream);
 379           else
 380             fputs_filtered (f_decorations.true_name, stream);
 381         }
 382       break;
 383
 384     case TYPE_CODE_REF:
 385     case TYPE_CODE_FUNC:
 386     case TYPE_CODE_FLAGS:
 387     case TYPE_CODE_FLT:
 388     case TYPE_CODE_VOID:
 389     case TYPE_CODE_ERROR:
 390     case TYPE_CODE_RANGE:
 391     case TYPE_CODE_UNDEF:
 392     case TYPE_CODE_COMPLEX:
 393     case TYPE_CODE_CHAR:
 394     default:
 395       generic_val_print (type, embedded_offset, address,
 396                          stream, recurse, original_value, options,
 397                          &f_decorations);
 398       break;
 399     }
 400 }
 401
 402 static void
 403 info_common_command_for_block (const struct block *block, const char *comname,
 404                                int *any_printed)
 405 {
 406   struct block_iterator iter;
 407   struct symbol *sym;
 408   struct value_print_options opts;
 409
 410   get_user_print_options (&opts);
 411
 412   ALL_BLOCK_SYMBOLS (block, iter, sym)
 413     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 414       {
 415         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 416         size_t index;
 417
 418         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 419
 420         if (comname && (!sym->linkage_name ()
 421                         || strcmp (comname, sym->linkage_name ()) != 0))
 422           continue;
 423
 424         if (*any_printed)
 425           putchar_filtered ('\n');
 426         else
 427           *any_printed = 1;
 428         if (sym->print_name ())
 429           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 430                            sym->print_name ());
 431         else
 432           printf_filtered (_("Contents of blank COMMON block:\n"));
 433
 434         for (index = 0; index < common->n_entries; index++)
 435           {
 436             struct value *val = NULL;
 437
 438             printf_filtered ("%s = ",
 439                              common->contents[index]->print_name ());
 440
 441             try
 442               {
 443                 val = value_of_variable (common->contents[index], block);
 444                 value_print (val, gdb_stdout, &opts);
 445               }
 446
 447             catch (const gdb_exception_error &except)
 448               {
 449                 fprintf_styled (gdb_stdout, metadata_style.style (),
 450                                 "<error reading variable: %s>",
 451                                 except.what ());
 452               }
 453
 454             putchar_filtered ('\n');
 455           }
 456       }
 457 }
 458
 459 /* This function is used to print out the values in a given COMMON
 460    block.  It will always use the most local common block of the
 461    given name.  */
 462
 463 static void
 464 info_common_command (const char *comname, int from_tty)
 465 {
 466   struct frame_info *fi;
 467   const struct block *block;
 468   int values_printed = 0;
 469
 470   /* We have been told to display the contents of F77 COMMON
 471      block supposedly visible in this function.  Let us
 472      first make sure that it is visible and if so, let
 473      us display its contents.  */
 474
 475   fi = get_selected_frame (_("No frame selected"));
 476
 477   /* The following is generally ripped off from stack.c's routine
 478      print_frame_info().  */
 479
 480   block = get_frame_block (fi, 0);
 481   if (block == NULL)
 482     {
 483       printf_filtered (_("No symbol table info available.\n"));
 484       return;
 485     }
 486
 487   while (block)
 488     {
 489       info_common_command_for_block (block, comname, &values_printed);
 490       /* After handling the function's top-level block, stop.  Don't
 491          continue to its superblock, the block of per-file symbols.  */
 492       if (BLOCK_FUNCTION (block))
 493         break;
 494       block = BLOCK_SUPERBLOCK (block);
 495     }
 496
 497   if (!values_printed)
 498     {
 499       if (comname)
 500         printf_filtered (_("No common block '%s'.\n"), comname);
 501       else
 502         printf_filtered (_("No common blocks.\n"));
 503     }
 504 }
 505
 506 void _initialize_f_valprint ();
 507 void
 508 _initialize_f_valprint ()
 509 {
 510   add_info ("common", info_common_command,
 511             _("Print out the values contained in a Fortran COMMON block."));
 512 }