gdb/f-valprint.c

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