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->bounds ()->low.kind () == PROP_UNDEFINED)
  50     error (_("Lower bound may not be '*' in F77"));
  51
  52   return type->bounds ()->low.const_val ();
  53 }
  54
  55 LONGEST
  56 f77_get_upperbound (struct type *type)
  57 {
  58   if (type->bounds ()->high.kind () == PROP_UNDEFINED)
  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->bounds ()->high.const_val ();
  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_TARGET_TYPE (type)->code () == TYPE_CODE_ARRAY
  89       || TYPE_TARGET_TYPE (type)->code () == 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 = check_typedef (type)->index_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->bit_stride () / (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 (i < upperbound)
 150             fprintf_filtered (stream, " ");
 151         }
 152       if (*elts >= options->print_max && i < upperbound)
 153         fprintf_filtered (stream, "...");
 154     }
 155   else
 156     {
 157       for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
 158            i++, (*elts)++)
 159         {
 160           struct value *elt = value_subscript ((struct value *)val, i);
 161
 162           common_val_print (elt, stream, recurse, 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 f-lang.h.  */
 215
 216 void
 217 f_language::value_print_inner (struct value *val, struct ui_file *stream,
 218                                int recurse,
 219                                const struct value_print_options *options) const
 220 {
 221   struct type *type = check_typedef (value_type (val));
 222   struct gdbarch *gdbarch = get_type_arch (type);
 223   int printed_field = 0; /* Number of fields printed.  */
 224   struct type *elttype;
 225   CORE_ADDR addr;
 226   int index;
 227   const gdb_byte *valaddr = value_contents_for_printing (val);
 228   const CORE_ADDR address = value_address (val);
 229
 230   switch (type->code ())
 231     {
 232     case TYPE_CODE_STRING:
 233       f77_get_dynamic_length_of_aggregate (type);
 234       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 235                        valaddr, TYPE_LENGTH (type), NULL, 0, options);
 236       break;
 237
 238     case TYPE_CODE_ARRAY:
 239       if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_CHAR)
 240         {
 241           fprintf_filtered (stream, "(");
 242           f77_print_array (type, valaddr, 0,
 243                            address, stream, recurse, val, options);
 244           fprintf_filtered (stream, ")");
 245         }
 246       else
 247         {
 248           struct type *ch_type = TYPE_TARGET_TYPE (type);
 249
 250           f77_get_dynamic_length_of_aggregate (type);
 251           LA_PRINT_STRING (stream, ch_type, valaddr,
 252                            TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
 253                            NULL, 0, options);
 254         }
 255       break;
 256
 257     case TYPE_CODE_PTR:
 258       if (options->format && options->format != 's')
 259         {
 260           value_print_scalar_formatted (val, options, 0, stream);
 261           break;
 262         }
 263       else
 264         {
 265           int want_space = 0;
 266
 267           addr = unpack_pointer (type, valaddr);
 268           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 269
 270           if (elttype->code () == TYPE_CODE_FUNC)
 271             {
 272               /* Try to print what function it points to.  */
 273               print_function_pointer_address (options, gdbarch, addr, stream);
 274               return;
 275             }
 276
 277           if (options->symbol_print)
 278             want_space = print_address_demangle (options, gdbarch, addr,
 279                                                  stream, demangle);
 280           else if (options->addressprint && options->format != 's')
 281             {
 282               fputs_filtered (paddress (gdbarch, addr), stream);
 283               want_space = 1;
 284             }
 285
 286           /* For a pointer to char or unsigned char, also print the string
 287              pointed to, unless pointer is null.  */
 288           if (TYPE_LENGTH (elttype) == 1
 289               && elttype->code () == TYPE_CODE_INT
 290               && (options->format == 0 || options->format == 's')
 291               && addr != 0)
 292             {
 293               if (want_space)
 294                 fputs_filtered (" ", stream);
 295               val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
 296                                 stream, options);
 297             }
 298           return;
 299         }
 300       break;
 301
 302     case TYPE_CODE_STRUCT:
 303     case TYPE_CODE_UNION:
 304       /* Starting from the Fortran 90 standard, Fortran supports derived
 305          types.  */
 306       fprintf_filtered (stream, "( ");
 307       for (index = 0; index < type->num_fields (); index++)
 308         {
 309           struct value *field = value_field (val, index);
 310
 311           struct type *field_type = check_typedef (type->field (index).type ());
 312
 313
 314           if (field_type->code () != TYPE_CODE_FUNC)
 315             {
 316               const char *field_name;
 317
 318               if (printed_field > 0)
 319                 fputs_filtered (", ", stream);
 320
 321               field_name = TYPE_FIELD_NAME (type, index);
 322               if (field_name != NULL)
 323                 {
 324                   fputs_styled (field_name, variable_name_style.style (),
 325                                 stream);
 326                   fputs_filtered (" = ", stream);
 327                 }
 328
 329               common_val_print (field, stream, recurse + 1,
 330                                 options, current_language);
 331
 332               ++printed_field;
 333             }
 334          }
 335       fprintf_filtered (stream, " )");
 336       break;
 337
 338     case TYPE_CODE_BOOL:
 339       if (options->format || options->output_format)
 340         {
 341           struct value_print_options opts = *options;
 342           opts.format = (options->format ? options->format
 343                          : options->output_format);
 344           value_print_scalar_formatted (val, &opts, 0, stream);
 345         }
 346       else
 347         {
 348           LONGEST longval = value_as_long (val);
 349           /* The Fortran standard doesn't specify how logical types are
 350              represented.  Different compilers use different non zero
 351              values to represent logical true.  */
 352           if (longval == 0)
 353             fputs_filtered (f_decorations.false_name, stream);
 354           else
 355             fputs_filtered (f_decorations.true_name, stream);
 356         }
 357       break;
 358
 359     case TYPE_CODE_INT:
 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_CHAR:
 370     default:
 371       generic_value_print (val, stream, recurse, options, &f_decorations);
 372       break;
 373     }
 374 }
 375
 376 static void
 377 info_common_command_for_block (const struct block *block, const char *comname,
 378                                int *any_printed)
 379 {
 380   struct block_iterator iter;
 381   struct symbol *sym;
 382   struct value_print_options opts;
 383
 384   get_user_print_options (&opts);
 385
 386   ALL_BLOCK_SYMBOLS (block, iter, sym)
 387     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 388       {
 389         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 390         size_t index;
 391
 392         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 393
 394         if (comname && (!sym->linkage_name ()
 395                         || strcmp (comname, sym->linkage_name ()) != 0))
 396           continue;
 397
 398         if (*any_printed)
 399           putchar_filtered ('\n');
 400         else
 401           *any_printed = 1;
 402         if (sym->print_name ())
 403           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 404                            sym->print_name ());
 405         else
 406           printf_filtered (_("Contents of blank COMMON block:\n"));
 407
 408         for (index = 0; index < common->n_entries; index++)
 409           {
 410             struct value *val = NULL;
 411
 412             printf_filtered ("%s = ",
 413                              common->contents[index]->print_name ());
 414
 415             try
 416               {
 417                 val = value_of_variable (common->contents[index], block);
 418                 value_print (val, gdb_stdout, &opts);
 419               }
 420
 421             catch (const gdb_exception_error &except)
 422               {
 423                 fprintf_styled (gdb_stdout, metadata_style.style (),
 424                                 "<error reading variable: %s>",
 425                                 except.what ());
 426               }
 427
 428             putchar_filtered ('\n');
 429           }
 430       }
 431 }
 432
 433 /* This function is used to print out the values in a given COMMON
 434    block.  It will always use the most local common block of the
 435    given name.  */
 436
 437 static void
 438 info_common_command (const char *comname, int from_tty)
 439 {
 440   struct frame_info *fi;
 441   const struct block *block;
 442   int values_printed = 0;
 443
 444   /* We have been told to display the contents of F77 COMMON
 445      block supposedly visible in this function.  Let us
 446      first make sure that it is visible and if so, let
 447      us display its contents.  */
 448
 449   fi = get_selected_frame (_("No frame selected"));
 450
 451   /* The following is generally ripped off from stack.c's routine
 452      print_frame_info().  */
 453
 454   block = get_frame_block (fi, 0);
 455   if (block == NULL)
 456     {
 457       printf_filtered (_("No symbol table info available.\n"));
 458       return;
 459     }
 460
 461   while (block)
 462     {
 463       info_common_command_for_block (block, comname, &values_printed);
 464       /* After handling the function's top-level block, stop.  Don't
 465          continue to its superblock, the block of per-file symbols.  */
 466       if (BLOCK_FUNCTION (block))
 467         break;
 468       block = BLOCK_SUPERBLOCK (block);
 469     }
 470
 471   if (!values_printed)
 472     {
 473       if (comname)
 474         printf_filtered (_("No common block '%s'.\n"), comname);
 475       else
 476         printf_filtered (_("No common blocks.\n"));
 477     }
 478 }
 479
 480 void _initialize_f_valprint ();
 481 void
 482 _initialize_f_valprint ()
 483 {
 484   add_info ("common", info_common_command,
 485             _("Print out the values contained in a Fortran COMMON block."));
 486 }