gdb/f-valprint.c

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