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/>. */
26 #include "expression.h"
35 #include "dictionary.h"
36 #include "cli/cli-style.h"
38 static void f77_get_dynamic_length_of_aggregate (struct type
*);
40 int f77_array_offset_tbl
[MAX_FORTRAN_DIMS
+ 1][2];
42 /* Array which holds offsets to be applied to get a row's elements
43 for a given array. Array also holds the size of each subarray. */
46 f77_get_lowerbound (struct type
*type
)
48 if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type
))
49 error (_("Lower bound may not be '*' in F77"));
51 return TYPE_ARRAY_LOWER_BOUND_VALUE (type
);
55 f77_get_upperbound (struct type
*type
)
57 if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type
))
59 /* We have an assumed size array on our hands. Assume that
60 upper_bound == lower_bound so that we show at least 1 element.
61 If the user wants to see more elements, let him manually ask for 'em
62 and we'll subscript the array and show him. */
64 return f77_get_lowerbound (type
);
67 return TYPE_ARRAY_UPPER_BOUND_VALUE (type
);
70 /* Obtain F77 adjustable array dimensions. */
73 f77_get_dynamic_length_of_aggregate (struct type
*type
)
78 /* Recursively go all the way down into a possibly multi-dimensional
79 F77 array and get the bounds. For simple arrays, this is pretty
80 easy but when the bounds are dynamic, we must be very careful
81 to add up all the lengths correctly. Not doing this right
82 will lead to horrendous-looking arrays in parameter lists.
84 This function also works for strings which behave very
85 similarly to arrays. */
87 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
88 || TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
89 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
91 /* Recursion ends here, start setting up lengths. */
92 lower_bound
= f77_get_lowerbound (type
);
93 upper_bound
= f77_get_upperbound (type
);
95 /* Patch in a valid length value. */
98 (upper_bound
- lower_bound
+ 1)
99 * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
102 /* Actual function which prints out F77 arrays, Valaddr == address in
103 the superior. Address == the address in the inferior. */
106 f77_print_array_1 (int nss
, int ndimensions
, struct type
*type
,
107 const gdb_byte
*valaddr
,
108 int embedded_offset
, CORE_ADDR address
,
109 struct ui_file
*stream
, int recurse
,
110 const struct value
*val
,
111 const struct value_print_options
*options
,
114 struct type
*range_type
= TYPE_INDEX_TYPE (check_typedef (type
));
115 CORE_ADDR addr
= address
+ embedded_offset
;
116 LONGEST lowerbound
, upperbound
;
119 get_discrete_bounds (range_type
, &lowerbound
, &upperbound
);
121 if (nss
!= ndimensions
)
123 size_t dim_size
= TYPE_LENGTH (TYPE_TARGET_TYPE (type
));
127 (i
< upperbound
+ 1 && (*elts
) < options
->print_max
);
130 struct value
*subarray
= value_from_contents_and_address
131 (TYPE_TARGET_TYPE (type
), value_contents_for_printing_const (val
)
132 + offs
, addr
+ offs
);
134 fprintf_filtered (stream
, "( ");
135 f77_print_array_1 (nss
+ 1, ndimensions
, value_type (subarray
),
136 value_contents_for_printing (subarray
),
137 value_embedded_offset (subarray
),
138 value_address (subarray
),
139 stream
, recurse
, subarray
, options
, elts
);
141 fprintf_filtered (stream
, ") ");
143 if (*elts
>= options
->print_max
&& i
< upperbound
)
144 fprintf_filtered (stream
, "...");
148 for (i
= lowerbound
; i
< upperbound
+ 1 && (*elts
) < options
->print_max
;
151 struct value
*elt
= value_subscript ((struct value
*)val
, i
);
153 val_print (value_type (elt
),
154 value_embedded_offset (elt
),
155 value_address (elt
), stream
, recurse
,
156 elt
, options
, current_language
);
159 fprintf_filtered (stream
, ", ");
161 if ((*elts
== options
->print_max
- 1)
162 && (i
!= upperbound
))
163 fprintf_filtered (stream
, "...");
168 /* This function gets called to print an F77 array, we set up some
169 stuff and then immediately call f77_print_array_1(). */
172 f77_print_array (struct type
*type
, const gdb_byte
*valaddr
,
174 CORE_ADDR address
, struct ui_file
*stream
,
176 const struct value
*val
,
177 const struct value_print_options
*options
)
182 ndimensions
= calc_f77_array_dims (type
);
184 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
186 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
187 ndimensions
, MAX_FORTRAN_DIMS
);
189 f77_print_array_1 (1, ndimensions
, type
, valaddr
, embedded_offset
,
190 address
, stream
, recurse
, val
, options
, &elts
);
194 /* Decorations for Fortran. */
196 static const struct generic_val_print_decorations f_decorations
=
208 /* See val_print for a description of the various parameters of this
209 function; they are identical. */
212 f_val_print (struct type
*type
, int embedded_offset
,
213 CORE_ADDR address
, struct ui_file
*stream
, int recurse
,
214 struct value
*original_value
,
215 const struct value_print_options
*options
)
217 struct gdbarch
*gdbarch
= get_type_arch (type
);
218 int printed_field
= 0; /* Number of fields printed. */
219 struct type
*elttype
;
222 const gdb_byte
*valaddr
=value_contents_for_printing (original_value
);
224 type
= check_typedef (type
);
225 switch (TYPE_CODE (type
))
227 case TYPE_CODE_STRING
:
228 f77_get_dynamic_length_of_aggregate (type
);
229 LA_PRINT_STRING (stream
, builtin_type (gdbarch
)->builtin_char
,
230 valaddr
+ embedded_offset
,
231 TYPE_LENGTH (type
), NULL
, 0, options
);
234 case TYPE_CODE_ARRAY
:
235 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_CHAR
)
237 fprintf_filtered (stream
, "(");
238 f77_print_array (type
, valaddr
, embedded_offset
,
239 address
, stream
, recurse
, original_value
, options
);
240 fprintf_filtered (stream
, ")");
244 struct type
*ch_type
= TYPE_TARGET_TYPE (type
);
246 f77_get_dynamic_length_of_aggregate (type
);
247 LA_PRINT_STRING (stream
, ch_type
,
248 valaddr
+ embedded_offset
,
249 TYPE_LENGTH (type
) / TYPE_LENGTH (ch_type
),
255 if (options
->format
&& options
->format
!= 's')
257 val_print_scalar_formatted (type
, embedded_offset
,
258 original_value
, options
, 0, stream
);
265 addr
= unpack_pointer (type
, valaddr
+ embedded_offset
);
266 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
268 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
270 /* Try to print what function it points to. */
271 print_function_pointer_address (options
, gdbarch
, addr
, stream
);
275 if (options
->symbol_print
)
276 want_space
= print_address_demangle (options
, gdbarch
, addr
,
278 else if (options
->addressprint
&& options
->format
!= 's')
280 fputs_filtered (paddress (gdbarch
, addr
), stream
);
284 /* For a pointer to char or unsigned char, also print the string
285 pointed to, unless pointer is null. */
286 if (TYPE_LENGTH (elttype
) == 1
287 && TYPE_CODE (elttype
) == TYPE_CODE_INT
288 && (options
->format
== 0 || options
->format
== 's')
292 fputs_filtered (" ", stream
);
293 val_print_string (TYPE_TARGET_TYPE (type
), NULL
, addr
, -1,
301 if (options
->format
|| options
->output_format
)
303 struct value_print_options opts
= *options
;
305 opts
.format
= (options
->format
? options
->format
306 : options
->output_format
);
307 val_print_scalar_formatted (type
, embedded_offset
,
308 original_value
, &opts
, 0, stream
);
311 val_print_scalar_formatted (type
, embedded_offset
,
312 original_value
, options
, 0, stream
);
315 case TYPE_CODE_STRUCT
:
316 case TYPE_CODE_UNION
:
317 /* Starting from the Fortran 90 standard, Fortran supports derived
319 fprintf_filtered (stream
, "( ");
320 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
322 struct value
*field
= value_field
323 ((struct value
*)original_value
, index
);
325 struct type
*field_type
= check_typedef (TYPE_FIELD_TYPE (type
, index
));
328 if (TYPE_CODE (field_type
) != TYPE_CODE_FUNC
)
330 const char *field_name
;
332 if (printed_field
> 0)
333 fputs_filtered (", ", stream
);
335 field_name
= TYPE_FIELD_NAME (type
, index
);
336 if (field_name
!= NULL
)
338 fputs_filtered (field_name
, stream
);
339 fputs_filtered (" = ", stream
);
342 val_print (value_type (field
),
343 value_embedded_offset (field
),
344 value_address (field
), stream
, recurse
+ 1,
345 field
, options
, current_language
);
350 fprintf_filtered (stream
, " )");
355 case TYPE_CODE_FLAGS
:
358 case TYPE_CODE_ERROR
:
359 case TYPE_CODE_RANGE
:
360 case TYPE_CODE_UNDEF
:
361 case TYPE_CODE_COMPLEX
:
365 generic_val_print (type
, embedded_offset
, address
,
366 stream
, recurse
, original_value
, options
,
373 info_common_command_for_block (const struct block
*block
, const char *comname
,
376 struct block_iterator iter
;
378 struct value_print_options opts
;
380 get_user_print_options (&opts
);
382 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
383 if (SYMBOL_DOMAIN (sym
) == COMMON_BLOCK_DOMAIN
)
385 const struct common_block
*common
= SYMBOL_VALUE_COMMON_BLOCK (sym
);
388 gdb_assert (SYMBOL_CLASS (sym
) == LOC_COMMON_BLOCK
);
390 if (comname
&& (!SYMBOL_LINKAGE_NAME (sym
)
391 || strcmp (comname
, SYMBOL_LINKAGE_NAME (sym
)) != 0))
395 putchar_filtered ('\n');
398 if (SYMBOL_PRINT_NAME (sym
))
399 printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
400 SYMBOL_PRINT_NAME (sym
));
402 printf_filtered (_("Contents of blank COMMON block:\n"));
404 for (index
= 0; index
< common
->n_entries
; index
++)
406 struct value
*val
= NULL
;
408 printf_filtered ("%s = ",
409 SYMBOL_PRINT_NAME (common
->contents
[index
]));
413 val
= value_of_variable (common
->contents
[index
], block
);
414 value_print (val
, gdb_stdout
, &opts
);
417 catch (const gdb_exception_error
&except
)
419 fprintf_styled (gdb_stdout
, metadata_style
.style (),
420 "<error reading variable: %s>",
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."));