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