1 /* Support for printing Fortran values for GDB, the GNU debugger. 2 3 Copyright (C) 1993-2023 Free Software Foundation, Inc. 4 5 Contributed by Motorola. Adapted from the C definitions by Farooq Butt 6 (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs. 7 8 This file is part of GDB. 9 10 This program is free software; you can redistribute it and/or modify 11 it under the terms of the GNU General Public License as published by 12 the Free Software Foundation; either version 3 of the License, or 13 (at your option) any later version. 14 15 This program is distributed in the hope that it will be useful, 16 but WITHOUT ANY WARRANTY; without even the implied warranty of 17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 GNU General Public License for more details. 19 20 You should have received a copy of the GNU General Public License 21 along with this program. If not, see <http://www.gnu.org/licenses/>. */ 22 23 #include "defs.h" 24 #include "annotate.h" 25 #include "symtab.h" 26 #include "gdbtypes.h" 27 #include "expression.h" 28 #include "value.h" 29 #include "valprint.h" 30 #include "language.h" 31 #include "f-lang.h" 32 #include "frame.h" 33 #include "gdbcore.h" 34 #include "command.h" 35 #include "block.h" 36 #include "dictionary.h" 37 #include "cli/cli-style.h" 38 #include "gdbarch.h" 39 #include "f-array-walker.h" 40 41 static void f77_get_dynamic_length_of_aggregate (struct type *); 42 43 LONGEST 44 f77_get_lowerbound (struct type *type) 45 { 46 if (type->bounds ()->low.kind () != PROP_CONST) 47 error (_("Lower bound may not be '*' in F77")); 48 49 return type->bounds ()->low.const_val (); 50 } 51 52 LONGEST 53 f77_get_upperbound (struct type *type) 54 { 55 if (type->bounds ()->high.kind () != PROP_CONST) 56 { 57 /* We have an assumed size array on our hands. Assume that 58 upper_bound == lower_bound so that we show at least 1 element. 59 If the user wants to see more elements, let him manually ask for 'em 60 and we'll subscript the array and show him. */ 61 62 return f77_get_lowerbound (type); 63 } 64 65 return type->bounds ()->high.const_val (); 66 } 67 68 /* Obtain F77 adjustable array dimensions. */ 69 70 static void 71 f77_get_dynamic_length_of_aggregate (struct type *type) 72 { 73 int upper_bound = -1; 74 int lower_bound = 1; 75 76 /* Recursively go all the way down into a possibly multi-dimensional 77 F77 array and get the bounds. For simple arrays, this is pretty 78 easy but when the bounds are dynamic, we must be very careful 79 to add up all the lengths correctly. Not doing this right 80 will lead to horrendous-looking arrays in parameter lists. 81 82 This function also works for strings which behave very 83 similarly to arrays. */ 84 85 if (type->target_type ()->code () == TYPE_CODE_ARRAY 86 || type->target_type ()->code () == TYPE_CODE_STRING) 87 f77_get_dynamic_length_of_aggregate (type->target_type ()); 88 89 /* Recursion ends here, start setting up lengths. */ 90 lower_bound = f77_get_lowerbound (type); 91 upper_bound = f77_get_upperbound (type); 92 93 /* Patch in a valid length value. */ 94 type->set_length ((upper_bound - lower_bound + 1) 95 * check_typedef (type->target_type ())->length ()); 96 } 97 98 /* Per-dimension statistics. */ 99 100 struct dimension_stats 101 { 102 /* The type of the index used to address elements in the dimension. */ 103 struct type *index_type; 104 105 /* Total number of elements in the dimension, counted as we go. */ 106 int nelts; 107 }; 108 109 /* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array 110 walking template. This specialisation prints Fortran arrays. */ 111 112 class fortran_array_printer_impl : public fortran_array_walker_base_impl 113 { 114 public: 115 /* Constructor. TYPE is the array type being printed, ADDRESS is the 116 address in target memory for the object of TYPE being printed. VAL is 117 the GDB value (of TYPE) being printed. STREAM is where to print to, 118 RECOURSE is passed through (and prevents infinite recursion), and 119 OPTIONS are the printing control options. */ 120 explicit fortran_array_printer_impl (struct type *type, 121 CORE_ADDR address, 122 struct value *val, 123 struct ui_file *stream, 124 int recurse, 125 const struct value_print_options *options) 126 : m_elts (0), 127 m_val (val), 128 m_stream (stream), 129 m_recurse (recurse), 130 m_options (options), 131 m_dimension (0), 132 m_nrepeats (0), 133 m_stats (0) 134 { /* Nothing. */ } 135 136 /* Called while iterating over the array bounds. When SHOULD_CONTINUE is 137 false then we must return false, as we have reached the end of the 138 array bounds for this dimension. However, we also return false if we 139 have printed too many elements (after printing '...'). In all other 140 cases, return true. */ 141 bool continue_walking (bool should_continue) 142 { 143 bool cont = should_continue && (m_elts < m_options->print_max); 144 if (!cont && should_continue) 145 gdb_puts ("...", m_stream); 146 return cont; 147 } 148 149 /* Called when we start iterating over a dimension. If it's not the 150 inner most dimension then print an opening '(' character. */ 151 void start_dimension (struct type *index_type, LONGEST nelts, bool inner_p) 152 { 153 size_t dim_indx = m_dimension++; 154 155 m_elt_type_prev = nullptr; 156 if (m_stats.size () < m_dimension) 157 { 158 m_stats.resize (m_dimension); 159 m_stats[dim_indx].index_type = index_type; 160 m_stats[dim_indx].nelts = nelts; 161 } 162 163 gdb_puts ("(", m_stream); 164 } 165 166 /* Called when we finish processing a batch of items within a dimension 167 of the array. Depending on whether this is the inner most dimension 168 or not we print different things, but this is all about adding 169 separators between elements, and dimensions of the array. */ 170 void finish_dimension (bool inner_p, bool last_p) 171 { 172 gdb_puts (")", m_stream); 173 if (!last_p) 174 gdb_puts (" ", m_stream); 175 176 m_dimension--; 177 } 178 179 /* Called when processing dimensions of the array other than the 180 innermost one. WALK_1 is the walker to normally call, ELT_TYPE is 181 the type of the element being extracted, and ELT_OFF is the offset 182 of the element from the start of array being walked, INDEX_TYPE 183 and INDEX is the type and the value respectively of the element's 184 index in the dimension currently being walked and LAST_P is true 185 only when this is the last element that will be processed in this 186 dimension. */ 187 void process_dimension (gdb::function_view<void (struct type *, 188 int, bool)> walk_1, 189 struct type *elt_type, LONGEST elt_off, 190 LONGEST index, bool last_p) 191 { 192 size_t dim_indx = m_dimension - 1; 193 struct type *elt_type_prev = m_elt_type_prev; 194 LONGEST elt_off_prev = m_elt_off_prev; 195 bool repeated = (m_options->repeat_count_threshold < UINT_MAX 196 && elt_type_prev != nullptr 197 && (m_elts + ((m_nrepeats + 1) 198 * m_stats[dim_indx + 1].nelts) 199 <= m_options->print_max) 200 && dimension_contents_eq (m_val, elt_type, 201 elt_off_prev, elt_off)); 202 203 if (repeated) 204 m_nrepeats++; 205 if (!repeated || last_p) 206 { 207 LONGEST nrepeats = m_nrepeats; 208 209 m_nrepeats = 0; 210 if (nrepeats >= m_options->repeat_count_threshold) 211 { 212 annotate_elt_rep (nrepeats + 1); 213 gdb_printf (m_stream, "%p[<repeats %s times>%p]", 214 metadata_style.style ().ptr (), 215 plongest (nrepeats + 1), 216 nullptr); 217 annotate_elt_rep_end (); 218 if (!repeated) 219 gdb_puts (" ", m_stream); 220 m_elts += nrepeats * m_stats[dim_indx + 1].nelts; 221 } 222 else 223 for (LONGEST i = nrepeats; i > 0; i--) 224 { 225 maybe_print_array_index (m_stats[dim_indx].index_type, 226 index - nrepeats + repeated, 227 m_stream, m_options); 228 walk_1 (elt_type_prev, elt_off_prev, repeated && i == 1); 229 } 230 231 if (!repeated) 232 { 233 /* We need to specially handle the case of hitting `print_max' 234 exactly as recursing would cause lone `(...)' to be printed. 235 And we need to print `...' by hand if the skipped element 236 would be the last one processed, because the subsequent call 237 to `continue_walking' from our caller won't do that. */ 238 if (m_elts < m_options->print_max) 239 { 240 maybe_print_array_index (m_stats[dim_indx].index_type, index, 241 m_stream, m_options); 242 walk_1 (elt_type, elt_off, last_p); 243 nrepeats++; 244 } 245 else if (last_p) 246 gdb_puts ("...", m_stream); 247 } 248 } 249 250 m_elt_type_prev = elt_type; 251 m_elt_off_prev = elt_off; 252 } 253 254 /* Called to process an element of ELT_TYPE at offset ELT_OFF from the 255 start of the parent object, where INDEX is the value of the element's 256 index in the dimension currently being walked and LAST_P is true only 257 when this is the last element to be processed in this dimension. */ 258 void process_element (struct type *elt_type, LONGEST elt_off, 259 LONGEST index, bool last_p) 260 { 261 size_t dim_indx = m_dimension - 1; 262 struct type *elt_type_prev = m_elt_type_prev; 263 LONGEST elt_off_prev = m_elt_off_prev; 264 bool repeated = (m_options->repeat_count_threshold < UINT_MAX 265 && elt_type_prev != nullptr 266 && value_contents_eq (m_val, elt_off_prev, m_val, elt_off, 267 elt_type->length ())); 268 269 if (repeated) 270 m_nrepeats++; 271 if (!repeated || last_p || m_elts + 1 == m_options->print_max) 272 { 273 LONGEST nrepeats = m_nrepeats; 274 bool printed = false; 275 276 if (nrepeats != 0) 277 { 278 m_nrepeats = 0; 279 if (nrepeats >= m_options->repeat_count_threshold) 280 { 281 annotate_elt_rep (nrepeats + 1); 282 gdb_printf (m_stream, "%p[<repeats %s times>%p]", 283 metadata_style.style ().ptr (), 284 plongest (nrepeats + 1), 285 nullptr); 286 annotate_elt_rep_end (); 287 } 288 else 289 { 290 /* Extract the element value from the parent value. */ 291 struct value *e_val 292 = value_from_component (m_val, elt_type, elt_off_prev); 293 294 for (LONGEST i = nrepeats; i > 0; i--) 295 { 296 maybe_print_array_index (m_stats[dim_indx].index_type, 297 index - i + 1, 298 m_stream, m_options); 299 common_val_print (e_val, m_stream, m_recurse, m_options, 300 current_language); 301 if (i > 1) 302 gdb_puts (", ", m_stream); 303 } 304 } 305 printed = true; 306 } 307 308 if (!repeated) 309 { 310 /* Extract the element value from the parent value. */ 311 struct value *e_val 312 = value_from_component (m_val, elt_type, elt_off); 313 314 if (printed) 315 gdb_puts (", ", m_stream); 316 maybe_print_array_index (m_stats[dim_indx].index_type, index, 317 m_stream, m_options); 318 common_val_print (e_val, m_stream, m_recurse, m_options, 319 current_language); 320 } 321 if (!last_p) 322 gdb_puts (", ", m_stream); 323 } 324 325 m_elt_type_prev = elt_type; 326 m_elt_off_prev = elt_off; 327 ++m_elts; 328 } 329 330 private: 331 /* Called to compare two VAL elements of ELT_TYPE at offsets OFFSET1 332 and OFFSET2 each. Handle subarrays recursively, because they may 333 have been sliced and we do not want to compare any memory contents 334 present between the slices requested. */ 335 bool 336 dimension_contents_eq (const struct value *val, struct type *type, 337 LONGEST offset1, LONGEST offset2) 338 { 339 if (type->code () == TYPE_CODE_ARRAY 340 && type->target_type ()->code () != TYPE_CODE_CHAR) 341 { 342 /* Extract the range, and get lower and upper bounds. */ 343 struct type *range_type = check_typedef (type)->index_type (); 344 LONGEST lowerbound, upperbound; 345 if (!get_discrete_bounds (range_type, &lowerbound, &upperbound)) 346 error ("failed to get range bounds"); 347 348 /* CALC is used to calculate the offsets for each element. */ 349 fortran_array_offset_calculator calc (type); 350 351 struct type *subarray_type = check_typedef (type->target_type ()); 352 for (LONGEST i = lowerbound; i < upperbound + 1; i++) 353 { 354 /* Use the index and the stride to work out a new offset. */ 355 LONGEST index_offset = calc.index_offset (i); 356 357 if (!dimension_contents_eq (val, subarray_type, 358 offset1 + index_offset, 359 offset2 + index_offset)) 360 return false; 361 } 362 return true; 363 } 364 else 365 return value_contents_eq (val, offset1, val, offset2, 366 type->length ()); 367 } 368 369 /* The number of elements printed so far. */ 370 int m_elts; 371 372 /* The value from which we are printing elements. */ 373 struct value *m_val; 374 375 /* The stream we should print too. */ 376 struct ui_file *m_stream; 377 378 /* The recursion counter, passed through when we print each element. */ 379 int m_recurse; 380 381 /* The print control options. Gives us the maximum number of elements to 382 print, and is passed through to each element that we print. */ 383 const struct value_print_options *m_options = nullptr; 384 385 /* The number of the current dimension being handled. */ 386 LONGEST m_dimension; 387 388 /* The number of element repetitions in the current series. */ 389 LONGEST m_nrepeats; 390 391 /* The type and offset from M_VAL of the element handled in the previous 392 iteration over the current dimension. */ 393 struct type *m_elt_type_prev; 394 LONGEST m_elt_off_prev; 395 396 /* Per-dimension stats. */ 397 std::vector<struct dimension_stats> m_stats; 398 }; 399 400 /* This function gets called to print a Fortran array. */ 401 402 static void 403 fortran_print_array (struct type *type, CORE_ADDR address, 404 struct ui_file *stream, int recurse, 405 const struct value *val, 406 const struct value_print_options *options) 407 { 408 fortran_array_walker<fortran_array_printer_impl> p 409 (type, address, (struct value *) val, stream, recurse, options); 410 p.walk (); 411 } 412 413 414 /* Decorations for Fortran. */ 415 416 static const struct generic_val_print_decorations f_decorations = 417 { 418 "(", 419 ",", 420 ")", 421 ".TRUE.", 422 ".FALSE.", 423 "void", 424 "{", 425 "}" 426 }; 427 428 /* See f-lang.h. */ 429 430 void 431 f_language::value_print_inner (struct value *val, struct ui_file *stream, 432 int recurse, 433 const struct value_print_options *options) const 434 { 435 struct type *type = check_typedef (value_type (val)); 436 struct gdbarch *gdbarch = type->arch (); 437 int printed_field = 0; /* Number of fields printed. */ 438 struct type *elttype; 439 CORE_ADDR addr; 440 int index; 441 const gdb_byte *valaddr = value_contents_for_printing (val).data (); 442 const CORE_ADDR address = value_address (val); 443 444 switch (type->code ()) 445 { 446 case TYPE_CODE_STRING: 447 f77_get_dynamic_length_of_aggregate (type); 448 printstr (stream, builtin_type (gdbarch)->builtin_char, valaddr, 449 type->length (), NULL, 0, options); 450 break; 451 452 case TYPE_CODE_ARRAY: 453 if (type->target_type ()->code () != TYPE_CODE_CHAR) 454 fortran_print_array (type, address, stream, recurse, val, options); 455 else 456 { 457 struct type *ch_type = type->target_type (); 458 459 f77_get_dynamic_length_of_aggregate (type); 460 printstr (stream, ch_type, valaddr, 461 type->length () / ch_type->length (), NULL, 0, 462 options); 463 } 464 break; 465 466 case TYPE_CODE_PTR: 467 if (options->format && options->format != 's') 468 { 469 value_print_scalar_formatted (val, options, 0, stream); 470 break; 471 } 472 else 473 { 474 int want_space = 0; 475 476 addr = unpack_pointer (type, valaddr); 477 elttype = check_typedef (type->target_type ()); 478 479 if (elttype->code () == TYPE_CODE_FUNC) 480 { 481 /* Try to print what function it points to. */ 482 print_function_pointer_address (options, gdbarch, addr, stream); 483 return; 484 } 485 486 if (options->symbol_print) 487 want_space = print_address_demangle (options, gdbarch, addr, 488 stream, demangle); 489 else if (options->addressprint && options->format != 's') 490 { 491 gdb_puts (paddress (gdbarch, addr), stream); 492 want_space = 1; 493 } 494 495 /* For a pointer to char or unsigned char, also print the string 496 pointed to, unless pointer is null. */ 497 if (elttype->length () == 1 498 && elttype->code () == TYPE_CODE_INT 499 && (options->format == 0 || options->format == 's') 500 && addr != 0) 501 { 502 if (want_space) 503 gdb_puts (" ", stream); 504 val_print_string (type->target_type (), NULL, addr, -1, 505 stream, options); 506 } 507 return; 508 } 509 break; 510 511 case TYPE_CODE_STRUCT: 512 case TYPE_CODE_UNION: 513 case TYPE_CODE_NAMELIST: 514 /* Starting from the Fortran 90 standard, Fortran supports derived 515 types. */ 516 gdb_printf (stream, "( "); 517 for (index = 0; index < type->num_fields (); index++) 518 { 519 struct type *field_type 520 = check_typedef (type->field (index).type ()); 521 522 if (field_type->code () != TYPE_CODE_FUNC) 523 { 524 const char *field_name = type->field (index).name (); 525 struct value *field; 526 527 if (type->code () == TYPE_CODE_NAMELIST) 528 { 529 /* While printing namelist items, fetch the appropriate 530 value field before printing its value. */ 531 struct block_symbol sym 532 = lookup_symbol (field_name, get_selected_block (nullptr), 533 VAR_DOMAIN, nullptr); 534 if (sym.symbol == nullptr) 535 error (_("failed to find symbol for name list component %s"), 536 field_name); 537 field = value_of_variable (sym.symbol, sym.block); 538 } 539 else 540 field = value_field (val, index); 541 542 if (printed_field > 0) 543 gdb_puts (", ", stream); 544 545 if (field_name != NULL) 546 { 547 fputs_styled (field_name, variable_name_style.style (), 548 stream); 549 gdb_puts (" = ", stream); 550 } 551 552 common_val_print (field, stream, recurse + 1, 553 options, current_language); 554 555 ++printed_field; 556 } 557 } 558 gdb_printf (stream, " )"); 559 break; 560 561 case TYPE_CODE_BOOL: 562 if (options->format || options->output_format) 563 { 564 struct value_print_options opts = *options; 565 opts.format = (options->format ? options->format 566 : options->output_format); 567 value_print_scalar_formatted (val, &opts, 0, stream); 568 } 569 else 570 { 571 LONGEST longval = value_as_long (val); 572 /* The Fortran standard doesn't specify how logical types are 573 represented. Different compilers use different non zero 574 values to represent logical true. */ 575 if (longval == 0) 576 gdb_puts (f_decorations.false_name, stream); 577 else 578 gdb_puts (f_decorations.true_name, stream); 579 } 580 break; 581 582 case TYPE_CODE_INT: 583 case TYPE_CODE_REF: 584 case TYPE_CODE_FUNC: 585 case TYPE_CODE_FLAGS: 586 case TYPE_CODE_FLT: 587 case TYPE_CODE_VOID: 588 case TYPE_CODE_ERROR: 589 case TYPE_CODE_RANGE: 590 case TYPE_CODE_UNDEF: 591 case TYPE_CODE_COMPLEX: 592 case TYPE_CODE_CHAR: 593 default: 594 generic_value_print (val, stream, recurse, options, &f_decorations); 595 break; 596 } 597 } 598 599 static void 600 info_common_command_for_block (const struct block *block, const char *comname, 601 int *any_printed) 602 { 603 struct block_iterator iter; 604 struct symbol *sym; 605 struct value_print_options opts; 606 607 get_user_print_options (&opts); 608 609 ALL_BLOCK_SYMBOLS (block, iter, sym) 610 if (sym->domain () == COMMON_BLOCK_DOMAIN) 611 { 612 const struct common_block *common = sym->value_common_block (); 613 size_t index; 614 615 gdb_assert (sym->aclass () == LOC_COMMON_BLOCK); 616 617 if (comname && (!sym->linkage_name () 618 || strcmp (comname, sym->linkage_name ()) != 0)) 619 continue; 620 621 if (*any_printed) 622 gdb_putc ('\n'); 623 else 624 *any_printed = 1; 625 if (sym->print_name ()) 626 gdb_printf (_("Contents of F77 COMMON block '%s':\n"), 627 sym->print_name ()); 628 else 629 gdb_printf (_("Contents of blank COMMON block:\n")); 630 631 for (index = 0; index < common->n_entries; index++) 632 { 633 struct value *val = NULL; 634 635 gdb_printf ("%s = ", 636 common->contents[index]->print_name ()); 637 638 try 639 { 640 val = value_of_variable (common->contents[index], block); 641 value_print (val, gdb_stdout, &opts); 642 } 643 644 catch (const gdb_exception_error &except) 645 { 646 fprintf_styled (gdb_stdout, metadata_style.style (), 647 "<error reading variable: %s>", 648 except.what ()); 649 } 650 651 gdb_putc ('\n'); 652 } 653 } 654 } 655 656 /* This function is used to print out the values in a given COMMON 657 block. It will always use the most local common block of the 658 given name. */ 659 660 static void 661 info_common_command (const char *comname, int from_tty) 662 { 663 frame_info_ptr fi; 664 const struct block *block; 665 int values_printed = 0; 666 667 /* We have been told to display the contents of F77 COMMON 668 block supposedly visible in this function. Let us 669 first make sure that it is visible and if so, let 670 us display its contents. */ 671 672 fi = get_selected_frame (_("No frame selected")); 673 674 /* The following is generally ripped off from stack.c's routine 675 print_frame_info(). */ 676 677 block = get_frame_block (fi, 0); 678 if (block == NULL) 679 { 680 gdb_printf (_("No symbol table info available.\n")); 681 return; 682 } 683 684 while (block) 685 { 686 info_common_command_for_block (block, comname, &values_printed); 687 /* After handling the function's top-level block, stop. Don't 688 continue to its superblock, the block of per-file symbols. */ 689 if (block->function ()) 690 break; 691 block = block->superblock (); 692 } 693 694 if (!values_printed) 695 { 696 if (comname) 697 gdb_printf (_("No common block '%s'.\n"), comname); 698 else 699 gdb_printf (_("No common blocks.\n")); 700 } 701 } 702 703 void _initialize_f_valprint (); 704 void 705 _initialize_f_valprint () 706 { 707 add_info ("common", info_common_command, 708 _("Print out the values contained in a Fortran COMMON block.")); 709 } 710