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