f-valprint.c revision 1.7
1/* Support for printing Fortran values for GDB, the GNU debugger. 2 3 Copyright (C) 1993-2017 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 37extern void _initialize_f_valprint (void); 38static void info_common_command (char *, int); 39static void f77_get_dynamic_length_of_aggregate (struct type *); 40 41int 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 46int 47f77_get_lowerbound (struct type *type) 48{ 49 if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type)) 50 error (_("Lower bound may not be '*' in F77")); 51 52 return TYPE_ARRAY_LOWER_BOUND_VALUE (type); 53} 54 55int 56f77_get_upperbound (struct type *type) 57{ 58 if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type)) 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_ARRAY_UPPER_BOUND_VALUE (type); 69} 70 71/* Obtain F77 adjustable array dimensions. */ 72 73static void 74f77_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_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY 89 || TYPE_CODE (TYPE_TARGET_TYPE (type)) == 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 106static void 107f77_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 = TYPE_INDEX_TYPE (check_typedef (type)); 116 CORE_ADDR addr = address + embedded_offset; 117 LONGEST lowerbound, upperbound; 118 int i; 119 120 get_discrete_bounds (range_type, &lowerbound, &upperbound); 121 122 if (nss != ndimensions) 123 { 124 size_t dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type)); 125 size_t offs = 0; 126 127 for (i = lowerbound; 128 (i < upperbound + 1 && (*elts) < options->print_max); 129 i++) 130 { 131 struct value *subarray = value_from_contents_and_address 132 (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val) 133 + offs, addr + offs); 134 135 fprintf_filtered (stream, "( "); 136 f77_print_array_1 (nss + 1, ndimensions, value_type (subarray), 137 value_contents_for_printing (subarray), 138 value_embedded_offset (subarray), 139 value_address (subarray), 140 stream, recurse, subarray, options, elts); 141 offs += dim_size; 142 fprintf_filtered (stream, ") "); 143 } 144 if (*elts >= options->print_max && i < upperbound) 145 fprintf_filtered (stream, "..."); 146 } 147 else 148 { 149 for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max; 150 i++, (*elts)++) 151 { 152 struct value *elt = value_subscript ((struct value *)val, i); 153 154 val_print (value_type (elt), 155 value_embedded_offset (elt), 156 value_address (elt), stream, recurse, 157 elt, options, current_language); 158 159 if (i != upperbound) 160 fprintf_filtered (stream, ", "); 161 162 if ((*elts == options->print_max - 1) 163 && (i != upperbound)) 164 fprintf_filtered (stream, "..."); 165 } 166 } 167} 168 169/* This function gets called to print an F77 array, we set up some 170 stuff and then immediately call f77_print_array_1(). */ 171 172static void 173f77_print_array (struct type *type, const gdb_byte *valaddr, 174 int embedded_offset, 175 CORE_ADDR address, struct ui_file *stream, 176 int recurse, 177 const struct value *val, 178 const struct value_print_options *options) 179{ 180 int ndimensions; 181 int elts = 0; 182 183 ndimensions = calc_f77_array_dims (type); 184 185 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0) 186 error (_("\ 187Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"), 188 ndimensions, MAX_FORTRAN_DIMS); 189 190 f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset, 191 address, stream, recurse, val, options, &elts); 192} 193 194 195/* Decorations for Fortran. */ 196 197static const struct generic_val_print_decorations f_decorations = 198{ 199 "(", 200 ",", 201 ")", 202 ".TRUE.", 203 ".FALSE.", 204 "VOID", 205 "{", 206 "}" 207}; 208 209/* See val_print for a description of the various parameters of this 210 function; they are identical. */ 211 212void 213f_val_print (struct type *type, int embedded_offset, 214 CORE_ADDR address, struct ui_file *stream, int recurse, 215 struct value *original_value, 216 const struct value_print_options *options) 217{ 218 struct gdbarch *gdbarch = get_type_arch (type); 219 enum bfd_endian byte_order = gdbarch_byte_order (gdbarch); 220 int printed_field = 0; /* Number of fields printed. */ 221 struct type *elttype; 222 CORE_ADDR addr; 223 int index; 224 const gdb_byte *valaddr =value_contents_for_printing (original_value); 225 226 type = check_typedef (type); 227 switch (TYPE_CODE (type)) 228 { 229 case TYPE_CODE_STRING: 230 f77_get_dynamic_length_of_aggregate (type); 231 LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char, 232 valaddr + embedded_offset, 233 TYPE_LENGTH (type), NULL, 0, options); 234 break; 235 236 case TYPE_CODE_ARRAY: 237 if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR) 238 { 239 fprintf_filtered (stream, "("); 240 f77_print_array (type, valaddr, embedded_offset, 241 address, stream, recurse, original_value, options); 242 fprintf_filtered (stream, ")"); 243 } 244 else 245 { 246 struct type *ch_type = TYPE_TARGET_TYPE (type); 247 248 f77_get_dynamic_length_of_aggregate (type); 249 LA_PRINT_STRING (stream, ch_type, 250 valaddr + embedded_offset, 251 TYPE_LENGTH (type) / TYPE_LENGTH (ch_type), 252 NULL, 0, options); 253 } 254 break; 255 256 case TYPE_CODE_PTR: 257 if (options->format && options->format != 's') 258 { 259 val_print_scalar_formatted (type, embedded_offset, 260 original_value, options, 0, stream); 261 break; 262 } 263 else 264 { 265 int want_space = 0; 266 267 addr = unpack_pointer (type, valaddr + embedded_offset); 268 elttype = check_typedef (TYPE_TARGET_TYPE (type)); 269 270 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC) 271 { 272 /* Try to print what function it points to. */ 273 print_function_pointer_address (options, gdbarch, addr, stream); 274 return; 275 } 276 277 if (options->symbol_print) 278 want_space = print_address_demangle (options, gdbarch, addr, 279 stream, demangle); 280 else if (options->addressprint && options->format != 's') 281 { 282 fputs_filtered (paddress (gdbarch, addr), stream); 283 want_space = 1; 284 } 285 286 /* For a pointer to char or unsigned char, also print the string 287 pointed to, unless pointer is null. */ 288 if (TYPE_LENGTH (elttype) == 1 289 && TYPE_CODE (elttype) == TYPE_CODE_INT 290 && (options->format == 0 || options->format == 's') 291 && addr != 0) 292 { 293 if (want_space) 294 fputs_filtered (" ", stream); 295 val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1, 296 stream, options); 297 } 298 return; 299 } 300 break; 301 302 case TYPE_CODE_INT: 303 if (options->format || options->output_format) 304 { 305 struct value_print_options opts = *options; 306 307 opts.format = (options->format ? options->format 308 : options->output_format); 309 val_print_scalar_formatted (type, embedded_offset, 310 original_value, &opts, 0, stream); 311 } 312 else 313 { 314 val_print_type_code_int (type, valaddr + embedded_offset, stream); 315 /* C and C++ has no single byte int type, char is used instead. 316 Since we don't know whether the value is really intended to 317 be used as an integer or a character, print the character 318 equivalent as well. */ 319 if (TYPE_LENGTH (type) == 1) 320 { 321 LONGEST c; 322 323 fputs_filtered (" ", stream); 324 c = unpack_long (type, valaddr + embedded_offset); 325 LA_PRINT_CHAR ((unsigned char) c, type, stream); 326 } 327 } 328 break; 329 330 case TYPE_CODE_STRUCT: 331 case TYPE_CODE_UNION: 332 /* Starting from the Fortran 90 standard, Fortran supports derived 333 types. */ 334 fprintf_filtered (stream, "( "); 335 for (index = 0; index < TYPE_NFIELDS (type); index++) 336 { 337 struct value *field = value_field 338 ((struct value *)original_value, index); 339 340 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, index)); 341 342 343 if (TYPE_CODE (field_type) != TYPE_CODE_FUNC) 344 { 345 const char *field_name; 346 347 if (printed_field > 0) 348 fputs_filtered (", ", stream); 349 350 field_name = TYPE_FIELD_NAME (type, index); 351 if (field_name != NULL) 352 { 353 fputs_filtered (field_name, stream); 354 fputs_filtered (" = ", stream); 355 } 356 357 val_print (value_type (field), 358 value_embedded_offset (field), 359 value_address (field), stream, recurse + 1, 360 field, options, current_language); 361 362 ++printed_field; 363 } 364 } 365 fprintf_filtered (stream, " )"); 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_BOOL: 378 case TYPE_CODE_CHAR: 379 default: 380 generic_val_print (type, embedded_offset, address, 381 stream, recurse, original_value, options, 382 &f_decorations); 383 break; 384 } 385 gdb_flush (stream); 386} 387 388static void 389info_common_command_for_block (const struct block *block, const char *comname, 390 int *any_printed) 391{ 392 struct block_iterator iter; 393 struct symbol *sym; 394 const char *name; 395 struct value_print_options opts; 396 397 get_user_print_options (&opts); 398 399 ALL_BLOCK_SYMBOLS (block, iter, sym) 400 if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN) 401 { 402 const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym); 403 size_t index; 404 405 gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK); 406 407 if (comname && (!SYMBOL_LINKAGE_NAME (sym) 408 || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0)) 409 continue; 410 411 if (*any_printed) 412 putchar_filtered ('\n'); 413 else 414 *any_printed = 1; 415 if (SYMBOL_PRINT_NAME (sym)) 416 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), 417 SYMBOL_PRINT_NAME (sym)); 418 else 419 printf_filtered (_("Contents of blank COMMON block:\n")); 420 421 for (index = 0; index < common->n_entries; index++) 422 { 423 struct value *val = NULL; 424 425 printf_filtered ("%s = ", 426 SYMBOL_PRINT_NAME (common->contents[index])); 427 428 TRY 429 { 430 val = value_of_variable (common->contents[index], block); 431 value_print (val, gdb_stdout, &opts); 432 } 433 434 CATCH (except, RETURN_MASK_ERROR) 435 { 436 printf_filtered ("<error reading variable: %s>", except.message); 437 } 438 END_CATCH 439 440 putchar_filtered ('\n'); 441 } 442 } 443} 444 445/* This function is used to print out the values in a given COMMON 446 block. It will always use the most local common block of the 447 given name. */ 448 449static void 450info_common_command (char *comname, int from_tty) 451{ 452 struct frame_info *fi; 453 const struct block *block; 454 int values_printed = 0; 455 456 /* We have been told to display the contents of F77 COMMON 457 block supposedly visible in this function. Let us 458 first make sure that it is visible and if so, let 459 us display its contents. */ 460 461 fi = get_selected_frame (_("No frame selected")); 462 463 /* The following is generally ripped off from stack.c's routine 464 print_frame_info(). */ 465 466 block = get_frame_block (fi, 0); 467 if (block == NULL) 468 { 469 printf_filtered (_("No symbol table info available.\n")); 470 return; 471 } 472 473 while (block) 474 { 475 info_common_command_for_block (block, comname, &values_printed); 476 /* After handling the function's top-level block, stop. Don't 477 continue to its superblock, the block of per-file symbols. */ 478 if (BLOCK_FUNCTION (block)) 479 break; 480 block = BLOCK_SUPERBLOCK (block); 481 } 482 483 if (!values_printed) 484 { 485 if (comname) 486 printf_filtered (_("No common block '%s'.\n"), comname); 487 else 488 printf_filtered (_("No common blocks.\n")); 489 } 490} 491 492void 493_initialize_f_valprint (void) 494{ 495 add_info ("common", info_common_command, 496 _("Print out the values contained in a Fortran COMMON block.")); 497} 498