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