gdb/f-valprint.c

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