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