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 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_dynamic_lowerbound (struct type *type, int *lower_bound)
  65 {
  66   struct frame_info *frame;
  67   CORE_ADDR current_frame_addr;
  68   CORE_ADDR ptr_to_lower_bound;
  69
  70   switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
  71     {
  72     case BOUND_BY_VALUE_ON_STACK:
  73       frame = deprecated_safe_get_selected_frame ();
  74       current_frame_addr = get_frame_base (frame);
  75       if (current_frame_addr > 0)
  76         {
  77           *lower_bound =
  78             read_memory_integer (current_frame_addr +
  79                                  TYPE_ARRAY_LOWER_BOUND_VALUE (type),
  80                                  4);
  81         }
  82       else
  83         {
  84           *lower_bound = DEFAULT_LOWER_BOUND;
  85           return BOUND_FETCH_ERROR;
  86         }
  87       break;
  88
  89     case BOUND_SIMPLE:
  90       *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
  91       break;
  92
  93     case BOUND_CANNOT_BE_DETERMINED:
  94       error (_("Lower bound may not be '*' in F77"));
  95       break;
  96
  97     case BOUND_BY_REF_ON_STACK:
  98       frame = deprecated_safe_get_selected_frame ();
  99       current_frame_addr = get_frame_base (frame);
 100       if (current_frame_addr > 0)
 101         {
 102           struct gdbarch *arch = get_frame_arch (frame);
 103           ptr_to_lower_bound =
 104             read_memory_typed_address (current_frame_addr +
 105                                        TYPE_ARRAY_LOWER_BOUND_VALUE (type),
 106                                        builtin_type (arch)->builtin_data_ptr);
 107           *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
 108         }
 109       else
 110         {
 111           *lower_bound = DEFAULT_LOWER_BOUND;
 112           return BOUND_FETCH_ERROR;
 113         }
 114       break;
 115
 116     case BOUND_BY_REF_IN_REG:
 117     case BOUND_BY_VALUE_IN_REG:
 118     default:
 119       error (_("??? unhandled dynamic array bound type ???"));
 120       break;
 121     }
 122   return BOUND_FETCH_OK;
 123 }
 124
 125 int
 126 f77_get_dynamic_upperbound (struct type *type, int *upper_bound)
 127 {
 128   struct frame_info *frame;
 129   CORE_ADDR current_frame_addr = 0;
 130   CORE_ADDR ptr_to_upper_bound;
 131
 132   switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
 133     {
 134     case BOUND_BY_VALUE_ON_STACK:
 135       frame = deprecated_safe_get_selected_frame ();
 136       current_frame_addr = get_frame_base (frame);
 137       if (current_frame_addr > 0)
 138         {
 139           *upper_bound =
 140             read_memory_integer (current_frame_addr +
 141                                  TYPE_ARRAY_UPPER_BOUND_VALUE (type),
 142                                  4);
 143         }
 144       else
 145         {
 146           *upper_bound = DEFAULT_UPPER_BOUND;
 147           return BOUND_FETCH_ERROR;
 148         }
 149       break;
 150
 151     case BOUND_SIMPLE:
 152       *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
 153       break;
 154
 155     case BOUND_CANNOT_BE_DETERMINED:
 156       /* we have an assumed size array on our hands. Assume that
 157          upper_bound == lower_bound so that we show at least
 158          1 element.If the user wants to see more elements, let
 159          him manually ask for 'em and we'll subscript the
 160          array and show him */
 161       f77_get_dynamic_lowerbound (type, upper_bound);
 162       break;
 163
 164     case BOUND_BY_REF_ON_STACK:
 165       frame = deprecated_safe_get_selected_frame ();
 166       current_frame_addr = get_frame_base (frame);
 167       if (current_frame_addr > 0)
 168         {
 169           struct gdbarch *arch = get_frame_arch (frame);
 170           ptr_to_upper_bound =
 171             read_memory_typed_address (current_frame_addr +
 172                                        TYPE_ARRAY_UPPER_BOUND_VALUE (type),
 173                                        builtin_type (arch)->builtin_data_ptr);
 174           *upper_bound = read_memory_integer (ptr_to_upper_bound, 4);
 175         }
 176       else
 177         {
 178           *upper_bound = DEFAULT_UPPER_BOUND;
 179           return BOUND_FETCH_ERROR;
 180         }
 181       break;
 182
 183     case BOUND_BY_REF_IN_REG:
 184     case BOUND_BY_VALUE_IN_REG:
 185     default:
 186       error (_("??? unhandled dynamic array bound type ???"));
 187       break;
 188     }
 189   return BOUND_FETCH_OK;
 190 }
 191
 192 /* Obtain F77 adjustable array dimensions */
 193
 194 static void
 195 f77_get_dynamic_length_of_aggregate (struct type *type)
 196 {
 197   int upper_bound = -1;
 198   int lower_bound = 1;
 199   int retcode;
 200
 201   /* Recursively go all the way down into a possibly multi-dimensional
 202      F77 array and get the bounds.  For simple arrays, this is pretty
 203      easy but when the bounds are dynamic, we must be very careful
 204      to add up all the lengths correctly.  Not doing this right
 205      will lead to horrendous-looking arrays in parameter lists.
 206
 207      This function also works for strings which behave very
 208      similarly to arrays.  */
 209
 210   if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
 211       || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
 212     f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
 213
 214   /* Recursion ends here, start setting up lengths.  */
 215   retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
 216   if (retcode == BOUND_FETCH_ERROR)
 217     error (_("Cannot obtain valid array lower bound"));
 218
 219   retcode = f77_get_dynamic_upperbound (type, &upper_bound);
 220   if (retcode == BOUND_FETCH_ERROR)
 221     error (_("Cannot obtain valid array upper bound"));
 222
 223   /* Patch in a valid length value. */
 224
 225   TYPE_LENGTH (type) =
 226     (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 227 }
 228
 229 /* Function that sets up the array offset,size table for the array
 230    type "type".  */
 231
 232 static void
 233 f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
 234 {
 235   struct type *tmp_type;
 236   int eltlen;
 237   int ndimen = 1;
 238   int upper, lower, retcode;
 239
 240   tmp_type = type;
 241
 242   while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
 243     {
 244       if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
 245         fprintf_filtered (stream, "<assumed size array> ");
 246
 247       retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
 248       if (retcode == BOUND_FETCH_ERROR)
 249         error (_("Cannot obtain dynamic upper bound"));
 250
 251       retcode = f77_get_dynamic_lowerbound (tmp_type, &lower);
 252       if (retcode == BOUND_FETCH_ERROR)
 253         error (_("Cannot obtain dynamic lower bound"));
 254
 255       F77_DIM_SIZE (ndimen) = upper - lower + 1;
 256
 257       tmp_type = TYPE_TARGET_TYPE (tmp_type);
 258       ndimen++;
 259     }
 260
 261   /* Now we multiply eltlen by all the offsets, so that later we
 262      can print out array elements correctly.  Up till now we
 263      know an offset to apply to get the item but we also
 264      have to know how much to add to get to the next item */
 265
 266   ndimen--;
 267   eltlen = TYPE_LENGTH (tmp_type);
 268   F77_DIM_OFFSET (ndimen) = eltlen;
 269   while (--ndimen > 0)
 270     {
 271       eltlen *= F77_DIM_SIZE (ndimen + 1);
 272       F77_DIM_OFFSET (ndimen) = eltlen;
 273     }
 274 }
 275
 276
 277
 278 /* Actual function which prints out F77 arrays, Valaddr == address in
 279    the superior.  Address == the address in the inferior.  */
 280
 281 static void
 282 f77_print_array_1 (int nss, int ndimensions, struct type *type,
 283                    const gdb_byte *valaddr, CORE_ADDR address,
 284                    struct ui_file *stream, int format,
 285                    int deref_ref, int recurse, enum val_prettyprint pretty,
 286                    int *elts)
 287 {
 288   int i;
 289
 290   if (nss != ndimensions)
 291     {
 292       for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++)
 293         {
 294           fprintf_filtered (stream, "( ");
 295           f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 296                              valaddr + i * F77_DIM_OFFSET (nss),
 297                              address + i * F77_DIM_OFFSET (nss),
 298                              stream, format, deref_ref, recurse, pretty, elts);
 299           fprintf_filtered (stream, ") ");
 300         }
 301       if (*elts >= print_max && i < F77_DIM_SIZE (nss))
 302         fprintf_filtered (stream, "...");
 303     }
 304   else
 305     {
 306       for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max;
 307            i++, (*elts)++)
 308         {
 309           val_print (TYPE_TARGET_TYPE (type),
 310                      valaddr + i * F77_DIM_OFFSET (ndimensions),
 311                      0,
 312                      address + i * F77_DIM_OFFSET (ndimensions),
 313                      stream, format, deref_ref, recurse, pretty,
 314                      current_language);
 315
 316           if (i != (F77_DIM_SIZE (nss) - 1))
 317             fprintf_filtered (stream, ", ");
 318
 319           if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
 320             fprintf_filtered (stream, "...");
 321         }
 322     }
 323 }
 324
 325 /* This function gets called to print an F77 array, we set up some
 326    stuff and then immediately call f77_print_array_1() */
 327
 328 static void
 329 f77_print_array (struct type *type, const gdb_byte *valaddr,
 330                  CORE_ADDR address, struct ui_file *stream,
 331                  int format, int deref_ref, int recurse,
 332                  enum val_prettyprint pretty)
 333 {
 334   int ndimensions;
 335   int elts = 0;
 336
 337   ndimensions = calc_f77_array_dims (type);
 338
 339   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 340     error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 341            ndimensions, MAX_FORTRAN_DIMS);
 342
 343   /* Since F77 arrays are stored column-major, we set up an
 344      offset table to get at the various row's elements. The
 345      offset table contains entries for both offset and subarray size. */
 346
 347   f77_create_arrayprint_offset_tbl (type, stream);
 348
 349   f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
 350                      deref_ref, recurse, pretty, &elts);
 351 }
 352 \f
 353
 354 /* Print data of type TYPE located at VALADDR (within GDB), which came from
 355    the inferior at address ADDRESS, onto stdio stream STREAM according to
 356    FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
 357    target byte order.
 358
 359    If the data are a string pointer, returns the number of string characters
 360    printed.
 361
 362    If DEREF_REF is nonzero, then dereference references, otherwise just print
 363    them like pointers.
 364
 365    The PRETTY parameter controls prettyprinting.  */
 366
 367 int
 368 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 369              CORE_ADDR address, struct ui_file *stream, int format,
 370              int deref_ref, int recurse, enum val_prettyprint pretty)
 371 {
 372   unsigned int i = 0;   /* Number of characters printed */
 373   struct type *elttype;
 374   LONGEST val;
 375   CORE_ADDR addr;
 376   int index;
 377
 378   CHECK_TYPEDEF (type);
 379   switch (TYPE_CODE (type))
 380     {
 381     case TYPE_CODE_STRING:
 382       f77_get_dynamic_length_of_aggregate (type);
 383       LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
 384       break;
 385
 386     case TYPE_CODE_ARRAY:
 387       fprintf_filtered (stream, "(");
 388       f77_print_array (type, valaddr, address, stream, format,
 389                        deref_ref, recurse, pretty);
 390       fprintf_filtered (stream, ")");
 391       break;
 392
 393     case TYPE_CODE_PTR:
 394       if (format && format != 's')
 395         {
 396           print_scalar_formatted (valaddr, type, format, 0, stream);
 397           break;
 398         }
 399       else
 400         {
 401           addr = unpack_pointer (type, valaddr);
 402           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 403
 404           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 405             {
 406               /* Try to print what function it points to.  */
 407               print_address_demangle (addr, stream, demangle);
 408               /* Return value is irrelevant except for string pointers.  */
 409               return 0;
 410             }
 411
 412           if (addressprint && format != 's')
 413             fputs_filtered (paddress (addr), stream);
 414
 415           /* For a pointer to char or unsigned char, also print the string
 416              pointed to, unless pointer is null.  */
 417           if (TYPE_LENGTH (elttype) == 1
 418               && TYPE_CODE (elttype) == TYPE_CODE_INT
 419               && (format == 0 || format == 's')
 420               && addr != 0)
 421             i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
 422
 423           /* Return number of characters printed, including the terminating
 424              '\0' if we reached the end.  val_print_string takes care including
 425              the terminating '\0' if necessary.  */
 426           return i;
 427         }
 428       break;
 429
 430     case TYPE_CODE_REF:
 431       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 432       if (addressprint)
 433         {
 434           CORE_ADDR addr
 435             = extract_typed_address (valaddr + embedded_offset, type);
 436           fprintf_filtered (stream, "@");
 437           fputs_filtered (paddress (addr), stream);
 438           if (deref_ref)
 439             fputs_filtered (": ", stream);
 440         }
 441       /* De-reference the reference.  */
 442       if (deref_ref)
 443         {
 444           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 445             {
 446               struct value *deref_val =
 447               value_at
 448               (TYPE_TARGET_TYPE (type),
 449                unpack_pointer (type, valaddr + embedded_offset));
 450               common_val_print (deref_val, stream, format, deref_ref, recurse,
 451                                 pretty, current_language);
 452             }
 453           else
 454             fputs_filtered ("???", stream);
 455         }
 456       break;
 457
 458     case TYPE_CODE_FUNC:
 459       if (format)
 460         {
 461           print_scalar_formatted (valaddr, type, format, 0, stream);
 462           break;
 463         }
 464       /* FIXME, we should consider, at least for ANSI C language, eliminating
 465          the distinction made between FUNCs and POINTERs to FUNCs.  */
 466       fprintf_filtered (stream, "{");
 467       type_print (type, "", stream, -1);
 468       fprintf_filtered (stream, "} ");
 469       /* Try to print what function it points to, and its address.  */
 470       print_address_demangle (address, stream, demangle);
 471       break;
 472
 473     case TYPE_CODE_INT:
 474       format = format ? format : output_format;
 475       if (format)
 476         print_scalar_formatted (valaddr, type, format, 0, stream);
 477       else
 478         {
 479           val_print_type_code_int (type, valaddr, stream);
 480           /* C and C++ has no single byte int type, char is used instead.
 481              Since we don't know whether the value is really intended to
 482              be used as an integer or a character, print the character
 483              equivalent as well. */
 484           if (TYPE_LENGTH (type) == 1)
 485             {
 486               fputs_filtered (" ", stream);
 487               LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
 488                              stream);
 489             }
 490         }
 491       break;
 492
 493     case TYPE_CODE_FLAGS:
 494       if (format)
 495           print_scalar_formatted (valaddr, type, format, 0, stream);
 496       else
 497         val_print_type_code_flags (type, valaddr, stream);
 498       break;
 499
 500     case TYPE_CODE_FLT:
 501       if (format)
 502         print_scalar_formatted (valaddr, type, format, 0, stream);
 503       else
 504         print_floating (valaddr, type, stream);
 505       break;
 506
 507     case TYPE_CODE_VOID:
 508       fprintf_filtered (stream, "VOID");
 509       break;
 510
 511     case TYPE_CODE_ERROR:
 512       fprintf_filtered (stream, "<error type>");
 513       break;
 514
 515     case TYPE_CODE_RANGE:
 516       /* FIXME, we should not ever have to print one of these yet.  */
 517       fprintf_filtered (stream, "<range type>");
 518       break;
 519
 520     case TYPE_CODE_BOOL:
 521       format = format ? format : output_format;
 522       if (format)
 523         print_scalar_formatted (valaddr, type, format, 0, stream);
 524       else
 525         {
 526           val = 0;
 527           switch (TYPE_LENGTH (type))
 528             {
 529             case 1:
 530               val = unpack_long (builtin_type_f_logical_s1, valaddr);
 531               break;
 532
 533             case 2:
 534               val = unpack_long (builtin_type_f_logical_s2, valaddr);
 535               break;
 536
 537             case 4:
 538               val = unpack_long (builtin_type_f_logical, valaddr);
 539               break;
 540
 541             default:
 542               error (_("Logicals of length %d bytes not supported"),
 543                      TYPE_LENGTH (type));
 544
 545             }
 546
 547           if (val == 0)
 548             fprintf_filtered (stream, ".FALSE.");
 549           else if (val == 1)
 550             fprintf_filtered (stream, ".TRUE.");
 551           else
 552             /* Not a legitimate logical type, print as an integer.  */
 553             {
 554               /* Bash the type code temporarily.  */
 555               TYPE_CODE (type) = TYPE_CODE_INT;
 556               f_val_print (type, valaddr, 0, address, stream, format,
 557                            deref_ref, recurse, pretty);
 558               /* Restore the type code so later uses work as intended. */
 559               TYPE_CODE (type) = TYPE_CODE_BOOL;
 560             }
 561         }
 562       break;
 563
 564     case TYPE_CODE_COMPLEX:
 565       switch (TYPE_LENGTH (type))
 566         {
 567         case 8:
 568           type = builtin_type_f_real;
 569           break;
 570         case 16:
 571           type = builtin_type_f_real_s8;
 572           break;
 573         case 32:
 574           type = builtin_type_f_real_s16;
 575           break;
 576         default:
 577           error (_("Cannot print out complex*%d variables"), TYPE_LENGTH (type));
 578         }
 579       fputs_filtered ("(", stream);
 580       print_floating (valaddr, type, stream);
 581       fputs_filtered (",", stream);
 582       print_floating (valaddr + TYPE_LENGTH (type), type, stream);
 583       fputs_filtered (")", stream);
 584       break;
 585
 586     case TYPE_CODE_UNDEF:
 587       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 588          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 589          and no complete type for struct foo in that file.  */
 590       fprintf_filtered (stream, "<incomplete type>");
 591       break;
 592
 593     case TYPE_CODE_STRUCT:
 594     case TYPE_CODE_UNION:
 595       /* Starting from the Fortran 90 standard, Fortran supports derived
 596          types.  */
 597       fprintf_filtered (stream, "( ");
 598       for (index = 0; index < TYPE_NFIELDS (type); index++)
 599         {
 600           int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 601           f_val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
 602                        embedded_offset, address, stream,
 603                        format, deref_ref, recurse, pretty);
 604           if (index != TYPE_NFIELDS (type) - 1)
 605             fputs_filtered (", ", stream);
 606         }
 607       fprintf_filtered (stream, " )");
 608       break;
 609
 610     default:
 611       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
 612     }
 613   gdb_flush (stream);
 614   return 0;
 615 }
 616
 617 static void
 618 list_all_visible_commons (char *funname)
 619 {
 620   SAVED_F77_COMMON_PTR tmp;
 621
 622   tmp = head_common_list;
 623
 624   printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
 625
 626   while (tmp != NULL)
 627     {
 628       if (strcmp (tmp->owning_function, funname) == 0)
 629         printf_filtered ("%s\n", tmp->name);
 630
 631       tmp = tmp->next;
 632     }
 633 }
 634
 635 /* This function is used to print out the values in a given COMMON
 636    block. It will always use the most local common block of the
 637    given name */
 638
 639 static void
 640 info_common_command (char *comname, int from_tty)
 641 {
 642   SAVED_F77_COMMON_PTR the_common;
 643   COMMON_ENTRY_PTR entry;
 644   struct frame_info *fi;
 645   char *funname = 0;
 646   struct symbol *func;
 647
 648   /* We have been told to display the contents of F77 COMMON
 649      block supposedly visible in this function.  Let us
 650      first make sure that it is visible and if so, let
 651      us display its contents */
 652
 653   fi = get_selected_frame (_("No frame selected"));
 654
 655   /* The following is generally ripped off from stack.c's routine
 656      print_frame_info() */
 657
 658   func = find_pc_function (get_frame_pc (fi));
 659   if (func)
 660     {
 661       /* In certain pathological cases, the symtabs give the wrong
 662          function (when we are in the first function in a file which
 663          is compiled without debugging symbols, the previous function
 664          is compiled with debugging symbols, and the "foo.o" symbol
 665          that is supposed to tell us where the file with debugging symbols
 666          ends has been truncated by ar because it is longer than 15
 667          characters).
 668
 669          So look in the minimal symbol tables as well, and if it comes
 670          up with a larger address for the function use that instead.
 671          I don't think this can ever cause any problems; there shouldn't
 672          be any minimal symbols in the middle of a function.
 673          FIXME:  (Not necessarily true.  What about text labels) */
 674
 675       struct minimal_symbol *msymbol =
 676         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 677
 678       if (msymbol != NULL
 679           && (SYMBOL_VALUE_ADDRESS (msymbol)
 680               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 681         funname = SYMBOL_LINKAGE_NAME (msymbol);
 682       else
 683         funname = SYMBOL_LINKAGE_NAME (func);
 684     }
 685   else
 686     {
 687       struct minimal_symbol *msymbol =
 688       lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 689
 690       if (msymbol != NULL)
 691         funname = SYMBOL_LINKAGE_NAME (msymbol);
 692       else /* Got no 'funname', code below will fail.  */
 693         error (_("No function found for frame."));
 694     }
 695
 696   /* If comname is NULL, we assume the user wishes to see the
 697      which COMMON blocks are visible here and then return */
 698
 699   if (comname == 0)
 700     {
 701       list_all_visible_commons (funname);
 702       return;
 703     }
 704
 705   the_common = find_common_for_function (comname, funname);
 706
 707   if (the_common)
 708     {
 709       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 710         printf_filtered (_("Contents of blank COMMON block:\n"));
 711       else
 712         printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
 713
 714       printf_filtered ("\n");
 715       entry = the_common->entries;
 716
 717       while (entry != NULL)
 718         {
 719           printf_filtered ("%s = ", SYMBOL_PRINT_NAME (entry->symbol));
 720           print_variable_value (entry->symbol, fi, gdb_stdout);
 721           printf_filtered ("\n");
 722           entry = entry->next;
 723         }
 724     }
 725   else
 726     printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
 727                      comname, funname);
 728 }
 729
 730 /* This function is used to determine whether there is a
 731    F77 common block visible at the current scope called 'comname'. */
 732
 733 #if 0
 734 static int
 735 there_is_a_visible_common_named (char *comname)
 736 {
 737   SAVED_F77_COMMON_PTR the_common;
 738   struct frame_info *fi;
 739   char *funname = 0;
 740   struct symbol *func;
 741
 742   if (comname == NULL)
 743     error (_("Cannot deal with NULL common name!"));
 744
 745   fi = get_selected_frame (_("No frame selected"));
 746
 747   /* The following is generally ripped off from stack.c's routine
 748      print_frame_info() */
 749
 750   func = find_pc_function (fi->pc);
 751   if (func)
 752     {
 753       /* In certain pathological cases, the symtabs give the wrong
 754          function (when we are in the first function in a file which
 755          is compiled without debugging symbols, the previous function
 756          is compiled with debugging symbols, and the "foo.o" symbol
 757          that is supposed to tell us where the file with debugging symbols
 758          ends has been truncated by ar because it is longer than 15
 759          characters).
 760
 761          So look in the minimal symbol tables as well, and if it comes
 762          up with a larger address for the function use that instead.
 763          I don't think this can ever cause any problems; there shouldn't
 764          be any minimal symbols in the middle of a function.
 765          FIXME:  (Not necessarily true.  What about text labels) */
 766
 767       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 768
 769       if (msymbol != NULL
 770           && (SYMBOL_VALUE_ADDRESS (msymbol)
 771               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 772         funname = SYMBOL_LINKAGE_NAME (msymbol);
 773       else
 774         funname = SYMBOL_LINKAGE_NAME (func);
 775     }
 776   else
 777     {
 778       struct minimal_symbol *msymbol =
 779       lookup_minimal_symbol_by_pc (fi->pc);
 780
 781       if (msymbol != NULL)
 782         funname = SYMBOL_LINKAGE_NAME (msymbol);
 783     }
 784
 785   the_common = find_common_for_function (comname, funname);
 786
 787   return (the_common ? 1 : 0);
 788 }
 789 #endif
 790
 791 void
 792 _initialize_f_valprint (void)
 793 {
 794   add_info ("common", info_common_command,
 795             _("Print out the values contained in a Fortran COMMON block."));
 796   if (xdb_commands)
 797     add_com ("lc", class_info, info_common_command,
 798              _("Print out the values contained in a Fortran COMMON block."));
 799 }