gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2014 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 "exceptions.h"
  37
  38 extern void _initialize_f_valprint (void);
  39 static void info_common_command (char *, int);
  40 static void f77_create_arrayprint_offset_tbl (struct type *,
  41                                               struct ui_file *);
  42 static void f77_get_dynamic_length_of_aggregate (struct type *);
  43
  44 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
  45
  46 /* Array which holds offsets to be applied to get a row's elements
  47    for a given array.  Array also holds the size of each subarray.  */
  48
  49 /* The following macro gives us the size of the nth dimension, Where
  50    n is 1 based.  */
  51
  52 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
  53
  54 /* The following gives us the offset for row n where n is 1-based.  */
  55
  56 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
  57
  58 int
  59 f77_get_lowerbound (struct type *type)
  60 {
  61   if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
  62     error (_("Lower bound may not be '*' in F77"));
  63
  64   return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
  65 }
  66
  67 int
  68 f77_get_upperbound (struct type *type)
  69 {
  70   if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
  71     {
  72       /* We have an assumed size array on our hands.  Assume that
  73          upper_bound == lower_bound so that we show at least 1 element.
  74          If the user wants to see more elements, let him manually ask for 'em
  75          and we'll subscript the array and show him.  */
  76
  77       return f77_get_lowerbound (type);
  78     }
  79
  80   return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
  81 }
  82
  83 /* Obtain F77 adjustable array dimensions.  */
  84
  85 static void
  86 f77_get_dynamic_length_of_aggregate (struct type *type)
  87 {
  88   int upper_bound = -1;
  89   int lower_bound = 1;
  90
  91   /* Recursively go all the way down into a possibly multi-dimensional
  92      F77 array and get the bounds.  For simple arrays, this is pretty
  93      easy but when the bounds are dynamic, we must be very careful
  94      to add up all the lengths correctly.  Not doing this right
  95      will lead to horrendous-looking arrays in parameter lists.
  96
  97      This function also works for strings which behave very
  98      similarly to arrays.  */
  99
 100   if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
 101       || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
 102     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
 103
 104   /* Recursion ends here, start setting up lengths.  */
 105   lower_bound = f77_get_lowerbound (type);
 106   upper_bound = f77_get_upperbound (type);
 107
 108   /* Patch in a valid length value.  */
 109
 110   TYPE_LENGTH (type) =
 111     (upper_bound - lower_bound + 1)
 112     * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 113 }
 114
 115 /* Function that sets up the array offset,size table for the array
 116    type "type".  */
 117
 118 static void
 119 f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
 120 {
 121   struct type *tmp_type;
 122   int eltlen;
 123   int ndimen = 1;
 124   int upper, lower;
 125
 126   tmp_type = type;
 127
 128   while (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)
 129     {
 130       upper = f77_get_upperbound (tmp_type);
 131       lower = f77_get_lowerbound (tmp_type);
 132
 133       F77_DIM_SIZE (ndimen) = upper - lower + 1;
 134
 135       tmp_type = TYPE_TARGET_TYPE (tmp_type);
 136       ndimen++;
 137     }
 138
 139   /* Now we multiply eltlen by all the offsets, so that later we
 140      can print out array elements correctly.  Up till now we
 141      know an offset to apply to get the item but we also
 142      have to know how much to add to get to the next item.  */
 143
 144   ndimen--;
 145   eltlen = TYPE_LENGTH (tmp_type);
 146   F77_DIM_OFFSET (ndimen) = eltlen;
 147   while (--ndimen > 0)
 148     {
 149       eltlen *= F77_DIM_SIZE (ndimen + 1);
 150       F77_DIM_OFFSET (ndimen) = eltlen;
 151     }
 152 }
 153
 154
 155
 156 /* Actual function which prints out F77 arrays, Valaddr == address in
 157    the superior.  Address == the address in the inferior.  */
 158
 159 static void
 160 f77_print_array_1 (int nss, int ndimensions, struct type *type,
 161                    const gdb_byte *valaddr,
 162                    int embedded_offset, CORE_ADDR address,
 163                    struct ui_file *stream, int recurse,
 164                    const struct value *val,
 165                    const struct value_print_options *options,
 166                    int *elts)
 167 {
 168   int i;
 169
 170   if (nss != ndimensions)
 171     {
 172       for (i = 0;
 173            (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);
 174            i++)
 175         {
 176           fprintf_filtered (stream, "( ");
 177           f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 178                              valaddr,
 179                              embedded_offset + i * F77_DIM_OFFSET (nss),
 180                              address,
 181                              stream, recurse, val, options, elts);
 182           fprintf_filtered (stream, ") ");
 183         }
 184       if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
 185         fprintf_filtered (stream, "...");
 186     }
 187   else
 188     {
 189       for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
 190            i++, (*elts)++)
 191         {
 192           val_print (TYPE_TARGET_TYPE (type),
 193                      valaddr,
 194                      embedded_offset + i * F77_DIM_OFFSET (ndimensions),
 195                      address, stream, recurse,
 196                      val, options, current_language);
 197
 198           if (i != (F77_DIM_SIZE (nss) - 1))
 199             fprintf_filtered (stream, ", ");
 200
 201           if ((*elts == options->print_max - 1)
 202               && (i != (F77_DIM_SIZE (nss) - 1)))
 203             fprintf_filtered (stream, "...");
 204         }
 205     }
 206 }
 207
 208 /* This function gets called to print an F77 array, we set up some
 209    stuff and then immediately call f77_print_array_1().  */
 210
 211 static void
 212 f77_print_array (struct type *type, const gdb_byte *valaddr,
 213                  int embedded_offset,
 214                  CORE_ADDR address, struct ui_file *stream,
 215                  int recurse,
 216                  const struct value *val,
 217                  const struct value_print_options *options)
 218 {
 219   int ndimensions;
 220   int elts = 0;
 221
 222   ndimensions = calc_f77_array_dims (type);
 223
 224   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 225     error (_("\
 226 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 227            ndimensions, MAX_FORTRAN_DIMS);
 228
 229   /* Since F77 arrays are stored column-major, we set up an
 230      offset table to get at the various row's elements.  The
 231      offset table contains entries for both offset and subarray size.  */
 232
 233   f77_create_arrayprint_offset_tbl (type, stream);
 234
 235   f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
 236                      address, stream, recurse, val, options, &elts);
 237 }
 238 \f
 239
 240 /* Decorations for Fortran.  */
 241
 242 static const struct generic_val_print_decorations f_decorations =
 243 {
 244   "(",
 245   ",",
 246   ")",
 247   ".TRUE.",
 248   ".FALSE.",
 249   "VOID",
 250 };
 251
 252 /* See val_print for a description of the various parameters of this
 253    function; they are identical.  */
 254
 255 void
 256 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 257              CORE_ADDR address, struct ui_file *stream, int recurse,
 258              const struct value *original_value,
 259              const struct value_print_options *options)
 260 {
 261   struct gdbarch *gdbarch = get_type_arch (type);
 262   enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
 263   unsigned int i = 0;   /* Number of characters printed.  */
 264   struct type *elttype;
 265   CORE_ADDR addr;
 266   int index;
 267
 268   CHECK_TYPEDEF (type);
 269   switch (TYPE_CODE (type))
 270     {
 271     case TYPE_CODE_STRING:
 272       f77_get_dynamic_length_of_aggregate (type);
 273       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 274                        valaddr + embedded_offset,
 275                        TYPE_LENGTH (type), NULL, 0, options);
 276       break;
 277
 278     case TYPE_CODE_ARRAY:
 279       if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
 280         {
 281           fprintf_filtered (stream, "(");
 282           f77_print_array (type, valaddr, embedded_offset,
 283                            address, stream, recurse, original_value, options);
 284           fprintf_filtered (stream, ")");
 285         }
 286       else
 287         {
 288           struct type *ch_type = TYPE_TARGET_TYPE (type);
 289
 290           f77_get_dynamic_length_of_aggregate (type);
 291           LA_PRINT_STRING (stream, ch_type,
 292                            valaddr + embedded_offset,
 293                            TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
 294                            NULL, 0, options);
 295         }
 296       break;
 297
 298     case TYPE_CODE_PTR:
 299       if (options->format && options->format != 's')
 300         {
 301           val_print_scalar_formatted (type, valaddr, embedded_offset,
 302                                       original_value, options, 0, stream);
 303           break;
 304         }
 305       else
 306         {
 307           int want_space = 0;
 308
 309           addr = unpack_pointer (type, valaddr + embedded_offset);
 310           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 311
 312           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 313             {
 314               /* Try to print what function it points to.  */
 315               print_function_pointer_address (options, gdbarch, addr, stream);
 316               return;
 317             }
 318
 319           if (options->symbol_print)
 320             want_space = print_address_demangle (options, gdbarch, addr,
 321                                                  stream, demangle);
 322           else if (options->addressprint && options->format != 's')
 323             {
 324               fputs_filtered (paddress (gdbarch, addr), stream);
 325               want_space = 1;
 326             }
 327
 328           /* For a pointer to char or unsigned char, also print the string
 329              pointed to, unless pointer is null.  */
 330           if (TYPE_LENGTH (elttype) == 1
 331               && TYPE_CODE (elttype) == TYPE_CODE_INT
 332               && (options->format == 0 || options->format == 's')
 333               && addr != 0)
 334             {
 335               if (want_space)
 336                 fputs_filtered (" ", stream);
 337               i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
 338                                     stream, options);
 339             }
 340           return;
 341         }
 342       break;
 343
 344     case TYPE_CODE_INT:
 345       if (options->format || options->output_format)
 346         {
 347           struct value_print_options opts = *options;
 348
 349           opts.format = (options->format ? options->format
 350                          : options->output_format);
 351           val_print_scalar_formatted (type, valaddr, embedded_offset,
 352                                       original_value, options, 0, stream);
 353         }
 354       else
 355         {
 356           val_print_type_code_int (type, valaddr + embedded_offset, stream);
 357           /* C and C++ has no single byte int type, char is used instead.
 358              Since we don't know whether the value is really intended to
 359              be used as an integer or a character, print the character
 360              equivalent as well.  */
 361           if (TYPE_LENGTH (type) == 1)
 362             {
 363               LONGEST c;
 364
 365               fputs_filtered (" ", stream);
 366               c = unpack_long (type, valaddr + embedded_offset);
 367               LA_PRINT_CHAR ((unsigned char) c, type, stream);
 368             }
 369         }
 370       break;
 371
 372     case TYPE_CODE_STRUCT:
 373     case TYPE_CODE_UNION:
 374       /* Starting from the Fortran 90 standard, Fortran supports derived
 375          types.  */
 376       fprintf_filtered (stream, "( ");
 377       for (index = 0; index < TYPE_NFIELDS (type); index++)
 378         {
 379           int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 380
 381           val_print (TYPE_FIELD_TYPE (type, index), valaddr,
 382                      embedded_offset + offset,
 383                      address, stream, recurse + 1,
 384                      original_value, options, current_language);
 385           if (index != TYPE_NFIELDS (type) - 1)
 386             fputs_filtered (", ", stream);
 387         }
 388       fprintf_filtered (stream, " )");
 389       break;
 390
 391     case TYPE_CODE_REF:
 392     case TYPE_CODE_FUNC:
 393     case TYPE_CODE_FLAGS:
 394     case TYPE_CODE_FLT:
 395     case TYPE_CODE_VOID:
 396     case TYPE_CODE_ERROR:
 397     case TYPE_CODE_RANGE:
 398     case TYPE_CODE_UNDEF:
 399     case TYPE_CODE_COMPLEX:
 400     case TYPE_CODE_BOOL:
 401     case TYPE_CODE_CHAR:
 402     default:
 403       generic_val_print (type, valaddr, embedded_offset, address,
 404                          stream, recurse, original_value, options,
 405                          &f_decorations);
 406       break;
 407     }
 408   gdb_flush (stream);
 409 }
 410
 411 static void
 412 info_common_command_for_block (const struct block *block, const char *comname,
 413                                int *any_printed)
 414 {
 415   struct block_iterator iter;
 416   struct symbol *sym;
 417   const char *name;
 418   struct value_print_options opts;
 419
 420   get_user_print_options (&opts);
 421
 422   ALL_BLOCK_SYMBOLS (block, iter, sym)
 423     if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
 424       {
 425         const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
 426         size_t index;
 427
 428         gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
 429
 430         if (comname && (!SYMBOL_LINKAGE_NAME (sym)
 431                         || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
 432           continue;
 433
 434         if (*any_printed)
 435           putchar_filtered ('\n');
 436         else
 437           *any_printed = 1;
 438         if (SYMBOL_PRINT_NAME (sym))
 439           printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
 440                            SYMBOL_PRINT_NAME (sym));
 441         else
 442           printf_filtered (_("Contents of blank COMMON block:\n"));
 443
 444         for (index = 0; index < common->n_entries; index++)
 445           {
 446             struct value *val = NULL;
 447             volatile struct gdb_exception except;
 448
 449             printf_filtered ("%s = ",
 450                              SYMBOL_PRINT_NAME (common->contents[index]));
 451
 452             TRY_CATCH (except, RETURN_MASK_ERROR)
 453               {
 454                 val = value_of_variable (common->contents[index], block);
 455                 value_print (val, gdb_stdout, &opts);
 456               }
 457
 458             if (except.reason < 0)
 459               printf_filtered ("<error reading variable: %s>", except.message);
 460             putchar_filtered ('\n');
 461           }
 462       }
 463 }
 464
 465 /* This function is used to print out the values in a given COMMON
 466    block.  It will always use the most local common block of the
 467    given name.  */
 468
 469 static void
 470 info_common_command (char *comname, int from_tty)
 471 {
 472   struct frame_info *fi;
 473   const struct block *block;
 474   int values_printed = 0;
 475
 476   /* We have been told to display the contents of F77 COMMON
 477      block supposedly visible in this function.  Let us
 478      first make sure that it is visible and if so, let
 479      us display its contents.  */
 480
 481   fi = get_selected_frame (_("No frame selected"));
 482
 483   /* The following is generally ripped off from stack.c's routine
 484      print_frame_info().  */
 485
 486   block = get_frame_block (fi, 0);
 487   if (block == NULL)
 488     {
 489       printf_filtered (_("No symbol table info available.\n"));
 490       return;
 491     }
 492
 493   while (block)
 494     {
 495       info_common_command_for_block (block, comname, &values_printed);
 496       /* After handling the function's top-level block, stop.  Don't
 497          continue to its superblock, the block of per-file symbols.  */
 498       if (BLOCK_FUNCTION (block))
 499         break;
 500       block = BLOCK_SUPERBLOCK (block);
 501     }
 502
 503   if (!values_printed)
 504     {
 505       if (comname)
 506         printf_filtered (_("No common block '%s'.\n"), comname);
 507       else
 508         printf_filtered (_("No common blocks.\n"));
 509     }
 510 }
 511
 512 void
 513 _initialize_f_valprint (void)
 514 {
 515   add_info ("common", info_common_command,
 516             _("Print out the values contained in a Fortran COMMON block."));
 517   if (xdb_commands)
 518     add_com ("lc", class_info, info_common_command,
 519              _("Print out the values contained in a Fortran COMMON block."));
 520 }