gdb/f-valprint.c

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