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_REF:
 361     case TYPE_CODE_FUNC:
 362     case TYPE_CODE_FLAGS:
 363     case TYPE_CODE_FLT:
 364     case TYPE_CODE_VOID:
 365     case TYPE_CODE_ERROR:
 366     case TYPE_CODE_RANGE:
 367     case TYPE_CODE_UNDEF:
 368     case TYPE_CODE_COMPLEX:
 369     case TYPE_CODE_BOOL:
 370     case TYPE_CODE_CHAR:
 371     default:
 372       generic_val_print (type, embedded_offset, address,
 373                          stream, recurse, original_value, options,
 374                          &f_decorations);
 375       break;
 376     }
 377 }
 378
 379 static void
 380 info_common_command_for_block (const struct block *block, const char *comname,
 381                                int *any_printed)
 382 {
 383   struct block_iterator iter;
 384   struct symbol *sym;
 385   struct value_print_options opts;
 386
 387   get_user_print_options (&opts);
 388
 389   ALL_BLOCK_SYMBOLS (block, iter, sym)
 390     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 391       {
 392         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 393         size_t index;
 394
 395         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 396
 397         if (comname && (!sym->linkage_name ()
 398                         || strcmp (comname, sym->linkage_name ()) != 0))
 399           continue;
 400
 401         if (*any_printed)
 402           putchar_filtered ('\n');
 403         else
 404           *any_printed = 1;
 405         if (sym->print_name ())
 406           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 407                            sym->print_name ());
 408         else
 409           printf_filtered (_("Contents of blank COMMON block:\n"));
 410
 411         for (index = 0; index < common->n_entries; index++)
 412           {
 413             struct value *val = NULL;
 414
 415             printf_filtered ("%s = ",
 416                              common->contents[index]->print_name ());
 417
 418             try
 419               {
 420                 val = value_of_variable (common->contents[index], block);
 421                 value_print (val, gdb_stdout, &opts);
 422               }
 423
 424             catch (const gdb_exception_error &except)
 425               {
 426                 fprintf_styled (gdb_stdout, metadata_style.style (),
 427                                 "<error reading variable: %s>",
 428                                 except.what ());
 429               }
 430
 431             putchar_filtered ('\n');
 432           }
 433       }
 434 }
 435
 436 /* This function is used to print out the values in a given COMMON
 437    block.  It will always use the most local common block of the
 438    given name.  */
 439
 440 static void
 441 info_common_command (const char *comname, int from_tty)
 442 {
 443   struct frame_info *fi;
 444   const struct block *block;
 445   int values_printed = 0;
 446
 447   /* We have been told to display the contents of F77 COMMON
 448      block supposedly visible in this function.  Let us
 449      first make sure that it is visible and if so, let
 450      us display its contents.  */
 451
 452   fi = get_selected_frame (_("No frame selected"));
 453
 454   /* The following is generally ripped off from stack.c's routine
 455      print_frame_info().  */
 456
 457   block = get_frame_block (fi, 0);
 458   if (block == NULL)
 459     {
 460       printf_filtered (_("No symbol table info available.\n"));
 461       return;
 462     }
 463
 464   while (block)
 465     {
 466       info_common_command_for_block (block, comname, &values_printed);
 467       /* After handling the function's top-level block, stop.  Don't
 468          continue to its superblock, the block of per-file symbols.  */
 469       if (BLOCK_FUNCTION (block))
 470         break;
 471       block = BLOCK_SUPERBLOCK (block);
 472     }
 473
 474   if (!values_printed)
 475     {
 476       if (comname)
 477         printf_filtered (_("No common block '%s'.\n"), comname);
 478       else
 479         printf_filtered (_("No common blocks.\n"));
 480     }
 481 }
 482
 483 void _initialize_f_valprint ();
 484 void
 485 _initialize_f_valprint ()
 486 {
 487   add_info ("common", info_common_command,
 488             _("Print out the values contained in a Fortran COMMON block."));
 489 }