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