1 /* Support for printing Fortran values for GDB, the GNU debugger. 2 3 Copyright (C) 1993-2016 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 37 extern void _initialize_f_valprint (void); 38 static void info_common_command (char *, int); 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 int 47 f77_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 55 int 56 f77_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 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_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 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 = 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_contents_for_printing (elt), 156 value_embedded_offset (elt), 157 value_address (elt), stream, recurse, 158 elt, options, current_language); 159 160 if (i != upperbound) 161 fprintf_filtered (stream, ", "); 162 163 if ((*elts == options->print_max - 1) 164 && (i != upperbound)) 165 fprintf_filtered (stream, "..."); 166 } 167 } 168 } 169 170 /* This function gets called to print an F77 array, we set up some 171 stuff and then immediately call f77_print_array_1(). */ 172 173 static void 174 f77_print_array (struct type *type, const gdb_byte *valaddr, 175 int embedded_offset, 176 CORE_ADDR address, struct ui_file *stream, 177 int recurse, 178 const struct value *val, 179 const struct value_print_options *options) 180 { 181 int ndimensions; 182 int elts = 0; 183 184 ndimensions = calc_f77_array_dims (type); 185 186 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0) 187 error (_("\ 188 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"), 189 ndimensions, MAX_FORTRAN_DIMS); 190 191 f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset, 192 address, stream, recurse, val, options, &elts); 193 } 194 195 196 /* Decorations for Fortran. */ 197 198 static const struct generic_val_print_decorations f_decorations = 199 { 200 "(", 201 ",", 202 ")", 203 ".TRUE.", 204 ".FALSE.", 205 "VOID", 206 "{", 207 "}" 208 }; 209 210 /* See val_print for a description of the various parameters of this 211 function; they are identical. */ 212 213 void 214 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset, 215 CORE_ADDR address, struct ui_file *stream, int recurse, 216 const struct value *original_value, 217 const struct value_print_options *options) 218 { 219 struct gdbarch *gdbarch = get_type_arch (type); 220 enum bfd_endian byte_order = gdbarch_byte_order (gdbarch); 221 int printed_field = 0; /* Number of fields printed. */ 222 struct type *elttype; 223 CORE_ADDR addr; 224 int index; 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, valaddr, 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, valaddr, 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_contents_for_printing (field), 359 value_embedded_offset (field), 360 value_address (field), stream, recurse + 1, 361 field, options, current_language); 362 363 ++printed_field; 364 } 365 } 366 fprintf_filtered (stream, " )"); 367 break; 368 369 case TYPE_CODE_REF: 370 case TYPE_CODE_FUNC: 371 case TYPE_CODE_FLAGS: 372 case TYPE_CODE_FLT: 373 case TYPE_CODE_VOID: 374 case TYPE_CODE_ERROR: 375 case TYPE_CODE_RANGE: 376 case TYPE_CODE_UNDEF: 377 case TYPE_CODE_COMPLEX: 378 case TYPE_CODE_BOOL: 379 case TYPE_CODE_CHAR: 380 default: 381 generic_val_print (type, valaddr, embedded_offset, address, 382 stream, recurse, original_value, options, 383 &f_decorations); 384 break; 385 } 386 gdb_flush (stream); 387 } 388 389 static void 390 info_common_command_for_block (const struct block *block, const char *comname, 391 int *any_printed) 392 { 393 struct block_iterator iter; 394 struct symbol *sym; 395 const char *name; 396 struct value_print_options opts; 397 398 get_user_print_options (&opts); 399 400 ALL_BLOCK_SYMBOLS (block, iter, sym) 401 if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN) 402 { 403 const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym); 404 size_t index; 405 406 gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK); 407 408 if (comname && (!SYMBOL_LINKAGE_NAME (sym) 409 || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0)) 410 continue; 411 412 if (*any_printed) 413 putchar_filtered ('\n'); 414 else 415 *any_printed = 1; 416 if (SYMBOL_PRINT_NAME (sym)) 417 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), 418 SYMBOL_PRINT_NAME (sym)); 419 else 420 printf_filtered (_("Contents of blank COMMON block:\n")); 421 422 for (index = 0; index < common->n_entries; index++) 423 { 424 struct value *val = NULL; 425 426 printf_filtered ("%s = ", 427 SYMBOL_PRINT_NAME (common->contents[index])); 428 429 TRY 430 { 431 val = value_of_variable (common->contents[index], block); 432 value_print (val, gdb_stdout, &opts); 433 } 434 435 CATCH (except, RETURN_MASK_ERROR) 436 { 437 printf_filtered ("<error reading variable: %s>", except.message); 438 } 439 END_CATCH 440 441 putchar_filtered ('\n'); 442 } 443 } 444 } 445 446 /* This function is used to print out the values in a given COMMON 447 block. It will always use the most local common block of the 448 given name. */ 449 450 static void 451 info_common_command (char *comname, int from_tty) 452 { 453 struct frame_info *fi; 454 const struct block *block; 455 int values_printed = 0; 456 457 /* We have been told to display the contents of F77 COMMON 458 block supposedly visible in this function. Let us 459 first make sure that it is visible and if so, let 460 us display its contents. */ 461 462 fi = get_selected_frame (_("No frame selected")); 463 464 /* The following is generally ripped off from stack.c's routine 465 print_frame_info(). */ 466 467 block = get_frame_block (fi, 0); 468 if (block == NULL) 469 { 470 printf_filtered (_("No symbol table info available.\n")); 471 return; 472 } 473 474 while (block) 475 { 476 info_common_command_for_block (block, comname, &values_printed); 477 /* After handling the function's top-level block, stop. Don't 478 continue to its superblock, the block of per-file symbols. */ 479 if (BLOCK_FUNCTION (block)) 480 break; 481 block = BLOCK_SUPERBLOCK (block); 482 } 483 484 if (!values_printed) 485 { 486 if (comname) 487 printf_filtered (_("No common block '%s'.\n"), comname); 488 else 489 printf_filtered (_("No common blocks.\n")); 490 } 491 } 492 493 void 494 _initialize_f_valprint (void) 495 { 496 add_info ("common", info_common_command, 497 _("Print out the values contained in a Fortran COMMON block.")); 498 } 499