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_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 = 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 f-lang.h.  */
 212
 213 void
 214 f_value_print_innner (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_INT:
 299       if (options->format || options->output_format)
 300         {
 301           struct value_print_options opts = *options;
 302
 303           opts.format = (options->format ? options->format
 304                          : options->output_format);
 305           value_print_scalar_formatted (val, &opts, 0, stream);
 306         }
 307       else
 308         value_print_scalar_formatted (val, options, 0, stream);
 309       break;
 310
 311     case TYPE_CODE_STRUCT:
 312     case TYPE_CODE_UNION:
 313       /* Starting from the Fortran 90 standard, Fortran supports derived
 314          types.  */
 315       fprintf_filtered (stream, "( ");
 316       for (index = 0; index < type->num_fields (); index++)
 317         {
 318           struct value *field = value_field (val, index);
 319
 320           struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, index));
 321
 322
 323           if (field_type->code () != TYPE_CODE_FUNC)
 324             {
 325               const char *field_name;
 326
 327               if (printed_field > 0)
 328                 fputs_filtered (", ", stream);
 329
 330               field_name = TYPE_FIELD_NAME (type, index);
 331               if (field_name != NULL)
 332                 {
 333                   fputs_styled (field_name, variable_name_style.style (),
 334                                 stream);
 335                   fputs_filtered (" = ", stream);
 336                 }
 337
 338               common_val_print (field, stream, recurse + 1,
 339                                 options, current_language);
 340
 341               ++printed_field;
 342             }
 343          }
 344       fprintf_filtered (stream, " )");
 345       break;
 346
 347     case TYPE_CODE_BOOL:
 348       if (options->format || options->output_format)
 349         {
 350           struct value_print_options opts = *options;
 351           opts.format = (options->format ? options->format
 352                          : options->output_format);
 353           value_print_scalar_formatted (val, &opts, 0, stream);
 354         }
 355       else
 356         {
 357           LONGEST longval = value_as_long (val);
 358           /* The Fortran standard doesn't specify how logical types are
 359              represented.  Different compilers use different non zero
 360              values to represent logical true.  */
 361           if (longval == 0)
 362             fputs_filtered (f_decorations.false_name, stream);
 363           else
 364             fputs_filtered (f_decorations.true_name, stream);
 365         }
 366       break;
 367
 368     case TYPE_CODE_REF:
 369     case TYPE_CODE_FUNC:
 370     case TYPE_CODE_FLAGS:
 371     case TYPE_CODE_FLT:
 372     case TYPE_CODE_VOID:
 373     case TYPE_CODE_ERROR:
 374     case TYPE_CODE_RANGE:
 375     case TYPE_CODE_UNDEF:
 376     case TYPE_CODE_COMPLEX:
 377     case TYPE_CODE_CHAR:
 378     default:
 379       generic_value_print (val, stream, recurse, options, &f_decorations);
 380       break;
 381     }
 382 }
 383
 384 static void
 385 info_common_command_for_block (const struct block *block, const char *comname,
 386                                int *any_printed)
 387 {
 388   struct block_iterator iter;
 389   struct symbol *sym;
 390   struct value_print_options opts;
 391
 392   get_user_print_options (&opts);
 393
 394   ALL_BLOCK_SYMBOLS (block, iter, sym)
 395     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 396       {
 397         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 398         size_t index;
 399
 400         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 401
 402         if (comname && (!sym->linkage_name ()
 403                         || strcmp (comname, sym->linkage_name ()) != 0))
 404           continue;
 405
 406         if (*any_printed)
 407           putchar_filtered ('\n');
 408         else
 409           *any_printed = 1;
 410         if (sym->print_name ())
 411           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 412                            sym->print_name ());
 413         else
 414           printf_filtered (_("Contents of blank COMMON block:\n"));
 415
 416         for (index = 0; index < common->n_entries; index++)
 417           {
 418             struct value *val = NULL;
 419
 420             printf_filtered ("%s = ",
 421                              common->contents[index]->print_name ());
 422
 423             try
 424               {
 425                 val = value_of_variable (common->contents[index], block);
 426                 value_print (val, gdb_stdout, &opts);
 427               }
 428
 429             catch (const gdb_exception_error &except)
 430               {
 431                 fprintf_styled (gdb_stdout, metadata_style.style (),
 432                                 "<error reading variable: %s>",
 433                                 except.what ());
 434               }
 435
 436             putchar_filtered ('\n');
 437           }
 438       }
 439 }
 440
 441 /* This function is used to print out the values in a given COMMON
 442    block.  It will always use the most local common block of the
 443    given name.  */
 444
 445 static void
 446 info_common_command (const char *comname, int from_tty)
 447 {
 448   struct frame_info *fi;
 449   const struct block *block;
 450   int values_printed = 0;
 451
 452   /* We have been told to display the contents of F77 COMMON
 453      block supposedly visible in this function.  Let us
 454      first make sure that it is visible and if so, let
 455      us display its contents.  */
 456
 457   fi = get_selected_frame (_("No frame selected"));
 458
 459   /* The following is generally ripped off from stack.c's routine
 460      print_frame_info().  */
 461
 462   block = get_frame_block (fi, 0);
 463   if (block == NULL)
 464     {
 465       printf_filtered (_("No symbol table info available.\n"));
 466       return;
 467     }
 468
 469   while (block)
 470     {
 471       info_common_command_for_block (block, comname, &values_printed);
 472       /* After handling the function's top-level block, stop.  Don't
 473          continue to its superblock, the block of per-file symbols.  */
 474       if (BLOCK_FUNCTION (block))
 475         break;
 476       block = BLOCK_SUPERBLOCK (block);
 477     }
 478
 479   if (!values_printed)
 480     {
 481       if (comname)
 482         printf_filtered (_("No common block '%s'.\n"), comname);
 483       else
 484         printf_filtered (_("No common blocks.\n"));
 485     }
 486 }
 487
 488 void _initialize_f_valprint ();
 489 void
 490 _initialize_f_valprint ()
 491 {
 492   add_info ("common", info_common_command,
 493             _("Print out the values contained in a Fortran COMMON block."));
 494 }