gdb/f-valprint.c

   1 /* Support for printing Fortran values for GDB, the GNU debugger.
   2
   3    Copyright 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2003, 2005 Free
   4    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., 59 Temple Place - Suite 330,
  24    Boston, MA 02111-1307, 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 bfd_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 bfd_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 bfd_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
 370   CHECK_TYPEDEF (type);
 371   switch (TYPE_CODE (type))
 372     {
 373     case TYPE_CODE_STRING:
 374       f77_get_dynamic_length_of_aggregate (type);
 375       LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
 376       break;
 377
 378     case TYPE_CODE_ARRAY:
 379       fprintf_filtered (stream, "(");
 380       f77_print_array (type, valaddr, address, stream, format,
 381                        deref_ref, recurse, pretty);
 382       fprintf_filtered (stream, ")");
 383       break;
 384
 385     case TYPE_CODE_PTR:
 386       if (format && format != 's')
 387         {
 388           print_scalar_formatted (valaddr, type, format, 0, stream);
 389           break;
 390         }
 391       else
 392         {
 393           addr = unpack_pointer (type, valaddr);
 394           elttype = check_typedef (TYPE_TARGET_TYPE (type));
 395
 396           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 397             {
 398               /* Try to print what function it points to.  */
 399               print_address_demangle (addr, stream, demangle);
 400               /* Return value is irrelevant except for string pointers.  */
 401               return 0;
 402             }
 403
 404           if (addressprint && format != 's')
 405             print_address_numeric (addr, 1, stream);
 406
 407           /* For a pointer to char or unsigned char, also print the string
 408              pointed to, unless pointer is null.  */
 409           if (TYPE_LENGTH (elttype) == 1
 410               && TYPE_CODE (elttype) == TYPE_CODE_INT
 411               && (format == 0 || format == 's')
 412               && addr != 0)
 413             i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
 414
 415           /* Return number of characters printed, including the terminating
 416              '\0' if we reached the end.  val_print_string takes care including
 417              the terminating '\0' if necessary.  */
 418           return i;
 419         }
 420       break;
 421
 422     case TYPE_CODE_REF:
 423       elttype = check_typedef (TYPE_TARGET_TYPE (type));
 424       if (addressprint)
 425         {
 426           CORE_ADDR addr
 427             = extract_typed_address (valaddr + embedded_offset, type);
 428           fprintf_filtered (stream, "@");
 429           print_address_numeric (addr, 1, stream);
 430           if (deref_ref)
 431             fputs_filtered (": ", stream);
 432         }
 433       /* De-reference the reference.  */
 434       if (deref_ref)
 435         {
 436           if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
 437             {
 438               struct value *deref_val =
 439               value_at
 440               (TYPE_TARGET_TYPE (type),
 441                unpack_pointer (lookup_pointer_type (builtin_type_void),
 442                                valaddr + embedded_offset));
 443               val_print (value_type (deref_val),
 444                          value_contents (deref_val),
 445                          0,
 446                          VALUE_ADDRESS (deref_val),
 447                          stream,
 448                          format,
 449                          deref_ref,
 450                          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_FLT:
 494       if (format)
 495         print_scalar_formatted (valaddr, type, format, 0, stream);
 496       else
 497         print_floating (valaddr, type, stream);
 498       break;
 499
 500     case TYPE_CODE_VOID:
 501       fprintf_filtered (stream, "VOID");
 502       break;
 503
 504     case TYPE_CODE_ERROR:
 505       fprintf_filtered (stream, "<error type>");
 506       break;
 507
 508     case TYPE_CODE_RANGE:
 509       /* FIXME, we should not ever have to print one of these yet.  */
 510       fprintf_filtered (stream, "<range type>");
 511       break;
 512
 513     case TYPE_CODE_BOOL:
 514       format = format ? format : output_format;
 515       if (format)
 516         print_scalar_formatted (valaddr, type, format, 0, stream);
 517       else
 518         {
 519           val = 0;
 520           switch (TYPE_LENGTH (type))
 521             {
 522             case 1:
 523               val = unpack_long (builtin_type_f_logical_s1, valaddr);
 524               break;
 525
 526             case 2:
 527               val = unpack_long (builtin_type_f_logical_s2, valaddr);
 528               break;
 529
 530             case 4:
 531               val = unpack_long (builtin_type_f_logical, valaddr);
 532               break;
 533
 534             default:
 535               error (_("Logicals of length %d bytes not supported"),
 536                      TYPE_LENGTH (type));
 537
 538             }
 539
 540           if (val == 0)
 541             fprintf_filtered (stream, ".FALSE.");
 542           else if (val == 1)
 543             fprintf_filtered (stream, ".TRUE.");
 544           else
 545             /* Not a legitimate logical type, print as an integer.  */
 546             {
 547               /* Bash the type code temporarily.  */
 548               TYPE_CODE (type) = TYPE_CODE_INT;
 549               f_val_print (type, valaddr, 0, address, stream, format,
 550                            deref_ref, recurse, pretty);
 551               /* Restore the type code so later uses work as intended. */
 552               TYPE_CODE (type) = TYPE_CODE_BOOL;
 553             }
 554         }
 555       break;
 556
 557     case TYPE_CODE_COMPLEX:
 558       switch (TYPE_LENGTH (type))
 559         {
 560         case 8:
 561           type = builtin_type_f_real;
 562           break;
 563         case 16:
 564           type = builtin_type_f_real_s8;
 565           break;
 566         case 32:
 567           type = builtin_type_f_real_s16;
 568           break;
 569         default:
 570           error (_("Cannot print out complex*%d variables"), TYPE_LENGTH (type));
 571         }
 572       fputs_filtered ("(", stream);
 573       print_floating (valaddr, type, stream);
 574       fputs_filtered (",", stream);
 575       print_floating (valaddr + TYPE_LENGTH (type), type, stream);
 576       fputs_filtered (")", stream);
 577       break;
 578
 579     case TYPE_CODE_UNDEF:
 580       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 581          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 582          and no complete type for struct foo in that file.  */
 583       fprintf_filtered (stream, "<incomplete type>");
 584       break;
 585
 586     default:
 587       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
 588     }
 589   gdb_flush (stream);
 590   return 0;
 591 }
 592
 593 static void
 594 list_all_visible_commons (char *funname)
 595 {
 596   SAVED_F77_COMMON_PTR tmp;
 597
 598   tmp = head_common_list;
 599
 600   printf_filtered ("All COMMON blocks visible at this level:\n\n");
 601
 602   while (tmp != NULL)
 603     {
 604       if (strcmp (tmp->owning_function, funname) == 0)
 605         printf_filtered ("%s\n", tmp->name);
 606
 607       tmp = tmp->next;
 608     }
 609 }
 610
 611 /* This function is used to print out the values in a given COMMON
 612    block. It will always use the most local common block of the
 613    given name */
 614
 615 static void
 616 info_common_command (char *comname, int from_tty)
 617 {
 618   SAVED_F77_COMMON_PTR the_common;
 619   COMMON_ENTRY_PTR entry;
 620   struct frame_info *fi;
 621   char *funname = 0;
 622   struct symbol *func;
 623
 624   /* We have been told to display the contents of F77 COMMON
 625      block supposedly visible in this function.  Let us
 626      first make sure that it is visible and if so, let
 627      us display its contents */
 628
 629   fi = deprecated_selected_frame;
 630
 631   if (fi == NULL)
 632     error (_("No frame selected"));
 633
 634   /* The following is generally ripped off from stack.c's routine
 635      print_frame_info() */
 636
 637   func = find_pc_function (get_frame_pc (fi));
 638   if (func)
 639     {
 640       /* In certain pathological cases, the symtabs give the wrong
 641          function (when we are in the first function in a file which
 642          is compiled without debugging symbols, the previous function
 643          is compiled with debugging symbols, and the "foo.o" symbol
 644          that is supposed to tell us where the file with debugging symbols
 645          ends has been truncated by ar because it is longer than 15
 646          characters).
 647
 648          So look in the minimal symbol tables as well, and if it comes
 649          up with a larger address for the function use that instead.
 650          I don't think this can ever cause any problems; there shouldn't
 651          be any minimal symbols in the middle of a function.
 652          FIXME:  (Not necessarily true.  What about text labels) */
 653
 654       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 655
 656       if (msymbol != NULL
 657           && (SYMBOL_VALUE_ADDRESS (msymbol)
 658               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 659         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 660       else
 661         funname = DEPRECATED_SYMBOL_NAME (func);
 662     }
 663   else
 664     {
 665       struct minimal_symbol *msymbol =
 666       lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 667
 668       if (msymbol != NULL)
 669         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 670     }
 671
 672   /* If comname is NULL, we assume the user wishes to see the
 673      which COMMON blocks are visible here and then return */
 674
 675   if (comname == 0)
 676     {
 677       list_all_visible_commons (funname);
 678       return;
 679     }
 680
 681   the_common = find_common_for_function (comname, funname);
 682
 683   if (the_common)
 684     {
 685       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 686         printf_filtered ("Contents of blank COMMON block:\n");
 687       else
 688         printf_filtered ("Contents of F77 COMMON block '%s':\n", comname);
 689
 690       printf_filtered ("\n");
 691       entry = the_common->entries;
 692
 693       while (entry != NULL)
 694         {
 695           printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol));
 696           print_variable_value (entry->symbol, fi, gdb_stdout);
 697           printf_filtered ("\n");
 698           entry = entry->next;
 699         }
 700     }
 701   else
 702     printf_filtered ("Cannot locate the common block %s in function '%s'\n",
 703                      comname, funname);
 704 }
 705
 706 /* This function is used to determine whether there is a
 707    F77 common block visible at the current scope called 'comname'. */
 708
 709 #if 0
 710 static int
 711 there_is_a_visible_common_named (char *comname)
 712 {
 713   SAVED_F77_COMMON_PTR the_common;
 714   struct frame_info *fi;
 715   char *funname = 0;
 716   struct symbol *func;
 717
 718   if (comname == NULL)
 719     error (_("Cannot deal with NULL common name!"));
 720
 721   fi = deprecated_selected_frame;
 722
 723   if (fi == NULL)
 724     error (_("No frame selected"));
 725
 726   /* The following is generally ripped off from stack.c's routine
 727      print_frame_info() */
 728
 729   func = find_pc_function (fi->pc);
 730   if (func)
 731     {
 732       /* In certain pathological cases, the symtabs give the wrong
 733          function (when we are in the first function in a file which
 734          is compiled without debugging symbols, the previous function
 735          is compiled with debugging symbols, and the "foo.o" symbol
 736          that is supposed to tell us where the file with debugging symbols
 737          ends has been truncated by ar because it is longer than 15
 738          characters).
 739
 740          So look in the minimal symbol tables as well, and if it comes
 741          up with a larger address for the function use that instead.
 742          I don't think this can ever cause any problems; there shouldn't
 743          be any minimal symbols in the middle of a function.
 744          FIXME:  (Not necessarily true.  What about text labels) */
 745
 746       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 747
 748       if (msymbol != NULL
 749           && (SYMBOL_VALUE_ADDRESS (msymbol)
 750               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 751         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 752       else
 753         funname = DEPRECATED_SYMBOL_NAME (func);
 754     }
 755   else
 756     {
 757       struct minimal_symbol *msymbol =
 758       lookup_minimal_symbol_by_pc (fi->pc);
 759
 760       if (msymbol != NULL)
 761         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 762     }
 763
 764   the_common = find_common_for_function (comname, funname);
 765
 766   return (the_common ? 1 : 0);
 767 }
 768 #endif
 769
 770 void
 771 _initialize_f_valprint (void)
 772 {
 773   add_info ("common", info_common_command,
 774             "Print out the values contained in a Fortran COMMON block.");
 775   if (xdb_commands)
 776     add_com ("lc", class_info, info_common_command,
 777              "Print out the values contained in a Fortran COMMON block.");
 778 }