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 = extract_unsigned_integer (valaddr, TYPE_LENGTH (type));
 527
 528           if (val == 0)
 529             fprintf_filtered (stream, ".FALSE.");
 530           else if (val == 1)
 531             fprintf_filtered (stream, ".TRUE.");
 532           else
 533             /* Not a legitimate logical type, print as an integer.  */
 534             {
 535               /* Bash the type code temporarily.  */
 536               TYPE_CODE (type) = TYPE_CODE_INT;
 537               f_val_print (type, valaddr, 0, address, stream, format,
 538                            deref_ref, recurse, pretty);
 539               /* Restore the type code so later uses work as intended. */
 540               TYPE_CODE (type) = TYPE_CODE_BOOL;
 541             }
 542         }
 543       break;
 544
 545     case TYPE_CODE_COMPLEX:
 546       type = TYPE_TARGET_TYPE (type);
 547       fputs_filtered ("(", stream);
 548       print_floating (valaddr, type, stream);
 549       fputs_filtered (",", stream);
 550       print_floating (valaddr + TYPE_LENGTH (type), type, stream);
 551       fputs_filtered (")", stream);
 552       break;
 553
 554     case TYPE_CODE_UNDEF:
 555       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 556          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 557          and no complete type for struct foo in that file.  */
 558       fprintf_filtered (stream, "<incomplete type>");
 559       break;
 560
 561     case TYPE_CODE_STRUCT:
 562     case TYPE_CODE_UNION:
 563       /* Starting from the Fortran 90 standard, Fortran supports derived
 564          types.  */
 565       fprintf_filtered (stream, "( ");
 566       for (index = 0; index < TYPE_NFIELDS (type); index++)
 567         {
 568           int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 569           f_val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
 570                        embedded_offset, address, stream,
 571                        format, deref_ref, recurse, pretty);
 572           if (index != TYPE_NFIELDS (type) - 1)
 573             fputs_filtered (", ", stream);
 574         }
 575       fprintf_filtered (stream, " )");
 576       break;
 577
 578     default:
 579       error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
 580     }
 581   gdb_flush (stream);
 582   return 0;
 583 }
 584
 585 static void
 586 list_all_visible_commons (char *funname)
 587 {
 588   SAVED_F77_COMMON_PTR tmp;
 589
 590   tmp = head_common_list;
 591
 592   printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
 593
 594   while (tmp != NULL)
 595     {
 596       if (strcmp (tmp->owning_function, funname) == 0)
 597         printf_filtered ("%s\n", tmp->name);
 598
 599       tmp = tmp->next;
 600     }
 601 }
 602
 603 /* This function is used to print out the values in a given COMMON
 604    block. It will always use the most local common block of the
 605    given name */
 606
 607 static void
 608 info_common_command (char *comname, int from_tty)
 609 {
 610   SAVED_F77_COMMON_PTR the_common;
 611   COMMON_ENTRY_PTR entry;
 612   struct frame_info *fi;
 613   char *funname = 0;
 614   struct symbol *func;
 615
 616   /* We have been told to display the contents of F77 COMMON
 617      block supposedly visible in this function.  Let us
 618      first make sure that it is visible and if so, let
 619      us display its contents */
 620
 621   fi = get_selected_frame (_("No frame selected"));
 622
 623   /* The following is generally ripped off from stack.c's routine
 624      print_frame_info() */
 625
 626   func = find_pc_function (get_frame_pc (fi));
 627   if (func)
 628     {
 629       /* In certain pathological cases, the symtabs give the wrong
 630          function (when we are in the first function in a file which
 631          is compiled without debugging symbols, the previous function
 632          is compiled with debugging symbols, and the "foo.o" symbol
 633          that is supposed to tell us where the file with debugging symbols
 634          ends has been truncated by ar because it is longer than 15
 635          characters).
 636
 637          So look in the minimal symbol tables as well, and if it comes
 638          up with a larger address for the function use that instead.
 639          I don't think this can ever cause any problems; there shouldn't
 640          be any minimal symbols in the middle of a function.
 641          FIXME:  (Not necessarily true.  What about text labels) */
 642
 643       struct minimal_symbol *msymbol =
 644         lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 645
 646       if (msymbol != NULL
 647           && (SYMBOL_VALUE_ADDRESS (msymbol)
 648               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 649         funname = SYMBOL_LINKAGE_NAME (msymbol);
 650       else
 651         funname = SYMBOL_LINKAGE_NAME (func);
 652     }
 653   else
 654     {
 655       struct minimal_symbol *msymbol =
 656       lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 657
 658       if (msymbol != NULL)
 659         funname = SYMBOL_LINKAGE_NAME (msymbol);
 660       else /* Got no 'funname', code below will fail.  */
 661         error (_("No function found for frame."));
 662     }
 663
 664   /* If comname is NULL, we assume the user wishes to see the
 665      which COMMON blocks are visible here and then return */
 666
 667   if (comname == 0)
 668     {
 669       list_all_visible_commons (funname);
 670       return;
 671     }
 672
 673   the_common = find_common_for_function (comname, funname);
 674
 675   if (the_common)
 676     {
 677       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 678         printf_filtered (_("Contents of blank COMMON block:\n"));
 679       else
 680         printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
 681
 682       printf_filtered ("\n");
 683       entry = the_common->entries;
 684
 685       while (entry != NULL)
 686         {
 687           printf_filtered ("%s = ", SYMBOL_PRINT_NAME (entry->symbol));
 688           print_variable_value (entry->symbol, fi, gdb_stdout);
 689           printf_filtered ("\n");
 690           entry = entry->next;
 691         }
 692     }
 693   else
 694     printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
 695                      comname, funname);
 696 }
 697
 698 /* This function is used to determine whether there is a
 699    F77 common block visible at the current scope called 'comname'. */
 700
 701 #if 0
 702 static int
 703 there_is_a_visible_common_named (char *comname)
 704 {
 705   SAVED_F77_COMMON_PTR the_common;
 706   struct frame_info *fi;
 707   char *funname = 0;
 708   struct symbol *func;
 709
 710   if (comname == NULL)
 711     error (_("Cannot deal with NULL common name!"));
 712
 713   fi = get_selected_frame (_("No frame selected"));
 714
 715   /* The following is generally ripped off from stack.c's routine
 716      print_frame_info() */
 717
 718   func = find_pc_function (fi->pc);
 719   if (func)
 720     {
 721       /* In certain pathological cases, the symtabs give the wrong
 722          function (when we are in the first function in a file which
 723          is compiled without debugging symbols, the previous function
 724          is compiled with debugging symbols, and the "foo.o" symbol
 725          that is supposed to tell us where the file with debugging symbols
 726          ends has been truncated by ar because it is longer than 15
 727          characters).
 728
 729          So look in the minimal symbol tables as well, and if it comes
 730          up with a larger address for the function use that instead.
 731          I don't think this can ever cause any problems; there shouldn't
 732          be any minimal symbols in the middle of a function.
 733          FIXME:  (Not necessarily true.  What about text labels) */
 734
 735       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 736
 737       if (msymbol != NULL
 738           && (SYMBOL_VALUE_ADDRESS (msymbol)
 739               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 740         funname = SYMBOL_LINKAGE_NAME (msymbol);
 741       else
 742         funname = SYMBOL_LINKAGE_NAME (func);
 743     }
 744   else
 745     {
 746       struct minimal_symbol *msymbol =
 747       lookup_minimal_symbol_by_pc (fi->pc);
 748
 749       if (msymbol != NULL)
 750         funname = SYMBOL_LINKAGE_NAME (msymbol);
 751     }
 752
 753   the_common = find_common_for_function (comname, funname);
 754
 755   return (the_common ? 1 : 0);
 756 }
 757 #endif
 758
 759 void
 760 _initialize_f_valprint (void)
 761 {
 762   add_info ("common", info_common_command,
 763             _("Print out the values contained in a Fortran COMMON block."));
 764   if (xdb_commands)
 765     add_com ("lc", class_info, info_common_command,
 766              _("Print out the values contained in a Fortran COMMON block."));
 767 }