15796c8dcSSimon Schubert /* Support for printing Fortran values for GDB, the GNU debugger.
25796c8dcSSimon Schubert
3*ef5ccd6cSJohn Marino Copyright (C) 1993-2013 Free Software Foundation, Inc.
45796c8dcSSimon Schubert
55796c8dcSSimon Schubert Contributed by Motorola. Adapted from the C definitions by Farooq Butt
65796c8dcSSimon Schubert (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
75796c8dcSSimon Schubert
85796c8dcSSimon Schubert This file is part of GDB.
95796c8dcSSimon Schubert
105796c8dcSSimon Schubert This program is free software; you can redistribute it and/or modify
115796c8dcSSimon Schubert it under the terms of the GNU General Public License as published by
125796c8dcSSimon Schubert the Free Software Foundation; either version 3 of the License, or
135796c8dcSSimon Schubert (at your option) any later version.
145796c8dcSSimon Schubert
155796c8dcSSimon Schubert This program is distributed in the hope that it will be useful,
165796c8dcSSimon Schubert but WITHOUT ANY WARRANTY; without even the implied warranty of
175796c8dcSSimon Schubert MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
185796c8dcSSimon Schubert GNU General Public License for more details.
195796c8dcSSimon Schubert
205796c8dcSSimon Schubert You should have received a copy of the GNU General Public License
215796c8dcSSimon Schubert along with this program. If not, see <http://www.gnu.org/licenses/>. */
225796c8dcSSimon Schubert
235796c8dcSSimon Schubert #include "defs.h"
245796c8dcSSimon Schubert #include "gdb_string.h"
255796c8dcSSimon Schubert #include "symtab.h"
265796c8dcSSimon Schubert #include "gdbtypes.h"
275796c8dcSSimon Schubert #include "expression.h"
285796c8dcSSimon Schubert #include "value.h"
295796c8dcSSimon Schubert #include "valprint.h"
305796c8dcSSimon Schubert #include "language.h"
315796c8dcSSimon Schubert #include "f-lang.h"
325796c8dcSSimon Schubert #include "frame.h"
335796c8dcSSimon Schubert #include "gdbcore.h"
345796c8dcSSimon Schubert #include "command.h"
355796c8dcSSimon Schubert #include "block.h"
36*ef5ccd6cSJohn Marino #include "dictionary.h"
37*ef5ccd6cSJohn Marino #include "gdb_assert.h"
38*ef5ccd6cSJohn Marino #include "exceptions.h"
395796c8dcSSimon Schubert
405796c8dcSSimon Schubert extern void _initialize_f_valprint (void);
415796c8dcSSimon Schubert static void info_common_command (char *, int);
425796c8dcSSimon Schubert static void f77_create_arrayprint_offset_tbl (struct type *,
435796c8dcSSimon Schubert struct ui_file *);
445796c8dcSSimon Schubert static void f77_get_dynamic_length_of_aggregate (struct type *);
455796c8dcSSimon Schubert
465796c8dcSSimon Schubert int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
475796c8dcSSimon Schubert
485796c8dcSSimon Schubert /* Array which holds offsets to be applied to get a row's elements
495796c8dcSSimon Schubert for a given array. Array also holds the size of each subarray. */
505796c8dcSSimon Schubert
515796c8dcSSimon Schubert /* The following macro gives us the size of the nth dimension, Where
525796c8dcSSimon Schubert n is 1 based. */
535796c8dcSSimon Schubert
545796c8dcSSimon Schubert #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
555796c8dcSSimon Schubert
565796c8dcSSimon Schubert /* The following gives us the offset for row n where n is 1-based. */
575796c8dcSSimon Schubert
585796c8dcSSimon Schubert #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
595796c8dcSSimon Schubert
605796c8dcSSimon Schubert int
f77_get_lowerbound(struct type * type)615796c8dcSSimon Schubert f77_get_lowerbound (struct type *type)
625796c8dcSSimon Schubert {
635796c8dcSSimon Schubert if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
645796c8dcSSimon Schubert error (_("Lower bound may not be '*' in F77"));
655796c8dcSSimon Schubert
665796c8dcSSimon Schubert return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
675796c8dcSSimon Schubert }
685796c8dcSSimon Schubert
695796c8dcSSimon Schubert int
f77_get_upperbound(struct type * type)705796c8dcSSimon Schubert f77_get_upperbound (struct type *type)
715796c8dcSSimon Schubert {
725796c8dcSSimon Schubert if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
735796c8dcSSimon Schubert {
745796c8dcSSimon Schubert /* We have an assumed size array on our hands. Assume that
755796c8dcSSimon Schubert upper_bound == lower_bound so that we show at least 1 element.
765796c8dcSSimon Schubert If the user wants to see more elements, let him manually ask for 'em
775796c8dcSSimon Schubert and we'll subscript the array and show him. */
785796c8dcSSimon Schubert
795796c8dcSSimon Schubert return f77_get_lowerbound (type);
805796c8dcSSimon Schubert }
815796c8dcSSimon Schubert
825796c8dcSSimon Schubert return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
835796c8dcSSimon Schubert }
845796c8dcSSimon Schubert
85c50c785cSJohn Marino /* Obtain F77 adjustable array dimensions. */
865796c8dcSSimon Schubert
875796c8dcSSimon Schubert static void
f77_get_dynamic_length_of_aggregate(struct type * type)885796c8dcSSimon Schubert f77_get_dynamic_length_of_aggregate (struct type *type)
895796c8dcSSimon Schubert {
905796c8dcSSimon Schubert int upper_bound = -1;
915796c8dcSSimon Schubert int lower_bound = 1;
925796c8dcSSimon Schubert
935796c8dcSSimon Schubert /* Recursively go all the way down into a possibly multi-dimensional
945796c8dcSSimon Schubert F77 array and get the bounds. For simple arrays, this is pretty
955796c8dcSSimon Schubert easy but when the bounds are dynamic, we must be very careful
965796c8dcSSimon Schubert to add up all the lengths correctly. Not doing this right
975796c8dcSSimon Schubert will lead to horrendous-looking arrays in parameter lists.
985796c8dcSSimon Schubert
995796c8dcSSimon Schubert This function also works for strings which behave very
1005796c8dcSSimon Schubert similarly to arrays. */
1015796c8dcSSimon Schubert
1025796c8dcSSimon Schubert if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
1035796c8dcSSimon Schubert || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
1045796c8dcSSimon Schubert f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
1055796c8dcSSimon Schubert
1065796c8dcSSimon Schubert /* Recursion ends here, start setting up lengths. */
1075796c8dcSSimon Schubert lower_bound = f77_get_lowerbound (type);
1085796c8dcSSimon Schubert upper_bound = f77_get_upperbound (type);
1095796c8dcSSimon Schubert
1105796c8dcSSimon Schubert /* Patch in a valid length value. */
1115796c8dcSSimon Schubert
1125796c8dcSSimon Schubert TYPE_LENGTH (type) =
113c50c785cSJohn Marino (upper_bound - lower_bound + 1)
114c50c785cSJohn Marino * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
1155796c8dcSSimon Schubert }
1165796c8dcSSimon Schubert
1175796c8dcSSimon Schubert /* Function that sets up the array offset,size table for the array
1185796c8dcSSimon Schubert type "type". */
1195796c8dcSSimon Schubert
1205796c8dcSSimon Schubert static void
f77_create_arrayprint_offset_tbl(struct type * type,struct ui_file * stream)1215796c8dcSSimon Schubert f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
1225796c8dcSSimon Schubert {
1235796c8dcSSimon Schubert struct type *tmp_type;
1245796c8dcSSimon Schubert int eltlen;
1255796c8dcSSimon Schubert int ndimen = 1;
126cf7f2e2dSJohn Marino int upper, lower;
1275796c8dcSSimon Schubert
1285796c8dcSSimon Schubert tmp_type = type;
1295796c8dcSSimon Schubert
130*ef5ccd6cSJohn Marino while (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)
1315796c8dcSSimon Schubert {
1325796c8dcSSimon Schubert upper = f77_get_upperbound (tmp_type);
1335796c8dcSSimon Schubert lower = f77_get_lowerbound (tmp_type);
1345796c8dcSSimon Schubert
1355796c8dcSSimon Schubert F77_DIM_SIZE (ndimen) = upper - lower + 1;
1365796c8dcSSimon Schubert
1375796c8dcSSimon Schubert tmp_type = TYPE_TARGET_TYPE (tmp_type);
1385796c8dcSSimon Schubert ndimen++;
1395796c8dcSSimon Schubert }
1405796c8dcSSimon Schubert
1415796c8dcSSimon Schubert /* Now we multiply eltlen by all the offsets, so that later we
1425796c8dcSSimon Schubert can print out array elements correctly. Up till now we
1435796c8dcSSimon Schubert know an offset to apply to get the item but we also
144c50c785cSJohn Marino have to know how much to add to get to the next item. */
1455796c8dcSSimon Schubert
1465796c8dcSSimon Schubert ndimen--;
1475796c8dcSSimon Schubert eltlen = TYPE_LENGTH (tmp_type);
1485796c8dcSSimon Schubert F77_DIM_OFFSET (ndimen) = eltlen;
1495796c8dcSSimon Schubert while (--ndimen > 0)
1505796c8dcSSimon Schubert {
1515796c8dcSSimon Schubert eltlen *= F77_DIM_SIZE (ndimen + 1);
1525796c8dcSSimon Schubert F77_DIM_OFFSET (ndimen) = eltlen;
1535796c8dcSSimon Schubert }
1545796c8dcSSimon Schubert }
1555796c8dcSSimon Schubert
1565796c8dcSSimon Schubert
1575796c8dcSSimon Schubert
1585796c8dcSSimon Schubert /* Actual function which prints out F77 arrays, Valaddr == address in
1595796c8dcSSimon Schubert the superior. Address == the address in the inferior. */
1605796c8dcSSimon Schubert
1615796c8dcSSimon Schubert static void
f77_print_array_1(int nss,int ndimensions,struct type * type,const gdb_byte * valaddr,int embedded_offset,CORE_ADDR address,struct ui_file * stream,int recurse,const struct value * val,const struct value_print_options * options,int * elts)1625796c8dcSSimon Schubert f77_print_array_1 (int nss, int ndimensions, struct type *type,
163c50c785cSJohn Marino const gdb_byte *valaddr,
164c50c785cSJohn Marino int embedded_offset, CORE_ADDR address,
1655796c8dcSSimon Schubert struct ui_file *stream, int recurse,
166cf7f2e2dSJohn Marino const struct value *val,
1675796c8dcSSimon Schubert const struct value_print_options *options,
1685796c8dcSSimon Schubert int *elts)
1695796c8dcSSimon Schubert {
1705796c8dcSSimon Schubert int i;
1715796c8dcSSimon Schubert
1725796c8dcSSimon Schubert if (nss != ndimensions)
1735796c8dcSSimon Schubert {
174c50c785cSJohn Marino for (i = 0;
175c50c785cSJohn Marino (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);
176c50c785cSJohn Marino i++)
1775796c8dcSSimon Schubert {
1785796c8dcSSimon Schubert fprintf_filtered (stream, "( ");
1795796c8dcSSimon Schubert f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
180c50c785cSJohn Marino valaddr,
181c50c785cSJohn Marino embedded_offset + i * F77_DIM_OFFSET (nss),
182c50c785cSJohn Marino address,
183cf7f2e2dSJohn Marino stream, recurse, val, options, elts);
1845796c8dcSSimon Schubert fprintf_filtered (stream, ") ");
1855796c8dcSSimon Schubert }
1865796c8dcSSimon Schubert if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
1875796c8dcSSimon Schubert fprintf_filtered (stream, "...");
1885796c8dcSSimon Schubert }
1895796c8dcSSimon Schubert else
1905796c8dcSSimon Schubert {
1915796c8dcSSimon Schubert for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
1925796c8dcSSimon Schubert i++, (*elts)++)
1935796c8dcSSimon Schubert {
1945796c8dcSSimon Schubert val_print (TYPE_TARGET_TYPE (type),
195c50c785cSJohn Marino valaddr,
196c50c785cSJohn Marino embedded_offset + i * F77_DIM_OFFSET (ndimensions),
197c50c785cSJohn Marino address, stream, recurse,
198c50c785cSJohn Marino val, options, current_language);
1995796c8dcSSimon Schubert
2005796c8dcSSimon Schubert if (i != (F77_DIM_SIZE (nss) - 1))
2015796c8dcSSimon Schubert fprintf_filtered (stream, ", ");
2025796c8dcSSimon Schubert
2035796c8dcSSimon Schubert if ((*elts == options->print_max - 1)
2045796c8dcSSimon Schubert && (i != (F77_DIM_SIZE (nss) - 1)))
2055796c8dcSSimon Schubert fprintf_filtered (stream, "...");
2065796c8dcSSimon Schubert }
2075796c8dcSSimon Schubert }
2085796c8dcSSimon Schubert }
2095796c8dcSSimon Schubert
2105796c8dcSSimon Schubert /* This function gets called to print an F77 array, we set up some
211c50c785cSJohn Marino stuff and then immediately call f77_print_array_1(). */
2125796c8dcSSimon Schubert
2135796c8dcSSimon Schubert static void
f77_print_array(struct type * type,const gdb_byte * valaddr,int embedded_offset,CORE_ADDR address,struct ui_file * stream,int recurse,const struct value * val,const struct value_print_options * options)2145796c8dcSSimon Schubert f77_print_array (struct type *type, const gdb_byte *valaddr,
215c50c785cSJohn Marino int embedded_offset,
2165796c8dcSSimon Schubert CORE_ADDR address, struct ui_file *stream,
217cf7f2e2dSJohn Marino int recurse,
218cf7f2e2dSJohn Marino const struct value *val,
219cf7f2e2dSJohn Marino const struct value_print_options *options)
2205796c8dcSSimon Schubert {
2215796c8dcSSimon Schubert int ndimensions;
2225796c8dcSSimon Schubert int elts = 0;
2235796c8dcSSimon Schubert
2245796c8dcSSimon Schubert ndimensions = calc_f77_array_dims (type);
2255796c8dcSSimon Schubert
2265796c8dcSSimon Schubert if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
227c50c785cSJohn Marino error (_("\
228c50c785cSJohn Marino Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
2295796c8dcSSimon Schubert ndimensions, MAX_FORTRAN_DIMS);
2305796c8dcSSimon Schubert
2315796c8dcSSimon Schubert /* Since F77 arrays are stored column-major, we set up an
2325796c8dcSSimon Schubert offset table to get at the various row's elements. The
2335796c8dcSSimon Schubert offset table contains entries for both offset and subarray size. */
2345796c8dcSSimon Schubert
2355796c8dcSSimon Schubert f77_create_arrayprint_offset_tbl (type, stream);
2365796c8dcSSimon Schubert
237c50c785cSJohn Marino f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
238c50c785cSJohn Marino address, stream, recurse, val, options, &elts);
2395796c8dcSSimon Schubert }
2405796c8dcSSimon Schubert
2415796c8dcSSimon Schubert
242*ef5ccd6cSJohn Marino /* Decorations for Fortran. */
2435796c8dcSSimon Schubert
244*ef5ccd6cSJohn Marino static const struct generic_val_print_decorations f_decorations =
245*ef5ccd6cSJohn Marino {
246*ef5ccd6cSJohn Marino "(",
247*ef5ccd6cSJohn Marino ",",
248*ef5ccd6cSJohn Marino ")",
249*ef5ccd6cSJohn Marino ".TRUE.",
250*ef5ccd6cSJohn Marino ".FALSE.",
251*ef5ccd6cSJohn Marino "VOID",
252*ef5ccd6cSJohn Marino };
253*ef5ccd6cSJohn Marino
254*ef5ccd6cSJohn Marino /* See val_print for a description of the various parameters of this
255*ef5ccd6cSJohn Marino function; they are identical. */
256*ef5ccd6cSJohn Marino
257*ef5ccd6cSJohn Marino void
f_val_print(struct type * type,const gdb_byte * valaddr,int embedded_offset,CORE_ADDR address,struct ui_file * stream,int recurse,const struct value * original_value,const struct value_print_options * options)2585796c8dcSSimon Schubert f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
2595796c8dcSSimon Schubert CORE_ADDR address, struct ui_file *stream, int recurse,
260cf7f2e2dSJohn Marino const struct value *original_value,
2615796c8dcSSimon Schubert const struct value_print_options *options)
2625796c8dcSSimon Schubert {
2635796c8dcSSimon Schubert struct gdbarch *gdbarch = get_type_arch (type);
2645796c8dcSSimon Schubert enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
265c50c785cSJohn Marino unsigned int i = 0; /* Number of characters printed. */
2665796c8dcSSimon Schubert struct type *elttype;
2675796c8dcSSimon Schubert CORE_ADDR addr;
2685796c8dcSSimon Schubert int index;
2695796c8dcSSimon Schubert
2705796c8dcSSimon Schubert CHECK_TYPEDEF (type);
2715796c8dcSSimon Schubert switch (TYPE_CODE (type))
2725796c8dcSSimon Schubert {
2735796c8dcSSimon Schubert case TYPE_CODE_STRING:
2745796c8dcSSimon Schubert f77_get_dynamic_length_of_aggregate (type);
2755796c8dcSSimon Schubert LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
276c50c785cSJohn Marino valaddr + embedded_offset,
277c50c785cSJohn Marino TYPE_LENGTH (type), NULL, 0, options);
2785796c8dcSSimon Schubert break;
2795796c8dcSSimon Schubert
2805796c8dcSSimon Schubert case TYPE_CODE_ARRAY:
281a45ae5f8SJohn Marino if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
282a45ae5f8SJohn Marino {
2835796c8dcSSimon Schubert fprintf_filtered (stream, "(");
284c50c785cSJohn Marino f77_print_array (type, valaddr, embedded_offset,
285c50c785cSJohn Marino address, stream, recurse, original_value, options);
2865796c8dcSSimon Schubert fprintf_filtered (stream, ")");
287a45ae5f8SJohn Marino }
288a45ae5f8SJohn Marino else
289a45ae5f8SJohn Marino {
290a45ae5f8SJohn Marino struct type *ch_type = TYPE_TARGET_TYPE (type);
291a45ae5f8SJohn Marino
292a45ae5f8SJohn Marino f77_get_dynamic_length_of_aggregate (type);
293a45ae5f8SJohn Marino LA_PRINT_STRING (stream, ch_type,
294a45ae5f8SJohn Marino valaddr + embedded_offset,
295a45ae5f8SJohn Marino TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
296a45ae5f8SJohn Marino NULL, 0, options);
297a45ae5f8SJohn Marino }
2985796c8dcSSimon Schubert break;
2995796c8dcSSimon Schubert
3005796c8dcSSimon Schubert case TYPE_CODE_PTR:
3015796c8dcSSimon Schubert if (options->format && options->format != 's')
3025796c8dcSSimon Schubert {
303c50c785cSJohn Marino val_print_scalar_formatted (type, valaddr, embedded_offset,
304c50c785cSJohn Marino original_value, options, 0, stream);
3055796c8dcSSimon Schubert break;
3065796c8dcSSimon Schubert }
3075796c8dcSSimon Schubert else
3085796c8dcSSimon Schubert {
309*ef5ccd6cSJohn Marino int want_space = 0;
310*ef5ccd6cSJohn Marino
311c50c785cSJohn Marino addr = unpack_pointer (type, valaddr + embedded_offset);
3125796c8dcSSimon Schubert elttype = check_typedef (TYPE_TARGET_TYPE (type));
3135796c8dcSSimon Schubert
3145796c8dcSSimon Schubert if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
3155796c8dcSSimon Schubert {
3165796c8dcSSimon Schubert /* Try to print what function it points to. */
317*ef5ccd6cSJohn Marino print_function_pointer_address (options, gdbarch, addr, stream);
318*ef5ccd6cSJohn Marino return;
3195796c8dcSSimon Schubert }
3205796c8dcSSimon Schubert
321*ef5ccd6cSJohn Marino if (options->symbol_print)
322*ef5ccd6cSJohn Marino want_space = print_address_demangle (options, gdbarch, addr,
323*ef5ccd6cSJohn Marino stream, demangle);
324*ef5ccd6cSJohn Marino else if (options->addressprint && options->format != 's')
325*ef5ccd6cSJohn Marino {
3265796c8dcSSimon Schubert fputs_filtered (paddress (gdbarch, addr), stream);
327*ef5ccd6cSJohn Marino want_space = 1;
328*ef5ccd6cSJohn Marino }
3295796c8dcSSimon Schubert
3305796c8dcSSimon Schubert /* For a pointer to char or unsigned char, also print the string
3315796c8dcSSimon Schubert pointed to, unless pointer is null. */
3325796c8dcSSimon Schubert if (TYPE_LENGTH (elttype) == 1
3335796c8dcSSimon Schubert && TYPE_CODE (elttype) == TYPE_CODE_INT
3345796c8dcSSimon Schubert && (options->format == 0 || options->format == 's')
3355796c8dcSSimon Schubert && addr != 0)
336*ef5ccd6cSJohn Marino {
337*ef5ccd6cSJohn Marino if (want_space)
338*ef5ccd6cSJohn Marino fputs_filtered (" ", stream);
339c50c785cSJohn Marino i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
340c50c785cSJohn Marino stream, options);
3415796c8dcSSimon Schubert }
342*ef5ccd6cSJohn Marino return;
3435796c8dcSSimon Schubert }
3445796c8dcSSimon Schubert break;
3455796c8dcSSimon Schubert
3465796c8dcSSimon Schubert case TYPE_CODE_INT:
3475796c8dcSSimon Schubert if (options->format || options->output_format)
3485796c8dcSSimon Schubert {
3495796c8dcSSimon Schubert struct value_print_options opts = *options;
350cf7f2e2dSJohn Marino
3515796c8dcSSimon Schubert opts.format = (options->format ? options->format
3525796c8dcSSimon Schubert : options->output_format);
353c50c785cSJohn Marino val_print_scalar_formatted (type, valaddr, embedded_offset,
354c50c785cSJohn Marino original_value, options, 0, stream);
3555796c8dcSSimon Schubert }
3565796c8dcSSimon Schubert else
3575796c8dcSSimon Schubert {
358c50c785cSJohn Marino val_print_type_code_int (type, valaddr + embedded_offset, stream);
3595796c8dcSSimon Schubert /* C and C++ has no single byte int type, char is used instead.
3605796c8dcSSimon Schubert Since we don't know whether the value is really intended to
3615796c8dcSSimon Schubert be used as an integer or a character, print the character
3625796c8dcSSimon Schubert equivalent as well. */
363*ef5ccd6cSJohn Marino if (TYPE_LENGTH (type) == 1)
3645796c8dcSSimon Schubert {
365c50c785cSJohn Marino LONGEST c;
366c50c785cSJohn Marino
3675796c8dcSSimon Schubert fputs_filtered (" ", stream);
368c50c785cSJohn Marino c = unpack_long (type, valaddr + embedded_offset);
369c50c785cSJohn Marino LA_PRINT_CHAR ((unsigned char) c, type, stream);
3705796c8dcSSimon Schubert }
3715796c8dcSSimon Schubert }
3725796c8dcSSimon Schubert break;
3735796c8dcSSimon Schubert
3745796c8dcSSimon Schubert case TYPE_CODE_STRUCT:
3755796c8dcSSimon Schubert case TYPE_CODE_UNION:
3765796c8dcSSimon Schubert /* Starting from the Fortran 90 standard, Fortran supports derived
3775796c8dcSSimon Schubert types. */
3785796c8dcSSimon Schubert fprintf_filtered (stream, "( ");
3795796c8dcSSimon Schubert for (index = 0; index < TYPE_NFIELDS (type); index++)
3805796c8dcSSimon Schubert {
3815796c8dcSSimon Schubert int offset = TYPE_FIELD_BITPOS (type, index) / 8;
382cf7f2e2dSJohn Marino
383c50c785cSJohn Marino val_print (TYPE_FIELD_TYPE (type, index), valaddr,
384c50c785cSJohn Marino embedded_offset + offset,
385c50c785cSJohn Marino address, stream, recurse + 1,
386cf7f2e2dSJohn Marino original_value, options, current_language);
3875796c8dcSSimon Schubert if (index != TYPE_NFIELDS (type) - 1)
3885796c8dcSSimon Schubert fputs_filtered (", ", stream);
3895796c8dcSSimon Schubert }
3905796c8dcSSimon Schubert fprintf_filtered (stream, " )");
3915796c8dcSSimon Schubert break;
3925796c8dcSSimon Schubert
393*ef5ccd6cSJohn Marino case TYPE_CODE_REF:
394*ef5ccd6cSJohn Marino case TYPE_CODE_FUNC:
395*ef5ccd6cSJohn Marino case TYPE_CODE_FLAGS:
396*ef5ccd6cSJohn Marino case TYPE_CODE_FLT:
397*ef5ccd6cSJohn Marino case TYPE_CODE_VOID:
398*ef5ccd6cSJohn Marino case TYPE_CODE_ERROR:
399*ef5ccd6cSJohn Marino case TYPE_CODE_RANGE:
400*ef5ccd6cSJohn Marino case TYPE_CODE_UNDEF:
401*ef5ccd6cSJohn Marino case TYPE_CODE_COMPLEX:
402*ef5ccd6cSJohn Marino case TYPE_CODE_BOOL:
403*ef5ccd6cSJohn Marino case TYPE_CODE_CHAR:
4045796c8dcSSimon Schubert default:
405*ef5ccd6cSJohn Marino generic_val_print (type, valaddr, embedded_offset, address,
406*ef5ccd6cSJohn Marino stream, recurse, original_value, options,
407*ef5ccd6cSJohn Marino &f_decorations);
408*ef5ccd6cSJohn Marino break;
4095796c8dcSSimon Schubert }
4105796c8dcSSimon Schubert gdb_flush (stream);
4115796c8dcSSimon Schubert }
4125796c8dcSSimon Schubert
4135796c8dcSSimon Schubert static void
info_common_command_for_block(struct block * block,const char * comname,int * any_printed)414*ef5ccd6cSJohn Marino info_common_command_for_block (struct block *block, const char *comname,
415*ef5ccd6cSJohn Marino int *any_printed)
4165796c8dcSSimon Schubert {
417*ef5ccd6cSJohn Marino struct block_iterator iter;
418*ef5ccd6cSJohn Marino struct symbol *sym;
419*ef5ccd6cSJohn Marino const char *name;
420*ef5ccd6cSJohn Marino struct value_print_options opts;
4215796c8dcSSimon Schubert
422*ef5ccd6cSJohn Marino get_user_print_options (&opts);
4235796c8dcSSimon Schubert
424*ef5ccd6cSJohn Marino ALL_BLOCK_SYMBOLS (block, iter, sym)
425*ef5ccd6cSJohn Marino if (SYMBOL_DOMAIN (sym) == COMMON_BLOCK_DOMAIN)
4265796c8dcSSimon Schubert {
427*ef5ccd6cSJohn Marino struct common_block *common = SYMBOL_VALUE_COMMON_BLOCK (sym);
428*ef5ccd6cSJohn Marino size_t index;
4295796c8dcSSimon Schubert
430*ef5ccd6cSJohn Marino gdb_assert (SYMBOL_CLASS (sym) == LOC_COMMON_BLOCK);
431*ef5ccd6cSJohn Marino
432*ef5ccd6cSJohn Marino if (comname && (!SYMBOL_LINKAGE_NAME (sym)
433*ef5ccd6cSJohn Marino || strcmp (comname, SYMBOL_LINKAGE_NAME (sym)) != 0))
434*ef5ccd6cSJohn Marino continue;
435*ef5ccd6cSJohn Marino
436*ef5ccd6cSJohn Marino if (*any_printed)
437*ef5ccd6cSJohn Marino putchar_filtered ('\n');
438*ef5ccd6cSJohn Marino else
439*ef5ccd6cSJohn Marino *any_printed = 1;
440*ef5ccd6cSJohn Marino if (SYMBOL_PRINT_NAME (sym))
441*ef5ccd6cSJohn Marino printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
442*ef5ccd6cSJohn Marino SYMBOL_PRINT_NAME (sym));
443*ef5ccd6cSJohn Marino else
444*ef5ccd6cSJohn Marino printf_filtered (_("Contents of blank COMMON block:\n"));
445*ef5ccd6cSJohn Marino
446*ef5ccd6cSJohn Marino for (index = 0; index < common->n_entries; index++)
447*ef5ccd6cSJohn Marino {
448*ef5ccd6cSJohn Marino struct value *val = NULL;
449*ef5ccd6cSJohn Marino volatile struct gdb_exception except;
450*ef5ccd6cSJohn Marino
451*ef5ccd6cSJohn Marino printf_filtered ("%s = ",
452*ef5ccd6cSJohn Marino SYMBOL_PRINT_NAME (common->contents[index]));
453*ef5ccd6cSJohn Marino
454*ef5ccd6cSJohn Marino TRY_CATCH (except, RETURN_MASK_ERROR)
455*ef5ccd6cSJohn Marino {
456*ef5ccd6cSJohn Marino val = value_of_variable (common->contents[index], block);
457*ef5ccd6cSJohn Marino value_print (val, gdb_stdout, &opts);
458*ef5ccd6cSJohn Marino }
459*ef5ccd6cSJohn Marino
460*ef5ccd6cSJohn Marino if (except.reason < 0)
461*ef5ccd6cSJohn Marino printf_filtered ("<error reading variable: %s>", except.message);
462*ef5ccd6cSJohn Marino putchar_filtered ('\n');
463*ef5ccd6cSJohn Marino }
4645796c8dcSSimon Schubert }
4655796c8dcSSimon Schubert }
4665796c8dcSSimon Schubert
4675796c8dcSSimon Schubert /* This function is used to print out the values in a given COMMON
4685796c8dcSSimon Schubert block. It will always use the most local common block of the
469c50c785cSJohn Marino given name. */
4705796c8dcSSimon Schubert
4715796c8dcSSimon Schubert static void
info_common_command(char * comname,int from_tty)4725796c8dcSSimon Schubert info_common_command (char *comname, int from_tty)
4735796c8dcSSimon Schubert {
4745796c8dcSSimon Schubert struct frame_info *fi;
475*ef5ccd6cSJohn Marino struct block *block;
476*ef5ccd6cSJohn Marino int values_printed = 0;
4775796c8dcSSimon Schubert
4785796c8dcSSimon Schubert /* We have been told to display the contents of F77 COMMON
4795796c8dcSSimon Schubert block supposedly visible in this function. Let us
4805796c8dcSSimon Schubert first make sure that it is visible and if so, let
481c50c785cSJohn Marino us display its contents. */
4825796c8dcSSimon Schubert
4835796c8dcSSimon Schubert fi = get_selected_frame (_("No frame selected"));
4845796c8dcSSimon Schubert
4855796c8dcSSimon Schubert /* The following is generally ripped off from stack.c's routine
486c50c785cSJohn Marino print_frame_info(). */
4875796c8dcSSimon Schubert
488*ef5ccd6cSJohn Marino block = get_frame_block (fi, 0);
489*ef5ccd6cSJohn Marino if (block == NULL)
4905796c8dcSSimon Schubert {
491*ef5ccd6cSJohn Marino printf_filtered (_("No symbol table info available.\n"));
4925796c8dcSSimon Schubert return;
4935796c8dcSSimon Schubert }
4945796c8dcSSimon Schubert
495*ef5ccd6cSJohn Marino while (block)
4965796c8dcSSimon Schubert {
497*ef5ccd6cSJohn Marino info_common_command_for_block (block, comname, &values_printed);
498*ef5ccd6cSJohn Marino /* After handling the function's top-level block, stop. Don't
499*ef5ccd6cSJohn Marino continue to its superblock, the block of per-file symbols. */
500*ef5ccd6cSJohn Marino if (BLOCK_FUNCTION (block))
501*ef5ccd6cSJohn Marino break;
502*ef5ccd6cSJohn Marino block = BLOCK_SUPERBLOCK (block);
503*ef5ccd6cSJohn Marino }
504*ef5ccd6cSJohn Marino
505*ef5ccd6cSJohn Marino if (!values_printed)
506*ef5ccd6cSJohn Marino {
507*ef5ccd6cSJohn Marino if (comname)
508*ef5ccd6cSJohn Marino printf_filtered (_("No common block '%s'.\n"), comname);
5095796c8dcSSimon Schubert else
510*ef5ccd6cSJohn Marino printf_filtered (_("No common blocks.\n"));
5115796c8dcSSimon Schubert }
5125796c8dcSSimon Schubert }
5135796c8dcSSimon Schubert
5145796c8dcSSimon Schubert void
_initialize_f_valprint(void)5155796c8dcSSimon Schubert _initialize_f_valprint (void)
5165796c8dcSSimon Schubert {
5175796c8dcSSimon Schubert add_info ("common", info_common_command,
5185796c8dcSSimon Schubert _("Print out the values contained in a Fortran COMMON block."));
5195796c8dcSSimon Schubert if (xdb_commands)
5205796c8dcSSimon Schubert add_com ("lc", class_info, info_common_command,
5215796c8dcSSimon Schubert _("Print out the values contained in a Fortran COMMON block."));
5225796c8dcSSimon Schubert }
523