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 };
 209
 210 /* See val_print for a description of the various parameters of this
 211    function; they are identical.  */
 212
 213 void
 214 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 215              CORE_ADDR address, struct ui_file *stream, int recurse,
 216              const struct value *original_value,
 217              const struct value_print_options *options)
 218 {
 219   struct gdbarch *gdbarch = get_type_arch (type);
 220   enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
 221   unsigned int i = 0;   /* Number of characters printed.  */
 222   int printed_field = 0; /* Number of fields printed.  */
 223   struct type *elttype;
 224   CORE_ADDR addr;
 225   int index;
 226
 227   type = check_typedef (type);
 228   switch (TYPE_CODE (type))
 229     {
 230     case TYPE_CODE_STRING:
 231       f77_get_dynamic_length_of_aggregate (type);
 232       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 233                        valaddr + embedded_offset,
 234                        TYPE_LENGTH (type), NULL, 0, options);
 235       break;
 236
 237     case TYPE_CODE_ARRAY:
 238       if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
 239         {
 240           fprintf_filtered (stream, "(");
 241           f77_print_array (type, valaddr, embedded_offset,
 242                            address, stream, recurse, original_value, options);
 243           fprintf_filtered (stream, ")");
 244         }
 245       else
 246         {
 247           struct type *ch_type = TYPE_TARGET_TYPE (type);
 248
 249           f77_get_dynamic_length_of_aggregate (type);
 250           LA_PRINT_STRING (stream, ch_type,
 251                            valaddr + embedded_offset,
 252                            TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
 253                            NULL, 0, options);
 254         }
 255       break;
 256
 257     case TYPE_CODE_PTR:
 258       if (options->format && options->format != 's')
 259         {
 260           val_print_scalar_formatted (type, valaddr, embedded_offset,
 261                                       original_value, options, 0, stream);
 262           break;
 263         }
 264       else
 265         {
 266           int want_space = 0;
 267
 268           addr = unpack_pointer (type, valaddr + embedded_offset);
 269           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 270
 271           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 272             {
 273               /* Try to print what function it points to.  */
 274               print_function_pointer_address (options, gdbarch, addr, stream);
 275               return;
 276             }
 277
 278           if (options->symbol_print)
 279             want_space = print_address_demangle (options, gdbarch, addr,
 280                                                  stream, demangle);
 281           else if (options->addressprint && options->format != 's')
 282             {
 283               fputs_filtered (paddress (gdbarch, addr), stream);
 284               want_space = 1;
 285             }
 286
 287           /* For a pointer to char or unsigned char, also print the string
 288              pointed to, unless pointer is null.  */
 289           if (TYPE_LENGTH (elttype) == 1
 290               && TYPE_CODE (elttype) == TYPE_CODE_INT
 291               && (options->format == 0 || options->format == 's')
 292               && addr != 0)
 293             {
 294               if (want_space)
 295                 fputs_filtered (" ", stream);
 296               i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
 297                                     stream, options);
 298             }
 299           return;
 300         }
 301       break;
 302
 303     case TYPE_CODE_INT:
 304       if (options->format || options->output_format)
 305         {
 306           struct value_print_options opts = *options;
 307
 308           opts.format = (options->format ? options->format
 309                          : options->output_format);
 310           val_print_scalar_formatted (type, valaddr, embedded_offset,
 311                                       original_value, &opts, 0, stream);
 312         }
 313       else
 314         {
 315           val_print_type_code_int (type, valaddr + embedded_offset, 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_contents_for_printing (field),
 360                          value_embedded_offset (field),
 361                          value_address (field), stream, recurse + 1,
 362                          field, options, current_language);
 363
 364               ++printed_field;
 365             }
 366          }
 367       fprintf_filtered (stream, " )");
 368       break;
 369
 370     case TYPE_CODE_REF:
 371     case TYPE_CODE_FUNC:
 372     case TYPE_CODE_FLAGS:
 373     case TYPE_CODE_FLT:
 374     case TYPE_CODE_VOID:
 375     case TYPE_CODE_ERROR:
 376     case TYPE_CODE_RANGE:
 377     case TYPE_CODE_UNDEF:
 378     case TYPE_CODE_COMPLEX:
 379     case TYPE_CODE_BOOL:
 380     case TYPE_CODE_CHAR:
 381     default:
 382       generic_val_print (type, valaddr, embedded_offset, address,
 383                          stream, recurse, original_value, options,
 384                          &f_decorations);
 385       break;
 386     }
 387   gdb_flush (stream);
 388 }
 389
 390 static void
 391 info_common_command_for_block (const struct block *block, const char *comname,
 392                                int *any_printed)
 393 {
 394   struct block_iterator iter;
 395   struct symbol *sym;
 396   const char *name;
 397   struct value_print_options opts;
 398
 399   get_user_print_options (&opts);
 400
 401   ALL_BLOCK_SYMBOLS (block, iter, sym)
 402     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 403       {
 404         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 405         size_t index;
 406
 407         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 408
 409         if (comname && (!SYMBOL_LINKAGE_NAME (sym)
 410                         || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
 411           continue;
 412
 413         if (*any_printed)
 414           putchar_filtered ('\n');
 415         else
 416           *any_printed = 1;
 417         if (SYMBOL_PRINT_NAME (sym))
 418           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 419                            SYMBOL_PRINT_NAME (sym));
 420         else
 421           printf_filtered (_("Contents of blank COMMON block:\n"));
 422
 423         for (index = 0; index < common->n_entries; index++)
 424           {
 425             struct value *val = NULL;
 426
 427             printf_filtered ("%s = ",
 428                              SYMBOL_PRINT_NAME (common->contents[index]));
 429
 430             TRY
 431               {
 432                 val = value_of_variable (common->contents[index], block);
 433                 value_print (val, gdb_stdout, &opts);
 434               }
 435
 436             CATCH (except, RETURN_MASK_ERROR)
 437               {
 438                 printf_filtered ("<error reading variable: %s>", except.message);
 439               }
 440             END_CATCH
 441
 442             putchar_filtered ('\n');
 443           }
 444       }
 445 }
 446
 447 /* This function is used to print out the values in a given COMMON
 448    block.  It will always use the most local common block of the
 449    given name.  */
 450
 451 static void
 452 info_common_command (char *comname, int from_tty)
 453 {
 454   struct frame_info *fi;
 455   const struct block *block;
 456   int values_printed = 0;
 457
 458   /* We have been told to display the contents of F77 COMMON
 459      block supposedly visible in this function.  Let us
 460      first make sure that it is visible and if so, let
 461      us display its contents.  */
 462
 463   fi = get_selected_frame (_("No frame selected"));
 464
 465   /* The following is generally ripped off from stack.c's routine
 466      print_frame_info().  */
 467
 468   block = get_frame_block (fi, 0);
 469   if (block == NULL)
 470     {
 471       printf_filtered (_("No symbol table info available.\n"));
 472       return;
 473     }
 474
 475   while (block)
 476     {
 477       info_common_command_for_block (block, comname, &values_printed);
 478       /* After handling the function's top-level block, stop.  Don't
 479          continue to its superblock, the block of per-file symbols.  */
 480       if (BLOCK_FUNCTION (block))
 481         break;
 482       block = BLOCK_SUPERBLOCK (block);
 483     }
 484
 485   if (!values_printed)
 486     {
 487       if (comname)
 488         printf_filtered (_("No common block '%s'.\n"), comname);
 489       else
 490         printf_filtered (_("No common blocks.\n"));
 491     }
 492 }
 493
 494 void
 495 _initialize_f_valprint (void)
 496 {
 497   add_info ("common", info_common_command,
 498             _("Print out the values contained in a Fortran COMMON block."));
 499 }