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