gdb/f-valprint.c

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