contrib/gdb/gdb/f-valprint.c

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