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 /* Print a FORTRAN COMPLEX value of type TYPE, pointed to in GDB by VALADDR,
 220    on STREAM.  which_complex indicates precision, which may be regular,
 221    *16, or *32 */
 222
 223 void
 224 f77_print_cmplx (valaddr, type, stream, which_complex)
 225      char *valaddr;
 226      struct type *type;
 227      FILE *stream;
 228      int which_complex;
 229 {
 230   float *f1,*f2;
 231   double *d1, *d2;
 232
 233   switch (which_complex)
 234     {
 235     case TARGET_COMPLEX_BIT:
 236       f1 = (float *) valaddr;
 237       f2 = (float *) (valaddr + sizeof(float));
 238       fprintf_filtered (stream, "(%.7e,%.7e)", *f1, *f2);
 239       break;
 240
 241     case TARGET_DOUBLE_COMPLEX_BIT:
 242       d1 = (double *) valaddr;
 243       d2 = (double *) (valaddr + sizeof(double));
 244       fprintf_filtered (stream, "(%.16e,%.16e)", *d1, *d2);
 245       break;
 246 #if 0
 247     case TARGET_EXT_COMPLEX_BIT:
 248       fprintf_filtered (stream, "<complex*32 format unavailable, "
 249                        "printing raw data>\n");
 250
 251       fprintf_filtered (stream, "( [ ");
 252
 253       for (i = 0;i<4;i++)
 254         fprintf_filtered (stream, "0x%x ",
 255                          * ( (unsigned int *) valaddr+i));
 256
 257       fprintf_filtered (stream, "],\n  [ ");
 258
 259       for (i=4;i<8;i++)
 260         fprintf_filtered (stream, "0x%x ",
 261                          * ((unsigned int *) valaddr+i));
 262
 263       fprintf_filtered (stream, "] )");
 264
 265       break;
 266 #endif
 267     default:
 268       fprintf_filtered (stream, "<cannot handle complex of this type>");
 269       break;
 270     }
 271 }
 272
 273 /* Function that sets up the array offset,size table for the array
 274    type "type".  */
 275
 276 void
 277 f77_create_arrayprint_offset_tbl (type, stream)
 278      struct type *type;
 279      FILE *stream;
 280 {
 281   struct type *tmp_type;
 282   int eltlen;
 283   int ndimen = 1;
 284   int upper, lower, retcode;
 285
 286   tmp_type = type;
 287
 288   while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
 289     {
 290       if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
 291         fprintf_filtered (stream, "<assumed size array> ");
 292
 293       retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
 294       if (retcode == BOUND_FETCH_ERROR)
 295         error ("Cannot obtain dynamic upper bound");
 296
 297       retcode = f77_get_dynamic_lowerbound(tmp_type,&lower);
 298       if (retcode == BOUND_FETCH_ERROR)
 299         error("Cannot obtain dynamic lower bound");
 300
 301       F77_DIM_SIZE (ndimen) = upper - lower + 1;
 302
 303       if (ndimen == 1)
 304         F77_DIM_OFFSET (ndimen) = 1;
 305       else
 306         F77_DIM_OFFSET (ndimen) =
 307           F77_DIM_OFFSET (ndimen - 1) * F77_DIM_SIZE(ndimen - 1);
 308
 309       tmp_type = TYPE_TARGET_TYPE (tmp_type);
 310       ndimen++;
 311     }
 312
 313   eltlen = TYPE_LENGTH (tmp_type);
 314
 315   /* Now we multiply eltlen by all the offsets, so that later we
 316      can print out array elements correctly.  Up till now we
 317      know an offset to apply to get the item but we also
 318      have to know how much to add to get to the next item */
 319
 320   tmp_type = type;
 321   ndimen = 1;
 322
 323   while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
 324     {
 325       F77_DIM_OFFSET (ndimen) *= eltlen;
 326       ndimen++;
 327       tmp_type = TYPE_TARGET_TYPE (tmp_type);
 328     }
 329 }
 330
 331 /* Actual function which prints out F77 arrays, Valaddr == address in
 332    the superior.  Address == the address in the inferior.  */
 333
 334 void
 335 f77_print_array_1 (nss, ndimensions, type, valaddr, address,
 336                    stream, format, deref_ref, recurse, pretty)
 337      int nss;
 338      int ndimensions;
 339      char *valaddr;
 340      struct type *type;
 341      CORE_ADDR address;
 342      FILE *stream;
 343      int format;
 344      int deref_ref;
 345      int recurse;
 346      enum val_prettyprint pretty;
 347 {
 348   int i;
 349
 350   if (nss != ndimensions)
 351     {
 352       for (i = 0; i< F77_DIM_SIZE(nss); i++)
 353         {
 354           fprintf_filtered (stream, "( ");
 355           f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 356                             valaddr + i * F77_DIM_OFFSET (nss),
 357                             address + i * F77_DIM_OFFSET (nss),
 358                             stream, format, deref_ref, recurse, pretty, i);
 359           fprintf_filtered (stream, ") ");
 360         }
 361     }
 362   else
 363     {
 364       for (i = 0; (i < F77_DIM_SIZE (nss) && i < print_max); i++)
 365         {
 366           val_print (TYPE_TARGET_TYPE (type),
 367                      valaddr + i * F77_DIM_OFFSET (ndimensions),
 368                      address + i * F77_DIM_OFFSET (ndimensions),
 369                      stream, format, deref_ref, recurse, pretty);
 370
 371           if (i != (F77_DIM_SIZE (nss) - 1))
 372             fprintf_filtered (stream, ", ");
 373
 374           if (i == print_max - 1)
 375             fprintf_filtered (stream, "...");
 376         }
 377     }
 378 }
 379
 380 /* This function gets called to print an F77 array, we set up some
 381    stuff and then immediately call f77_print_array_1() */
 382
 383 void
 384 f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse,
 385                  pretty)
 386      struct type *type;
 387      char *valaddr;
 388      CORE_ADDR address;
 389      FILE *stream;
 390      int format;
 391      int deref_ref;
 392      int recurse;
 393      enum val_prettyprint pretty;
 394 {
 395   int ndimensions;
 396
 397   ndimensions = calc_f77_array_dims (type);
 398
 399   if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
 400     error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
 401            ndimensions, MAX_FORTRAN_DIMS);
 402
 403   /* Since F77 arrays are stored column-major, we set up an
 404      offset table to get at the various row's elements. The
 405      offset table contains entries for both offset and subarray size. */
 406
 407   f77_create_arrayprint_offset_tbl (type, stream);
 408
 409   f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
 410                      deref_ref, recurse, pretty);
 411 }
 412
 413 \f
 414 /* Print data of type TYPE located at VALADDR (within GDB), which came from
 415    the inferior at address ADDRESS, onto stdio stream STREAM according to
 416    FORMAT (a letter or 0 for natural format).  The data at VALADDR is in
 417    target byte order.
 418
 419    If the data are a string pointer, returns the number of string characters
 420    printed.
 421
 422    If DEREF_REF is nonzero, then dereference references, otherwise just print
 423    them like pointers.
 424
 425    The PRETTY parameter controls prettyprinting.  */
 426
 427 int
 428 f_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
 429              pretty)
 430      struct type *type;
 431      char *valaddr;
 432      CORE_ADDR address;
 433      FILE *stream;
 434      int format;
 435      int deref_ref;
 436      int recurse;
 437      enum val_prettyprint pretty;
 438 {
 439   register unsigned int i = 0;          /* Number of characters printed */
 440   unsigned len;
 441   struct type *elttype;
 442   LONGEST val;
 443   char *localstr;
 444   char *straddr;
 445   CORE_ADDR addr;
 446
 447   switch (TYPE_CODE (type))
 448     {
 449     case TYPE_CODE_LITERAL_STRING:
 450       /* It is trivial to print out F77 strings allocated in the
 451          superior process. The address field is actually a
 452          pointer to the bytes of the literal. For an internalvar,
 453          valaddr points to a ptr. which points to
 454          VALUE_LITERAL_DATA(value->internalvar->value)
 455          and for straight literals (i.e. of the form 'hello world'),
 456          valaddr points a ptr to VALUE_LITERAL_DATA(value). */
 457
 458       /* First dereference valaddr.  This relies on valaddr pointing to the
 459          aligner union of a struct value (so we are now fetching the
 460          literal_data pointer from that union).  FIXME: Is this always
 461          true.  */
 462
 463       straddr = * (char **) valaddr;
 464
 465       if (straddr)
 466         {
 467           len = TYPE_LENGTH (type);
 468           localstr = alloca (len + 1);
 469           strncpy (localstr, straddr, len);
 470           localstr[len] = '\0';
 471           fprintf_filtered (stream, "'%s'", localstr);
 472         }
 473       else
 474         fprintf_filtered (stream, "Unable to print literal F77 string");
 475       break;
 476
 477       /* Strings are a little bit funny. They can be viewed as
 478          monolithic arrays that are dealt with as atomic data
 479          items. As such they are the only atomic data items whose
 480          contents are not located in the superior process. Instead
 481          instead of having the actual data, they contain pointers
 482          to addresses in the inferior where data is located.  Thus
 483          instead of using valaddr, we use address. */
 484
 485     case TYPE_CODE_STRING:
 486       f77_get_dynamic_length_of_aggregate (type);
 487       val_print_string (address, TYPE_LENGTH (type), stream);
 488       break;
 489
 490     case TYPE_CODE_ARRAY:
 491       fprintf_filtered (stream, "(");
 492       f77_print_array (type, valaddr, address, stream, format,
 493                        deref_ref, recurse, pretty);
 494       fprintf_filtered (stream, ")");
 495       break;
 496 #if 0
 497       /* Array of unspecified length: treat like pointer to first elt.  */
 498       valaddr = (char *) &address;
 499       /* FALL THROUGH */
 500 #endif
 501     case TYPE_CODE_PTR:
 502       if (format && format != 's')
 503         {
 504           print_scalar_formatted (valaddr, type, format, 0, stream);
 505           break;
 506         }
 507       else
 508         {
 509           addr = unpack_pointer (type, valaddr);
 510           elttype = TYPE_TARGET_TYPE (type);
 511
 512           if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
 513             {
 514               /* Try to print what function it points to.  */
 515               print_address_demangle (addr, stream, demangle);
 516               /* Return value is irrelevant except for string pointers.  */
 517               return 0;
 518             }
 519
 520           if (addressprint && format != 's')
 521             fprintf_filtered (stream, "0x%x", addr);
 522
 523           /* For a pointer to char or unsigned char, also print the string
 524              pointed to, unless pointer is null.  */
 525           if (TYPE_LENGTH (elttype) == 1
 526               && TYPE_CODE (elttype) == TYPE_CODE_INT
 527               && (format == 0 || format == 's')
 528               && addr != 0)
 529             i = val_print_string (addr, 0, stream);
 530
 531           /* Return number of characters printed, plus one for the
 532              terminating null if we have "reached the end".  */
 533           return (i + (print_max && i != print_max));
 534         }
 535       break;
 536
 537     case TYPE_CODE_FUNC:
 538       if (format)
 539         {
 540           print_scalar_formatted (valaddr, type, format, 0, stream);
 541           break;
 542         }
 543       /* FIXME, we should consider, at least for ANSI C language, eliminating
 544          the distinction made between FUNCs and POINTERs to FUNCs.  */
 545       fprintf_filtered (stream, "{");
 546       type_print (type, "", stream, -1);
 547       fprintf_filtered (stream, "} ");
 548       /* Try to print what function it points to, and its address.  */
 549       print_address_demangle (address, stream, demangle);
 550       break;
 551
 552     case TYPE_CODE_INT:
 553       format = format ? format : output_format;
 554       if (format)
 555         print_scalar_formatted (valaddr, type, format, 0, stream);
 556       else
 557         {
 558           val_print_type_code_int (type, valaddr, stream);
 559           /* C and C++ has no single byte int type, char is used instead.
 560              Since we don't know whether the value is really intended to
 561              be used as an integer or a character, print the character
 562              equivalent as well. */
 563           if (TYPE_LENGTH (type) == 1)
 564             {
 565               fputs_filtered (" ", stream);
 566               LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
 567                              stream);
 568             }
 569         }
 570       break;
 571
 572     case TYPE_CODE_FLT:
 573       if (format)
 574         print_scalar_formatted (valaddr, type, format, 0, stream);
 575       else
 576         print_floating (valaddr, type, stream);
 577       break;
 578
 579     case TYPE_CODE_VOID:
 580       fprintf_filtered (stream, "VOID");
 581       break;
 582
 583     case TYPE_CODE_ERROR:
 584       fprintf_filtered (stream, "<error type>");
 585       break;
 586
 587     case TYPE_CODE_RANGE:
 588       /* FIXME, we should not ever have to print one of these yet.  */
 589       fprintf_filtered (stream, "<range type>");
 590       break;
 591
 592     case TYPE_CODE_BOOL:
 593       format = format ? format : output_format;
 594       if (format)
 595         print_scalar_formatted (valaddr, type, format, 0, stream);
 596       else
 597         {
 598           val = 0;
 599           switch (TYPE_LENGTH(type))
 600             {
 601             case 1:
 602               val = unpack_long (builtin_type_f_logical_s1, valaddr);
 603               break ;
 604
 605             case 2:
 606               val = unpack_long (builtin_type_f_logical_s2, valaddr);
 607               break ;
 608
 609             case 4:
 610               val = unpack_long (builtin_type_f_logical, valaddr);
 611               break ;
 612
 613             default:
 614               error ("Logicals of length %d bytes not supported",
 615                      TYPE_LENGTH (type));
 616
 617             }
 618
 619           if (val == 0)
 620             fprintf_filtered (stream, ".FALSE.");
 621           else
 622             if (val == 1)
 623               fprintf_filtered (stream, ".TRUE.");
 624             else
 625               /* Not a legitimate logical type, print as an integer.  */
 626               {
 627                 /* Bash the type code temporarily.  */
 628                 TYPE_CODE (type) = TYPE_CODE_INT;
 629                 f_val_print (type, valaddr, address, stream, format,
 630                              deref_ref, recurse, pretty);
 631                 /* Restore the type code so later uses work as intended. */
 632                 TYPE_CODE (type) = TYPE_CODE_BOOL;
 633               }
 634         }
 635       break;
 636
 637     case TYPE_CODE_LITERAL_COMPLEX:
 638       /* We know that the literal complex is stored in the superior
 639          process not the inferior and that it is 16 bytes long.
 640          Just like the case above with a literal array, the
 641          bytes for the the literal complex number are stored
 642          at the address pointed to by valaddr */
 643
 644       if (TYPE_LENGTH (type) == 32)
 645         error ("Cannot currently print out complex*32 literals");
 646
 647       /* First dereference valaddr.  */
 648
 649       addr = * (CORE_ADDR *) valaddr;
 650
 651       if (addr)
 652         {
 653           fprintf_filtered (stream, "(");
 654
 655           if (TYPE_LENGTH(type) == 16)
 656             {
 657               fprintf_filtered (stream, "%.16f", * (double *) addr);
 658               fprintf_filtered (stream, ", %.16f", * (double *)
 659                                 (addr + sizeof(double)));
 660             }
 661           else
 662             {
 663               fprintf_filtered (stream, "%.8f", * (float *) addr);
 664               fprintf_filtered (stream, ", %.8f", * (float *)
 665                                 (addr + sizeof(float)));
 666             }
 667           fprintf_filtered (stream, ") ");
 668         }
 669       else
 670         fprintf_filtered (stream, "Unable to print literal F77 array");
 671       break;
 672
 673     case TYPE_CODE_COMPLEX:
 674       switch (TYPE_LENGTH (type))
 675         {
 676         case 8:
 677           f77_print_cmplx (valaddr, type, stream, TARGET_COMPLEX_BIT);
 678           break;
 679
 680         case 16:
 681           f77_print_cmplx(valaddr, type, stream, TARGET_DOUBLE_COMPLEX_BIT);
 682           break;
 683 #if 0
 684         case 32:
 685           f77_print_cmplx(valaddr, type, stream, TARGET_EXT_COMPLEX_BIT);
 686           break;
 687 #endif
 688         default:
 689           error ("Cannot print out complex*%d variables", TYPE_LENGTH(type));
 690         }
 691       break;
 692
 693     case TYPE_CODE_UNDEF:
 694       /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
 695          dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
 696          and no complete type for struct foo in that file.  */
 697       fprintf_filtered (stream, "<incomplete type>");
 698       break;
 699
 700     default:
 701       error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
 702     }
 703   fflush (stream);
 704   return 0;
 705 }
 706
 707 void
 708 list_all_visible_commons (funname)
 709      char *funname;
 710 {
 711   SAVED_F77_COMMON_PTR  tmp;
 712
 713   tmp = head_common_list;
 714
 715   printf_filtered ("All COMMON blocks visible at this level:\n\n");
 716
 717   while (tmp != NULL)
 718     {
 719       if (STREQ(tmp->owning_function,funname))
 720         printf_filtered ("%s\n", tmp->name);
 721
 722       tmp = tmp->next;
 723     }
 724 }
 725
 726 /* This function is used to print out the values in a given COMMON
 727    block. It will always use the most local common block of the
 728    given name */
 729
 730 static void
 731 info_common_command (comname, from_tty)
 732      char *comname;
 733      int from_tty;
 734 {
 735   SAVED_F77_COMMON_PTR  the_common;
 736   COMMON_ENTRY_PTR entry;
 737   struct frame_info *fi;
 738   register char *funname = 0;
 739   struct symbol *func;
 740
 741   /* We have been told to display the contents of F77 COMMON
 742      block supposedly visible in this function.  Let us
 743      first make sure that it is visible and if so, let
 744      us display its contents */
 745
 746   fi = selected_frame;
 747
 748   if (fi == NULL)
 749     error ("No frame selected");
 750
 751   /* The following is generally ripped off from stack.c's routine
 752      print_frame_info() */
 753
 754   func = find_pc_function (fi->pc);
 755   if (func)
 756     {
 757       /* In certain pathological cases, the symtabs give the wrong
 758          function (when we are in the first function in a file which
 759          is compiled without debugging symbols, the previous function
 760          is compiled with debugging symbols, and the "foo.o" symbol
 761          that is supposed to tell us where the file with debugging symbols
 762          ends has been truncated by ar because it is longer than 15
 763          characters).
 764
 765          So look in the minimal symbol tables as well, and if it comes
 766          up with a larger address for the function use that instead.
 767          I don't think this can ever cause any problems; there shouldn't
 768          be any minimal symbols in the middle of a function.
 769          FIXME:  (Not necessarily true.  What about text labels) */
 770
 771       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 772
 773       if (msymbol != NULL
 774           && (SYMBOL_VALUE_ADDRESS (msymbol)
 775               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 776         funname = SYMBOL_NAME (msymbol);
 777       else
 778         funname = SYMBOL_NAME (func);
 779     }
 780   else
 781     {
 782       register struct minimal_symbol *msymbol =
 783         lookup_minimal_symbol_by_pc (fi->pc);
 784
 785       if (msymbol != NULL)
 786         funname = SYMBOL_NAME (msymbol);
 787     }
 788
 789   /* If comnname is NULL, we assume the user wishes to see the
 790      which COMMON blocks are visible here and then return */
 791
 792   if (strlen (comname) == 0)
 793     {
 794       list_all_visible_commons (funname);
 795       return;
 796     }
 797
 798   the_common = find_common_for_function (comname,funname);
 799
 800   if (the_common)
 801     {
 802       if (STREQ(comname,BLANK_COMMON_NAME_LOCAL))
 803         printf_filtered ("Contents of blank COMMON block:\n");
 804       else
 805         printf_filtered ("Contents of F77 COMMON block '%s':\n",comname);
 806
 807       printf_filtered ("\n");
 808       entry = the_common->entries;
 809
 810       while (entry != NULL)
 811         {
 812           printf_filtered ("%s = ",SYMBOL_NAME(entry->symbol));
 813           print_variable_value (entry->symbol,fi,stdout);
 814           printf_filtered ("\n");
 815           entry = entry->next;
 816         }
 817     }
 818   else
 819     printf_filtered ("Cannot locate the common block %s in function '%s'\n",
 820                     comname, funname);
 821 }
 822
 823 /* This function is used to determine whether there is a
 824    F77 common block visible at the current scope called 'comname'. */
 825
 826 int
 827 there_is_a_visible_common_named (comname)
 828      char *comname;
 829 {
 830   SAVED_F77_COMMON_PTR  the_common;
 831   struct frame_info *fi;
 832   register char *funname = 0;
 833   struct symbol *func;
 834
 835   if (comname == NULL)
 836     error ("Cannot deal with NULL common name!");
 837
 838   fi = selected_frame;
 839
 840   if (fi == NULL)
 841     error ("No frame selected");
 842
 843   /* The following is generally ripped off from stack.c's routine
 844      print_frame_info() */
 845
 846   func = find_pc_function (fi->pc);
 847   if (func)
 848     {
 849       /* In certain pathological cases, the symtabs give the wrong
 850          function (when we are in the first function in a file which
 851          is compiled without debugging symbols, the previous function
 852          is compiled with debugging symbols, and the "foo.o" symbol
 853          that is supposed to tell us where the file with debugging symbols
 854          ends has been truncated by ar because it is longer than 15
 855          characters).
 856
 857          So look in the minimal symbol tables as well, and if it comes
 858          up with a larger address for the function use that instead.
 859          I don't think this can ever cause any problems; there shouldn't
 860          be any minimal symbols in the middle of a function.
 861          FIXME:  (Not necessarily true.  What about text labels) */
 862
 863       struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
 864
 865       if (msymbol != NULL
 866           && (SYMBOL_VALUE_ADDRESS (msymbol)
 867               > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
 868         funname = SYMBOL_NAME (msymbol);
 869       else
 870         funname = SYMBOL_NAME (func);
 871     }
 872   else
 873     {
 874       register struct minimal_symbol *msymbol =
 875         lookup_minimal_symbol_by_pc (fi->pc);
 876
 877       if (msymbol != NULL)
 878         funname = SYMBOL_NAME (msymbol);
 879     }
 880
 881   the_common = find_common_for_function (comname, funname);
 882
 883   return (the_common ? 1 : 0);
 884 }
 885
 886 void
 887 _initialize_f_valprint ()
 888 {
 889   add_info ("common", info_common_command,
 890             "Print out the values contained in a Fortran COMMON block.");
 891 }