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               val_print (VALUE_TYPE (deref_val),
 448                          VALUE_CONTENTS (deref_val),
 449                          0,
 450                          VALUE_ADDRESS (deref_val),
 451                          stream,
 452                          format,
 453                          deref_ref,
 454                          recurse,
 455                          pretty);
 456             }
 457           else
 458             fputs_filtered ("???", stream);
 459         }
 460       break;
 461
 462     case TYPE_CODE_FUNC:
 463       if (format)
 464         {
 465           print_scalar_formatted (valaddr, type, format, 0, stream);
 466           break;
 467         }
 468       /* FIXME, we should consider, at least for ANSI C language, eliminating
 469          the distinction made between FUNCs and POINTERs to FUNCs.  */
 470       fprintf_filtered (stream, "{");
 471       type_print (type, "", stream, -1);
 472       fprintf_filtered (stream, "} ");
 473       /* Try to print what function it points to, and its address.  */
 474       print_address_demangle (address, stream, demangle);
 475       break;
 476
 477     case TYPE_CODE_INT:
 478       format = format ? format : output_format;
 479       if (format)
 480         print_scalar_formatted (valaddr, type, format, 0, stream);
 481       else
 482         {
 483           val_print_type_code_int (type, valaddr, stream);
 484           /* C and C++ has no single byte int type, char is used instead.
 485              Since we don't know whether the value is really intended to
 486              be used as an integer or a character, print the character
 487              equivalent as well. */
 488           if (TYPE_LENGTH (type) == 1)
 489             {
 490               fputs_filtered (" ", stream);
 491               LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
 492                              stream);
 493             }
 494         }
 495       break;
 496
 497     case TYPE_CODE_FLT:
 498       if (format)
 499         print_scalar_formatted (valaddr, type, format, 0, stream);
 500       else
 501         print_floating (valaddr, type, stream);
 502       break;
 503
 504     case TYPE_CODE_VOID:
 505       fprintf_filtered (stream, "VOID");
 506       break;
 507
 508     case TYPE_CODE_ERROR:
 509       fprintf_filtered (stream, "<error type>");
 510       break;
 511
 512     case TYPE_CODE_RANGE:
 513       /* FIXME, we should not ever have to print one of these yet.  */
 514       fprintf_filtered (stream, "<range type>");
 515       break;
 516
 517     case TYPE_CODE_BOOL:
 518       format = format ? format : output_format;
 519       if (format)
 520         print_scalar_formatted (valaddr, type, format, 0, stream);
 521       else
 522         {
 523           val = 0;
 524           switch (TYPE_LENGTH (type))
 525             {
 526             case 1:
 527               val = unpack_long (builtin_type_f_logical_s1, valaddr);
 528               break;
 529
 530             case 2:
 531               val = unpack_long (builtin_type_f_logical_s2, valaddr);
 532               break;
 533
 534             case 4:
 535               val = unpack_long (builtin_type_f_logical, valaddr);
 536               break;
 537
 538             default:
 539               error ("Logicals of length %d bytes not supported",
 540                      TYPE_LENGTH (type));
 541
 542             }
 543
 544           if (val == 0)
 545             fprintf_filtered (stream, ".FALSE.");
 546           else if (val == 1)
 547             fprintf_filtered (stream, ".TRUE.");
 548           else
 549             /* Not a legitimate logical type, print as an integer.  */
 550             {
 551               /* Bash the type code temporarily.  */
 552               TYPE_CODE (type) = TYPE_CODE_INT;
 553               f_val_print (type, valaddr, 0, address, stream, format,
 554                            deref_ref, recurse, pretty);
 555               /* Restore the type code so later uses work as intended. */
 556               TYPE_CODE (type) = TYPE_CODE_BOOL;
 557             }
 558         }
 559       break;
 560
 561     case TYPE_CODE_COMPLEX:
 562       switch (TYPE_LENGTH (type))
 563         {
 564         case 8:
 565           type = builtin_type_f_real;
 566           break;
 567         case 16:
 568           type = builtin_type_f_real_s8;
 569           break;
 570         case 32:
 571           type = builtin_type_f_real_s16;
 572           break;
 573         default:
 574           error ("Cannot print out complex*%d variables", TYPE_LENGTH (type));
 575         }
 576       fputs_filtered ("(", stream);
 577       print_floating (valaddr, type, stream);
 578       fputs_filtered (",", stream);
 579       print_floating (valaddr + TYPE_LENGTH (type), type, stream);
 580       fputs_filtered (")", stream);
 581       break;
 582
 583     case TYPE_CODE_UNDEF:
 584       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 585          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 586          and no complete type for struct foo in that file.  */
 587       fprintf_filtered (stream, "<incomplete type>");
 588       break;
 589
 590     default:
 591       error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
 592     }
 593   gdb_flush (stream);
 594   return 0;
 595 }
 596
 597 static void
 598 list_all_visible_commons (char *funname)
 599 {
 600   SAVED_F77_COMMON_PTR tmp;
 601
 602   tmp = head_common_list;
 603
 604   printf_filtered ("All COMMON blocks visible at this level:\n\n");
 605
 606   while (tmp != NULL)
 607     {
 608       if (strcmp (tmp->owning_function, funname) == 0)
 609         printf_filtered ("%s\n", tmp->name);
 610
 611       tmp = tmp->next;
 612     }
 613 }
 614
 615 /* This function is used to print out the values in a given COMMON
 616    block. It will always use the most local common block of the
 617    given name */
 618
 619 static void
 620 info_common_command (char *comname, int from_tty)
 621 {
 622   SAVED_F77_COMMON_PTR the_common;
 623   COMMON_ENTRY_PTR entry;
 624   struct frame_info *fi;
 625   char *funname = 0;
 626   struct symbol *func;
 627
 628   /* We have been told to display the contents of F77 COMMON
 629      block supposedly visible in this function.  Let us
 630      first make sure that it is visible and if so, let
 631      us display its contents */
 632
 633   fi = deprecated_selected_frame;
 634
 635   if (fi == NULL)
 636     error ("No frame selected");
 637
 638   /* The following is generally ripped off from stack.c's routine
 639      print_frame_info() */
 640
 641   func = find_pc_function (get_frame_pc (fi));
 642   if (func)
 643     {
 644       /* In certain pathological cases, the symtabs give the wrong
 645          function (when we are in the first function in a file which
 646          is compiled without debugging symbols, the previous function
 647          is compiled with debugging symbols, and the "foo.o" symbol
 648          that is supposed to tell us where the file with debugging symbols
 649          ends has been truncated by ar because it is longer than 15
 650          characters).
 651
 652          So look in the minimal symbol tables as well, and if it comes
 653          up with a larger address for the function use that instead.
 654          I don't think this can ever cause any problems; there shouldn't
 655          be any minimal symbols in the middle of a function.
 656          FIXME:  (Not necessarily true.  What about text labels) */
 657
 658       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 659
 660       if (msymbol != NULL
 661           && (SYMBOL_VALUE_ADDRESS (msymbol)
 662               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 663         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 664       else
 665         funname = DEPRECATED_SYMBOL_NAME (func);
 666     }
 667   else
 668     {
 669       struct minimal_symbol *msymbol =
 670       lookup_minimal_symbol_by_pc (get_frame_pc (fi));
 671
 672       if (msymbol != NULL)
 673         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 674     }
 675
 676   /* If comname is NULL, we assume the user wishes to see the
 677      which COMMON blocks are visible here and then return */
 678
 679   if (comname == 0)
 680     {
 681       list_all_visible_commons (funname);
 682       return;
 683     }
 684
 685   the_common = find_common_for_function (comname, funname);
 686
 687   if (the_common)
 688     {
 689       if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
 690         printf_filtered ("Contents of blank COMMON block:\n");
 691       else
 692         printf_filtered ("Contents of F77 COMMON block '%s':\n", comname);
 693
 694       printf_filtered ("\n");
 695       entry = the_common->entries;
 696
 697       while (entry != NULL)
 698         {
 699           printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol));
 700           print_variable_value (entry->symbol, fi, gdb_stdout);
 701           printf_filtered ("\n");
 702           entry = entry->next;
 703         }
 704     }
 705   else
 706     printf_filtered ("Cannot locate the common block %s in function '%s'\n",
 707                      comname, funname);
 708 }
 709
 710 /* This function is used to determine whether there is a
 711    F77 common block visible at the current scope called 'comname'. */
 712
 713 #if 0
 714 static int
 715 there_is_a_visible_common_named (char *comname)
 716 {
 717   SAVED_F77_COMMON_PTR the_common;
 718   struct frame_info *fi;
 719   char *funname = 0;
 720   struct symbol *func;
 721
 722   if (comname == NULL)
 723     error ("Cannot deal with NULL common name!");
 724
 725   fi = deprecated_selected_frame;
 726
 727   if (fi == NULL)
 728     error ("No frame selected");
 729
 730   /* The following is generally ripped off from stack.c's routine
 731      print_frame_info() */
 732
 733   func = find_pc_function (fi->pc);
 734   if (func)
 735     {
 736       /* In certain pathological cases, the symtabs give the wrong
 737          function (when we are in the first function in a file which
 738          is compiled without debugging symbols, the previous function
 739          is compiled with debugging symbols, and the "foo.o" symbol
 740          that is supposed to tell us where the file with debugging symbols
 741          ends has been truncated by ar because it is longer than 15
 742          characters).
 743
 744          So look in the minimal symbol tables as well, and if it comes
 745          up with a larger address for the function use that instead.
 746          I don't think this can ever cause any problems; there shouldn't
 747          be any minimal symbols in the middle of a function.
 748          FIXME:  (Not necessarily true.  What about text labels) */
 749
 750       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 751
 752       if (msymbol != NULL
 753           && (SYMBOL_VALUE_ADDRESS (msymbol)
 754               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 755         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 756       else
 757         funname = DEPRECATED_SYMBOL_NAME (func);
 758     }
 759   else
 760     {
 761       struct minimal_symbol *msymbol =
 762       lookup_minimal_symbol_by_pc (fi->pc);
 763
 764       if (msymbol != NULL)
 765         funname = DEPRECATED_SYMBOL_NAME (msymbol);
 766     }
 767
 768   the_common = find_common_for_function (comname, funname);
 769
 770   return (the_common ? 1 : 0);
 771 }
 772 #endif
 773
 774 void
 775 _initialize_f_valprint (void)
 776 {
 777   add_info ("common", info_common_command,
 778             "Print out the values contained in a Fortran COMMON block.");
 779   if (xdb_commands)
 780     add_com ("lc", class_info, info_common_command,
 781              "Print out the values contained in a Fortran COMMON block.");
 782 }