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
  38 extern void _initialize_f_valprint (void);
  39 static void info_common_command (char *, int);
  40 static void list_all_visible_commons (const char *);
  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 list_all_visible_commons (const char *funname)
 414 {
 415   SAVED_F77_COMMON_PTR tmp;
 416
 417   tmp = head_common_list;
 418
 419   printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
 420
 421   while (tmp != NULL)
 422     {
 423       if (strcmp (tmp->owning_function, funname) == 0)
 424         printf_filtered ("%s\n", tmp->name);
 425
 426       tmp = tmp->next;
 427     }
 428 }
 429
 430 /* This function is used to print out the values in a given COMMON
 431    block.  It will always use the most local common block of the
 432    given name.  */
 433
 434 static void
 435 info_common_command (char *comname, int from_tty)
 436 {
 437   SAVED_F77_COMMON_PTR the_common;
 438   COMMON_ENTRY_PTR entry;
 439   struct frame_info *fi;
 440   const char *funname = 0;
 441   struct symbol *func;
 442
 443   /* We have been told to display the contents of F77 COMMON
 444      block supposedly visible in this function.  Let us
 445      first make sure that it is visible and if so, let
 446      us display its contents.  */
 447
 448   fi = get_selected_frame (_("No frame selected"));
 449
 450   /* The following is generally ripped off from stack.c's routine
 451      print_frame_info().  */
 452
 453   func = find_pc_function (get_frame_pc (fi));
 454   if (func)
 455     {
 456       /* In certain pathological cases, the symtabs give the wrong
 457          function (when we are in the first function in a file which
 458          is compiled without debugging symbols, the previous function
 459          is compiled with debugging symbols, and the "foo.o" symbol
 460          that is supposed to tell us where the file with debugging symbols
 461          ends has been truncated by ar because it is longer than 15
 462          characters).
 463
 464          So look in the minimal symbol tables as well, and if it comes
 465          up with a larger address for the function use that instead.
 466          I don't think this can ever cause any problems; there shouldn't
 467          be any minimal symbols in the middle of a function.
 468          FIXME:  (Not necessarily true.  What about text labels?)  */
 469
 470       struct minimal_symbol *msymbol =
 471         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 472
 473       if (msymbol != NULL
 474           && (SYMBOL_VALUE_ADDRESS (msymbol)
 475               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 476         funname = SYMBOL_LINKAGE_NAME (msymbol);
 477       else
 478         funname = SYMBOL_LINKAGE_NAME (func);
 479     }
 480   else
 481     {
 482       struct minimal_symbol *msymbol =
 483         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 484
 485       if (msymbol != NULL)
 486         funname = SYMBOL_LINKAGE_NAME (msymbol);
 487       else /* Got no 'funname', code below will fail.  */
 488         error (_("No function found for frame."));
 489     }
 490
 491   /* If comname is NULL, we assume the user wishes to see the
 492      which COMMON blocks are visible here and then return.  */
 493
 494   if (comname == 0)
 495     {
 496       list_all_visible_commons (funname);
 497       return;
 498     }
 499
 500   the_common = find_common_for_function (comname, funname);
 501
 502   if (the_common)
 503     {
 504       struct frame_id frame_id = get_frame_id (fi);
 505
 506       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 507         printf_filtered (_("Contents of blank COMMON block:\n"));
 508       else
 509         printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
 510
 511       printf_filtered ("\n");
 512       entry = the_common->entries;
 513
 514       while (entry != NULL)
 515         {
 516           fi = frame_find_by_id (frame_id);
 517           if (fi == NULL)
 518             {
 519               warning (_("Unable to restore previously selected frame."));
 520               break;
 521             }
 522
 523           print_variable_and_value (NULL, entry->symbol, fi, gdb_stdout, 0);
 524
 525           /* print_variable_and_value invalidates FI.  */
 526           fi = NULL;
 527
 528           entry = entry->next;
 529         }
 530     }
 531   else
 532     printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
 533                      comname, funname);
 534 }
 535
 536 void
 537 _initialize_f_valprint (void)
 538 {
 539   add_info ("common", info_common_command,
 540             _("Print out the values contained in a Fortran COMMON block."));
 541   if (xdb_commands)
 542     add_com ("lc", class_info, info_common_command,
 543              _("Print out the values contained in a Fortran COMMON block."));
 544 }