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