gdb/f-valprint.c

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