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