1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993-2022 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/>. */
27 #include "expression.h"
36 #include "dictionary.h"
37 #include "cli/cli-style.h"
39 #include "f-array-walker.h"
41 static void f77_get_dynamic_length_of_aggregate (struct type
*);
44 f77_get_lowerbound (struct type
*type
)
46 if (type
->bounds ()->low
.kind () != PROP_CONST
)
47 error (_("Lower bound may not be '*' in F77"));
49 return type
->bounds ()->low
.const_val ();
53 f77_get_upperbound (struct type
*type
)
55 if (type
->bounds ()->high
.kind () != PROP_CONST
)
57 /* We have an assumed size array on our hands. Assume that
58 upper_bound == lower_bound so that we show at least 1 element.
59 If the user wants to see more elements, let him manually ask for 'em
60 and we'll subscript the array and show him. */
62 return f77_get_lowerbound (type
);
65 return type
->bounds ()->high
.const_val ();
68 /* Obtain F77 adjustable array dimensions. */
71 f77_get_dynamic_length_of_aggregate (struct type
*type
)
76 /* Recursively go all the way down into a possibly multi-dimensional
77 F77 array and get the bounds. For simple arrays, this is pretty
78 easy but when the bounds are dynamic, we must be very careful
79 to add up all the lengths correctly. Not doing this right
80 will lead to horrendous-looking arrays in parameter lists.
82 This function also works for strings which behave very
83 similarly to arrays. */
85 if (TYPE_TARGET_TYPE (type
)->code () == TYPE_CODE_ARRAY
86 || TYPE_TARGET_TYPE (type
)->code () == TYPE_CODE_STRING
)
87 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
89 /* Recursion ends here, start setting up lengths. */
90 lower_bound
= f77_get_lowerbound (type
);
91 upper_bound
= f77_get_upperbound (type
);
93 /* Patch in a valid length value. */
96 (upper_bound
- lower_bound
+ 1)
97 * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
100 /* Per-dimension statistics. */
102 struct dimension_stats
104 /* The type of the index used to address elements in the dimension. */
105 struct type
*index_type
;
107 /* Total number of elements in the dimension, counted as we go. */
111 /* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array
112 walking template. This specialisation prints Fortran arrays. */
114 class fortran_array_printer_impl
: public fortran_array_walker_base_impl
117 /* Constructor. TYPE is the array type being printed, ADDRESS is the
118 address in target memory for the object of TYPE being printed. VAL is
119 the GDB value (of TYPE) being printed. STREAM is where to print to,
120 RECOURSE is passed through (and prevents infinite recursion), and
121 OPTIONS are the printing control options. */
122 explicit fortran_array_printer_impl (struct type
*type
,
125 struct ui_file
*stream
,
127 const struct value_print_options
*options
)
138 /* Called while iterating over the array bounds. When SHOULD_CONTINUE is
139 false then we must return false, as we have reached the end of the
140 array bounds for this dimension. However, we also return false if we
141 have printed too many elements (after printing '...'). In all other
142 cases, return true. */
143 bool continue_walking (bool should_continue
)
145 bool cont
= should_continue
&& (m_elts
< m_options
->print_max
);
146 if (!cont
&& should_continue
)
147 gdb_puts ("...", m_stream
);
151 /* Called when we start iterating over a dimension. If it's not the
152 inner most dimension then print an opening '(' character. */
153 void start_dimension (struct type
*index_type
, LONGEST nelts
, bool inner_p
)
155 size_t dim_indx
= m_dimension
++;
157 m_elt_type_prev
= nullptr;
158 if (m_stats
.size () < m_dimension
)
160 m_stats
.resize (m_dimension
);
161 m_stats
[dim_indx
].index_type
= index_type
;
162 m_stats
[dim_indx
].nelts
= nelts
;
165 gdb_puts ("(", m_stream
);
168 /* Called when we finish processing a batch of items within a dimension
169 of the array. Depending on whether this is the inner most dimension
170 or not we print different things, but this is all about adding
171 separators between elements, and dimensions of the array. */
172 void finish_dimension (bool inner_p
, bool last_p
)
174 gdb_puts (")", m_stream
);
176 gdb_puts (" ", m_stream
);
181 /* Called when processing dimensions of the array other than the
182 innermost one. WALK_1 is the walker to normally call, ELT_TYPE is
183 the type of the element being extracted, and ELT_OFF is the offset
184 of the element from the start of array being walked, INDEX_TYPE
185 and INDEX is the type and the value respectively of the element's
186 index in the dimension currently being walked and LAST_P is true
187 only when this is the last element that will be processed in this
189 void process_dimension (gdb::function_view
<void (struct type
*,
191 struct type
*elt_type
, LONGEST elt_off
,
192 LONGEST index
, bool last_p
)
194 size_t dim_indx
= m_dimension
- 1;
195 struct type
*elt_type_prev
= m_elt_type_prev
;
196 LONGEST elt_off_prev
= m_elt_off_prev
;
197 bool repeated
= (m_options
->repeat_count_threshold
< UINT_MAX
198 && elt_type_prev
!= nullptr
199 && (m_elts
+ ((m_nrepeats
+ 1)
200 * m_stats
[dim_indx
+ 1].nelts
)
201 <= m_options
->print_max
)
202 && dimension_contents_eq (m_val
, elt_type
,
203 elt_off_prev
, elt_off
));
207 if (!repeated
|| last_p
)
209 LONGEST nrepeats
= m_nrepeats
;
212 if (nrepeats
>= m_options
->repeat_count_threshold
)
214 annotate_elt_rep (nrepeats
+ 1);
215 gdb_printf (m_stream
, "%p[<repeats %s times>%p]",
216 metadata_style
.style ().ptr (),
217 plongest (nrepeats
+ 1),
219 annotate_elt_rep_end ();
221 gdb_puts (" ", m_stream
);
222 m_elts
+= nrepeats
* m_stats
[dim_indx
+ 1].nelts
;
225 for (LONGEST i
= nrepeats
; i
> 0; i
--)
227 maybe_print_array_index (m_stats
[dim_indx
].index_type
,
228 index
- nrepeats
+ repeated
,
229 m_stream
, m_options
);
230 walk_1 (elt_type_prev
, elt_off_prev
, repeated
&& i
== 1);
235 /* We need to specially handle the case of hitting `print_max'
236 exactly as recursing would cause lone `(...)' to be printed.
237 And we need to print `...' by hand if the skipped element
238 would be the last one processed, because the subsequent call
239 to `continue_walking' from our caller won't do that. */
240 if (m_elts
< m_options
->print_max
)
242 maybe_print_array_index (m_stats
[dim_indx
].index_type
, index
,
243 m_stream
, m_options
);
244 walk_1 (elt_type
, elt_off
, last_p
);
248 gdb_puts ("...", m_stream
);
252 m_elt_type_prev
= elt_type
;
253 m_elt_off_prev
= elt_off
;
256 /* Called to process an element of ELT_TYPE at offset ELT_OFF from the
257 start of the parent object, where INDEX is the value of the element's
258 index in the dimension currently being walked and LAST_P is true only
259 when this is the last element to be processed in this dimension. */
260 void process_element (struct type
*elt_type
, LONGEST elt_off
,
261 LONGEST index
, bool last_p
)
263 size_t dim_indx
= m_dimension
- 1;
264 struct type
*elt_type_prev
= m_elt_type_prev
;
265 LONGEST elt_off_prev
= m_elt_off_prev
;
266 bool repeated
= (m_options
->repeat_count_threshold
< UINT_MAX
267 && elt_type_prev
!= nullptr
268 && value_contents_eq (m_val
, elt_off_prev
, m_val
, elt_off
,
269 TYPE_LENGTH (elt_type
)));
273 if (!repeated
|| last_p
|| m_elts
+ 1 == m_options
->print_max
)
275 LONGEST nrepeats
= m_nrepeats
;
276 bool printed
= false;
281 if (nrepeats
>= m_options
->repeat_count_threshold
)
283 annotate_elt_rep (nrepeats
+ 1);
284 gdb_printf (m_stream
, "%p[<repeats %s times>%p]",
285 metadata_style
.style ().ptr (),
286 plongest (nrepeats
+ 1),
288 annotate_elt_rep_end ();
292 /* Extract the element value from the parent value. */
294 = value_from_component (m_val
, elt_type
, elt_off_prev
);
296 for (LONGEST i
= nrepeats
; i
> 0; i
--)
298 maybe_print_array_index (m_stats
[dim_indx
].index_type
,
300 m_stream
, m_options
);
301 common_val_print (e_val
, m_stream
, m_recurse
, m_options
,
304 gdb_puts (", ", m_stream
);
312 /* Extract the element value from the parent value. */
314 = value_from_component (m_val
, elt_type
, elt_off
);
317 gdb_puts (", ", m_stream
);
318 maybe_print_array_index (m_stats
[dim_indx
].index_type
, index
,
319 m_stream
, m_options
);
320 common_val_print (e_val
, m_stream
, m_recurse
, m_options
,
324 gdb_puts (", ", m_stream
);
327 m_elt_type_prev
= elt_type
;
328 m_elt_off_prev
= elt_off
;
333 /* Called to compare two VAL elements of ELT_TYPE at offsets OFFSET1
334 and OFFSET2 each. Handle subarrays recursively, because they may
335 have been sliced and we do not want to compare any memory contents
336 present between the slices requested. */
338 dimension_contents_eq (const struct value
*val
, struct type
*type
,
339 LONGEST offset1
, LONGEST offset2
)
341 if (type
->code () == TYPE_CODE_ARRAY
342 && TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_CHAR
)
344 /* Extract the range, and get lower and upper bounds. */
345 struct type
*range_type
= check_typedef (type
)->index_type ();
346 LONGEST lowerbound
, upperbound
;
347 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
348 error ("failed to get range bounds");
350 /* CALC is used to calculate the offsets for each element. */
351 fortran_array_offset_calculator
calc (type
);
353 struct type
*subarray_type
= check_typedef (TYPE_TARGET_TYPE (type
));
354 for (LONGEST i
= lowerbound
; i
< upperbound
+ 1; i
++)
356 /* Use the index and the stride to work out a new offset. */
357 LONGEST index_offset
= calc
.index_offset (i
);
359 if (!dimension_contents_eq (val
, subarray_type
,
360 offset1
+ index_offset
,
361 offset2
+ index_offset
))
367 return value_contents_eq (val
, offset1
, val
, offset2
,
371 /* The number of elements printed so far. */
374 /* The value from which we are printing elements. */
377 /* The stream we should print too. */
378 struct ui_file
*m_stream
;
380 /* The recursion counter, passed through when we print each element. */
383 /* The print control options. Gives us the maximum number of elements to
384 print, and is passed through to each element that we print. */
385 const struct value_print_options
*m_options
= nullptr;
387 /* The number of the current dimension being handled. */
390 /* The number of element repetitions in the current series. */
393 /* The type and offset from M_VAL of the element handled in the previous
394 iteration over the current dimension. */
395 struct type
*m_elt_type_prev
;
396 LONGEST m_elt_off_prev
;
398 /* Per-dimension stats. */
399 std::vector
<struct dimension_stats
> m_stats
;
402 /* This function gets called to print a Fortran array. */
405 fortran_print_array (struct type
*type
, CORE_ADDR address
,
406 struct ui_file
*stream
, int recurse
,
407 const struct value
*val
,
408 const struct value_print_options
*options
)
410 fortran_array_walker
<fortran_array_printer_impl
> p
411 (type
, address
, (struct value
*) val
, stream
, recurse
, options
);
416 /* Decorations for Fortran. */
418 static const struct generic_val_print_decorations f_decorations
=
433 f_language::value_print_inner (struct value
*val
, struct ui_file
*stream
,
435 const struct value_print_options
*options
) const
437 struct type
*type
= check_typedef (value_type (val
));
438 struct gdbarch
*gdbarch
= type
->arch ();
439 int printed_field
= 0; /* Number of fields printed. */
440 struct type
*elttype
;
443 const gdb_byte
*valaddr
= value_contents_for_printing (val
).data ();
444 const CORE_ADDR address
= value_address (val
);
446 switch (type
->code ())
448 case TYPE_CODE_STRING
:
449 f77_get_dynamic_length_of_aggregate (type
);
450 printstr (stream
, builtin_type (gdbarch
)->builtin_char
, valaddr
,
451 TYPE_LENGTH (type
), NULL
, 0, options
);
454 case TYPE_CODE_ARRAY
:
455 if (TYPE_TARGET_TYPE (type
)->code () != TYPE_CODE_CHAR
)
456 fortran_print_array (type
, address
, stream
, recurse
, val
, options
);
459 struct type
*ch_type
= TYPE_TARGET_TYPE (type
);
461 f77_get_dynamic_length_of_aggregate (type
);
462 printstr (stream
, ch_type
, valaddr
,
463 TYPE_LENGTH (type
) / TYPE_LENGTH (ch_type
), NULL
, 0,
469 if (options
->format
&& options
->format
!= 's')
471 value_print_scalar_formatted (val
, options
, 0, stream
);
478 addr
= unpack_pointer (type
, valaddr
);
479 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
481 if (elttype
->code () == TYPE_CODE_FUNC
)
483 /* Try to print what function it points to. */
484 print_function_pointer_address (options
, gdbarch
, addr
, stream
);
488 if (options
->symbol_print
)
489 want_space
= print_address_demangle (options
, gdbarch
, addr
,
491 else if (options
->addressprint
&& options
->format
!= 's')
493 gdb_puts (paddress (gdbarch
, addr
), stream
);
497 /* For a pointer to char or unsigned char, also print the string
498 pointed to, unless pointer is null. */
499 if (TYPE_LENGTH (elttype
) == 1
500 && elttype
->code () == TYPE_CODE_INT
501 && (options
->format
== 0 || options
->format
== 's')
505 gdb_puts (" ", stream
);
506 val_print_string (TYPE_TARGET_TYPE (type
), NULL
, addr
, -1,
513 case TYPE_CODE_STRUCT
:
514 case TYPE_CODE_UNION
:
515 case TYPE_CODE_NAMELIST
:
516 /* Starting from the Fortran 90 standard, Fortran supports derived
518 gdb_printf (stream
, "( ");
519 for (index
= 0; index
< type
->num_fields (); index
++)
521 struct type
*field_type
522 = check_typedef (type
->field (index
).type ());
524 if (field_type
->code () != TYPE_CODE_FUNC
)
526 const char *field_name
= type
->field (index
).name ();
529 if (type
->code () == TYPE_CODE_NAMELIST
)
531 /* While printing namelist items, fetch the appropriate
532 value field before printing its value. */
533 struct block_symbol sym
534 = lookup_symbol (field_name
, get_selected_block (nullptr),
535 VAR_DOMAIN
, nullptr);
536 if (sym
.symbol
== nullptr)
537 error (_("failed to find symbol for name list component %s"),
539 field
= value_of_variable (sym
.symbol
, sym
.block
);
542 field
= value_field (val
, index
);
544 if (printed_field
> 0)
545 gdb_puts (", ", stream
);
547 if (field_name
!= NULL
)
549 fputs_styled (field_name
, variable_name_style
.style (),
551 gdb_puts (" = ", stream
);
554 common_val_print (field
, stream
, recurse
+ 1,
555 options
, current_language
);
560 gdb_printf (stream
, " )");
564 if (options
->format
|| options
->output_format
)
566 struct value_print_options opts
= *options
;
567 opts
.format
= (options
->format
? options
->format
568 : options
->output_format
);
569 value_print_scalar_formatted (val
, &opts
, 0, stream
);
573 LONGEST longval
= value_as_long (val
);
574 /* The Fortran standard doesn't specify how logical types are
575 represented. Different compilers use different non zero
576 values to represent logical true. */
578 gdb_puts (f_decorations
.false_name
, stream
);
580 gdb_puts (f_decorations
.true_name
, stream
);
587 case TYPE_CODE_FLAGS
:
590 case TYPE_CODE_ERROR
:
591 case TYPE_CODE_RANGE
:
592 case TYPE_CODE_UNDEF
:
593 case TYPE_CODE_COMPLEX
:
596 generic_value_print (val
, stream
, recurse
, options
, &f_decorations
);
602 info_common_command_for_block (const struct block
*block
, const char *comname
,
605 struct block_iterator iter
;
607 struct value_print_options opts
;
609 get_user_print_options (&opts
);
611 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
612 if (sym
->domain () == COMMON_BLOCK_DOMAIN
)
614 const struct common_block
*common
= sym
->value_common_block ();
617 gdb_assert (sym
->aclass () == LOC_COMMON_BLOCK
);
619 if (comname
&& (!sym
->linkage_name ()
620 || strcmp (comname
, sym
->linkage_name ()) != 0))
627 if (sym
->print_name ())
628 gdb_printf (_("Contents of F77 COMMON block '%s':\n"),
631 gdb_printf (_("Contents of blank COMMON block:\n"));
633 for (index
= 0; index
< common
->n_entries
; index
++)
635 struct value
*val
= NULL
;
638 common
->contents
[index
]->print_name ());
642 val
= value_of_variable (common
->contents
[index
], block
);
643 value_print (val
, gdb_stdout
, &opts
);
646 catch (const gdb_exception_error
&except
)
648 fprintf_styled (gdb_stdout
, metadata_style
.style (),
649 "<error reading variable: %s>",
658 /* This function is used to print out the values in a given COMMON
659 block. It will always use the most local common block of the
663 info_common_command (const char *comname
, int from_tty
)
665 struct frame_info
*fi
;
666 const struct block
*block
;
667 int values_printed
= 0;
669 /* We have been told to display the contents of F77 COMMON
670 block supposedly visible in this function. Let us
671 first make sure that it is visible and if so, let
672 us display its contents. */
674 fi
= get_selected_frame (_("No frame selected"));
676 /* The following is generally ripped off from stack.c's routine
677 print_frame_info(). */
679 block
= get_frame_block (fi
, 0);
682 gdb_printf (_("No symbol table info available.\n"));
688 info_common_command_for_block (block
, comname
, &values_printed
);
689 /* After handling the function's top-level block, stop. Don't
690 continue to its superblock, the block of per-file symbols. */
691 if (block
->function ())
693 block
= block
->superblock ();
699 gdb_printf (_("No common block '%s'.\n"), comname
);
701 gdb_printf (_("No common blocks.\n"));
705 void _initialize_f_valprint ();
707 _initialize_f_valprint ()
709 add_info ("common", info_common_command
,
710 _("Print out the values contained in a Fortran COMMON block."));