gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2003, 2005, 2006,
   4    2007, 2008, 2009, 2010 Free Software 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 #if 0
  39 static int there_is_a_visible_common_named (char *);
  40 #endif
  41
  42 extern void _initialize_f_valprint (void);
  43 static void info_common_command (char *, int);
  44 static void list_all_visible_commons (char *);
  45 static void f77_create_arrayprint_offset_tbl (struct type *,
  46                                               struct ui_file *);
  47 static void f77_get_dynamic_length_of_aggregate (struct type *);
  48
  49 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
  50
  51 /* Array which holds offsets to be applied to get a row's elements
  52    for a given array. Array also holds the size of each subarray.  */
  53
  54 /* The following macro gives us the size of the nth dimension, Where
  55    n is 1 based. */
  56
  57 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
  58
  59 /* The following gives us the offset for row n where n is 1-based. */
  60
  61 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
  62
  63 int
  64 f77_get_lowerbound (struct type *type)
  65 {
  66   if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
  67     error (_("Lower bound may not be '*' in F77"));
  68
  69   return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
  70 }
  71
  72 int
  73 f77_get_upperbound (struct type *type)
  74 {
  75   if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
  76     {
  77       /* We have an assumed size array on our hands.  Assume that
  78          upper_bound == lower_bound so that we show at least 1 element.
  79          If the user wants to see more elements, let him manually ask for 'em
  80          and we'll subscript the array and show him.  */
  81
  82       return f77_get_lowerbound (type);
  83     }
  84
  85   return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
  86 }
  87
  88 /* Obtain F77 adjustable array dimensions */
  89
  90 static void
  91 f77_get_dynamic_length_of_aggregate (struct type *type)
  92 {
  93   int upper_bound = -1;
  94   int lower_bound = 1;
  95
  96   /* Recursively go all the way down into a possibly multi-dimensional
  97      F77 array and get the bounds.  For simple arrays, this is pretty
  98      easy but when the bounds are dynamic, we must be very careful
  99      to add up all the lengths correctly.  Not doing this right
 100      will lead to horrendous-looking arrays in parameter lists.
 101
 102      This function also works for strings which behave very
 103      similarly to arrays.  */
 104
 105   if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
 106       || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
 107     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
 108
 109   /* Recursion ends here, start setting up lengths.  */
 110   lower_bound = f77_get_lowerbound (type);
 111   upper_bound = f77_get_upperbound (type);
 112
 113   /* Patch in a valid length value. */
 114
 115   TYPE_LENGTH (type) =
 116     (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 117 }
 118
 119 /* Function that sets up the array offset,size table for the array
 120    type "type".  */
 121
 122 static void
 123 f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
 124 {
 125   struct type *tmp_type;
 126   int eltlen;
 127   int ndimen = 1;
 128   int upper, lower;
 129
 130   tmp_type = type;
 131
 132   while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
 133     {
 134       upper = f77_get_upperbound (tmp_type);
 135       lower = f77_get_lowerbound (tmp_type);
 136
 137       F77_DIM_SIZE (ndimen) = upper - lower + 1;
 138
 139       tmp_type = TYPE_TARGET_TYPE (tmp_type);
 140       ndimen++;
 141     }
 142
 143   /* Now we multiply eltlen by all the offsets, so that later we
 144      can print out array elements correctly.  Up till now we
 145      know an offset to apply to get the item but we also
 146      have to know how much to add to get to the next item */
 147
 148   ndimen--;
 149   eltlen = TYPE_LENGTH (tmp_type);
 150   F77_DIM_OFFSET (ndimen) = eltlen;
 151   while (--ndimen > 0)
 152     {
 153       eltlen *= F77_DIM_SIZE (ndimen + 1);
 154       F77_DIM_OFFSET (ndimen) = eltlen;
 155     }
 156 }
 157
 158
 159
 160 /* Actual function which prints out F77 arrays, Valaddr == address in
 161    the superior.  Address == the address in the inferior.  */
 162
 163 static void
 164 f77_print_array_1 (int nss, int ndimensions, struct type *type,
 165                    const gdb_byte *valaddr, CORE_ADDR address,
 166                    struct ui_file *stream, int recurse,
 167                    const struct value_print_options *options,
 168                    int *elts)
 169 {
 170   int i;
 171
 172   if (nss != ndimensions)
 173     {
 174       for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max); i++)
 175         {
 176           fprintf_filtered (stream, "( ");
 177           f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 178                              valaddr + i * F77_DIM_OFFSET (nss),
 179                              address + i * F77_DIM_OFFSET (nss),
 180                              stream, recurse, 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 + i * F77_DIM_OFFSET (ndimensions),
 193                      0,
 194                      address + i * F77_DIM_OFFSET (ndimensions),
 195                      stream, recurse, 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                  CORE_ADDR address, struct ui_file *stream,
 213                  int recurse, const struct value_print_options *options)
 214 {
 215   int ndimensions;
 216   int elts = 0;
 217
 218   ndimensions = calc_f77_array_dims (type);
 219
 220   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 221     error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 222            ndimensions, MAX_FORTRAN_DIMS);
 223
 224   /* Since F77 arrays are stored column-major, we set up an
 225      offset table to get at the various row's elements. The
 226      offset table contains entries for both offset and subarray size. */
 227
 228   f77_create_arrayprint_offset_tbl (type, stream);
 229
 230   f77_print_array_1 (1, ndimensions, type, valaddr, address, stream,
 231                      recurse, options, &elts);
 232 }
 233 \f
 234
 235 /* Print data of type TYPE located at VALADDR (within GDB), which came from
 236    the inferior at address ADDRESS, onto stdio stream STREAM according to
 237    OPTIONS.  The data at VALADDR is in target byte order.
 238
 239    If the data are a string pointer, returns the number of string characters
 240    printed.  */
 241
 242 int
 243 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 244              CORE_ADDR address, struct ui_file *stream, int recurse,
 245              const struct value_print_options *options)
 246 {
 247   struct gdbarch *gdbarch = get_type_arch (type);
 248   enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
 249   unsigned int i = 0;   /* Number of characters printed */
 250   struct type *elttype;
 251   LONGEST val;
 252   CORE_ADDR addr;
 253   int index;
 254
 255   CHECK_TYPEDEF (type);
 256   switch (TYPE_CODE (type))
 257     {
 258     case TYPE_CODE_STRING:
 259       f77_get_dynamic_length_of_aggregate (type);
 260       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 261                        valaddr, TYPE_LENGTH (type), NULL, 0, options);
 262       break;
 263
 264     case TYPE_CODE_ARRAY:
 265       fprintf_filtered (stream, "(");
 266       f77_print_array (type, valaddr, address, stream, recurse, options);
 267       fprintf_filtered (stream, ")");
 268       break;
 269
 270     case TYPE_CODE_PTR:
 271       if (options->format && options->format != 's')
 272         {
 273           print_scalar_formatted (valaddr, type, options, 0, stream);
 274           break;
 275         }
 276       else
 277         {
 278           addr = unpack_pointer (type, valaddr);
 279           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 280
 281           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 282             {
 283               /* Try to print what function it points to.  */
 284               print_address_demangle (gdbarch, addr, stream, demangle);
 285               /* Return value is irrelevant except for string pointers.  */
 286               return 0;
 287             }
 288
 289           if (options->addressprint && options->format != 's')
 290             fputs_filtered (paddress (gdbarch, addr), stream);
 291
 292           /* For a pointer to char or unsigned char, also print the string
 293              pointed to, unless pointer is null.  */
 294           if (TYPE_LENGTH (elttype) == 1
 295               && TYPE_CODE (elttype) == TYPE_CODE_INT
 296               && (options->format == 0 || options->format == 's')
 297               && addr != 0)
 298             i = val_print_string (TYPE_TARGET_TYPE (type), addr, -1, stream,
 299                                   options);
 300
 301           /* Return number of characters printed, including the terminating
 302              '\0' if we reached the end.  val_print_string takes care including
 303              the terminating '\0' if necessary.  */
 304           return i;
 305         }
 306       break;
 307
 308     case TYPE_CODE_REF:
 309       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 310       if (options->addressprint)
 311         {
 312           CORE_ADDR addr
 313             = extract_typed_address (valaddr + embedded_offset, type);
 314           fprintf_filtered (stream, "@");
 315           fputs_filtered (paddress (gdbarch, addr), stream);
 316           if (options->deref_ref)
 317             fputs_filtered (": ", stream);
 318         }
 319       /* De-reference the reference.  */
 320       if (options->deref_ref)
 321         {
 322           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 323             {
 324               struct value *deref_val =
 325               value_at
 326               (TYPE_TARGET_TYPE (type),
 327                unpack_pointer (type, valaddr + embedded_offset));
 328               common_val_print (deref_val, stream, recurse,
 329                                 options, current_language);
 330             }
 331           else
 332             fputs_filtered ("???", stream);
 333         }
 334       break;
 335
 336     case TYPE_CODE_FUNC:
 337       if (options->format)
 338         {
 339           print_scalar_formatted (valaddr, type, options, 0, stream);
 340           break;
 341         }
 342       /* FIXME, we should consider, at least for ANSI C language, eliminating
 343          the distinction made between FUNCs and POINTERs to FUNCs.  */
 344       fprintf_filtered (stream, "{");
 345       type_print (type, "", stream, -1);
 346       fprintf_filtered (stream, "} ");
 347       /* Try to print what function it points to, and its address.  */
 348       print_address_demangle (gdbarch, address, stream, demangle);
 349       break;
 350
 351     case TYPE_CODE_INT:
 352       if (options->format || options->output_format)
 353         {
 354           struct value_print_options opts = *options;
 355           opts.format = (options->format ? options->format
 356                          : options->output_format);
 357           print_scalar_formatted (valaddr, type, &opts, 0, stream);
 358         }
 359       else
 360         {
 361           val_print_type_code_int (type, valaddr, stream);
 362           /* C and C++ has no single byte int type, char is used instead.
 363              Since we don't know whether the value is really intended to
 364              be used as an integer or a character, print the character
 365              equivalent as well. */
 366           if (TYPE_LENGTH (type) == 1)
 367             {
 368               fputs_filtered (" ", stream);
 369               LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
 370                              type, stream);
 371             }
 372         }
 373       break;
 374
 375     case TYPE_CODE_FLAGS:
 376       if (options->format)
 377           print_scalar_formatted (valaddr, type, options, 0, stream);
 378       else
 379         val_print_type_code_flags (type, valaddr, stream);
 380       break;
 381
 382     case TYPE_CODE_FLT:
 383       if (options->format)
 384         print_scalar_formatted (valaddr, type, options, 0, stream);
 385       else
 386         print_floating (valaddr, type, stream);
 387       break;
 388
 389     case TYPE_CODE_VOID:
 390       fprintf_filtered (stream, "VOID");
 391       break;
 392
 393     case TYPE_CODE_ERROR:
 394       fprintf_filtered (stream, "<error type>");
 395       break;
 396
 397     case TYPE_CODE_RANGE:
 398       /* FIXME, we should not ever have to print one of these yet.  */
 399       fprintf_filtered (stream, "<range type>");
 400       break;
 401
 402     case TYPE_CODE_BOOL:
 403       if (options->format || options->output_format)
 404         {
 405           struct value_print_options opts = *options;
 406           opts.format = (options->format ? options->format
 407                          : options->output_format);
 408           print_scalar_formatted (valaddr, type, &opts, 0, stream);
 409         }
 410       else
 411         {
 412           val = extract_unsigned_integer (valaddr,
 413                                           TYPE_LENGTH (type), byte_order);
 414           if (val == 0)
 415             fprintf_filtered (stream, ".FALSE.");
 416           else if (val == 1)
 417             fprintf_filtered (stream, ".TRUE.");
 418           else
 419             /* Not a legitimate logical type, print as an integer.  */
 420             {
 421               /* Bash the type code temporarily.  */
 422               TYPE_CODE (type) = TYPE_CODE_INT;
 423               f_val_print (type, valaddr, 0, address, stream, recurse, options);
 424               /* Restore the type code so later uses work as intended. */
 425               TYPE_CODE (type) = TYPE_CODE_BOOL;
 426             }
 427         }
 428       break;
 429
 430     case TYPE_CODE_COMPLEX:
 431       type = TYPE_TARGET_TYPE (type);
 432       fputs_filtered ("(", stream);
 433       print_floating (valaddr, type, stream);
 434       fputs_filtered (",", stream);
 435       print_floating (valaddr + TYPE_LENGTH (type), type, stream);
 436       fputs_filtered (")", stream);
 437       break;
 438
 439     case TYPE_CODE_UNDEF:
 440       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 441          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 442          and no complete type for struct foo in that file.  */
 443       fprintf_filtered (stream, "<incomplete type>");
 444       break;
 445
 446     case TYPE_CODE_STRUCT:
 447     case TYPE_CODE_UNION:
 448       /* Starting from the Fortran 90 standard, Fortran supports derived
 449          types.  */
 450       fprintf_filtered (stream, "( ");
 451       for (index = 0; index < TYPE_NFIELDS (type); index++)
 452         {
 453           int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 454           f_val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
 455                        embedded_offset, address, stream, recurse, options);
 456           if (index != TYPE_NFIELDS (type) - 1)
 457             fputs_filtered (", ", stream);
 458         }
 459       fprintf_filtered (stream, " )");
 460       break;
 461
 462     default:
 463       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
 464     }
 465   gdb_flush (stream);
 466   return 0;
 467 }
 468
 469 static void
 470 list_all_visible_commons (char *funname)
 471 {
 472   SAVED_F77_COMMON_PTR tmp;
 473
 474   tmp = head_common_list;
 475
 476   printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
 477
 478   while (tmp != NULL)
 479     {
 480       if (strcmp (tmp->owning_function, funname) == 0)
 481         printf_filtered ("%s\n", tmp->name);
 482
 483       tmp = tmp->next;
 484     }
 485 }
 486
 487 /* This function is used to print out the values in a given COMMON
 488    block. It will always use the most local common block of the
 489    given name */
 490
 491 static void
 492 info_common_command (char *comname, int from_tty)
 493 {
 494   SAVED_F77_COMMON_PTR the_common;
 495   COMMON_ENTRY_PTR entry;
 496   struct frame_info *fi;
 497   char *funname = 0;
 498   struct symbol *func;
 499
 500   /* We have been told to display the contents of F77 COMMON
 501      block supposedly visible in this function.  Let us
 502      first make sure that it is visible and if so, let
 503      us display its contents */
 504
 505   fi = get_selected_frame (_("No frame selected"));
 506
 507   /* The following is generally ripped off from stack.c's routine
 508      print_frame_info() */
 509
 510   func = find_pc_function (get_frame_pc (fi));
 511   if (func)
 512     {
 513       /* In certain pathological cases, the symtabs give the wrong
 514          function (when we are in the first function in a file which
 515          is compiled without debugging symbols, the previous function
 516          is compiled with debugging symbols, and the "foo.o" symbol
 517          that is supposed to tell us where the file with debugging symbols
 518          ends has been truncated by ar because it is longer than 15
 519          characters).
 520
 521          So look in the minimal symbol tables as well, and if it comes
 522          up with a larger address for the function use that instead.
 523          I don't think this can ever cause any problems; there shouldn't
 524          be any minimal symbols in the middle of a function.
 525          FIXME:  (Not necessarily true.  What about text labels) */
 526
 527       struct minimal_symbol *msymbol =
 528         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 529
 530       if (msymbol != NULL
 531           && (SYMBOL_VALUE_ADDRESS (msymbol)
 532               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 533         funname = SYMBOL_LINKAGE_NAME (msymbol);
 534       else
 535         funname = SYMBOL_LINKAGE_NAME (func);
 536     }
 537   else
 538     {
 539       struct minimal_symbol *msymbol =
 540       lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 541
 542       if (msymbol != NULL)
 543         funname = SYMBOL_LINKAGE_NAME (msymbol);
 544       else /* Got no 'funname', code below will fail.  */
 545         error (_("No function found for frame."));
 546     }
 547
 548   /* If comname is NULL, we assume the user wishes to see the
 549      which COMMON blocks are visible here and then return */
 550
 551   if (comname == 0)
 552     {
 553       list_all_visible_commons (funname);
 554       return;
 555     }
 556
 557   the_common = find_common_for_function (comname, funname);
 558
 559   if (the_common)
 560     {
 561       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 562         printf_filtered (_("Contents of blank COMMON block:\n"));
 563       else
 564         printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
 565
 566       printf_filtered ("\n");
 567       entry = the_common->entries;
 568
 569       while (entry != NULL)
 570         {
 571           print_variable_and_value (NULL, entry->symbol, fi, gdb_stdout, 0);
 572           entry = entry->next;
 573         }
 574     }
 575   else
 576     printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
 577                      comname, funname);
 578 }
 579
 580 /* This function is used to determine whether there is a
 581    F77 common block visible at the current scope called 'comname'. */
 582
 583 #if 0
 584 static int
 585 there_is_a_visible_common_named (char *comname)
 586 {
 587   SAVED_F77_COMMON_PTR the_common;
 588   struct frame_info *fi;
 589   char *funname = 0;
 590   struct symbol *func;
 591
 592   if (comname == NULL)
 593     error (_("Cannot deal with NULL common name!"));
 594
 595   fi = get_selected_frame (_("No frame selected"));
 596
 597   /* The following is generally ripped off from stack.c's routine
 598      print_frame_info() */
 599
 600   func = find_pc_function (fi->pc);
 601   if (func)
 602     {
 603       /* In certain pathological cases, the symtabs give the wrong
 604          function (when we are in the first function in a file which
 605          is compiled without debugging symbols, the previous function
 606          is compiled with debugging symbols, and the "foo.o" symbol
 607          that is supposed to tell us where the file with debugging symbols
 608          ends has been truncated by ar because it is longer than 15
 609          characters).
 610
 611          So look in the minimal symbol tables as well, and if it comes
 612          up with a larger address for the function use that instead.
 613          I don't think this can ever cause any problems; there shouldn't
 614          be any minimal symbols in the middle of a function.
 615          FIXME:  (Not necessarily true.  What about text labels) */
 616
 617       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 618
 619       if (msymbol != NULL
 620           && (SYMBOL_VALUE_ADDRESS (msymbol)
 621               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 622         funname = SYMBOL_LINKAGE_NAME (msymbol);
 623       else
 624         funname = SYMBOL_LINKAGE_NAME (func);
 625     }
 626   else
 627     {
 628       struct minimal_symbol *msymbol =
 629       lookup_minimal_symbol_by_pc (fi->pc);
 630
 631       if (msymbol != NULL)
 632         funname = SYMBOL_LINKAGE_NAME (msymbol);
 633     }
 634
 635   the_common = find_common_for_function (comname, funname);
 636
 637   return (the_common ? 1 : 0);
 638 }
 639 #endif
 640
 641 void
 642 _initialize_f_valprint (void)
 643 {
 644   add_info ("common", info_common_command,
 645             _("Print out the values contained in a Fortran COMMON block."));
 646   if (xdb_commands)
 647     add_com ("lc", class_info, info_common_command,
 648              _("Print out the values contained in a Fortran COMMON block."));
 649 }