1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993-2020 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"
36 #include "cli/cli-style.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 struct gdbarch
*gdbarch
= get_type_arch (type
);
125 size_t dim_size
= type_length_units (TYPE_TARGET_TYPE (type
));
126 int unit_size
= gdbarch_addressable_memory_unit_size (gdbarch
);
127 size_t byte_stride
= TYPE_ARRAY_BIT_STRIDE (type
) / (unit_size
* 8);
128 if (byte_stride
== 0)
129 byte_stride
= dim_size
;
133 (i
< upperbound
+ 1 && (*elts
) < options
->print_max
);
136 struct value
*subarray
= value_from_contents_and_address
137 (TYPE_TARGET_TYPE (type
), value_contents_for_printing_const (val
)
138 + offs
, addr
+ offs
);
140 fprintf_filtered (stream
, "( ");
141 f77_print_array_1 (nss
+ 1, ndimensions
, value_type (subarray
),
142 value_contents_for_printing (subarray
),
143 value_embedded_offset (subarray
),
144 value_address (subarray
),
145 stream
, recurse
, subarray
, options
, elts
);
147 fprintf_filtered (stream
, ") ");
149 if (*elts
>= options
->print_max
&& i
< upperbound
)
150 fprintf_filtered (stream
, "...");
154 for (i
= lowerbound
; i
< upperbound
+ 1 && (*elts
) < options
->print_max
;
157 struct value
*elt
= value_subscript ((struct value
*)val
, i
);
159 val_print (value_type (elt
),
160 value_embedded_offset (elt
),
161 value_address (elt
), stream
, recurse
,
162 elt
, options
, current_language
);
165 fprintf_filtered (stream
, ", ");
167 if ((*elts
== options
->print_max
- 1)
168 && (i
!= upperbound
))
169 fprintf_filtered (stream
, "...");
174 /* This function gets called to print an F77 array, we set up some
175 stuff and then immediately call f77_print_array_1(). */
178 f77_print_array (struct type
*type
, const gdb_byte
*valaddr
,
180 CORE_ADDR address
, struct ui_file
*stream
,
182 const struct value
*val
,
183 const struct value_print_options
*options
)
188 ndimensions
= calc_f77_array_dims (type
);
190 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
192 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
193 ndimensions
, MAX_FORTRAN_DIMS
);
195 f77_print_array_1 (1, ndimensions
, type
, valaddr
, embedded_offset
,
196 address
, stream
, recurse
, val
, options
, &elts
);
200 /* Decorations for Fortran. */
202 static const struct generic_val_print_decorations f_decorations
=
214 /* See val_print for a description of the various parameters of this
215 function; they are identical. */
218 f_val_print (struct type
*type
, int embedded_offset
,
219 CORE_ADDR address
, struct ui_file
*stream
, int recurse
,
220 struct value
*original_value
,
221 const struct value_print_options
*options
)
223 struct gdbarch
*gdbarch
= get_type_arch (type
);
224 int printed_field
= 0; /* Number of fields printed. */
225 struct type
*elttype
;
228 const gdb_byte
*valaddr
=value_contents_for_printing (original_value
);
230 type
= check_typedef (type
);
231 switch (TYPE_CODE (type
))
233 case TYPE_CODE_STRING
:
234 f77_get_dynamic_length_of_aggregate (type
);
235 LA_PRINT_STRING (stream
, builtin_type (gdbarch
)->builtin_char
,
236 valaddr
+ embedded_offset
,
237 TYPE_LENGTH (type
), NULL
, 0, options
);
240 case TYPE_CODE_ARRAY
:
241 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_CHAR
)
243 fprintf_filtered (stream
, "(");
244 f77_print_array (type
, valaddr
, embedded_offset
,
245 address
, stream
, recurse
, original_value
, options
);
246 fprintf_filtered (stream
, ")");
250 struct type
*ch_type
= TYPE_TARGET_TYPE (type
);
252 f77_get_dynamic_length_of_aggregate (type
);
253 LA_PRINT_STRING (stream
, ch_type
,
254 valaddr
+ embedded_offset
,
255 TYPE_LENGTH (type
) / TYPE_LENGTH (ch_type
),
261 if (options
->format
&& options
->format
!= 's')
263 val_print_scalar_formatted (type
, embedded_offset
,
264 original_value
, options
, 0, stream
);
271 addr
= unpack_pointer (type
, valaddr
+ embedded_offset
);
272 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
274 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
276 /* Try to print what function it points to. */
277 print_function_pointer_address (options
, gdbarch
, addr
, stream
);
281 if (options
->symbol_print
)
282 want_space
= print_address_demangle (options
, gdbarch
, addr
,
284 else if (options
->addressprint
&& options
->format
!= 's')
286 fputs_filtered (paddress (gdbarch
, addr
), stream
);
290 /* For a pointer to char or unsigned char, also print the string
291 pointed to, unless pointer is null. */
292 if (TYPE_LENGTH (elttype
) == 1
293 && TYPE_CODE (elttype
) == TYPE_CODE_INT
294 && (options
->format
== 0 || options
->format
== 's')
298 fputs_filtered (" ", stream
);
299 val_print_string (TYPE_TARGET_TYPE (type
), NULL
, addr
, -1,
307 if (options
->format
|| options
->output_format
)
309 struct value_print_options opts
= *options
;
311 opts
.format
= (options
->format
? options
->format
312 : options
->output_format
);
313 val_print_scalar_formatted (type
, embedded_offset
,
314 original_value
, &opts
, 0, stream
);
317 val_print_scalar_formatted (type
, embedded_offset
,
318 original_value
, options
, 0, stream
);
321 case TYPE_CODE_STRUCT
:
322 case TYPE_CODE_UNION
:
323 /* Starting from the Fortran 90 standard, Fortran supports derived
325 fprintf_filtered (stream
, "( ");
326 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
328 struct value
*field
= value_field
329 ((struct value
*)original_value
, index
);
331 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, index
));
334 if (TYPE_CODE (field_type
) != TYPE_CODE_FUNC
)
336 const char *field_name
;
338 if (printed_field
> 0)
339 fputs_filtered (", ", stream
);
341 field_name
= TYPE_FIELD_NAME (type
, index
);
342 if (field_name
!= NULL
)
344 fputs_styled (field_name
, variable_name_style
.style (),
346 fputs_filtered (" = ", stream
);
349 val_print (value_type (field
),
350 value_embedded_offset (field
),
351 value_address (field
), stream
, recurse
+ 1,
352 field
, options
, current_language
);
357 fprintf_filtered (stream
, " )");
361 if (options
->format
|| options
->output_format
)
363 struct value_print_options opts
= *options
;
364 opts
.format
= (options
->format
? options
->format
365 : options
->output_format
);
366 val_print_scalar_formatted (type
, embedded_offset
,
367 original_value
, &opts
, 0, stream
);
371 int unit_size
= gdbarch_addressable_memory_unit_size (gdbarch
);
373 = unpack_long (type
, valaddr
+ embedded_offset
* unit_size
);
374 /* The Fortran standard doesn't specify how logical types are
375 represented. Different compilers use different non zero
376 values to represent logical true. */
378 fputs_filtered (f_decorations
.false_name
, stream
);
380 fputs_filtered (f_decorations
.true_name
, stream
);
386 case TYPE_CODE_FLAGS
:
389 case TYPE_CODE_ERROR
:
390 case TYPE_CODE_RANGE
:
391 case TYPE_CODE_UNDEF
:
392 case TYPE_CODE_COMPLEX
:
395 generic_val_print (type
, embedded_offset
, address
,
396 stream
, recurse
, original_value
, options
,
403 info_common_command_for_block (const struct block
*block
, const char *comname
,
406 struct block_iterator iter
;
408 struct value_print_options opts
;
410 get_user_print_options (&opts
);
412 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
413 if (SYMBOL_DOMAIN (sym
) == COMMON_BLOCK_DOMAIN
)
415 const struct common_block
*common
= SYMBOL_VALUE_COMMON_BLOCK (sym
);
418 gdb_assert (SYMBOL_CLASS (sym
) == LOC_COMMON_BLOCK
);
420 if (comname
&& (!sym
->linkage_name ()
421 || strcmp (comname
, sym
->linkage_name ()) != 0))
425 putchar_filtered ('\n');
428 if (sym
->print_name ())
429 printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
432 printf_filtered (_("Contents of blank COMMON block:\n"));
434 for (index
= 0; index
< common
->n_entries
; index
++)
436 struct value
*val
= NULL
;
438 printf_filtered ("%s = ",
439 common
->contents
[index
]->print_name ());
443 val
= value_of_variable (common
->contents
[index
], block
);
444 value_print (val
, gdb_stdout
, &opts
);
447 catch (const gdb_exception_error
&except
)
449 fprintf_styled (gdb_stdout
, metadata_style
.style (),
450 "<error reading variable: %s>",
454 putchar_filtered ('\n');
459 /* This function is used to print out the values in a given COMMON
460 block. It will always use the most local common block of the
464 info_common_command (const char *comname
, int from_tty
)
466 struct frame_info
*fi
;
467 const struct block
*block
;
468 int values_printed
= 0;
470 /* We have been told to display the contents of F77 COMMON
471 block supposedly visible in this function. Let us
472 first make sure that it is visible and if so, let
473 us display its contents. */
475 fi
= get_selected_frame (_("No frame selected"));
477 /* The following is generally ripped off from stack.c's routine
478 print_frame_info(). */
480 block
= get_frame_block (fi
, 0);
483 printf_filtered (_("No symbol table info available.\n"));
489 info_common_command_for_block (block
, comname
, &values_printed
);
490 /* After handling the function's top-level block, stop. Don't
491 continue to its superblock, the block of per-file symbols. */
492 if (BLOCK_FUNCTION (block
))
494 block
= BLOCK_SUPERBLOCK (block
);
500 printf_filtered (_("No common block '%s'.\n"), comname
);
502 printf_filtered (_("No common blocks.\n"));
506 void _initialize_f_valprint ();
508 _initialize_f_valprint ()
510 add_info ("common", info_common_command
,
511 _("Print out the values contained in a Fortran COMMON block."));