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 Free Software Foundation, Inc.
   5
   6    Contributed by Motorola.  Adapted from the C definitions by Farooq Butt
   7    ([email protected]), 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 2 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, write to the Free Software
  23    Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24    Boston, MA 02110-1301, USA.  */
  25
  26 #include "defs.h"
  27 #include "gdb_string.h"
  28 #include "symtab.h"
  29 #include "gdbtypes.h"
  30 #include "expression.h"
  31 #include "value.h"
  32 #include "valprint.h"
  33 #include "language.h"
  34 #include "f-lang.h"
  35 #include "frame.h"
  36 #include "gdbcore.h"
  37 #include "command.h"
  38 #include "block.h"
  39
  40 #if 0
  41 static int there_is_a_visible_common_named (char *);
  42 #endif
  43
  44 extern void _initialize_f_valprint (void);
  45 static void info_common_command (char *, int);
  46 static void list_all_visible_commons (char *);
  47 static void f77_create_arrayprint_offset_tbl (struct type *,
  48                                               struct ui_file *);
  49 static void f77_get_dynamic_length_of_aggregate (struct type *);
  50
  51 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
  52
  53 /* Array which holds offsets to be applied to get a row's elements
  54    for a given array. Array also holds the size of each subarray.  */
  55
  56 /* The following macro gives us the size of the nth dimension, Where
  57    n is 1 based. */
  58
  59 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
  60
  61 /* The following gives us the offset for row n where n is 1-based. */
  62
  63 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
  64
  65 int
  66 f77_get_dynamic_lowerbound (struct type *type, int *lower_bound)
  67 {
  68   struct frame_info *frame;
  69   CORE_ADDR current_frame_addr;
  70   CORE_ADDR ptr_to_lower_bound;
  71
  72   switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
  73     {
  74     case BOUND_BY_VALUE_ON_STACK:
  75       frame = deprecated_safe_get_selected_frame ();
  76       current_frame_addr = get_frame_base (frame);
  77       if (current_frame_addr > 0)
  78         {
  79           *lower_bound =
  80             read_memory_integer (current_frame_addr +
  81                                  TYPE_ARRAY_LOWER_BOUND_VALUE (type),
  82                                  4);
  83         }
  84       else
  85         {
  86           *lower_bound = DEFAULT_LOWER_BOUND;
  87           return BOUND_FETCH_ERROR;
  88         }
  89       break;
  90
  91     case BOUND_SIMPLE:
  92       *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
  93       break;
  94
  95     case BOUND_CANNOT_BE_DETERMINED:
  96       error (_("Lower bound may not be '*' in F77"));
  97       break;
  98
  99     case BOUND_BY_REF_ON_STACK:
 100       frame = deprecated_safe_get_selected_frame ();
 101       current_frame_addr = get_frame_base (frame);
 102       if (current_frame_addr > 0)
 103         {
 104           ptr_to_lower_bound =
 105             read_memory_typed_address (current_frame_addr +
 106                                        TYPE_ARRAY_LOWER_BOUND_VALUE (type),
 107                                        builtin_type_void_data_ptr);
 108           *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
 109         }
 110       else
 111         {
 112           *lower_bound = DEFAULT_LOWER_BOUND;
 113           return BOUND_FETCH_ERROR;
 114         }
 115       break;
 116
 117     case BOUND_BY_REF_IN_REG:
 118     case BOUND_BY_VALUE_IN_REG:
 119     default:
 120       error (_("??? unhandled dynamic array bound type ???"));
 121       break;
 122     }
 123   return BOUND_FETCH_OK;
 124 }
 125
 126 int
 127 f77_get_dynamic_upperbound (struct type *type, int *upper_bound)
 128 {
 129   struct frame_info *frame;
 130   CORE_ADDR current_frame_addr = 0;
 131   CORE_ADDR ptr_to_upper_bound;
 132
 133   switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
 134     {
 135     case BOUND_BY_VALUE_ON_STACK:
 136       frame = deprecated_safe_get_selected_frame ();
 137       current_frame_addr = get_frame_base (frame);
 138       if (current_frame_addr > 0)
 139         {
 140           *upper_bound =
 141             read_memory_integer (current_frame_addr +
 142                                  TYPE_ARRAY_UPPER_BOUND_VALUE (type),
 143                                  4);
 144         }
 145       else
 146         {
 147           *upper_bound = DEFAULT_UPPER_BOUND;
 148           return BOUND_FETCH_ERROR;
 149         }
 150       break;
 151
 152     case BOUND_SIMPLE:
 153       *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
 154       break;
 155
 156     case BOUND_CANNOT_BE_DETERMINED:
 157       /* we have an assumed size array on our hands. Assume that
 158          upper_bound == lower_bound so that we show at least
 159          1 element.If the user wants to see more elements, let
 160          him manually ask for 'em and we'll subscript the
 161          array and show him */
 162       f77_get_dynamic_lowerbound (type, upper_bound);
 163       break;
 164
 165     case BOUND_BY_REF_ON_STACK:
 166       frame = deprecated_safe_get_selected_frame ();
 167       current_frame_addr = get_frame_base (frame);
 168       if (current_frame_addr > 0)
 169         {
 170           ptr_to_upper_bound =
 171             read_memory_typed_address (current_frame_addr +
 172                                        TYPE_ARRAY_UPPER_BOUND_VALUE (type),
 173                                        builtin_type_void_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
 315           if (i != (F77_DIM_SIZE (nss) - 1))
 316             fprintf_filtered (stream, ", ");
 317
 318           if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
 319             fprintf_filtered (stream, "...");
 320         }
 321     }
 322 }
 323
 324 /* This function gets called to print an F77 array, we set up some
 325    stuff and then immediately call f77_print_array_1() */
 326
 327 static void
 328 f77_print_array (struct type *type, const gdb_byte *valaddr,
 329                  CORE_ADDR address, struct ui_file *stream,
 330                  int format, int deref_ref, int recurse,
 331                  enum val_prettyprint pretty)
 332 {
 333   int ndimensions;
 334   int elts = 0;
 335
 336   ndimensions = calc_f77_array_dims (type);
 337
 338   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 339     error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 340            ndimensions, MAX_FORTRAN_DIMS);
 341
 342   /* Since F77 arrays are stored column-major, we set up an
 343      offset table to get at the various row's elements. The
 344      offset table contains entries for both offset and subarray size. */
 345
 346   f77_create_arrayprint_offset_tbl (type, stream);
 347
 348   f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
 349                      deref_ref, recurse, pretty, &elts);
 350 }
 351 \f
 352
 353 /* Print data of type TYPE located at VALADDR (within GDB), which came from
 354    the inferior at address ADDRESS, onto stdio stream STREAM according to
 355    FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
 356    target byte order.
 357
 358    If the data are a string pointer, returns the number of string characters
 359    printed.
 360
 361    If DEREF_REF is nonzero, then dereference references, otherwise just print
 362    them like pointers.
 363
 364    The PRETTY parameter controls prettyprinting.  */
 365
 366 int
 367 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 368              CORE_ADDR address, struct ui_file *stream, int format,
 369              int deref_ref, int recurse, enum val_prettyprint pretty)
 370 {
 371   unsigned int i = 0;   /* Number of characters printed */
 372   struct type *elttype;
 373   LONGEST val;
 374   CORE_ADDR addr;
 375   int index;
 376
 377   CHECK_TYPEDEF (type);
 378   switch (TYPE_CODE (type))
 379     {
 380     case TYPE_CODE_STRING:
 381       f77_get_dynamic_length_of_aggregate (type);
 382       LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
 383       break;
 384
 385     case TYPE_CODE_ARRAY:
 386       fprintf_filtered (stream, "(");
 387       f77_print_array (type, valaddr, address, stream, format,
 388                        deref_ref, recurse, pretty);
 389       fprintf_filtered (stream, ")");
 390       break;
 391
 392     case TYPE_CODE_PTR:
 393       if (format && format != 's')
 394         {
 395           print_scalar_formatted (valaddr, type, format, 0, stream);
 396           break;
 397         }
 398       else
 399         {
 400           addr = unpack_pointer (type, valaddr);
 401           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 402
 403           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 404             {
 405               /* Try to print what function it points to.  */
 406               print_address_demangle (addr, stream, demangle);
 407               /* Return value is irrelevant except for string pointers.  */
 408               return 0;
 409             }
 410
 411           if (addressprint && format != 's')
 412             deprecated_print_address_numeric (addr, 1, stream);
 413
 414           /* For a pointer to char or unsigned char, also print the string
 415              pointed to, unless pointer is null.  */
 416           if (TYPE_LENGTH (elttype) == 1
 417               && TYPE_CODE (elttype) == TYPE_CODE_INT
 418               && (format == 0 || format == 's')
 419               && addr != 0)
 420             i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
 421
 422           /* Return number of characters printed, including the terminating
 423              '\0' if we reached the end.  val_print_string takes care including
 424              the terminating '\0' if necessary.  */
 425           return i;
 426         }
 427       break;
 428
 429     case TYPE_CODE_REF:
 430       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 431       if (addressprint)
 432         {
 433           CORE_ADDR addr
 434             = extract_typed_address (valaddr + embedded_offset, type);
 435           fprintf_filtered (stream, "@");
 436           deprecated_print_address_numeric (addr, 1, stream);
 437           if (deref_ref)
 438             fputs_filtered (": ", stream);
 439         }
 440       /* De-reference the reference.  */
 441       if (deref_ref)
 442         {
 443           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 444             {
 445               struct value *deref_val =
 446               value_at
 447               (TYPE_TARGET_TYPE (type),
 448                unpack_pointer (lookup_pointer_type (builtin_type_void),
 449                                valaddr + embedded_offset));
 450               common_val_print (deref_val, stream, format, deref_ref, recurse,
 451                                 pretty);
 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       /* Starting from the Fortran 90 standard, Fortran supports derived
 595          types.  */
 596       fprintf_filtered (stream, "{ ");
 597       for (index = 0; index < TYPE_NFIELDS (type); index++)
 598         {
 599           int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 600           f_val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
 601                        embedded_offset, address, stream,
 602                        format, deref_ref, recurse, pretty);
 603           if (index != TYPE_NFIELDS (type) - 1)
 604             fputs_filtered (", ", stream);
 605         }
 606       fprintf_filtered (stream, "}");
 607       break;
 608
 609     default:
 610       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
 611     }
 612   gdb_flush (stream);
 613   return 0;
 614 }
 615
 616 static void
 617 list_all_visible_commons (char *funname)
 618 {
 619   SAVED_F77_COMMON_PTR tmp;
 620
 621   tmp = head_common_list;
 622
 623   printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
 624
 625   while (tmp != NULL)
 626     {
 627       if (strcmp (tmp->owning_function, funname) == 0)
 628         printf_filtered ("%s\n", tmp->name);
 629
 630       tmp = tmp->next;
 631     }
 632 }
 633
 634 /* This function is used to print out the values in a given COMMON
 635    block. It will always use the most local common block of the
 636    given name */
 637
 638 static void
 639 info_common_command (char *comname, int from_tty)
 640 {
 641   SAVED_F77_COMMON_PTR the_common;
 642   COMMON_ENTRY_PTR entry;
 643   struct frame_info *fi;
 644   char *funname = 0;
 645   struct symbol *func;
 646
 647   /* We have been told to display the contents of F77 COMMON
 648      block supposedly visible in this function.  Let us
 649      first make sure that it is visible and if so, let
 650      us display its contents */
 651
 652   fi = get_selected_frame (_("No frame selected"));
 653
 654   /* The following is generally ripped off from stack.c's routine
 655      print_frame_info() */
 656
 657   func = find_pc_function (get_frame_pc (fi));
 658   if (func)
 659     {
 660       /* In certain pathological cases, the symtabs give the wrong
 661          function (when we are in the first function in a file which
 662          is compiled without debugging symbols, the previous function
 663          is compiled with debugging symbols, and the "foo.o" symbol
 664          that is supposed to tell us where the file with debugging symbols
 665          ends has been truncated by ar because it is longer than 15
 666          characters).
 667
 668          So look in the minimal symbol tables as well, and if it comes
 669          up with a larger address for the function use that instead.
 670          I don't think this can ever cause any problems; there shouldn't
 671          be any minimal symbols in the middle of a function.
 672          FIXME:  (Not necessarily true.  What about text labels) */
 673
 674       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 675
 676       if (msymbol != NULL
 677           && (SYMBOL_VALUE_ADDRESS (msymbol)
 678               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 679         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 680       else
 681         funname = DEPRECATED_SYMBOL_NAME (func);
 682     }
 683   else
 684     {
 685       struct minimal_symbol *msymbol =
 686       lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 687
 688       if (msymbol != NULL)
 689         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 690     }
 691
 692   /* If comname is NULL, we assume the user wishes to see the
 693      which COMMON blocks are visible here and then return */
 694
 695   if (comname == 0)
 696     {
 697       list_all_visible_commons (funname);
 698       return;
 699     }
 700
 701   the_common = find_common_for_function (comname, funname);
 702
 703   if (the_common)
 704     {
 705       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 706         printf_filtered (_("Contents of blank COMMON block:\n"));
 707       else
 708         printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
 709
 710       printf_filtered ("\n");
 711       entry = the_common->entries;
 712
 713       while (entry != NULL)
 714         {
 715           printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol));
 716           print_variable_value (entry->symbol, fi, gdb_stdout);
 717           printf_filtered ("\n");
 718           entry = entry->next;
 719         }
 720     }
 721   else
 722     printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
 723                      comname, funname);
 724 }
 725
 726 /* This function is used to determine whether there is a
 727    F77 common block visible at the current scope called 'comname'. */
 728
 729 #if 0
 730 static int
 731 there_is_a_visible_common_named (char *comname)
 732 {
 733   SAVED_F77_COMMON_PTR the_common;
 734   struct frame_info *fi;
 735   char *funname = 0;
 736   struct symbol *func;
 737
 738   if (comname == NULL)
 739     error (_("Cannot deal with NULL common name!"));
 740
 741   fi = get_selected_frame (_("No frame selected"));
 742
 743   /* The following is generally ripped off from stack.c's routine
 744      print_frame_info() */
 745
 746   func = find_pc_function (fi->pc);
 747   if (func)
 748     {
 749       /* In certain pathological cases, the symtabs give the wrong
 750          function (when we are in the first function in a file which
 751          is compiled without debugging symbols, the previous function
 752          is compiled with debugging symbols, and the "foo.o" symbol
 753          that is supposed to tell us where the file with debugging symbols
 754          ends has been truncated by ar because it is longer than 15
 755          characters).
 756
 757          So look in the minimal symbol tables as well, and if it comes
 758          up with a larger address for the function use that instead.
 759          I don't think this can ever cause any problems; there shouldn't
 760          be any minimal symbols in the middle of a function.
 761          FIXME:  (Not necessarily true.  What about text labels) */
 762
 763       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 764
 765       if (msymbol != NULL
 766           && (SYMBOL_VALUE_ADDRESS (msymbol)
 767               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 768         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 769       else
 770         funname = DEPRECATED_SYMBOL_NAME (func);
 771     }
 772   else
 773     {
 774       struct minimal_symbol *msymbol =
 775       lookup_minimal_symbol_by_pc (fi->pc);
 776
 777       if (msymbol != NULL)
 778         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 779     }
 780
 781   the_common = find_common_for_function (comname, funname);
 782
 783   return (the_common ? 1 : 0);
 784 }
 785 #endif
 786
 787 void
 788 _initialize_f_valprint (void)
 789 {
 790   add_info ("common", info_common_command,
 791             _("Print out the values contained in a Fortran COMMON block."));
 792   if (xdb_commands)
 793     add_com ("lc", class_info, info_common_command,
 794              _("Print out the values contained in a Fortran COMMON block."));
 795 }