1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993-1996, 1998-2000, 2003, 2005-2012 Free Software
6 Contributed by Motorola. Adapted from the C definitions by Farooq Butt
7 (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
9 This file is part of GDB.
11 This program is free software; you can redistribute it and/or modify
12 it under the terms of the GNU General Public License as published by
13 the Free Software Foundation; either version 3 of the License, or
14 (at your option) any later version.
16 This program is distributed in the hope that it will be useful,
17 but WITHOUT ANY WARRANTY; without even the implied warranty of
18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 GNU General Public License for more details.
21 You should have received a copy of the GNU General Public License
22 along with this program. If not, see <http://www.gnu.org/licenses/>. */
25 #include "gdb_string.h"
28 #include "expression.h"
37 #include "dictionary.h"
38 #include "gdb_assert.h"
39 #include "exceptions.h"
41 extern void _initialize_f_valprint (void);
42 static void info_common_command (char *, int);
43 static void f77_create_arrayprint_offset_tbl (struct type
*,
45 static void f77_get_dynamic_length_of_aggregate (struct type
*);
47 int f77_array_offset_tbl
[MAX_FORTRAN_DIMS
+ 1][2];
49 /* Array which holds offsets to be applied to get a row's elements
50 for a given array. Array also holds the size of each subarray. */
52 /* The following macro gives us the size of the nth dimension, Where
55 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
57 /* The following gives us the offset for row n where n is 1-based. */
59 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
62 f77_get_lowerbound (struct type
*type
)
64 if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type
))
65 error (_("Lower bound may not be '*' in F77"));
67 return TYPE_ARRAY_LOWER_BOUND_VALUE (type
);
71 f77_get_upperbound (struct type
*type
)
73 if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type
))
75 /* We have an assumed size array on our hands. Assume that
76 upper_bound == lower_bound so that we show at least 1 element.
77 If the user wants to see more elements, let him manually ask for 'em
78 and we'll subscript the array and show him. */
80 return f77_get_lowerbound (type
);
83 return TYPE_ARRAY_UPPER_BOUND_VALUE (type
);
86 /* Obtain F77 adjustable array dimensions. */
89 f77_get_dynamic_length_of_aggregate (struct type
*type
)
94 /* Recursively go all the way down into a possibly multi-dimensional
95 F77 array and get the bounds. For simple arrays, this is pretty
96 easy but when the bounds are dynamic, we must be very careful
97 to add up all the lengths correctly. Not doing this right
98 will lead to horrendous-looking arrays in parameter lists.
100 This function also works for strings which behave very
101 similarly to arrays. */
103 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
104 || TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
105 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
107 /* Recursion ends here, start setting up lengths. */
108 lower_bound
= f77_get_lowerbound (type
);
109 upper_bound
= f77_get_upperbound (type
);
111 /* Patch in a valid length value. */
114 (upper_bound
- lower_bound
+ 1)
115 * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
118 /* Function that sets up the array offset,size table for the array
122 f77_create_arrayprint_offset_tbl (struct type
*type
, struct ui_file
*stream
)
124 struct type
*tmp_type
;
131 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
133 upper
= f77_get_upperbound (tmp_type
);
134 lower
= f77_get_lowerbound (tmp_type
);
136 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
138 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
142 /* Now we multiply eltlen by all the offsets, so that later we
143 can print out array elements correctly. Up till now we
144 know an offset to apply to get the item but we also
145 have to know how much to add to get to the next item. */
148 eltlen
= TYPE_LENGTH (tmp_type
);
149 F77_DIM_OFFSET (ndimen
) = eltlen
;
152 eltlen
*= F77_DIM_SIZE (ndimen
+ 1);
153 F77_DIM_OFFSET (ndimen
) = eltlen
;
159 /* Actual function which prints out F77 arrays, Valaddr == address in
160 the superior. Address == the address in the inferior. */
163 f77_print_array_1 (int nss
, int ndimensions
, struct type
*type
,
164 const gdb_byte
*valaddr
,
165 int embedded_offset
, CORE_ADDR address
,
166 struct ui_file
*stream
, int recurse
,
167 const struct value
*val
,
168 const struct value_print_options
*options
,
173 if (nss
!= ndimensions
)
176 (i
< F77_DIM_SIZE (nss
) && (*elts
) < options
->print_max
);
179 fprintf_filtered (stream
, "( ");
180 f77_print_array_1 (nss
+ 1, ndimensions
, TYPE_TARGET_TYPE (type
),
182 embedded_offset
+ i
* F77_DIM_OFFSET (nss
),
184 stream
, recurse
, val
, options
, elts
);
185 fprintf_filtered (stream
, ") ");
187 if (*elts
>= options
->print_max
&& i
< F77_DIM_SIZE (nss
))
188 fprintf_filtered (stream
, "...");
192 for (i
= 0; i
< F77_DIM_SIZE (nss
) && (*elts
) < options
->print_max
;
195 val_print (TYPE_TARGET_TYPE (type
),
197 embedded_offset
+ i
* F77_DIM_OFFSET (ndimensions
),
198 address
, stream
, recurse
,
199 val
, options
, current_language
);
201 if (i
!= (F77_DIM_SIZE (nss
) - 1))
202 fprintf_filtered (stream
, ", ");
204 if ((*elts
== options
->print_max
- 1)
205 && (i
!= (F77_DIM_SIZE (nss
) - 1)))
206 fprintf_filtered (stream
, "...");
211 /* This function gets called to print an F77 array, we set up some
212 stuff and then immediately call f77_print_array_1(). */
215 f77_print_array (struct type
*type
, const gdb_byte
*valaddr
,
217 CORE_ADDR address
, struct ui_file
*stream
,
219 const struct value
*val
,
220 const struct value_print_options
*options
)
225 ndimensions
= calc_f77_array_dims (type
);
227 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
229 Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
230 ndimensions
, MAX_FORTRAN_DIMS
);
232 /* Since F77 arrays are stored column-major, we set up an
233 offset table to get at the various row's elements. The
234 offset table contains entries for both offset and subarray size. */
236 f77_create_arrayprint_offset_tbl (type
, stream
);
238 f77_print_array_1 (1, ndimensions
, type
, valaddr
, embedded_offset
,
239 address
, stream
, recurse
, val
, options
, &elts
);
243 /* Decorations for Fortran. */
245 static const struct generic_val_print_decorations f_decorations
=
255 /* See val_print for a description of the various parameters of this
256 function; they are identical. */
259 f_val_print (struct type
*type
, const gdb_byte
*valaddr
, int embedded_offset
,
260 CORE_ADDR address
, struct ui_file
*stream
, int recurse
,
261 const struct value
*original_value
,
262 const struct value_print_options
*options
)
264 struct gdbarch
*gdbarch
= get_type_arch (type
);
265 enum bfd_endian byte_order
= gdbarch_byte_order (gdbarch
);
266 unsigned int i
= 0; /* Number of characters printed. */
267 struct type
*elttype
;
271 CHECK_TYPEDEF (type
);
272 switch (TYPE_CODE (type
))
274 case TYPE_CODE_STRING
:
275 f77_get_dynamic_length_of_aggregate (type
);
276 LA_PRINT_STRING (stream
, builtin_type (gdbarch
)->builtin_char
,
277 valaddr
+ embedded_offset
,
278 TYPE_LENGTH (type
), NULL
, 0, options
);
281 case TYPE_CODE_ARRAY
:
282 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) != TYPE_CODE_CHAR
)
284 fprintf_filtered (stream
, "(");
285 f77_print_array (type
, valaddr
, embedded_offset
,
286 address
, stream
, recurse
, original_value
, options
);
287 fprintf_filtered (stream
, ")");
291 struct type
*ch_type
= TYPE_TARGET_TYPE (type
);
293 f77_get_dynamic_length_of_aggregate (type
);
294 LA_PRINT_STRING (stream
, ch_type
,
295 valaddr
+ embedded_offset
,
296 TYPE_LENGTH (type
) / TYPE_LENGTH (ch_type
),
302 if (options
->format
&& options
->format
!= 's')
304 val_print_scalar_formatted (type
, valaddr
, embedded_offset
,
305 original_value
, options
, 0, stream
);
312 addr
= unpack_pointer (type
, valaddr
+ embedded_offset
);
313 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
315 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
317 /* Try to print what function it points to. */
318 print_function_pointer_address (options
, gdbarch
, addr
, stream
);
322 if (options
->symbol_print
)
323 want_space
= print_address_demangle (options
, gdbarch
, addr
,
325 else if (options
->addressprint
&& options
->format
!= 's')
327 fputs_filtered (paddress (gdbarch
, addr
), stream
);
331 /* For a pointer to char or unsigned char, also print the string
332 pointed to, unless pointer is null. */
333 if (TYPE_LENGTH (elttype
) == 1
334 && TYPE_CODE (elttype
) == TYPE_CODE_INT
335 && (options
->format
== 0 || options
->format
== 's')
339 fputs_filtered (" ", stream
);
340 i
= val_print_string (TYPE_TARGET_TYPE (type
), NULL
, addr
, -1,
348 if (options
->format
|| options
->output_format
)
350 struct value_print_options opts
= *options
;
352 opts
.format
= (options
->format
? options
->format
353 : options
->output_format
);
354 val_print_scalar_formatted (type
, valaddr
, embedded_offset
,
355 original_value
, options
, 0, stream
);
359 val_print_type_code_int (type
, valaddr
+ embedded_offset
, stream
);
360 /* C and C++ has no single byte int type, char is used instead.
361 Since we don't know whether the value is really intended to
362 be used as an integer or a character, print the character
363 equivalent as well. */
364 if (TYPE_LENGTH (type
) == 1)
368 fputs_filtered (" ", stream
);
369 c
= unpack_long (type
, valaddr
+ embedded_offset
);
370 LA_PRINT_CHAR ((unsigned char) c
, type
, stream
);
375 case TYPE_CODE_STRUCT
:
376 case TYPE_CODE_UNION
:
377 /* Starting from the Fortran 90 standard, Fortran supports derived
379 fprintf_filtered (stream
, "( ");
380 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
382 int offset
= TYPE_FIELD_BITPOS (type
, index
) / 8;
384 val_print (TYPE_FIELD_TYPE (type
, index
), valaddr
,
385 embedded_offset
+ offset
,
386 address
, stream
, recurse
+ 1,
387 original_value
, options
, current_language
);
388 if (index
!= TYPE_NFIELDS (type
) - 1)
389 fputs_filtered (", ", stream
);
391 fprintf_filtered (stream
, " )");
396 case TYPE_CODE_FLAGS
:
399 case TYPE_CODE_ERROR
:
400 case TYPE_CODE_RANGE
:
401 case TYPE_CODE_UNDEF
:
402 case TYPE_CODE_COMPLEX
:
406 generic_val_print (type
, valaddr
, embedded_offset
, address
,
407 stream
, recurse
, original_value
, options
,
415 info_common_command_for_block (struct block
*block
, const char *comname
,
418 struct block_iterator iter
;
421 struct value_print_options opts
;
423 get_user_print_options (&opts
);
425 ALL_BLOCK_SYMBOLS (block
, iter
, sym
)
426 if (SYMBOL_DOMAIN (sym
) == COMMON_BLOCK_DOMAIN
)
428 struct common_block
*common
= SYMBOL_VALUE_COMMON_BLOCK (sym
);
431 gdb_assert (SYMBOL_CLASS (sym
) == LOC_STATIC
);
433 if (comname
&& (!SYMBOL_LINKAGE_NAME (sym
)
434 || strcmp (comname
, SYMBOL_LINKAGE_NAME (sym
)) != 0))
438 putchar_filtered ('\n');
441 if (SYMBOL_PRINT_NAME (sym
))
442 printf_filtered (_("Contents of F77 COMMON block '%s':\n"),
443 SYMBOL_PRINT_NAME (sym
));
445 printf_filtered (_("Contents of blank COMMON block:\n"));
447 for (index
= 0; index
< common
->n_entries
; index
++)
449 struct value
*val
= NULL
;
450 volatile struct gdb_exception except
;
452 printf_filtered ("%s = ",
453 SYMBOL_PRINT_NAME (common
->contents
[index
]));
455 TRY_CATCH (except
, RETURN_MASK_ERROR
)
457 val
= value_of_variable (common
->contents
[index
], block
);
458 value_print (val
, gdb_stdout
, &opts
);
461 if (except
.reason
< 0)
462 printf_filtered ("<error reading variable: %s>", except
.message
);
463 putchar_filtered ('\n');
468 /* This function is used to print out the values in a given COMMON
469 block. It will always use the most local common block of the
473 info_common_command (char *comname
, int from_tty
)
475 struct frame_info
*fi
;
477 int values_printed
= 0;
479 /* We have been told to display the contents of F77 COMMON
480 block supposedly visible in this function. Let us
481 first make sure that it is visible and if so, let
482 us display its contents. */
484 fi
= get_selected_frame (_("No frame selected"));
486 /* The following is generally ripped off from stack.c's routine
487 print_frame_info(). */
489 block
= get_frame_block (fi
, 0);
492 printf_filtered (_("No symbol table info available.\n"));
498 info_common_command_for_block (block
, comname
, &values_printed
);
499 /* After handling the function's top-level block, stop. Don't
500 continue to its superblock, the block of per-file symbols. */
501 if (BLOCK_FUNCTION (block
))
503 block
= BLOCK_SUPERBLOCK (block
);
509 printf_filtered (_("No common block '%s'.\n"), comname
);
511 printf_filtered (_("No common blocks.\n"));
516 _initialize_f_valprint (void)
518 add_info ("common", info_common_command
,
519 _("Print out the values contained in a Fortran COMMON block."));
521 add_com ("lc", class_info
, info_common_command
,
522 _("Print out the values contained in a Fortran COMMON block."));