gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2016 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_contents_for_printing (elt),
 156                      value_embedded_offset (elt),
 157                      value_address (elt), stream, recurse,
 158                      elt, options, current_language);
 159
 160           if (i != upperbound)
 161             fprintf_filtered (stream, ", ");
 162
 163           if ((*elts == options->print_max - 1)
 164               && (i != upperbound))
 165             fprintf_filtered (stream, "...");
 166         }
 167     }
 168 }
 169
 170 /* This function gets called to print an F77 array, we set up some
 171    stuff and then immediately call f77_print_array_1().  */
 172
 173 static void
 174 f77_print_array (struct type *type, const gdb_byte *valaddr,
 175                  int embedded_offset,
 176                  CORE_ADDR address, struct ui_file *stream,
 177                  int recurse,
 178                  const struct value *val,
 179                  const struct value_print_options *options)
 180 {
 181   int ndimensions;
 182   int elts = 0;
 183
 184   ndimensions = calc_f77_array_dims (type);
 185
 186   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 187     error (_("\
 188 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 189            ndimensions, MAX_FORTRAN_DIMS);
 190
 191   f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
 192                      address, stream, recurse, val, options, &elts);
 193 }
 194 \f
 195
 196 /* Decorations for Fortran.  */
 197
 198 static const struct generic_val_print_decorations f_decorations =
 199 {
 200   "(",
 201   ",",
 202   ")",
 203   ".TRUE.",
 204   ".FALSE.",
 205   "VOID",
 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, const gdb_byte *valaddr, int embedded_offset,
 213              CORE_ADDR address, struct ui_file *stream, int recurse,
 214              const 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   unsigned int i = 0;   /* Number of characters printed.  */
 220   struct type *elttype;
 221   CORE_ADDR addr;
 222   int index;
 223
 224   type = check_typedef (type);
 225   switch (TYPE_CODE (type))
 226     {
 227     case TYPE_CODE_STRING:
 228       f77_get_dynamic_length_of_aggregate (type);
 229       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 230                        valaddr + embedded_offset,
 231                        TYPE_LENGTH (type), NULL, 0, options);
 232       break;
 233
 234     case TYPE_CODE_ARRAY:
 235       if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
 236         {
 237           fprintf_filtered (stream, "(");
 238           f77_print_array (type, valaddr, embedded_offset,
 239                            address, stream, recurse, original_value, 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,
 248                            valaddr + embedded_offset,
 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           val_print_scalar_formatted (type, valaddr, embedded_offset,
 258                                       original_value, options, 0, stream);
 259           break;
 260         }
 261       else
 262         {
 263           int want_space = 0;
 264
 265           addr = unpack_pointer (type, valaddr + embedded_offset);
 266           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 267
 268           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 269             {
 270               /* Try to print what function it points to.  */
 271               print_function_pointer_address (options, gdbarch, addr, stream);
 272               return;
 273             }
 274
 275           if (options->symbol_print)
 276             want_space = print_address_demangle (options, gdbarch, addr,
 277                                                  stream, demangle);
 278           else if (options->addressprint && options->format != 's')
 279             {
 280               fputs_filtered (paddress (gdbarch, addr), stream);
 281               want_space = 1;
 282             }
 283
 284           /* For a pointer to char or unsigned char, also print the string
 285              pointed to, unless pointer is null.  */
 286           if (TYPE_LENGTH (elttype) == 1
 287               && TYPE_CODE (elttype) == TYPE_CODE_INT
 288               && (options->format == 0 || options->format == 's')
 289               && addr != 0)
 290             {
 291               if (want_space)
 292                 fputs_filtered (" ", stream);
 293               i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
 294                                     stream, options);
 295             }
 296           return;
 297         }
 298       break;
 299
 300     case TYPE_CODE_INT:
 301       if (options->format || options->output_format)
 302         {
 303           struct value_print_options opts = *options;
 304
 305           opts.format = (options->format ? options->format
 306                          : options->output_format);
 307           val_print_scalar_formatted (type, valaddr, embedded_offset,
 308                                       original_value, &opts, 0, stream);
 309         }
 310       else
 311         {
 312           val_print_type_code_int (type, valaddr + embedded_offset, stream);
 313           /* C and C++ has no single byte int type, char is used instead.
 314              Since we don't know whether the value is really intended to
 315              be used as an integer or a character, print the character
 316              equivalent as well.  */
 317           if (TYPE_LENGTH (type) == 1)
 318             {
 319               LONGEST c;
 320
 321               fputs_filtered (" ", stream);
 322               c = unpack_long (type, valaddr + embedded_offset);
 323               LA_PRINT_CHAR ((unsigned char) c, type, stream);
 324             }
 325         }
 326       break;
 327
 328     case TYPE_CODE_STRUCT:
 329     case TYPE_CODE_UNION:
 330       /* Starting from the Fortran 90 standard, Fortran supports derived
 331          types.  */
 332       fprintf_filtered (stream, "( ");
 333       for (index = 0; index < TYPE_NFIELDS (type); index++)
 334         {
 335           struct value *field = value_field
 336             ((struct value *)original_value, index);
 337
 338           val_print (value_type (field),
 339                      value_contents_for_printing (field),
 340                      value_embedded_offset (field),
 341                      value_address (field), stream, recurse + 1,
 342                      field, options, current_language);
 343
 344           if (index != TYPE_NFIELDS (type) - 1)
 345             fputs_filtered (", ", stream);
 346         }
 347       fprintf_filtered (stream, " )");
 348       break;
 349
 350     case TYPE_CODE_REF:
 351     case TYPE_CODE_FUNC:
 352     case TYPE_CODE_FLAGS:
 353     case TYPE_CODE_FLT:
 354     case TYPE_CODE_VOID:
 355     case TYPE_CODE_ERROR:
 356     case TYPE_CODE_RANGE:
 357     case TYPE_CODE_UNDEF:
 358     case TYPE_CODE_COMPLEX:
 359     case TYPE_CODE_BOOL:
 360     case TYPE_CODE_CHAR:
 361     default:
 362       generic_val_print (type, valaddr, embedded_offset, address,
 363                          stream, recurse, original_value, options,
 364                          &f_decorations);
 365       break;
 366     }
 367   gdb_flush (stream);
 368 }
 369
 370 static void
 371 info_common_command_for_block (const struct block *block, const char *comname,
 372                                int *any_printed)
 373 {
 374   struct block_iterator iter;
 375   struct symbol *sym;
 376   const char *name;
 377   struct value_print_options opts;
 378
 379   get_user_print_options (&opts);
 380
 381   ALL_BLOCK_SYMBOLS (block, iter, sym)
 382     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 383       {
 384         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 385         size_t index;
 386
 387         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 388
 389         if (comname && (!SYMBOL_LINKAGE_NAME (sym)
 390                         || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
 391           continue;
 392
 393         if (*any_printed)
 394           putchar_filtered ('\n');
 395         else
 396           *any_printed = 1;
 397         if (SYMBOL_PRINT_NAME (sym))
 398           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 399                            SYMBOL_PRINT_NAME (sym));
 400         else
 401           printf_filtered (_("Contents of blank COMMON block:\n"));
 402
 403         for (index = 0; index < common->n_entries; index++)
 404           {
 405             struct value *val = NULL;
 406
 407             printf_filtered ("%s = ",
 408                              SYMBOL_PRINT_NAME (common->contents[index]));
 409
 410             TRY
 411               {
 412                 val = value_of_variable (common->contents[index], block);
 413                 value_print (val, gdb_stdout, &opts);
 414               }
 415
 416             CATCH (except, RETURN_MASK_ERROR)
 417               {
 418                 printf_filtered ("<error reading variable: %s>", except.message);
 419               }
 420             END_CATCH
 421
 422             putchar_filtered ('\n');
 423           }
 424       }
 425 }
 426
 427 /* This function is used to print out the values in a given COMMON
 428    block.  It will always use the most local common block of the
 429    given name.  */
 430
 431 static void
 432 info_common_command (char *comname, int from_tty)
 433 {
 434   struct frame_info *fi;
 435   const struct block *block;
 436   int values_printed = 0;
 437
 438   /* We have been told to display the contents of F77 COMMON
 439      block supposedly visible in this function.  Let us
 440      first make sure that it is visible and if so, let
 441      us display its contents.  */
 442
 443   fi = get_selected_frame (_("No frame selected"));
 444
 445   /* The following is generally ripped off from stack.c's routine
 446      print_frame_info().  */
 447
 448   block = get_frame_block (fi, 0);
 449   if (block == NULL)
 450     {
 451       printf_filtered (_("No symbol table info available.\n"));
 452       return;
 453     }
 454
 455   while (block)
 456     {
 457       info_common_command_for_block (block, comname, &values_printed);
 458       /* After handling the function's top-level block, stop.  Don't
 459          continue to its superblock, the block of per-file symbols.  */
 460       if (BLOCK_FUNCTION (block))
 461         break;
 462       block = BLOCK_SUPERBLOCK (block);
 463     }
 464
 465   if (!values_printed)
 466     {
 467       if (comname)
 468         printf_filtered (_("No common block '%s'.\n"), comname);
 469       else
 470         printf_filtered (_("No common blocks.\n"));
 471     }
 472 }
 473
 474 void
 475 _initialize_f_valprint (void)
 476 {
 477   add_info ("common", info_common_command,
 478             _("Print out the values contained in a Fortran COMMON block."));
 479 }