1 /* Support for printing Fortran values for GDB, the GNU debugger. 2 3 Copyright (C) 1993-2020 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 "symtab.h" 25 #include "gdbtypes.h" 26 #include "expression.h" 27 #include "value.h" 28 #include "valprint.h" 29 #include "language.h" 30 #include "f-lang.h" 31 #include "frame.h" 32 #include "gdbcore.h" 33 #include "command.h" 34 #include "block.h" 35 #include "dictionary.h" 36 #include "cli/cli-style.h" 37 #include "gdbarch.h" 38 39 static void f77_get_dynamic_length_of_aggregate (struct type *); 40 41 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2]; 42 43 /* Array which holds offsets to be applied to get a row's elements 44 for a given array. Array also holds the size of each subarray. */ 45 46 LONGEST 47 f77_get_lowerbound (struct type *type) 48 { 49 if (type->bounds ()->low.kind () == PROP_UNDEFINED) 50 error (_("Lower bound may not be '*' in F77")); 51 52 return type->bounds ()->low.const_val (); 53 } 54 55 LONGEST 56 f77_get_upperbound (struct type *type) 57 { 58 if (type->bounds ()->high.kind () == PROP_UNDEFINED) 59 { 60 /* We have an assumed size array on our hands. Assume that 61 upper_bound == lower_bound so that we show at least 1 element. 62 If the user wants to see more elements, let him manually ask for 'em 63 and we'll subscript the array and show him. */ 64 65 return f77_get_lowerbound (type); 66 } 67 68 return type->bounds ()->high.const_val (); 69 } 70 71 /* Obtain F77 adjustable array dimensions. */ 72 73 static void 74 f77_get_dynamic_length_of_aggregate (struct type *type) 75 { 76 int upper_bound = -1; 77 int lower_bound = 1; 78 79 /* Recursively go all the way down into a possibly multi-dimensional 80 F77 array and get the bounds. For simple arrays, this is pretty 81 easy but when the bounds are dynamic, we must be very careful 82 to add up all the lengths correctly. Not doing this right 83 will lead to horrendous-looking arrays in parameter lists. 84 85 This function also works for strings which behave very 86 similarly to arrays. */ 87 88 if (TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_ARRAY 89 || TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_STRING) 90 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type)); 91 92 /* Recursion ends here, start setting up lengths. */ 93 lower_bound = f77_get_lowerbound (type); 94 upper_bound = f77_get_upperbound (type); 95 96 /* Patch in a valid length value. */ 97 98 TYPE_LENGTH (type) = 99 (upper_bound - lower_bound + 1) 100 * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type))); 101 } 102 103 /* Actual function which prints out F77 arrays, Valaddr == address in 104 the superior. Address == the address in the inferior. */ 105 106 static void 107 f77_print_array_1 (int nss, int ndimensions, struct type *type, 108 const gdb_byte *valaddr, 109 int embedded_offset, CORE_ADDR address, 110 struct ui_file *stream, int recurse, 111 const struct value *val, 112 const struct value_print_options *options, 113 int *elts) 114 { 115 struct type *range_type = check_typedef (type)->index_type (); 116 CORE_ADDR addr = address + embedded_offset; 117 LONGEST lowerbound, upperbound; 118 LONGEST i; 119 120 get_discrete_bounds (range_type, &lowerbound, &upperbound); 121 122 if (nss != ndimensions) 123 { 124 struct gdbarch *gdbarch = get_type_arch (type); 125 size_t dim_size = type_length_units (TYPE_TARGET_TYPE (type)); 126 int unit_size = gdbarch_addressable_memory_unit_size (gdbarch); 127 size_t byte_stride = type->bit_stride () / (unit_size * 8); 128 if (byte_stride == 0) 129 byte_stride = dim_size; 130 size_t offs = 0; 131 132 for (i = lowerbound; 133 (i < upperbound + 1 && (*elts) < options->print_max); 134 i++) 135 { 136 struct value *subarray = value_from_contents_and_address 137 (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val) 138 + offs, addr + offs); 139 140 fprintf_filtered (stream, "( "); 141 f77_print_array_1 (nss + 1, ndimensions, value_type (subarray), 142 value_contents_for_printing (subarray), 143 value_embedded_offset (subarray), 144 value_address (subarray), 145 stream, recurse, subarray, options, elts); 146 offs += byte_stride; 147 fprintf_filtered (stream, ") "); 148 } 149 if (*elts >= options->print_max && i < upperbound) 150 fprintf_filtered (stream, "..."); 151 } 152 else 153 { 154 for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max; 155 i++, (*elts)++) 156 { 157 struct value *elt = value_subscript ((struct value *)val, i); 158 159 common_val_print (elt, stream, recurse, options, current_language); 160 161 if (i != upperbound) 162 fprintf_filtered (stream, ", "); 163 164 if ((*elts == options->print_max - 1) 165 && (i != upperbound)) 166 fprintf_filtered (stream, "..."); 167 } 168 } 169 } 170 171 /* This function gets called to print an F77 array, we set up some 172 stuff and then immediately call f77_print_array_1(). */ 173 174 static void 175 f77_print_array (struct type *type, const gdb_byte *valaddr, 176 int embedded_offset, 177 CORE_ADDR address, struct ui_file *stream, 178 int recurse, 179 const struct value *val, 180 const struct value_print_options *options) 181 { 182 int ndimensions; 183 int elts = 0; 184 185 ndimensions = calc_f77_array_dims (type); 186 187 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0) 188 error (_("\ 189 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"), 190 ndimensions, MAX_FORTRAN_DIMS); 191 192 f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset, 193 address, stream, recurse, val, options, &elts); 194 } 195 196 197 /* Decorations for Fortran. */ 198 199 static const struct generic_val_print_decorations f_decorations = 200 { 201 "(", 202 ",", 203 ")", 204 ".TRUE.", 205 ".FALSE.", 206 "void", 207 "{", 208 "}" 209 }; 210 211 /* See f-lang.h. */ 212 213 void 214 f_value_print_inner (struct value *val, struct ui_file *stream, int recurse, 215 const struct value_print_options *options) 216 { 217 struct type *type = check_typedef (value_type (val)); 218 struct gdbarch *gdbarch = get_type_arch (type); 219 int printed_field = 0; /* Number of fields printed. */ 220 struct type *elttype; 221 CORE_ADDR addr; 222 int index; 223 const gdb_byte *valaddr = value_contents_for_printing (val); 224 const CORE_ADDR address = value_address (val); 225 226 switch (type->code ()) 227 { 228 case TYPE_CODE_STRING: 229 f77_get_dynamic_length_of_aggregate (type); 230 LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char, 231 valaddr, TYPE_LENGTH (type), NULL, 0, options); 232 break; 233 234 case TYPE_CODE_ARRAY: 235 if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_CHAR) 236 { 237 fprintf_filtered (stream, "("); 238 f77_print_array (type, valaddr, 0, 239 address, stream, recurse, val, options); 240 fprintf_filtered (stream, ")"); 241 } 242 else 243 { 244 struct type *ch_type = TYPE_TARGET_TYPE (type); 245 246 f77_get_dynamic_length_of_aggregate (type); 247 LA_PRINT_STRING (stream, ch_type, valaddr, 248 TYPE_LENGTH (type) / TYPE_LENGTH (ch_type), 249 NULL, 0, options); 250 } 251 break; 252 253 case TYPE_CODE_PTR: 254 if (options->format && options->format != 's') 255 { 256 value_print_scalar_formatted (val, options, 0, stream); 257 break; 258 } 259 else 260 { 261 int want_space = 0; 262 263 addr = unpack_pointer (type, valaddr); 264 elttype = check_typedef (TYPE_TARGET_TYPE (type)); 265 266 if (elttype->code () == TYPE_CODE_FUNC) 267 { 268 /* Try to print what function it points to. */ 269 print_function_pointer_address (options, gdbarch, addr, stream); 270 return; 271 } 272 273 if (options->symbol_print) 274 want_space = print_address_demangle (options, gdbarch, addr, 275 stream, demangle); 276 else if (options->addressprint && options->format != 's') 277 { 278 fputs_filtered (paddress (gdbarch, addr), stream); 279 want_space = 1; 280 } 281 282 /* For a pointer to char or unsigned char, also print the string 283 pointed to, unless pointer is null. */ 284 if (TYPE_LENGTH (elttype) == 1 285 && elttype->code () == TYPE_CODE_INT 286 && (options->format == 0 || options->format == 's') 287 && addr != 0) 288 { 289 if (want_space) 290 fputs_filtered (" ", stream); 291 val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1, 292 stream, options); 293 } 294 return; 295 } 296 break; 297 298 case TYPE_CODE_INT: 299 if (options->format || options->output_format) 300 { 301 struct value_print_options opts = *options; 302 303 opts.format = (options->format ? options->format 304 : options->output_format); 305 value_print_scalar_formatted (val, &opts, 0, stream); 306 } 307 else 308 value_print_scalar_formatted (val, options, 0, stream); 309 break; 310 311 case TYPE_CODE_STRUCT: 312 case TYPE_CODE_UNION: 313 /* Starting from the Fortran 90 standard, Fortran supports derived 314 types. */ 315 fprintf_filtered (stream, "( "); 316 for (index = 0; index < type->num_fields (); index++) 317 { 318 struct value *field = value_field (val, index); 319 320 struct type *field_type = check_typedef (type->field (index).type ()); 321 322 323 if (field_type->code () != TYPE_CODE_FUNC) 324 { 325 const char *field_name; 326 327 if (printed_field > 0) 328 fputs_filtered (", ", stream); 329 330 field_name = TYPE_FIELD_NAME (type, index); 331 if (field_name != NULL) 332 { 333 fputs_styled (field_name, variable_name_style.style (), 334 stream); 335 fputs_filtered (" = ", stream); 336 } 337 338 common_val_print (field, stream, recurse + 1, 339 options, current_language); 340 341 ++printed_field; 342 } 343 } 344 fprintf_filtered (stream, " )"); 345 break; 346 347 case TYPE_CODE_BOOL: 348 if (options->format || options->output_format) 349 { 350 struct value_print_options opts = *options; 351 opts.format = (options->format ? options->format 352 : options->output_format); 353 value_print_scalar_formatted (val, &opts, 0, stream); 354 } 355 else 356 { 357 LONGEST longval = value_as_long (val); 358 /* The Fortran standard doesn't specify how logical types are 359 represented. Different compilers use different non zero 360 values to represent logical true. */ 361 if (longval == 0) 362 fputs_filtered (f_decorations.false_name, stream); 363 else 364 fputs_filtered (f_decorations.true_name, stream); 365 } 366 break; 367 368 case TYPE_CODE_REF: 369 case TYPE_CODE_FUNC: 370 case TYPE_CODE_FLAGS: 371 case TYPE_CODE_FLT: 372 case TYPE_CODE_VOID: 373 case TYPE_CODE_ERROR: 374 case TYPE_CODE_RANGE: 375 case TYPE_CODE_UNDEF: 376 case TYPE_CODE_COMPLEX: 377 case TYPE_CODE_CHAR: 378 default: 379 generic_value_print (val, stream, recurse, options, &f_decorations); 380 break; 381 } 382 } 383 384 static void 385 info_common_command_for_block (const struct block *block, const char *comname, 386 int *any_printed) 387 { 388 struct block_iterator iter; 389 struct symbol *sym; 390 struct value_print_options opts; 391 392 get_user_print_options (&opts); 393 394 ALL_BLOCK_SYMBOLS (block, iter, sym) 395 if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN) 396 { 397 const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym); 398 size_t index; 399 400 gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK); 401 402 if (comname && (!sym->linkage_name () 403 || strcmp (comname, sym->linkage_name ()) != 0)) 404 continue; 405 406 if (*any_printed) 407 putchar_filtered ('\n'); 408 else 409 *any_printed = 1; 410 if (sym->print_name ()) 411 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), 412 sym->print_name ()); 413 else 414 printf_filtered (_("Contents of blank COMMON block:\n")); 415 416 for (index = 0; index < common->n_entries; index++) 417 { 418 struct value *val = NULL; 419 420 printf_filtered ("%s = ", 421 common->contents[index]->print_name ()); 422 423 try 424 { 425 val = value_of_variable (common->contents[index], block); 426 value_print (val, gdb_stdout, &opts); 427 } 428 429 catch (const gdb_exception_error &except) 430 { 431 fprintf_styled (gdb_stdout, metadata_style.style (), 432 "<error reading variable: %s>", 433 except.what ()); 434 } 435 436 putchar_filtered ('\n'); 437 } 438 } 439 } 440 441 /* This function is used to print out the values in a given COMMON 442 block. It will always use the most local common block of the 443 given name. */ 444 445 static void 446 info_common_command (const char *comname, int from_tty) 447 { 448 struct frame_info *fi; 449 const struct block *block; 450 int values_printed = 0; 451 452 /* We have been told to display the contents of F77 COMMON 453 block supposedly visible in this function. Let us 454 first make sure that it is visible and if so, let 455 us display its contents. */ 456 457 fi = get_selected_frame (_("No frame selected")); 458 459 /* The following is generally ripped off from stack.c's routine 460 print_frame_info(). */ 461 462 block = get_frame_block (fi, 0); 463 if (block == NULL) 464 { 465 printf_filtered (_("No symbol table info available.\n")); 466 return; 467 } 468 469 while (block) 470 { 471 info_common_command_for_block (block, comname, &values_printed); 472 /* After handling the function's top-level block, stop. Don't 473 continue to its superblock, the block of per-file symbols. */ 474 if (BLOCK_FUNCTION (block)) 475 break; 476 block = BLOCK_SUPERBLOCK (block); 477 } 478 479 if (!values_printed) 480 { 481 if (comname) 482 printf_filtered (_("No common block '%s'.\n"), comname); 483 else 484 printf_filtered (_("No common blocks.\n")); 485 } 486 } 487 488 void _initialize_f_valprint (); 489 void 490 _initialize_f_valprint () 491 { 492 add_info ("common", info_common_command, 493 _("Print out the values contained in a Fortran COMMON block.")); 494 } 495