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, 2008, 2009, 2010, 2011 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 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 fprintf_filtered (stream, "("); 275 f77_print_array (type, valaddr, embedded_offset, 276 address, stream, recurse, original_value, options); 277 fprintf_filtered (stream, ")"); 278 break; 279 280 case TYPE_CODE_PTR: 281 if (options->format && options->format != 's') 282 { 283 val_print_scalar_formatted (type, valaddr, embedded_offset, 284 original_value, options, 0, stream); 285 break; 286 } 287 else 288 { 289 addr = unpack_pointer (type, valaddr + embedded_offset); 290 elttype = check_typedef (TYPE_TARGET_TYPE (type)); 291 292 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC) 293 { 294 /* Try to print what function it points to. */ 295 print_address_demangle (gdbarch, addr, stream, demangle); 296 /* Return value is irrelevant except for string pointers. */ 297 return 0; 298 } 299 300 if (options->addressprint && options->format != 's') 301 fputs_filtered (paddress (gdbarch, addr), stream); 302 303 /* For a pointer to char or unsigned char, also print the string 304 pointed to, unless pointer is null. */ 305 if (TYPE_LENGTH (elttype) == 1 306 && TYPE_CODE (elttype) == TYPE_CODE_INT 307 && (options->format == 0 || options->format == 's') 308 && addr != 0) 309 i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1, 310 stream, options); 311 312 /* Return number of characters printed, including the terminating 313 '\0' if we reached the end. val_print_string takes care including 314 the terminating '\0' if necessary. */ 315 return i; 316 } 317 break; 318 319 case TYPE_CODE_REF: 320 elttype = check_typedef (TYPE_TARGET_TYPE (type)); 321 if (options->addressprint) 322 { 323 CORE_ADDR addr 324 = extract_typed_address (valaddr + embedded_offset, type); 325 326 fprintf_filtered (stream, "@"); 327 fputs_filtered (paddress (gdbarch, addr), stream); 328 if (options->deref_ref) 329 fputs_filtered (": ", stream); 330 } 331 /* De-reference the reference. */ 332 if (options->deref_ref) 333 { 334 if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF) 335 { 336 struct value *deref_val = 337 value_at 338 (TYPE_TARGET_TYPE (type), 339 unpack_pointer (type, valaddr + embedded_offset)); 340 341 common_val_print (deref_val, stream, recurse, 342 options, current_language); 343 } 344 else 345 fputs_filtered ("???", stream); 346 } 347 break; 348 349 case TYPE_CODE_FUNC: 350 if (options->format) 351 { 352 val_print_scalar_formatted (type, valaddr, embedded_offset, 353 original_value, options, 0, stream); 354 break; 355 } 356 /* FIXME, we should consider, at least for ANSI C language, eliminating 357 the distinction made between FUNCs and POINTERs to FUNCs. */ 358 fprintf_filtered (stream, "{"); 359 type_print (type, "", stream, -1); 360 fprintf_filtered (stream, "} "); 361 /* Try to print what function it points to, and its address. */ 362 print_address_demangle (gdbarch, address, stream, demangle); 363 break; 364 365 case TYPE_CODE_INT: 366 if (options->format || options->output_format) 367 { 368 struct value_print_options opts = *options; 369 370 opts.format = (options->format ? options->format 371 : options->output_format); 372 val_print_scalar_formatted (type, valaddr, embedded_offset, 373 original_value, options, 0, stream); 374 } 375 else 376 { 377 val_print_type_code_int (type, valaddr + embedded_offset, stream); 378 /* C and C++ has no single byte int type, char is used instead. 379 Since we don't know whether the value is really intended to 380 be used as an integer or a character, print the character 381 equivalent as well. */ 382 if (TYPE_LENGTH (type) == 1) 383 { 384 LONGEST c; 385 386 fputs_filtered (" ", stream); 387 c = unpack_long (type, valaddr + embedded_offset); 388 LA_PRINT_CHAR ((unsigned char) c, type, stream); 389 } 390 } 391 break; 392 393 case TYPE_CODE_FLAGS: 394 if (options->format) 395 val_print_scalar_formatted (type, valaddr, embedded_offset, 396 original_value, options, 0, stream); 397 else 398 val_print_type_code_flags (type, valaddr + embedded_offset, stream); 399 break; 400 401 case TYPE_CODE_FLT: 402 if (options->format) 403 val_print_scalar_formatted (type, valaddr, embedded_offset, 404 original_value, options, 0, stream); 405 else 406 print_floating (valaddr + embedded_offset, type, stream); 407 break; 408 409 case TYPE_CODE_VOID: 410 fprintf_filtered (stream, "VOID"); 411 break; 412 413 case TYPE_CODE_ERROR: 414 fprintf_filtered (stream, "%s", TYPE_ERROR_NAME (type)); 415 break; 416 417 case TYPE_CODE_RANGE: 418 /* FIXME, we should not ever have to print one of these yet. */ 419 fprintf_filtered (stream, "<range type>"); 420 break; 421 422 case TYPE_CODE_BOOL: 423 if (options->format || options->output_format) 424 { 425 struct value_print_options opts = *options; 426 427 opts.format = (options->format ? options->format 428 : options->output_format); 429 val_print_scalar_formatted (type, valaddr, embedded_offset, 430 original_value, &opts, 0, stream); 431 } 432 else 433 { 434 val = extract_unsigned_integer (valaddr + embedded_offset, 435 TYPE_LENGTH (type), byte_order); 436 if (val == 0) 437 fprintf_filtered (stream, ".FALSE."); 438 else if (val == 1) 439 fprintf_filtered (stream, ".TRUE."); 440 else 441 /* Not a legitimate logical type, print as an integer. */ 442 { 443 /* Bash the type code temporarily. */ 444 TYPE_CODE (type) = TYPE_CODE_INT; 445 val_print (type, valaddr, embedded_offset, 446 address, stream, recurse, 447 original_value, options, current_language); 448 /* Restore the type code so later uses work as intended. */ 449 TYPE_CODE (type) = TYPE_CODE_BOOL; 450 } 451 } 452 break; 453 454 case TYPE_CODE_COMPLEX: 455 type = TYPE_TARGET_TYPE (type); 456 fputs_filtered ("(", stream); 457 print_floating (valaddr + embedded_offset, type, stream); 458 fputs_filtered (",", stream); 459 print_floating (valaddr + embedded_offset + TYPE_LENGTH (type), 460 type, stream); 461 fputs_filtered (")", stream); 462 break; 463 464 case TYPE_CODE_UNDEF: 465 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use 466 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar" 467 and no complete type for struct foo in that file. */ 468 fprintf_filtered (stream, "<incomplete type>"); 469 break; 470 471 case TYPE_CODE_STRUCT: 472 case TYPE_CODE_UNION: 473 /* Starting from the Fortran 90 standard, Fortran supports derived 474 types. */ 475 fprintf_filtered (stream, "( "); 476 for (index = 0; index < TYPE_NFIELDS (type); index++) 477 { 478 int offset = TYPE_FIELD_BITPOS (type, index) / 8; 479 480 val_print (TYPE_FIELD_TYPE (type, index), valaddr, 481 embedded_offset + offset, 482 address, stream, recurse + 1, 483 original_value, options, current_language); 484 if (index != TYPE_NFIELDS (type) - 1) 485 fputs_filtered (", ", stream); 486 } 487 fprintf_filtered (stream, " )"); 488 break; 489 490 default: 491 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type)); 492 } 493 gdb_flush (stream); 494 return 0; 495 } 496 497 static void 498 list_all_visible_commons (char *funname) 499 { 500 SAVED_F77_COMMON_PTR tmp; 501 502 tmp = head_common_list; 503 504 printf_filtered (_("All COMMON blocks visible at this level:\n\n")); 505 506 while (tmp != NULL) 507 { 508 if (strcmp (tmp->owning_function, funname) == 0) 509 printf_filtered ("%s\n", tmp->name); 510 511 tmp = tmp->next; 512 } 513 } 514 515 /* This function is used to print out the values in a given COMMON 516 block. It will always use the most local common block of the 517 given name. */ 518 519 static void 520 info_common_command (char *comname, int from_tty) 521 { 522 SAVED_F77_COMMON_PTR the_common; 523 COMMON_ENTRY_PTR entry; 524 struct frame_info *fi; 525 char *funname = 0; 526 struct symbol *func; 527 528 /* We have been told to display the contents of F77 COMMON 529 block supposedly visible in this function. Let us 530 first make sure that it is visible and if so, let 531 us display its contents. */ 532 533 fi = get_selected_frame (_("No frame selected")); 534 535 /* The following is generally ripped off from stack.c's routine 536 print_frame_info(). */ 537 538 func = find_pc_function (get_frame_pc (fi)); 539 if (func) 540 { 541 /* In certain pathological cases, the symtabs give the wrong 542 function (when we are in the first function in a file which 543 is compiled without debugging symbols, the previous function 544 is compiled with debugging symbols, and the "foo.o" symbol 545 that is supposed to tell us where the file with debugging symbols 546 ends has been truncated by ar because it is longer than 15 547 characters). 548 549 So look in the minimal symbol tables as well, and if it comes 550 up with a larger address for the function use that instead. 551 I don't think this can ever cause any problems; there shouldn't 552 be any minimal symbols in the middle of a function. 553 FIXME: (Not necessarily true. What about text labels?) */ 554 555 struct minimal_symbol *msymbol = 556 lookup_minimal_symbol_by_pc (get_frame_pc (fi)); 557 558 if (msymbol != NULL 559 && (SYMBOL_VALUE_ADDRESS (msymbol) 560 > BLOCK_START (SYMBOL_BLOCK_VALUE (func)))) 561 funname = SYMBOL_LINKAGE_NAME (msymbol); 562 else 563 funname = SYMBOL_LINKAGE_NAME (func); 564 } 565 else 566 { 567 struct minimal_symbol *msymbol = 568 lookup_minimal_symbol_by_pc (get_frame_pc (fi)); 569 570 if (msymbol != NULL) 571 funname = SYMBOL_LINKAGE_NAME (msymbol); 572 else /* Got no 'funname', code below will fail. */ 573 error (_("No function found for frame.")); 574 } 575 576 /* If comname is NULL, we assume the user wishes to see the 577 which COMMON blocks are visible here and then return. */ 578 579 if (comname == 0) 580 { 581 list_all_visible_commons (funname); 582 return; 583 } 584 585 the_common = find_common_for_function (comname, funname); 586 587 if (the_common) 588 { 589 if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0) 590 printf_filtered (_("Contents of blank COMMON block:\n")); 591 else 592 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname); 593 594 printf_filtered ("\n"); 595 entry = the_common->entries; 596 597 while (entry != NULL) 598 { 599 print_variable_and_value (NULL, entry->symbol, fi, gdb_stdout, 0); 600 entry = entry->next; 601 } 602 } 603 else 604 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"), 605 comname, funname); 606 } 607 608 /* This function is used to determine whether there is a 609 F77 common block visible at the current scope called 'comname'. */ 610 611 #if 0 612 static int 613 there_is_a_visible_common_named (char *comname) 614 { 615 SAVED_F77_COMMON_PTR the_common; 616 struct frame_info *fi; 617 char *funname = 0; 618 struct symbol *func; 619 620 if (comname == NULL) 621 error (_("Cannot deal with NULL common name!")); 622 623 fi = get_selected_frame (_("No frame selected")); 624 625 /* The following is generally ripped off from stack.c's routine 626 print_frame_info(). */ 627 628 func = find_pc_function (fi->pc); 629 if (func) 630 { 631 /* In certain pathological cases, the symtabs give the wrong 632 function (when we are in the first function in a file which 633 is compiled without debugging symbols, the previous function 634 is compiled with debugging symbols, and the "foo.o" symbol 635 that is supposed to tell us where the file with debugging symbols 636 ends has been truncated by ar because it is longer than 15 637 characters). 638 639 So look in the minimal symbol tables as well, and if it comes 640 up with a larger address for the function use that instead. 641 I don't think this can ever cause any problems; there shouldn't 642 be any minimal symbols in the middle of a function. 643 FIXME: (Not necessarily true. What about text labels?) */ 644 645 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc); 646 647 if (msymbol != NULL 648 && (SYMBOL_VALUE_ADDRESS (msymbol) 649 > BLOCK_START (SYMBOL_BLOCK_VALUE (func)))) 650 funname = SYMBOL_LINKAGE_NAME (msymbol); 651 else 652 funname = SYMBOL_LINKAGE_NAME (func); 653 } 654 else 655 { 656 struct minimal_symbol *msymbol = 657 lookup_minimal_symbol_by_pc (fi->pc); 658 659 if (msymbol != NULL) 660 funname = SYMBOL_LINKAGE_NAME (msymbol); 661 } 662 663 the_common = find_common_for_function (comname, funname); 664 665 return (the_common ? 1 : 0); 666 } 667 #endif 668 669 void 670 _initialize_f_valprint (void) 671 { 672 add_info ("common", info_common_command, 673 _("Print out the values contained in a Fortran COMMON block.")); 674 if (xdb_commands) 675 add_com ("lc", class_info, info_common_command, 676 _("Print out the values contained in a Fortran COMMON block.")); 677 } 678