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