1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993-2019 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/>. */
25 /* Local non-gdb includes. */
28 #include "dictionary.h"
29 #include "expression.h"
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_embedded_offset (elt
),
156 value_address (elt
), stream
, recurse
,
157 elt
, options
, current_language
);
160 fprintf_filtered (stream
, ", ");
162 if ((*elts
== options
->print_max
- 1)
163 && (i
!= upperbound
))
164 fprintf_filtered (stream
, "...");
169 /* This function gets called to print an F77 array, we set up some
170 stuff and then immediately call f77_print_array_1(). */
173 f77_print_array (struct type
*type
, const gdb_byte
*valaddr
,
175 CORE_ADDR address
, struct ui_file
*stream
,
177 const struct value
*val
,
178 const struct value_print_options
*options
)
183 ndimensions
= calc_f77_array_dims (type
);
185 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
187 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
188 ndimensions
, MAX_FORTRAN_DIMS
);
190 f77_print_array_1 (1, ndimensions
, type
, valaddr
, embedded_offset
,
191 address
, stream
, recurse
, val
, options
, &elts
);
195 /* Decorations for Fortran. */
197 static const struct generic_val_print_decorations f_decorations
=
209 /* See val_print for a description of the various parameters of this
210 function; they are identical. */
213 f_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
)
218 struct gdbarch
*gdbarch
= get_type_arch (type
);
219 int printed_field
= 0; /* Number of fields printed. */
220 struct type
*elttype
;
223 const gdb_byte
*valaddr
=value_contents_for_printing (original_value
);
225 type
= check_typedef (type
);
226 switch (TYPE_CODE (type
))
228 case TYPE_CODE_STRING
:
229 f77_get_dynamic_length_of_aggregate (type
);
230 LA_PRINT_STRING (stream
, builtin_type (gdbarch
)->builtin_char
,
231 valaddr
+ embedded_offset
,
232 TYPE_LENGTH (type
), NULL
, 0, options
);
235 case TYPE_CODE_ARRAY
:
236 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_CHAR
)
238 fprintf_filtered (stream
, "(");
239 f77_print_array (type
, valaddr
, embedded_offset
,
240 address
, stream
, recurse
, original_value
, options
);
241 fprintf_filtered (stream
, ")");
245 struct type
*ch_type
= TYPE_TARGET_TYPE (type
);
247 f77_get_dynamic_length_of_aggregate (type
);
248 LA_PRINT_STRING (stream
, ch_type
,
249 valaddr
+ embedded_offset
,
250 TYPE_LENGTH (type
) / TYPE_LENGTH (ch_type
),
256 if (options
->format
&& options
->format
!= 's')
258 val_print_scalar_formatted (type
, embedded_offset
,
259 original_value
, options
, 0, stream
);
266 addr
= unpack_pointer (type
, valaddr
+ embedded_offset
);
267 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
269 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
271 /* Try to print what function it points to. */
272 print_function_pointer_address (options
, gdbarch
, addr
, stream
);
276 if (options
->symbol_print
)
277 want_space
= print_address_demangle (options
, gdbarch
, addr
,
279 else if (options
->addressprint
&& options
->format
!= 's')
281 fputs_filtered (paddress (gdbarch
, addr
), stream
);
285 /* For a pointer to char or unsigned char, also print the string
286 pointed to, unless pointer is null. */
287 if (TYPE_LENGTH (elttype
) == 1
288 && TYPE_CODE (elttype
) == TYPE_CODE_INT
289 && (options
->format
== 0 || options
->format
== 's')
293 fputs_filtered (" ", stream
);
294 val_print_string (TYPE_TARGET_TYPE (type
), NULL
, addr
, -1,
302 if (options
->format
|| options
->output_format
)
304 struct value_print_options opts
= *options
;
306 opts
.format
= (options
->format
? options
->format
307 : options
->output_format
);
308 val_print_scalar_formatted (type
, embedded_offset
,
309 original_value
, &opts
, 0, stream
);
312 val_print_scalar_formatted (type
, embedded_offset
,
313 original_value
, options
, 0, stream
);
316 case TYPE_CODE_STRUCT
:
317 case TYPE_CODE_UNION
:
318 /* Starting from the Fortran 90 standard, Fortran supports derived
320 fprintf_filtered (stream
, "( ");
321 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
323 struct value
*field
= value_field
324 ((struct value
*)original_value
, index
);
326 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, index
));
329 if (TYPE_CODE (field_type
) != TYPE_CODE_FUNC
)
331 const char *field_name
;
333 if (printed_field
> 0)
334 fputs_filtered (", ", stream
);
336 field_name
= TYPE_FIELD_NAME (type
, index
);
337 if (field_name
!= NULL
)
339 fputs_filtered (field_name
, stream
);
340 fputs_filtered (" = ", stream
);
343 val_print (value_type (field
),
344 value_embedded_offset (field
),
345 value_address (field
), stream
, recurse
+ 1,
346 field
, options
, current_language
);
351 fprintf_filtered (stream
, " )");
356 case TYPE_CODE_FLAGS
:
359 case TYPE_CODE_ERROR
:
360 case TYPE_CODE_RANGE
:
361 case TYPE_CODE_UNDEF
:
362 case TYPE_CODE_COMPLEX
:
366 generic_val_print (type
, embedded_offset
, address
,
367 stream
, recurse
, original_value
, options
,
374 info_common_command_for_block (const struct block
*block
, const char *comname
,
377 struct block_iterator iter
;
379 struct value_print_options opts
;
381 get_user_print_options (&opts
);
383 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
384 if (SYMBOL_DOMAIN (sym
) == COMMON_BLOCK_DOMAIN
)
386 const struct common_block
*common
= SYMBOL_VALUE_COMMON_BLOCK (sym
);
389 gdb_assert (SYMBOL_CLASS (sym
) == LOC_COMMON_BLOCK
);
391 if (comname
&& (!SYMBOL_LINKAGE_NAME (sym
)
392 || strcmp (comname
, SYMBOL_LINKAGE_NAME (sym
)) != 0))
396 putchar_filtered ('\n');
399 if (SYMBOL_PRINT_NAME (sym
))
400 printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
401 SYMBOL_PRINT_NAME (sym
));
403 printf_filtered (_("Contents of blank COMMON block:\n"));
405 for (index
= 0; index
< common
->n_entries
; index
++)
407 struct value
*val
= NULL
;
409 printf_filtered ("%s = ",
410 SYMBOL_PRINT_NAME (common
->contents
[index
]));
414 val
= value_of_variable (common
->contents
[index
], block
);
415 value_print (val
, gdb_stdout
, &opts
);
418 CATCH (except
, RETURN_MASK_ERROR
)
420 printf_filtered ("<error reading variable: %s>", except
.message
);
424 putchar_filtered ('\n');
429 /* This function is used to print out the values in a given COMMON
430 block. It will always use the most local common block of the
434 info_common_command (const char *comname
, int from_tty
)
436 struct frame_info
*fi
;
437 const struct block
*block
;
438 int values_printed
= 0;
440 /* We have been told to display the contents of F77 COMMON
441 block supposedly visible in this function. Let us
442 first make sure that it is visible and if so, let
443 us display its contents. */
445 fi
= get_selected_frame (_("No frame selected"));
447 /* The following is generally ripped off from stack.c's routine
448 print_frame_info(). */
450 block
= get_frame_block (fi
, 0);
453 printf_filtered (_("No symbol table info available.\n"));
459 info_common_command_for_block (block
, comname
, &values_printed
);
460 /* After handling the function's top-level block, stop. Don't
461 continue to its superblock, the block of per-file symbols. */
462 if (BLOCK_FUNCTION (block
))
464 block
= BLOCK_SUPERBLOCK (block
);
470 printf_filtered (_("No common block '%s'.\n"), comname
);
472 printf_filtered (_("No common blocks.\n"));
477 _initialize_f_valprint (void)
479 add_info ("common", info_common_command
,
480 _("Print out the values contained in a Fortran COMMON block."));