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