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