1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993-2023 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
.is_constant ())
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
.is_constant ())
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 ()->code () == TYPE_CODE_ARRAY
86 || type
->target_type ()->code () == TYPE_CODE_STRING
)
87 f77_get_dynamic_length_of_aggregate (type
->target_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. */
94 type
->set_length ((upper_bound
- lower_bound
+ 1)
95 * check_typedef (type
->target_type ())->length ());
98 /* Per-dimension statistics. */
100 struct dimension_stats
102 /* The type of the index used to address elements in the dimension. */
103 struct type
*index_type
;
105 /* Total number of elements in the dimension, counted as we go. */
109 /* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array
110 walking template. This specialisation prints Fortran arrays. */
112 class fortran_array_printer_impl
: public fortran_array_walker_base_impl
115 /* Constructor. TYPE is the array type being printed, ADDRESS is the
116 address in target memory for the object of TYPE being printed. VAL is
117 the GDB value (of TYPE) being printed. STREAM is where to print to,
118 RECOURSE is passed through (and prevents infinite recursion), and
119 OPTIONS are the printing control options. */
120 explicit fortran_array_printer_impl (struct type
*type
,
123 struct ui_file
*stream
,
125 const struct value_print_options
*options
)
136 /* Called while iterating over the array bounds. When SHOULD_CONTINUE is
137 false then we must return false, as we have reached the end of the
138 array bounds for this dimension. However, we also return false if we
139 have printed too many elements (after printing '...'). In all other
140 cases, return true. */
141 bool continue_walking (bool should_continue
)
143 bool cont
= should_continue
&& (m_elts
< m_options
->print_max
);
144 if (!cont
&& should_continue
)
145 gdb_puts ("...", m_stream
);
149 /* Called when we start iterating over a dimension. If it's not the
150 inner most dimension then print an opening '(' character. */
151 void start_dimension (struct type
*index_type
, LONGEST nelts
, bool inner_p
)
153 size_t dim_indx
= m_dimension
++;
155 m_elt_type_prev
= nullptr;
156 if (m_stats
.size () < m_dimension
)
158 m_stats
.resize (m_dimension
);
159 m_stats
[dim_indx
].index_type
= index_type
;
160 m_stats
[dim_indx
].nelts
= nelts
;
163 gdb_puts ("(", m_stream
);
166 /* Called when we finish processing a batch of items within a dimension
167 of the array. Depending on whether this is the inner most dimension
168 or not we print different things, but this is all about adding
169 separators between elements, and dimensions of the array. */
170 void finish_dimension (bool inner_p
, bool last_p
)
172 gdb_puts (")", m_stream
);
174 gdb_puts (" ", m_stream
);
179 /* Called when processing dimensions of the array other than the
180 innermost one. WALK_1 is the walker to normally call, ELT_TYPE is
181 the type of the element being extracted, and ELT_OFF is the offset
182 of the element from the start of array being walked, INDEX_TYPE
183 and INDEX is the type and the value respectively of the element's
184 index in the dimension currently being walked and LAST_P is true
185 only when this is the last element that will be processed in this
187 void process_dimension (gdb::function_view
<void (struct type
*,
189 struct type
*elt_type
, LONGEST elt_off
,
190 LONGEST index
, bool last_p
)
192 size_t dim_indx
= m_dimension
- 1;
193 struct type
*elt_type_prev
= m_elt_type_prev
;
194 LONGEST elt_off_prev
= m_elt_off_prev
;
195 bool repeated
= (m_options
->repeat_count_threshold
< UINT_MAX
196 && elt_type_prev
!= nullptr
197 && (m_elts
+ ((m_nrepeats
+ 1)
198 * m_stats
[dim_indx
+ 1].nelts
)
199 <= m_options
->print_max
)
200 && dimension_contents_eq (m_val
, elt_type
,
201 elt_off_prev
, elt_off
));
205 if (!repeated
|| last_p
)
207 LONGEST nrepeats
= m_nrepeats
;
210 if (nrepeats
>= m_options
->repeat_count_threshold
)
212 annotate_elt_rep (nrepeats
+ 1);
213 gdb_printf (m_stream
, "%p[<repeats %s times>%p]",
214 metadata_style
.style ().ptr (),
215 plongest (nrepeats
+ 1),
217 annotate_elt_rep_end ();
219 gdb_puts (" ", m_stream
);
220 m_elts
+= nrepeats
* m_stats
[dim_indx
+ 1].nelts
;
223 for (LONGEST i
= nrepeats
; i
> 0; i
--)
225 maybe_print_array_index (m_stats
[dim_indx
].index_type
,
226 index
- nrepeats
+ repeated
,
227 m_stream
, m_options
);
228 walk_1 (elt_type_prev
, elt_off_prev
, repeated
&& i
== 1);
233 /* We need to specially handle the case of hitting `print_max'
234 exactly as recursing would cause lone `(...)' to be printed.
235 And we need to print `...' by hand if the skipped element
236 would be the last one processed, because the subsequent call
237 to `continue_walking' from our caller won't do that. */
238 if (m_elts
< m_options
->print_max
)
240 maybe_print_array_index (m_stats
[dim_indx
].index_type
, index
,
241 m_stream
, m_options
);
242 walk_1 (elt_type
, elt_off
, last_p
);
246 gdb_puts ("...", m_stream
);
250 m_elt_type_prev
= elt_type
;
251 m_elt_off_prev
= elt_off
;
254 /* Called to process an element of ELT_TYPE at offset ELT_OFF from the
255 start of the parent object, where INDEX is the value of the element's
256 index in the dimension currently being walked and LAST_P is true only
257 when this is the last element to be processed in this dimension. */
258 void process_element (struct type
*elt_type
, LONGEST elt_off
,
259 LONGEST index
, bool last_p
)
261 size_t dim_indx
= m_dimension
- 1;
262 struct type
*elt_type_prev
= m_elt_type_prev
;
263 LONGEST elt_off_prev
= m_elt_off_prev
;
264 bool repeated
= false;
266 if (m_options
->repeat_count_threshold
< UINT_MAX
267 && elt_type_prev
!= nullptr)
269 /* When printing large arrays this spot is called frequently, so clean
270 up temporary values asap to prevent allocating a large amount of
272 scoped_value_mark free_values
;
273 struct value
*e_val
= value_from_component (m_val
, elt_type
, elt_off
);
274 struct value
*e_prev
= value_from_component (m_val
, elt_type
,
276 repeated
= ((e_prev
->entirely_available ()
277 && e_val
->entirely_available ()
278 && e_prev
->contents_eq (e_val
))
279 || (e_prev
->entirely_unavailable ()
280 && e_val
->entirely_unavailable ()));
285 if (!repeated
|| last_p
|| m_elts
+ 1 == m_options
->print_max
)
287 LONGEST nrepeats
= m_nrepeats
;
288 bool printed
= false;
293 if (nrepeats
>= m_options
->repeat_count_threshold
)
295 annotate_elt_rep (nrepeats
+ 1);
296 gdb_printf (m_stream
, "%p[<repeats %s times>%p]",
297 metadata_style
.style ().ptr (),
298 plongest (nrepeats
+ 1),
300 annotate_elt_rep_end ();
304 /* Extract the element value from the parent value. */
306 = value_from_component (m_val
, elt_type
, elt_off_prev
);
308 for (LONGEST i
= nrepeats
; i
> 0; i
--)
310 maybe_print_array_index (m_stats
[dim_indx
].index_type
,
312 m_stream
, m_options
);
313 common_val_print (e_val
, m_stream
, m_recurse
, m_options
,
316 gdb_puts (", ", m_stream
);
324 /* Extract the element value from the parent value. */
326 = value_from_component (m_val
, elt_type
, elt_off
);
329 gdb_puts (", ", m_stream
);
330 maybe_print_array_index (m_stats
[dim_indx
].index_type
, index
,
331 m_stream
, m_options
);
332 common_val_print (e_val
, m_stream
, m_recurse
, m_options
,
336 gdb_puts (", ", m_stream
);
339 m_elt_type_prev
= elt_type
;
340 m_elt_off_prev
= elt_off
;
345 /* Called to compare two VAL elements of ELT_TYPE at offsets OFFSET1
346 and OFFSET2 each. Handle subarrays recursively, because they may
347 have been sliced and we do not want to compare any memory contents
348 present between the slices requested. */
350 dimension_contents_eq (struct value
*val
, struct type
*type
,
351 LONGEST offset1
, LONGEST offset2
)
353 if (type
->code () == TYPE_CODE_ARRAY
354 && type
->target_type ()->code () != TYPE_CODE_CHAR
)
356 /* Extract the range, and get lower and upper bounds. */
357 struct type
*range_type
= check_typedef (type
)->index_type ();
358 LONGEST lowerbound
, upperbound
;
359 if (!get_discrete_bounds (range_type
, &lowerbound
, &upperbound
))
360 error ("failed to get range bounds");
362 /* CALC is used to calculate the offsets for each element. */
363 fortran_array_offset_calculator
calc (type
);
365 struct type
*subarray_type
= check_typedef (type
->target_type ());
366 for (LONGEST i
= lowerbound
; i
< upperbound
+ 1; i
++)
368 /* Use the index and the stride to work out a new offset. */
369 LONGEST index_offset
= calc
.index_offset (i
);
371 if (!dimension_contents_eq (val
, subarray_type
,
372 offset1
+ index_offset
,
373 offset2
+ index_offset
))
380 struct value
*e_val1
= value_from_component (val
, type
, offset1
);
381 struct value
*e_val2
= value_from_component (val
, type
, offset2
);
383 return ((e_val1
->entirely_available ()
384 && e_val2
->entirely_available ()
385 && e_val1
->contents_eq (e_val2
))
386 || (e_val1
->entirely_unavailable ()
387 && e_val2
->entirely_unavailable ()));
391 /* The number of elements printed so far. */
394 /* The value from which we are printing elements. */
397 /* The stream we should print too. */
398 struct ui_file
*m_stream
;
400 /* The recursion counter, passed through when we print each element. */
403 /* The print control options. Gives us the maximum number of elements to
404 print, and is passed through to each element that we print. */
405 const struct value_print_options
*m_options
= nullptr;
407 /* The number of the current dimension being handled. */
410 /* The number of element repetitions in the current series. */
413 /* The type and offset from M_VAL of the element handled in the previous
414 iteration over the current dimension. */
415 struct type
*m_elt_type_prev
;
416 LONGEST m_elt_off_prev
;
418 /* Per-dimension stats. */
419 std::vector
<struct dimension_stats
> m_stats
;
422 /* This function gets called to print a Fortran array. */
425 fortran_print_array (struct type
*type
, CORE_ADDR address
,
426 struct ui_file
*stream
, int recurse
,
427 const struct value
*val
,
428 const struct value_print_options
*options
)
430 fortran_array_walker
<fortran_array_printer_impl
> p
431 (type
, address
, (struct value
*) val
, stream
, recurse
, options
);
436 /* Decorations for Fortran. */
438 static const struct generic_val_print_decorations f_decorations
=
453 f_language::value_print_inner (struct value
*val
, struct ui_file
*stream
,
455 const struct value_print_options
*options
) const
457 struct type
*type
= check_typedef (val
->type ());
458 struct gdbarch
*gdbarch
= type
->arch ();
459 int printed_field
= 0; /* Number of fields printed. */
460 struct type
*elttype
;
463 const gdb_byte
*valaddr
= val
->contents_for_printing ().data ();
464 const CORE_ADDR address
= val
->address ();
466 switch (type
->code ())
468 case TYPE_CODE_STRING
:
469 f77_get_dynamic_length_of_aggregate (type
);
470 printstr (stream
, builtin_type (gdbarch
)->builtin_char
, valaddr
,
471 type
->length (), NULL
, 0, options
);
474 case TYPE_CODE_ARRAY
:
475 if (type
->target_type ()->code () != TYPE_CODE_CHAR
)
476 fortran_print_array (type
, address
, stream
, recurse
, val
, options
);
479 struct type
*ch_type
= type
->target_type ();
481 f77_get_dynamic_length_of_aggregate (type
);
482 printstr (stream
, ch_type
, valaddr
,
483 type
->length () / ch_type
->length (), NULL
, 0,
489 if (options
->format
&& options
->format
!= 's')
491 value_print_scalar_formatted (val
, options
, 0, stream
);
498 addr
= unpack_pointer (type
, valaddr
);
499 elttype
= check_typedef (type
->target_type ());
501 if (elttype
->code () == TYPE_CODE_FUNC
)
503 /* Try to print what function it points to. */
504 print_function_pointer_address (options
, gdbarch
, addr
, stream
);
508 if (options
->symbol_print
)
509 want_space
= print_address_demangle (options
, gdbarch
, addr
,
511 else if (options
->addressprint
&& options
->format
!= 's')
513 gdb_puts (paddress (gdbarch
, addr
), stream
);
517 /* For a pointer to char or unsigned char, also print the string
518 pointed to, unless pointer is null. */
519 if (elttype
->length () == 1
520 && elttype
->code () == TYPE_CODE_INT
521 && (options
->format
== 0 || options
->format
== 's')
525 gdb_puts (" ", stream
);
526 val_print_string (type
->target_type (), NULL
, addr
, -1,
533 case TYPE_CODE_STRUCT
:
534 case TYPE_CODE_UNION
:
535 case TYPE_CODE_NAMELIST
:
536 /* Starting from the Fortran 90 standard, Fortran supports derived
538 gdb_printf (stream
, "( ");
539 for (index
= 0; index
< type
->num_fields (); index
++)
541 struct type
*field_type
542 = check_typedef (type
->field (index
).type ());
544 if (field_type
->code () != TYPE_CODE_FUNC
)
546 const char *field_name
= type
->field (index
).name ();
549 if (type
->code () == TYPE_CODE_NAMELIST
)
551 /* While printing namelist items, fetch the appropriate
552 value field before printing its value. */
553 struct block_symbol sym
554 = lookup_symbol (field_name
, get_selected_block (nullptr),
555 VAR_DOMAIN
, nullptr);
556 if (sym
.symbol
== nullptr)
557 error (_("failed to find symbol for name list component %s"),
559 field
= value_of_variable (sym
.symbol
, sym
.block
);
562 field
= value_field (val
, index
);
564 if (printed_field
> 0)
565 gdb_puts (", ", stream
);
567 if (field_name
!= NULL
)
569 fputs_styled (field_name
, variable_name_style
.style (),
571 gdb_puts (" = ", stream
);
574 common_val_print (field
, stream
, recurse
+ 1,
575 options
, current_language
);
580 gdb_printf (stream
, " )");
584 if (options
->format
|| options
->output_format
)
586 struct value_print_options opts
= *options
;
587 opts
.format
= (options
->format
? options
->format
588 : options
->output_format
);
589 value_print_scalar_formatted (val
, &opts
, 0, stream
);
593 LONGEST longval
= value_as_long (val
);
594 /* The Fortran standard doesn't specify how logical types are
595 represented. Different compilers use different non zero
596 values to represent logical true. */
598 gdb_puts (f_decorations
.false_name
, stream
);
600 gdb_puts (f_decorations
.true_name
, stream
);
607 case TYPE_CODE_FLAGS
:
610 case TYPE_CODE_ERROR
:
611 case TYPE_CODE_RANGE
:
612 case TYPE_CODE_UNDEF
:
613 case TYPE_CODE_COMPLEX
:
616 generic_value_print (val
, stream
, recurse
, options
, &f_decorations
);
622 info_common_command_for_block (const struct block
*block
, const char *comname
,
625 struct value_print_options opts
;
627 get_user_print_options (&opts
);
629 for (struct symbol
*sym
: block_iterator_range (block
))
630 if (sym
->domain () == COMMON_BLOCK_DOMAIN
)
632 const struct common_block
*common
= sym
->value_common_block ();
635 gdb_assert (sym
->aclass () == LOC_COMMON_BLOCK
);
637 if (comname
&& (!sym
->linkage_name ()
638 || strcmp (comname
, sym
->linkage_name ()) != 0))
645 if (sym
->print_name ())
646 gdb_printf (_("Contents of F77 COMMON block '%s':\n"),
649 gdb_printf (_("Contents of blank COMMON block:\n"));
651 for (index
= 0; index
< common
->n_entries
; index
++)
653 struct value
*val
= NULL
;
656 common
->contents
[index
]->print_name ());
660 val
= value_of_variable (common
->contents
[index
], block
);
661 value_print (val
, gdb_stdout
, &opts
);
664 catch (const gdb_exception_error
&except
)
666 fprintf_styled (gdb_stdout
, metadata_style
.style (),
667 "<error reading variable: %s>",
676 /* This function is used to print out the values in a given COMMON
677 block. It will always use the most local common block of the
681 info_common_command (const char *comname
, int from_tty
)
684 const struct block
*block
;
685 int values_printed
= 0;
687 /* We have been told to display the contents of F77 COMMON
688 block supposedly visible in this function. Let us
689 first make sure that it is visible and if so, let
690 us display its contents. */
692 fi
= get_selected_frame (_("No frame selected"));
694 /* The following is generally ripped off from stack.c's routine
695 print_frame_info(). */
697 block
= get_frame_block (fi
, 0);
700 gdb_printf (_("No symbol table info available.\n"));
706 info_common_command_for_block (block
, comname
, &values_printed
);
707 /* After handling the function's top-level block, stop. Don't
708 continue to its superblock, the block of per-file symbols. */
709 if (block
->function ())
711 block
= block
->superblock ();
717 gdb_printf (_("No common block '%s'.\n"), comname
);
719 gdb_printf (_("No common blocks.\n"));
723 void _initialize_f_valprint ();
725 _initialize_f_valprint ()
727 add_info ("common", info_common_command
,
728 _("Print out the values contained in a Fortran COMMON block."));