gdb/f-valprint.c

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