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