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