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