gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2017 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
  37 static void info_common_command (char *, int);
  38 static void f77_get_dynamic_length_of_aggregate (struct type *);
  39
  40 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
  41
  42 /* Array which holds offsets to be applied to get a row's elements
  43    for a given array.  Array also holds the size of each subarray.  */
  44
  45 int
  46 f77_get_lowerbound (struct type *type)
  47 {
  48   if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
  49     error (_("Lower bound may not be '*' in F77"));
  50
  51   return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
  52 }
  53
  54 int
  55 f77_get_upperbound (struct type *type)
  56 {
  57   if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
  58     {
  59       /* We have an assumed size array on our hands.  Assume that
  60          upper_bound == lower_bound so that we show at least 1 element.
  61          If the user wants to see more elements, let him manually ask for 'em
  62          and we'll subscript the array and show him.  */
  63
  64       return f77_get_lowerbound (type);
  65     }
  66
  67   return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
  68 }
  69
  70 /* Obtain F77 adjustable array dimensions.  */
  71
  72 static void
  73 f77_get_dynamic_length_of_aggregate (struct type *type)
  74 {
  75   int upper_bound = -1;
  76   int lower_bound = 1;
  77
  78   /* Recursively go all the way down into a possibly multi-dimensional
  79      F77 array and get the bounds.  For simple arrays, this is pretty
  80      easy but when the bounds are dynamic, we must be very careful
  81      to add up all the lengths correctly.  Not doing this right
  82      will lead to horrendous-looking arrays in parameter lists.
  83
  84      This function also works for strings which behave very
  85      similarly to arrays.  */
  86
  87   if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
  88       || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
  89     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
  90
  91   /* Recursion ends here, start setting up lengths.  */
  92   lower_bound = f77_get_lowerbound (type);
  93   upper_bound = f77_get_upperbound (type);
  94
  95   /* Patch in a valid length value.  */
  96
  97   TYPE_LENGTH (type) =
  98     (upper_bound - lower_bound + 1)
  99     * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 100 }
 101
 102 /* Actual function which prints out F77 arrays, Valaddr == address in
 103    the superior.  Address == the address in the inferior.  */
 104
 105 static void
 106 f77_print_array_1 (int nss, int ndimensions, struct type *type,
 107                    const gdb_byte *valaddr,
 108                    int embedded_offset, CORE_ADDR address,
 109                    struct ui_file *stream, int recurse,
 110                    const struct value *val,
 111                    const struct value_print_options *options,
 112                    int *elts)
 113 {
 114   struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
 115   CORE_ADDR addr = address + embedded_offset;
 116   LONGEST lowerbound, upperbound;
 117   int i;
 118
 119   get_discrete_bounds (range_type, &lowerbound, &upperbound);
 120
 121   if (nss != ndimensions)
 122     {
 123       size_t dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
 124       size_t offs = 0;
 125
 126       for (i = lowerbound;
 127            (i < upperbound + 1 && (*elts) < options->print_max);
 128            i++)
 129         {
 130           struct value *subarray = value_from_contents_and_address
 131             (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
 132              + offs, addr + offs);
 133
 134           fprintf_filtered (stream, "( ");
 135           f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),
 136                              value_contents_for_printing (subarray),
 137                              value_embedded_offset (subarray),
 138                              value_address (subarray),
 139                              stream, recurse, subarray, options, elts);
 140           offs += dim_size;
 141           fprintf_filtered (stream, ") ");
 142         }
 143       if (*elts >= options->print_max && i < upperbound)
 144         fprintf_filtered (stream, "...");
 145     }
 146   else
 147     {
 148       for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
 149            i++, (*elts)++)
 150         {
 151           struct value *elt = value_subscript ((struct value *)val, i);
 152
 153           val_print (value_type (elt),
 154                      value_embedded_offset (elt),
 155                      value_address (elt), stream, recurse,
 156                      elt, options, current_language);
 157
 158           if (i != upperbound)
 159             fprintf_filtered (stream, ", ");
 160
 161           if ((*elts == options->print_max - 1)
 162               && (i != upperbound))
 163             fprintf_filtered (stream, "...");
 164         }
 165     }
 166 }
 167
 168 /* This function gets called to print an F77 array, we set up some
 169    stuff and then immediately call f77_print_array_1().  */
 170
 171 static void
 172 f77_print_array (struct type *type, const gdb_byte *valaddr,
 173                  int embedded_offset,
 174                  CORE_ADDR address, struct ui_file *stream,
 175                  int recurse,
 176                  const struct value *val,
 177                  const struct value_print_options *options)
 178 {
 179   int ndimensions;
 180   int elts = 0;
 181
 182   ndimensions = calc_f77_array_dims (type);
 183
 184   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 185     error (_("\
 186 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 187            ndimensions, MAX_FORTRAN_DIMS);
 188
 189   f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
 190                      address, stream, recurse, val, options, &elts);
 191 }
 192 \f
 193
 194 /* Decorations for Fortran.  */
 195
 196 static const struct generic_val_print_decorations f_decorations =
 197 {
 198   "(",
 199   ",",
 200   ")",
 201   ".TRUE.",
 202   ".FALSE.",
 203   "VOID",
 204   "{",
 205   "}"
 206 };
 207
 208 /* See val_print for a description of the various parameters of this
 209    function; they are identical.  */
 210
 211 void
 212 f_val_print (struct type *type, int embedded_offset,
 213              CORE_ADDR address, struct ui_file *stream, int recurse,
 214              struct value *original_value,
 215              const struct value_print_options *options)
 216 {
 217   struct gdbarch *gdbarch = get_type_arch (type);
 218   enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
 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 (original_value);
 224
 225   type = check_typedef (type);
 226   switch (TYPE_CODE (type))
 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 + embedded_offset,
 232                        TYPE_LENGTH (type), NULL, 0, options);
 233       break;
 234
 235     case TYPE_CODE_ARRAY:
 236       if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
 237         {
 238           fprintf_filtered (stream, "(");
 239           f77_print_array (type, valaddr, embedded_offset,
 240                            address, stream, recurse, original_value, 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,
 249                            valaddr + embedded_offset,
 250                            TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
 251                            NULL, 0, options);
 252         }
 253       break;
 254
 255     case TYPE_CODE_PTR:
 256       if (options->format && options->format != 's')
 257         {
 258           val_print_scalar_formatted (type, embedded_offset,
 259                                       original_value, options, 0, stream);
 260           break;
 261         }
 262       else
 263         {
 264           int want_space = 0;
 265
 266           addr = unpack_pointer (type, valaddr + embedded_offset);
 267           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 268
 269           if (TYPE_CODE (elttype) == 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               && TYPE_CODE (elttype) == 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_INT:
 302       if (options->format || options->output_format)
 303         {
 304           struct value_print_options opts = *options;
 305
 306           opts.format = (options->format ? options->format
 307                          : options->output_format);
 308           val_print_scalar_formatted (type, embedded_offset,
 309                                       original_value, &opts, 0, stream);
 310         }
 311       else
 312         val_print_scalar_formatted (type, embedded_offset,
 313                                     original_value, options, 0, stream);
 314       break;
 315
 316     case TYPE_CODE_STRUCT:
 317     case TYPE_CODE_UNION:
 318       /* Starting from the Fortran 90 standard, Fortran supports derived
 319          types.  */
 320       fprintf_filtered (stream, "( ");
 321       for (index = 0; index < TYPE_NFIELDS (type); index++)
 322         {
 323           struct value *field = value_field
 324             ((struct value *)original_value, index);
 325
 326           struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, index));
 327
 328
 329           if (TYPE_CODE (field_type) != TYPE_CODE_FUNC)
 330             {
 331               const char *field_name;
 332
 333               if (printed_field > 0)
 334                 fputs_filtered (", ", stream);
 335
 336               field_name = TYPE_FIELD_NAME (type, index);
 337               if (field_name != NULL)
 338                 {
 339                   fputs_filtered (field_name, stream);
 340                   fputs_filtered (" = ", stream);
 341                 }
 342
 343               val_print (value_type (field),
 344                          value_embedded_offset (field),
 345                          value_address (field), stream, recurse + 1,
 346                          field, options, current_language);
 347
 348               ++printed_field;
 349             }
 350          }
 351       fprintf_filtered (stream, " )");
 352       break;
 353
 354     case TYPE_CODE_REF:
 355     case TYPE_CODE_FUNC:
 356     case TYPE_CODE_FLAGS:
 357     case TYPE_CODE_FLT:
 358     case TYPE_CODE_VOID:
 359     case TYPE_CODE_ERROR:
 360     case TYPE_CODE_RANGE:
 361     case TYPE_CODE_UNDEF:
 362     case TYPE_CODE_COMPLEX:
 363     case TYPE_CODE_BOOL:
 364     case TYPE_CODE_CHAR:
 365     default:
 366       generic_val_print (type, embedded_offset, address,
 367                          stream, recurse, original_value, options,
 368                          &f_decorations);
 369       break;
 370     }
 371   gdb_flush (stream);
 372 }
 373
 374 static void
 375 info_common_command_for_block (const struct block *block, const char *comname,
 376                                int *any_printed)
 377 {
 378   struct block_iterator iter;
 379   struct symbol *sym;
 380   const char *name;
 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 && (!SYMBOL_LINKAGE_NAME (sym)
 394                         || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
 395           continue;
 396
 397         if (*any_printed)
 398           putchar_filtered ('\n');
 399         else
 400           *any_printed = 1;
 401         if (SYMBOL_PRINT_NAME (sym))
 402           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 403                            SYMBOL_PRINT_NAME (sym));
 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                              SYMBOL_PRINT_NAME (common->contents[index]));
 413
 414             TRY
 415               {
 416                 val = value_of_variable (common->contents[index], block);
 417                 value_print (val, gdb_stdout, &opts);
 418               }
 419
 420             CATCH (except, RETURN_MASK_ERROR)
 421               {
 422                 printf_filtered ("<error reading variable: %s>", except.message);
 423               }
 424             END_CATCH
 425
 426             putchar_filtered ('\n');
 427           }
 428       }
 429 }
 430
 431 /* This function is used to print out the values in a given COMMON
 432    block.  It will always use the most local common block of the
 433    given name.  */
 434
 435 static void
 436 info_common_command (char *comname, int from_tty)
 437 {
 438   struct frame_info *fi;
 439   const struct block *block;
 440   int values_printed = 0;
 441
 442   /* We have been told to display the contents of F77 COMMON
 443      block supposedly visible in this function.  Let us
 444      first make sure that it is visible and if so, let
 445      us display its contents.  */
 446
 447   fi = get_selected_frame (_("No frame selected"));
 448
 449   /* The following is generally ripped off from stack.c's routine
 450      print_frame_info().  */
 451
 452   block = get_frame_block (fi, 0);
 453   if (block == NULL)
 454     {
 455       printf_filtered (_("No symbol table info available.\n"));
 456       return;
 457     }
 458
 459   while (block)
 460     {
 461       info_common_command_for_block (block, comname, &values_printed);
 462       /* After handling the function's top-level block, stop.  Don't
 463          continue to its superblock, the block of per-file symbols.  */
 464       if (BLOCK_FUNCTION (block))
 465         break;
 466       block = BLOCK_SUPERBLOCK (block);
 467     }
 468
 469   if (!values_printed)
 470     {
 471       if (comname)
 472         printf_filtered (_("No common block '%s'.\n"), comname);
 473       else
 474         printf_filtered (_("No common blocks.\n"));
 475     }
 476 }
 477
 478 void
 479 _initialize_f_valprint (void)
 480 {
 481   add_info ("common", info_common_command,
 482             _("Print out the values contained in a Fortran COMMON block."));
 483 }