1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993-2016 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C definitions by Farooq Butt
6 (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
8 This file is part of GDB.
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.
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.
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/>. */
26 #include "expression.h"
35 #include "dictionary.h"
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 *);
41 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
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. */
47 f77_get_lowerbound (struct type *type)
49 if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
50 error (_("Lower bound may not be '*' in F77"));
52 return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
56 f77_get_upperbound (struct type *type)
58 if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
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. */
65 return f77_get_lowerbound (type);
68 return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
71 /* Obtain F77 adjustable array dimensions. */
74 f77_get_dynamic_length_of_aggregate (struct type *type)
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.
85 This function also works for strings which behave very
86 similarly to arrays. */
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));
92 /* Recursion ends here, start setting up lengths. */
93 lower_bound = f77_get_lowerbound (type);
94 upper_bound = f77_get_upperbound (type);
96 /* Patch in a valid length value. */
99 (upper_bound - lower_bound + 1)
100 * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
103 /* Actual function which prints out F77 arrays, Valaddr == address in
104 the superior. Address == the address in the inferior. */
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,
115 struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
116 CORE_ADDR addr = address + embedded_offset;
117 LONGEST lowerbound, upperbound;
120 get_discrete_bounds (range_type, &lowerbound, &upperbound);
122 if (nss != ndimensions)
124 size_t dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
128 (i < upperbound + 1 && (*elts) < options->print_max);
131 struct value *subarray = value_from_contents_and_address
132 (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
133 + offs, addr + offs);
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);
142 fprintf_filtered (stream, ") ");
144 if (*elts >= options->print_max && i < upperbound)
145 fprintf_filtered (stream, "...");
149 for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
152 struct value *elt = value_subscript ((struct value *)val, i);
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);
161 fprintf_filtered (stream, ", ");
163 if ((*elts == options->print_max - 1)
164 && (i != upperbound))
165 fprintf_filtered (stream, "...");
170 /* This function gets called to print an F77 array, we set up some
171 stuff and then immediately call f77_print_array_1(). */
174 f77_print_array (struct type *type, const gdb_byte *valaddr,
176 CORE_ADDR address, struct ui_file *stream,
178 const struct value *val,
179 const struct value_print_options *options)
184 ndimensions = calc_f77_array_dims (type);
186 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
188 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
189 ndimensions, MAX_FORTRAN_DIMS);
191 f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
192 address, stream, recurse, val, options, &elts);
196 /* Decorations for Fortran. */
198 static const struct generic_val_print_decorations f_decorations =
210 /* See val_print for a description of the various parameters of this
211 function; they are identical. */
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)
219 struct gdbarch *gdbarch = get_type_arch (type);
220 enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
221 unsigned int i = 0; /* Number of characters printed. */
222 int printed_field = 0; /* Number of fields printed. */
223 struct type *elttype;
227 type = check_typedef (type);
228 switch (TYPE_CODE (type))
230 case TYPE_CODE_STRING:
231 f77_get_dynamic_length_of_aggregate (type);
232 LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
233 valaddr + embedded_offset,
234 TYPE_LENGTH (type), NULL, 0, options);
237 case TYPE_CODE_ARRAY:
238 if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
240 fprintf_filtered (stream, "(");
241 f77_print_array (type, valaddr, embedded_offset,
242 address, stream, recurse, original_value, options);
243 fprintf_filtered (stream, ")");
247 struct type *ch_type = TYPE_TARGET_TYPE (type);
249 f77_get_dynamic_length_of_aggregate (type);
250 LA_PRINT_STRING (stream, ch_type,
251 valaddr + embedded_offset,
252 TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
258 if (options->format && options->format != 's')
260 val_print_scalar_formatted (type, valaddr, embedded_offset,
261 original_value, options, 0, stream);
268 addr = unpack_pointer (type, valaddr + embedded_offset);
269 elttype = check_typedef (TYPE_TARGET_TYPE (type));
271 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
273 /* Try to print what function it points to. */
274 print_function_pointer_address (options, gdbarch, addr, stream);
278 if (options->symbol_print)
279 want_space = print_address_demangle (options, gdbarch, addr,
281 else if (options->addressprint && options->format != 's')
283 fputs_filtered (paddress (gdbarch, addr), stream);
287 /* For a pointer to char or unsigned char, also print the string
288 pointed to, unless pointer is null. */
289 if (TYPE_LENGTH (elttype) == 1
290 && TYPE_CODE (elttype) == TYPE_CODE_INT
291 && (options->format == 0 || options->format == 's')
295 fputs_filtered (" ", stream);
296 i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
304 if (options->format || options->output_format)
306 struct value_print_options opts = *options;
308 opts.format = (options->format ? options->format
309 : options->output_format);
310 val_print_scalar_formatted (type, valaddr, embedded_offset,
311 original_value, &opts, 0, stream);
315 val_print_type_code_int (type, valaddr + embedded_offset, stream);
316 /* C and C++ has no single byte int type, char is used instead.
317 Since we don't know whether the value is really intended to
318 be used as an integer or a character, print the character
319 equivalent as well. */
320 if (TYPE_LENGTH (type) == 1)
324 fputs_filtered (" ", stream);
325 c = unpack_long (type, valaddr + embedded_offset);
326 LA_PRINT_CHAR ((unsigned char) c, type, stream);
331 case TYPE_CODE_STRUCT:
332 case TYPE_CODE_UNION:
333 /* Starting from the Fortran 90 standard, Fortran supports derived
335 fprintf_filtered (stream, "( ");
336 for (index = 0; index < TYPE_NFIELDS (type); index++)
338 struct value *field = value_field
339 ((struct value *)original_value, index);
341 struct type *field_type = check_typedef (TYPE_FIELD_TYPE (type, index));
344 if (TYPE_CODE (field_type) != TYPE_CODE_FUNC)
346 const char *field_name;
348 if (printed_field > 0)
349 fputs_filtered (", ", stream);
351 field_name = TYPE_FIELD_NAME (type, index);
352 if (field_name != NULL)
354 fputs_filtered (field_name, stream);
355 fputs_filtered (" = ", stream);
358 val_print (value_type (field),
359 value_contents_for_printing (field),
360 value_embedded_offset (field),
361 value_address (field), stream, recurse + 1,
362 field, options, current_language);
367 fprintf_filtered (stream, " )");
372 case TYPE_CODE_FLAGS:
375 case TYPE_CODE_ERROR:
376 case TYPE_CODE_RANGE:
377 case TYPE_CODE_UNDEF:
378 case TYPE_CODE_COMPLEX:
382 generic_val_print (type, valaddr, embedded_offset, address,
383 stream, recurse, original_value, options,
391 info_common_command_for_block (const struct block *block, const char *comname,
394 struct block_iterator iter;
397 struct value_print_options opts;
399 get_user_print_options (&opts);
401 ALL_BLOCK_SYMBOLS (block, iter, sym)
402 if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
404 const struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
407 gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
409 if (comname && (!SYMBOL_LINKAGE_NAME (sym)
410 || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
414 putchar_filtered ('\n');
417 if (SYMBOL_PRINT_NAME (sym))
418 printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
419 SYMBOL_PRINT_NAME (sym));
421 printf_filtered (_("Contents of blank COMMON block:\n"));
423 for (index = 0; index < common->n_entries; index++)
425 struct value *val = NULL;
427 printf_filtered ("%s = ",
428 SYMBOL_PRINT_NAME (common->contents[index]));
432 val = value_of_variable (common->contents[index], block);
433 value_print (val, gdb_stdout, &opts);
436 CATCH (except, RETURN_MASK_ERROR)
438 printf_filtered ("<error reading variable: %s>", except.message);
442 putchar_filtered ('\n');
447 /* This function is used to print out the values in a given COMMON
448 block. It will always use the most local common block of the
452 info_common_command (char *comname, int from_tty)
454 struct frame_info *fi;
455 const struct block *block;
456 int values_printed = 0;
458 /* We have been told to display the contents of F77 COMMON
459 block supposedly visible in this function. Let us
460 first make sure that it is visible and if so, let
461 us display its contents. */
463 fi = get_selected_frame (_("No frame selected"));
465 /* The following is generally ripped off from stack.c's routine
466 print_frame_info(). */
468 block = get_frame_block (fi, 0);
471 printf_filtered (_("No symbol table info available.\n"));
477 info_common_command_for_block (block, comname, &values_printed);
478 /* After handling the function's top-level block, stop. Don't
479 continue to its superblock, the block of per-file symbols. */
480 if (BLOCK_FUNCTION (block))
482 block = BLOCK_SUPERBLOCK (block);
488 printf_filtered (_("No common block '%s'.\n"), comname);
490 printf_filtered (_("No common blocks.\n"));
495 _initialize_f_valprint (void)
497 add_info ("common", info_common_command,
498 _("Print out the values contained in a Fortran COMMON block."));