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