Automatic date update in version.in
[binutils-gdb/blckswan.git] / gdb / f-valprint.c
blob6a3f83c21941bc6cce4b7e0ce70e6967ac8bce5a
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/>. */
23 #include "defs.h"
24 #include "annotate.h"
25 #include "symtab.h"
26 #include "gdbtypes.h"
27 #include "expression.h"
28 #include "value.h"
29 #include "valprint.h"
30 #include "language.h"
31 #include "f-lang.h"
32 #include "frame.h"
33 #include "gdbcore.h"
34 #include "command.h"
35 #include "block.h"
36 #include "dictionary.h"
37 #include "cli/cli-style.h"
38 #include "gdbarch.h"
39 #include "f-array-walker.h"
41 static void f77_get_dynamic_length_of_aggregate (struct type *);
43 LONGEST
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 ();
52 LONGEST
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. */
70 static void
71 f77_get_dynamic_length_of_aggregate (struct type *type)
73 int upper_bound = -1;
74 int lower_bound = 1;
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. */
95 TYPE_LENGTH (type) =
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. */
108 int nelts;
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
116 public:
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,
123 CORE_ADDR address,
124 struct value *val,
125 struct ui_file *stream,
126 int recurse,
127 const struct value_print_options *options)
128 : m_elts (0),
129 m_val (val),
130 m_stream (stream),
131 m_recurse (recurse),
132 m_options (options),
133 m_dimension (0),
134 m_nrepeats (0),
135 m_stats (0)
136 { /* Nothing. */ }
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);
148 return cont;
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);
175 if (!last_p)
176 gdb_puts (" ", m_stream);
178 m_dimension--;
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
188 dimension. */
189 void process_dimension (gdb::function_view<void (struct type *,
190 int, bool)> walk_1,
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));
205 if (repeated)
206 m_nrepeats++;
207 if (!repeated || last_p)
209 LONGEST nrepeats = m_nrepeats;
211 m_nrepeats = 0;
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),
218 nullptr);
219 annotate_elt_rep_end ();
220 if (!repeated)
221 gdb_puts (" ", m_stream);
222 m_elts += nrepeats * m_stats[dim_indx + 1].nelts;
224 else
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);
233 if (!repeated)
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);
245 nrepeats++;
247 else if (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)));
271 if (repeated)
272 m_nrepeats++;
273 if (!repeated || last_p || m_elts + 1 == m_options->print_max)
275 LONGEST nrepeats = m_nrepeats;
276 bool printed = false;
278 if (nrepeats != 0)
280 m_nrepeats = 0;
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),
287 nullptr);
288 annotate_elt_rep_end ();
290 else
292 /* Extract the element value from the parent value. */
293 struct value *e_val
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,
299 index - i + 1,
300 m_stream, m_options);
301 common_val_print (e_val, m_stream, m_recurse, m_options,
302 current_language);
303 if (i > 1)
304 gdb_puts (", ", m_stream);
307 printed = true;
310 if (!repeated)
312 /* Extract the element value from the parent value. */
313 struct value *e_val
314 = value_from_component (m_val, elt_type, elt_off);
316 if (printed)
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,
321 current_language);
323 if (!last_p)
324 gdb_puts (", ", m_stream);
327 m_elt_type_prev = elt_type;
328 m_elt_off_prev = elt_off;
329 ++m_elts;
332 private:
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. */
337 bool
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))
362 return false;
364 return true;
366 else
367 return value_contents_eq (val, offset1, val, offset2,
368 TYPE_LENGTH (type));
371 /* The number of elements printed so far. */
372 int m_elts;
374 /* The value from which we are printing elements. */
375 struct value *m_val;
377 /* The stream we should print too. */
378 struct ui_file *m_stream;
380 /* The recursion counter, passed through when we print each element. */
381 int m_recurse;
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. */
388 LONGEST m_dimension;
390 /* The number of element repetitions in the current series. */
391 LONGEST m_nrepeats;
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. */
404 static void
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);
412 p.walk ();
416 /* Decorations for Fortran. */
418 static const struct generic_val_print_decorations f_decorations =
420 "(",
421 ",",
422 ")",
423 ".TRUE.",
424 ".FALSE.",
425 "void",
426 "{",
430 /* See f-lang.h. */
432 void
433 f_language::value_print_inner (struct value *val, struct ui_file *stream,
434 int recurse,
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;
441 CORE_ADDR addr;
442 int index;
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);
452 break;
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);
457 else
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,
464 options);
466 break;
468 case TYPE_CODE_PTR:
469 if (options->format && options->format != 's')
471 value_print_scalar_formatted (val, options, 0, stream);
472 break;
474 else
476 int want_space = 0;
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);
485 return;
488 if (options->symbol_print)
489 want_space = print_address_demangle (options, gdbarch, addr,
490 stream, demangle);
491 else if (options->addressprint && options->format != 's')
493 gdb_puts (paddress (gdbarch, addr), stream);
494 want_space = 1;
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')
502 && addr != 0)
504 if (want_space)
505 gdb_puts (" ", stream);
506 val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
507 stream, options);
509 return;
511 break;
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
517 types. */
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 ();
527 struct value *field;
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"),
538 field_name);
539 field = value_of_variable (sym.symbol, sym.block);
541 else
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 (),
550 stream);
551 gdb_puts (" = ", stream);
554 common_val_print (field, stream, recurse + 1,
555 options, current_language);
557 ++printed_field;
560 gdb_printf (stream, " )");
561 break;
563 case TYPE_CODE_BOOL:
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);
571 else
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. */
577 if (longval == 0)
578 gdb_puts (f_decorations.false_name, stream);
579 else
580 gdb_puts (f_decorations.true_name, stream);
582 break;
584 case TYPE_CODE_INT:
585 case TYPE_CODE_REF:
586 case TYPE_CODE_FUNC:
587 case TYPE_CODE_FLAGS:
588 case TYPE_CODE_FLT:
589 case TYPE_CODE_VOID:
590 case TYPE_CODE_ERROR:
591 case TYPE_CODE_RANGE:
592 case TYPE_CODE_UNDEF:
593 case TYPE_CODE_COMPLEX:
594 case TYPE_CODE_CHAR:
595 default:
596 generic_value_print (val, stream, recurse, options, &f_decorations);
597 break;
601 static void
602 info_common_command_for_block (const struct block *block, const char *comname,
603 int *any_printed)
605 struct block_iterator iter;
606 struct symbol *sym;
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 ();
615 size_t index;
617 gdb_assert (sym->aclass () == LOC_COMMON_BLOCK);
619 if (comname && (!sym->linkage_name ()
620 || strcmp (comname, sym->linkage_name ()) != 0))
621 continue;
623 if (*any_printed)
624 gdb_putc ('\n');
625 else
626 *any_printed = 1;
627 if (sym->print_name ())
628 gdb_printf (_("Contents of F77 COMMON block '%s':\n"),
629 sym->print_name ());
630 else
631 gdb_printf (_("Contents of blank COMMON block:\n"));
633 for (index = 0; index < common->n_entries; index++)
635 struct value *val = NULL;
637 gdb_printf ("%s = ",
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>",
650 except.what ());
653 gdb_putc ('\n');
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
660 given name. */
662 static void
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);
680 if (block == NULL)
682 gdb_printf (_("No symbol table info available.\n"));
683 return;
686 while (block)
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 ())
692 break;
693 block = block->superblock ();
696 if (!values_printed)
698 if (comname)
699 gdb_printf (_("No common block '%s'.\n"), comname);
700 else
701 gdb_printf (_("No common blocks.\n"));
705 void _initialize_f_valprint ();
706 void
707 _initialize_f_valprint ()
709 add_info ("common", info_common_command,
710 _("Print out the values contained in a Fortran COMMON block."));