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