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