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