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 *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; (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max); i++)
 176         {
 177           fprintf_filtered (stream, "( ");
 178           f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 179                              valaddr + i * F77_DIM_OFFSET (nss),
 180                              address + i * F77_DIM_OFFSET (nss),
 181                              stream, recurse, val, options, elts);
 182           fprintf_filtered (stream, ") ");
 183         }
 184       if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
 185         fprintf_filtered (stream, "...");
 186     }
 187   else
 188     {
 189       for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
 190            i++, (*elts)++)
 191         {
 192           val_print (TYPE_TARGET_TYPE (type),
 193                      valaddr + i * F77_DIM_OFFSET (ndimensions),
 194                      0,
 195                      address + i * F77_DIM_OFFSET (ndimensions),
 196                      stream, recurse, val, options, current_language);
 197
 198           if (i != (F77_DIM_SIZE (nss) - 1))
 199             fprintf_filtered (stream, ", ");
 200
 201           if ((*elts == options->print_max - 1)
 202               && (i != (F77_DIM_SIZE (nss) - 1)))
 203             fprintf_filtered (stream, "...");
 204         }
 205     }
 206 }
 207
 208 /* This function gets called to print an F77 array, we set up some
 209    stuff and then immediately call f77_print_array_1() */
 210
 211 static void
 212 f77_print_array (struct type *type, const gdb_byte *valaddr,
 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 (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 225            ndimensions, MAX_FORTRAN_DIMS);
 226
 227   /* Since F77 arrays are stored column-major, we set up an
 228      offset table to get at the various row's elements. The
 229      offset table contains entries for both offset and subarray size. */
 230
 231   f77_create_arrayprint_offset_tbl (type, stream);
 232
 233   f77_print_array_1 (1, ndimensions, type, valaddr, address, stream,
 234                      recurse, val, options, &elts);
 235 }
 236 \f
 237
 238 /* Print data of type TYPE located at VALADDR (within GDB), which came from
 239    the inferior at address ADDRESS, onto stdio stream STREAM according to
 240    OPTIONS.  The data at VALADDR is in target byte order.
 241
 242    If the data are a string pointer, returns the number of string characters
 243    printed.  */
 244
 245 int
 246 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 247              CORE_ADDR address, struct ui_file *stream, int recurse,
 248              const struct value *original_value,
 249              const struct value_print_options *options)
 250 {
 251   struct gdbarch *gdbarch = get_type_arch (type);
 252   enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
 253   unsigned int i = 0;   /* Number of characters printed */
 254   struct type *elttype;
 255   LONGEST val;
 256   CORE_ADDR addr;
 257   int index;
 258
 259   CHECK_TYPEDEF (type);
 260   switch (TYPE_CODE (type))
 261     {
 262     case TYPE_CODE_STRING:
 263       f77_get_dynamic_length_of_aggregate (type);
 264       LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
 265                        valaddr, TYPE_LENGTH (type), NULL, 0, options);
 266       break;
 267
 268     case TYPE_CODE_ARRAY:
 269       fprintf_filtered (stream, "(");
 270       f77_print_array (type, valaddr, address, stream, recurse, original_value, options);
 271       fprintf_filtered (stream, ")");
 272       break;
 273
 274     case TYPE_CODE_PTR:
 275       if (options->format && options->format != 's')
 276         {
 277           print_scalar_formatted (valaddr, type, options, 0, stream);
 278           break;
 279         }
 280       else
 281         {
 282           addr = unpack_pointer (type, valaddr);
 283           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 284
 285           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 286             {
 287               /* Try to print what function it points to.  */
 288               print_address_demangle (gdbarch, addr, stream, demangle);
 289               /* Return value is irrelevant except for string pointers.  */
 290               return 0;
 291             }
 292
 293           if (options->addressprint && options->format != 's')
 294             fputs_filtered (paddress (gdbarch, addr), stream);
 295
 296           /* For a pointer to char or unsigned char, also print the string
 297              pointed to, unless pointer is null.  */
 298           if (TYPE_LENGTH (elttype) == 1
 299               && TYPE_CODE (elttype) == TYPE_CODE_INT
 300               && (options->format == 0 || options->format == 's')
 301               && addr != 0)
 302             i = val_print_string (TYPE_TARGET_TYPE (type), addr, -1, stream,
 303                                   options);
 304
 305           /* Return number of characters printed, including the terminating
 306              '\0' if we reached the end.  val_print_string takes care including
 307              the terminating '\0' if necessary.  */
 308           return i;
 309         }
 310       break;
 311
 312     case TYPE_CODE_REF:
 313       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 314       if (options->addressprint)
 315         {
 316           CORE_ADDR addr
 317             = extract_typed_address (valaddr + embedded_offset, type);
 318
 319           fprintf_filtered (stream, "@");
 320           fputs_filtered (paddress (gdbarch, addr), stream);
 321           if (options->deref_ref)
 322             fputs_filtered (": ", stream);
 323         }
 324       /* De-reference the reference.  */
 325       if (options->deref_ref)
 326         {
 327           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 328             {
 329               struct value *deref_val =
 330                 value_at
 331                 (TYPE_TARGET_TYPE (type),
 332                  unpack_pointer (type, valaddr + embedded_offset));
 333
 334               common_val_print (deref_val, stream, recurse,
 335                                 options, current_language);
 336             }
 337           else
 338             fputs_filtered ("???", stream);
 339         }
 340       break;
 341
 342     case TYPE_CODE_FUNC:
 343       if (options->format)
 344         {
 345           print_scalar_formatted (valaddr, type, options, 0, stream);
 346           break;
 347         }
 348       /* FIXME, we should consider, at least for ANSI C language, eliminating
 349          the distinction made between FUNCs and POINTERs to FUNCs.  */
 350       fprintf_filtered (stream, "{");
 351       type_print (type, "", stream, -1);
 352       fprintf_filtered (stream, "} ");
 353       /* Try to print what function it points to, and its address.  */
 354       print_address_demangle (gdbarch, address, stream, demangle);
 355       break;
 356
 357     case TYPE_CODE_INT:
 358       if (options->format || options->output_format)
 359         {
 360           struct value_print_options opts = *options;
 361
 362           opts.format = (options->format ? options->format
 363                          : options->output_format);
 364           print_scalar_formatted (valaddr, type, &opts, 0, stream);
 365         }
 366       else
 367         {
 368           val_print_type_code_int (type, valaddr, stream);
 369           /* C and C++ has no single byte int type, char is used instead.
 370              Since we don't know whether the value is really intended to
 371              be used as an integer or a character, print the character
 372              equivalent as well. */
 373           if (TYPE_LENGTH (type) == 1)
 374             {
 375               fputs_filtered (" ", stream);
 376               LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
 377                              type, stream);
 378             }
 379         }
 380       break;
 381
 382     case TYPE_CODE_FLAGS:
 383       if (options->format)
 384           print_scalar_formatted (valaddr, type, options, 0, stream);
 385       else
 386         val_print_type_code_flags (type, valaddr, stream);
 387       break;
 388
 389     case TYPE_CODE_FLT:
 390       if (options->format)
 391         print_scalar_formatted (valaddr, type, options, 0, stream);
 392       else
 393         print_floating (valaddr, type, stream);
 394       break;
 395
 396     case TYPE_CODE_VOID:
 397       fprintf_filtered (stream, "VOID");
 398       break;
 399
 400     case TYPE_CODE_ERROR:
 401       fprintf_filtered (stream, "%s", TYPE_ERROR_NAME (type));
 402       break;
 403
 404     case TYPE_CODE_RANGE:
 405       /* FIXME, we should not ever have to print one of these yet.  */
 406       fprintf_filtered (stream, "<range type>");
 407       break;
 408
 409     case TYPE_CODE_BOOL:
 410       if (options->format || options->output_format)
 411         {
 412           struct value_print_options opts = *options;
 413
 414           opts.format = (options->format ? options->format
 415                          : options->output_format);
 416           print_scalar_formatted (valaddr, type, &opts, 0, stream);
 417         }
 418       else
 419         {
 420           val = extract_unsigned_integer (valaddr,
 421                                           TYPE_LENGTH (type), byte_order);
 422           if (val == 0)
 423             fprintf_filtered (stream, ".FALSE.");
 424           else if (val == 1)
 425             fprintf_filtered (stream, ".TRUE.");
 426           else
 427             /* Not a legitimate logical type, print as an integer.  */
 428             {
 429               /* Bash the type code temporarily.  */
 430               TYPE_CODE (type) = TYPE_CODE_INT;
 431               val_print (type, valaddr, 0, address, stream, recurse,
 432                          original_value, options, current_language);
 433               /* Restore the type code so later uses work as intended. */
 434               TYPE_CODE (type) = TYPE_CODE_BOOL;
 435             }
 436         }
 437       break;
 438
 439     case TYPE_CODE_COMPLEX:
 440       type = TYPE_TARGET_TYPE (type);
 441       fputs_filtered ("(", stream);
 442       print_floating (valaddr, type, stream);
 443       fputs_filtered (",", stream);
 444       print_floating (valaddr + TYPE_LENGTH (type), type, stream);
 445       fputs_filtered (")", stream);
 446       break;
 447
 448     case TYPE_CODE_UNDEF:
 449       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 450          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 451          and no complete type for struct foo in that file.  */
 452       fprintf_filtered (stream, "<incomplete type>");
 453       break;
 454
 455     case TYPE_CODE_STRUCT:
 456     case TYPE_CODE_UNION:
 457       /* Starting from the Fortran 90 standard, Fortran supports derived
 458          types.  */
 459       fprintf_filtered (stream, "( ");
 460       for (index = 0; index < TYPE_NFIELDS (type); index++)
 461         {
 462           int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 463
 464           val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
 465                      embedded_offset, address, stream, recurse + 1,
 466                      original_value, options, current_language);
 467           if (index != TYPE_NFIELDS (type) - 1)
 468             fputs_filtered (", ", stream);
 469         }
 470       fprintf_filtered (stream, " )");
 471       break;
 472
 473     default:
 474       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
 475     }
 476   gdb_flush (stream);
 477   return 0;
 478 }
 479
 480 static void
 481 list_all_visible_commons (char *funname)
 482 {
 483   SAVED_F77_COMMON_PTR tmp;
 484
 485   tmp = head_common_list;
 486
 487   printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
 488
 489   while (tmp != NULL)
 490     {
 491       if (strcmp (tmp->owning_function, funname) == 0)
 492         printf_filtered ("%s\n", tmp->name);
 493
 494       tmp = tmp->next;
 495     }
 496 }
 497
 498 /* This function is used to print out the values in a given COMMON
 499    block. It will always use the most local common block of the
 500    given name */
 501
 502 static void
 503 info_common_command (char *comname, int from_tty)
 504 {
 505   SAVED_F77_COMMON_PTR the_common;
 506   COMMON_ENTRY_PTR entry;
 507   struct frame_info *fi;
 508   char *funname = 0;
 509   struct symbol *func;
 510
 511   /* We have been told to display the contents of F77 COMMON
 512      block supposedly visible in this function.  Let us
 513      first make sure that it is visible and if so, let
 514      us display its contents */
 515
 516   fi = get_selected_frame (_("No frame selected"));
 517
 518   /* The following is generally ripped off from stack.c's routine
 519      print_frame_info() */
 520
 521   func = find_pc_function (get_frame_pc (fi));
 522   if (func)
 523     {
 524       /* In certain pathological cases, the symtabs give the wrong
 525          function (when we are in the first function in a file which
 526          is compiled without debugging symbols, the previous function
 527          is compiled with debugging symbols, and the "foo.o" symbol
 528          that is supposed to tell us where the file with debugging symbols
 529          ends has been truncated by ar because it is longer than 15
 530          characters).
 531
 532          So look in the minimal symbol tables as well, and if it comes
 533          up with a larger address for the function use that instead.
 534          I don't think this can ever cause any problems; there shouldn't
 535          be any minimal symbols in the middle of a function.
 536          FIXME:  (Not necessarily true.  What about text labels) */
 537
 538       struct minimal_symbol *msymbol =
 539         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 540
 541       if (msymbol != NULL
 542           && (SYMBOL_VALUE_ADDRESS (msymbol)
 543               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 544         funname = SYMBOL_LINKAGE_NAME (msymbol);
 545       else
 546         funname = SYMBOL_LINKAGE_NAME (func);
 547     }
 548   else
 549     {
 550       struct minimal_symbol *msymbol =
 551         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 552
 553       if (msymbol != NULL)
 554         funname = SYMBOL_LINKAGE_NAME (msymbol);
 555       else /* Got no 'funname', code below will fail.  */
 556         error (_("No function found for frame."));
 557     }
 558
 559   /* If comname is NULL, we assume the user wishes to see the
 560      which COMMON blocks are visible here and then return */
 561
 562   if (comname == 0)
 563     {
 564       list_all_visible_commons (funname);
 565       return;
 566     }
 567
 568   the_common = find_common_for_function (comname, funname);
 569
 570   if (the_common)
 571     {
 572       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 573         printf_filtered (_("Contents of blank COMMON block:\n"));
 574       else
 575         printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
 576
 577       printf_filtered ("\n");
 578       entry = the_common->entries;
 579
 580       while (entry != NULL)
 581         {
 582           print_variable_and_value (NULL, entry->symbol, fi, gdb_stdout, 0);
 583           entry = entry->next;
 584         }
 585     }
 586   else
 587     printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
 588                      comname, funname);
 589 }
 590
 591 /* This function is used to determine whether there is a
 592    F77 common block visible at the current scope called 'comname'. */
 593
 594 #if 0
 595 static int
 596 there_is_a_visible_common_named (char *comname)
 597 {
 598   SAVED_F77_COMMON_PTR the_common;
 599   struct frame_info *fi;
 600   char *funname = 0;
 601   struct symbol *func;
 602
 603   if (comname == NULL)
 604     error (_("Cannot deal with NULL common name!"));
 605
 606   fi = get_selected_frame (_("No frame selected"));
 607
 608   /* The following is generally ripped off from stack.c's routine
 609      print_frame_info() */
 610
 611   func = find_pc_function (fi->pc);
 612   if (func)
 613     {
 614       /* In certain pathological cases, the symtabs give the wrong
 615          function (when we are in the first function in a file which
 616          is compiled without debugging symbols, the previous function
 617          is compiled with debugging symbols, and the "foo.o" symbol
 618          that is supposed to tell us where the file with debugging symbols
 619          ends has been truncated by ar because it is longer than 15
 620          characters).
 621
 622          So look in the minimal symbol tables as well, and if it comes
 623          up with a larger address for the function use that instead.
 624          I don't think this can ever cause any problems; there shouldn't
 625          be any minimal symbols in the middle of a function.
 626          FIXME:  (Not necessarily true.  What about text labels) */
 627
 628       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 629
 630       if (msymbol != NULL
 631           && (SYMBOL_VALUE_ADDRESS (msymbol)
 632               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 633         funname = SYMBOL_LINKAGE_NAME (msymbol);
 634       else
 635         funname = SYMBOL_LINKAGE_NAME (func);
 636     }
 637   else
 638     {
 639       struct minimal_symbol *msymbol =
 640         lookup_minimal_symbol_by_pc (fi->pc);
 641
 642       if (msymbol != NULL)
 643         funname = SYMBOL_LINKAGE_NAME (msymbol);
 644     }
 645
 646   the_common = find_common_for_function (comname, funname);
 647
 648   return (the_common ? 1 : 0);
 649 }
 650 #endif
 651
 652 void
 653 _initialize_f_valprint (void)
 654 {
 655   add_info ("common", info_common_command,
 656             _("Print out the values contained in a Fortran COMMON block."));
 657   if (xdb_commands)
 658     add_com ("lc", class_info, info_common_command,
 659              _("Print out the values contained in a Fortran COMMON block."));
 660 }