1 /* Support for printing Fortran values for GDB, the GNU debugger.
3 Copyright (C) 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2003, 2005, 2006,
4 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
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"
39 static int there_is_a_visible_common_named (char *);
42 extern void _initialize_f_valprint (void);
43 static void info_common_command (char *, int);
44 static void list_all_visible_commons (char *);
45 static void f77_create_arrayprint_offset_tbl (struct type
*,
47 static void f77_get_dynamic_length_of_aggregate (struct type
*);
49 int f77_array_offset_tbl
[MAX_FORTRAN_DIMS
+ 1][2];
51 /* Array which holds offsets to be applied to get a row's elements
52 for a given array. Array also holds the size of each subarray. */
54 /* The following macro gives us the size of the nth dimension, Where
57 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
59 /* The following gives us the offset for row n where n is 1-based. */
61 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
64 f77_get_lowerbound (struct type
*type
)
66 if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type
))
67 error (_("Lower bound may not be '*' in F77"));
69 return TYPE_ARRAY_LOWER_BOUND_VALUE (type
);
73 f77_get_upperbound (struct type
*type
)
75 if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type
))
77 /* We have an assumed size array on our hands. Assume that
78 upper_bound == lower_bound so that we show at least 1 element.
79 If the user wants to see more elements, let him manually ask for 'em
80 and we'll subscript the array and show him. */
82 return f77_get_lowerbound (type
);
85 return TYPE_ARRAY_UPPER_BOUND_VALUE (type
);
88 /* Obtain F77 adjustable array dimensions */
91 f77_get_dynamic_length_of_aggregate (struct type
*type
)
96 /* Recursively go all the way down into a possibly multi-dimensional
97 F77 array and get the bounds. For simple arrays, this is pretty
98 easy but when the bounds are dynamic, we must be very careful
99 to add up all the lengths correctly. Not doing this right
100 will lead to horrendous-looking arrays in parameter lists.
102 This function also works for strings which behave very
103 similarly to arrays. */
105 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
106 || TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
107 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
109 /* Recursion ends here, start setting up lengths. */
110 lower_bound
= f77_get_lowerbound (type
);
111 upper_bound
= f77_get_upperbound (type
);
113 /* Patch in a valid length value. */
116 (upper_bound
- lower_bound
+ 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
119 /* Function that sets up the array offset,size table for the array
123 f77_create_arrayprint_offset_tbl (struct type
*type
, struct ui_file
*stream
)
125 struct type
*tmp_type
;
132 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
134 upper
= f77_get_upperbound (tmp_type
);
135 lower
= f77_get_lowerbound (tmp_type
);
137 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
139 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
143 /* Now we multiply eltlen by all the offsets, so that later we
144 can print out array elements correctly. Up till now we
145 know an offset to apply to get the item but we also
146 have to know how much to add to get to the next item */
149 eltlen
= TYPE_LENGTH (tmp_type
);
150 F77_DIM_OFFSET (ndimen
) = eltlen
;
153 eltlen
*= F77_DIM_SIZE (ndimen
+ 1);
154 F77_DIM_OFFSET (ndimen
) = eltlen
;
160 /* Actual function which prints out F77 arrays, Valaddr == address in
161 the superior. Address == the address in the inferior. */
164 f77_print_array_1 (int nss
, int ndimensions
, struct type
*type
,
165 const gdb_byte
*valaddr
, 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
)
175 for (i
= 0; (i
< F77_DIM_SIZE (nss
) && (*elts
) < options
->print_max
); i
++)
177 fprintf_filtered (stream
, "( ");
178 f77_print_array_1 (nss
+ 1, ndimensions
, TYPE_TARGET_TYPE (type
),
179 valaddr
+ i
* F77_DIM_OFFSET (nss
),
180 address
+ i
* F77_DIM_OFFSET (nss
),
181 stream
, recurse
, val
, options
, elts
);
182 fprintf_filtered (stream
, ") ");
184 if (*elts
>= options
->print_max
&& i
< F77_DIM_SIZE (nss
))
185 fprintf_filtered (stream
, "...");
189 for (i
= 0; i
< F77_DIM_SIZE (nss
) && (*elts
) < options
->print_max
;
192 val_print (TYPE_TARGET_TYPE (type
),
193 valaddr
+ i
* F77_DIM_OFFSET (ndimensions
),
195 address
+ i
* F77_DIM_OFFSET (ndimensions
),
196 stream
, recurse
, val
, options
, current_language
);
198 if (i
!= (F77_DIM_SIZE (nss
) - 1))
199 fprintf_filtered (stream
, ", ");
201 if ((*elts
== options
->print_max
- 1)
202 && (i
!= (F77_DIM_SIZE (nss
) - 1)))
203 fprintf_filtered (stream
, "...");
208 /* This function gets called to print an F77 array, we set up some
209 stuff and then immediately call f77_print_array_1() */
212 f77_print_array (struct type
*type
, const gdb_byte
*valaddr
,
213 CORE_ADDR address
, struct ui_file
*stream
,
215 const struct value
*val
,
216 const struct value_print_options
*options
)
221 ndimensions
= calc_f77_array_dims (type
);
223 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
224 error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
225 ndimensions
, MAX_FORTRAN_DIMS
);
227 /* Since F77 arrays are stored column-major, we set up an
228 offset table to get at the various row's elements. The
229 offset table contains entries for both offset and subarray size. */
231 f77_create_arrayprint_offset_tbl (type
, stream
);
233 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
,
234 recurse
, val
, options
, &elts
);
238 /* Print data of type TYPE located at VALADDR (within GDB), which came from
239 the inferior at address ADDRESS, onto stdio stream STREAM according to
240 OPTIONS. The data at VALADDR is in target byte order.
242 If the data are a string pointer, returns the number of string characters
246 f_val_print (struct type
*type
, const gdb_byte
*valaddr
, int embedded_offset
,
247 CORE_ADDR address
, struct ui_file
*stream
, int recurse
,
248 const struct value
*original_value
,
249 const struct value_print_options
*options
)
251 struct gdbarch
*gdbarch
= get_type_arch (type
);
252 enum bfd_endian byte_order
= gdbarch_byte_order (gdbarch
);
253 unsigned int i
= 0; /* Number of characters printed */
254 struct type
*elttype
;
259 CHECK_TYPEDEF (type
);
260 switch (TYPE_CODE (type
))
262 case TYPE_CODE_STRING
:
263 f77_get_dynamic_length_of_aggregate (type
);
264 LA_PRINT_STRING (stream
, builtin_type (gdbarch
)->builtin_char
,
265 valaddr
, TYPE_LENGTH (type
), NULL
, 0, options
);
268 case TYPE_CODE_ARRAY
:
269 fprintf_filtered (stream
, "(");
270 f77_print_array (type
, valaddr
, address
, stream
, recurse
, original_value
, options
);
271 fprintf_filtered (stream
, ")");
275 if (options
->format
&& options
->format
!= 's')
277 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
282 addr
= unpack_pointer (type
, valaddr
);
283 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
285 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
287 /* Try to print what function it points to. */
288 print_address_demangle (gdbarch
, addr
, stream
, demangle
);
289 /* Return value is irrelevant except for string pointers. */
293 if (options
->addressprint
&& options
->format
!= 's')
294 fputs_filtered (paddress (gdbarch
, addr
), stream
);
296 /* For a pointer to char or unsigned char, also print the string
297 pointed to, unless pointer is null. */
298 if (TYPE_LENGTH (elttype
) == 1
299 && TYPE_CODE (elttype
) == TYPE_CODE_INT
300 && (options
->format
== 0 || options
->format
== 's')
302 i
= val_print_string (TYPE_TARGET_TYPE (type
), addr
, -1, stream
,
305 /* Return number of characters printed, including the terminating
306 '\0' if we reached the end. val_print_string takes care including
307 the terminating '\0' if necessary. */
313 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
314 if (options
->addressprint
)
317 = extract_typed_address (valaddr
+ embedded_offset
, type
);
319 fprintf_filtered (stream
, "@");
320 fputs_filtered (paddress (gdbarch
, addr
), stream
);
321 if (options
->deref_ref
)
322 fputs_filtered (": ", stream
);
324 /* De-reference the reference. */
325 if (options
->deref_ref
)
327 if (TYPE_CODE (elttype
) != TYPE_CODE_UNDEF
)
329 struct value
*deref_val
=
331 (TYPE_TARGET_TYPE (type
),
332 unpack_pointer (type
, valaddr
+ embedded_offset
));
334 common_val_print (deref_val
, stream
, recurse
,
335 options
, current_language
);
338 fputs_filtered ("???", stream
);
345 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
348 /* FIXME, we should consider, at least for ANSI C language, eliminating
349 the distinction made between FUNCs and POINTERs to FUNCs. */
350 fprintf_filtered (stream
, "{");
351 type_print (type
, "", stream
, -1);
352 fprintf_filtered (stream
, "} ");
353 /* Try to print what function it points to, and its address. */
354 print_address_demangle (gdbarch
, address
, stream
, demangle
);
358 if (options
->format
|| options
->output_format
)
360 struct value_print_options opts
= *options
;
362 opts
.format
= (options
->format
? options
->format
363 : options
->output_format
);
364 print_scalar_formatted (valaddr
, type
, &opts
, 0, stream
);
368 val_print_type_code_int (type
, valaddr
, stream
);
369 /* C and C++ has no single byte int type, char is used instead.
370 Since we don't know whether the value is really intended to
371 be used as an integer or a character, print the character
372 equivalent as well. */
373 if (TYPE_LENGTH (type
) == 1)
375 fputs_filtered (" ", stream
);
376 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
382 case TYPE_CODE_FLAGS
:
384 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
386 val_print_type_code_flags (type
, valaddr
, stream
);
391 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
393 print_floating (valaddr
, type
, stream
);
397 fprintf_filtered (stream
, "VOID");
400 case TYPE_CODE_ERROR
:
401 fprintf_filtered (stream
, "%s", TYPE_ERROR_NAME (type
));
404 case TYPE_CODE_RANGE
:
405 /* FIXME, we should not ever have to print one of these yet. */
406 fprintf_filtered (stream
, "<range type>");
410 if (options
->format
|| options
->output_format
)
412 struct value_print_options opts
= *options
;
414 opts
.format
= (options
->format
? options
->format
415 : options
->output_format
);
416 print_scalar_formatted (valaddr
, type
, &opts
, 0, stream
);
420 val
= extract_unsigned_integer (valaddr
,
421 TYPE_LENGTH (type
), byte_order
);
423 fprintf_filtered (stream
, ".FALSE.");
425 fprintf_filtered (stream
, ".TRUE.");
427 /* Not a legitimate logical type, print as an integer. */
429 /* Bash the type code temporarily. */
430 TYPE_CODE (type
) = TYPE_CODE_INT
;
431 val_print (type
, valaddr
, 0, address
, stream
, recurse
,
432 original_value
, options
, current_language
);
433 /* Restore the type code so later uses work as intended. */
434 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
439 case TYPE_CODE_COMPLEX
:
440 type
= TYPE_TARGET_TYPE (type
);
441 fputs_filtered ("(", stream
);
442 print_floating (valaddr
, type
, stream
);
443 fputs_filtered (",", stream
);
444 print_floating (valaddr
+ TYPE_LENGTH (type
), type
, stream
);
445 fputs_filtered (")", stream
);
448 case TYPE_CODE_UNDEF
:
449 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
450 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
451 and no complete type for struct foo in that file. */
452 fprintf_filtered (stream
, "<incomplete type>");
455 case TYPE_CODE_STRUCT
:
456 case TYPE_CODE_UNION
:
457 /* Starting from the Fortran 90 standard, Fortran supports derived
459 fprintf_filtered (stream
, "( ");
460 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
462 int offset
= TYPE_FIELD_BITPOS (type
, index
) / 8;
464 val_print (TYPE_FIELD_TYPE (type
, index
), valaddr
+ offset
,
465 embedded_offset
, address
, stream
, recurse
+ 1,
466 original_value
, options
, current_language
);
467 if (index
!= TYPE_NFIELDS (type
) - 1)
468 fputs_filtered (", ", stream
);
470 fprintf_filtered (stream
, " )");
474 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type
));
481 list_all_visible_commons (char *funname
)
483 SAVED_F77_COMMON_PTR tmp
;
485 tmp
= head_common_list
;
487 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
491 if (strcmp (tmp
->owning_function
, funname
) == 0)
492 printf_filtered ("%s\n", tmp
->name
);
498 /* This function is used to print out the values in a given COMMON
499 block. It will always use the most local common block of the
503 info_common_command (char *comname
, int from_tty
)
505 SAVED_F77_COMMON_PTR the_common
;
506 COMMON_ENTRY_PTR entry
;
507 struct frame_info
*fi
;
511 /* We have been told to display the contents of F77 COMMON
512 block supposedly visible in this function. Let us
513 first make sure that it is visible and if so, let
514 us display its contents */
516 fi
= get_selected_frame (_("No frame selected"));
518 /* The following is generally ripped off from stack.c's routine
519 print_frame_info() */
521 func
= find_pc_function (get_frame_pc (fi
));
524 /* In certain pathological cases, the symtabs give the wrong
525 function (when we are in the first function in a file which
526 is compiled without debugging symbols, the previous function
527 is compiled with debugging symbols, and the "foo.o" symbol
528 that is supposed to tell us where the file with debugging symbols
529 ends has been truncated by ar because it is longer than 15
532 So look in the minimal symbol tables as well, and if it comes
533 up with a larger address for the function use that instead.
534 I don't think this can ever cause any problems; there shouldn't
535 be any minimal symbols in the middle of a function.
536 FIXME: (Not necessarily true. What about text labels) */
538 struct minimal_symbol
*msymbol
=
539 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
542 && (SYMBOL_VALUE_ADDRESS (msymbol
)
543 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
544 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
546 funname
= SYMBOL_LINKAGE_NAME (func
);
550 struct minimal_symbol
*msymbol
=
551 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
554 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
555 else /* Got no 'funname', code below will fail. */
556 error (_("No function found for frame."));
559 /* If comname is NULL, we assume the user wishes to see the
560 which COMMON blocks are visible here and then return */
564 list_all_visible_commons (funname
);
568 the_common
= find_common_for_function (comname
, funname
);
572 if (strcmp (comname
, BLANK_COMMON_NAME_LOCAL
) == 0)
573 printf_filtered (_("Contents of blank COMMON block:\n"));
575 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname
);
577 printf_filtered ("\n");
578 entry
= the_common
->entries
;
580 while (entry
!= NULL
)
582 print_variable_and_value (NULL
, entry
->symbol
, fi
, gdb_stdout
, 0);
587 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
591 /* This function is used to determine whether there is a
592 F77 common block visible at the current scope called 'comname'. */
596 there_is_a_visible_common_named (char *comname
)
598 SAVED_F77_COMMON_PTR the_common
;
599 struct frame_info
*fi
;
604 error (_("Cannot deal with NULL common name!"));
606 fi
= get_selected_frame (_("No frame selected"));
608 /* The following is generally ripped off from stack.c's routine
609 print_frame_info() */
611 func
= find_pc_function (fi
->pc
);
614 /* In certain pathological cases, the symtabs give the wrong
615 function (when we are in the first function in a file which
616 is compiled without debugging symbols, the previous function
617 is compiled with debugging symbols, and the "foo.o" symbol
618 that is supposed to tell us where the file with debugging symbols
619 ends has been truncated by ar because it is longer than 15
622 So look in the minimal symbol tables as well, and if it comes
623 up with a larger address for the function use that instead.
624 I don't think this can ever cause any problems; there shouldn't
625 be any minimal symbols in the middle of a function.
626 FIXME: (Not necessarily true. What about text labels) */
628 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
631 && (SYMBOL_VALUE_ADDRESS (msymbol
)
632 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
633 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
635 funname
= SYMBOL_LINKAGE_NAME (func
);
639 struct minimal_symbol
*msymbol
=
640 lookup_minimal_symbol_by_pc (fi
->pc
);
643 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
646 the_common
= find_common_for_function (comname
, funname
);
648 return (the_common
? 1 : 0);
653 _initialize_f_valprint (void)
655 add_info ("common", info_common_command
,
656 _("Print out the values contained in a Fortran COMMON block."));
658 add_com ("lc", class_info
, info_common_command
,
659 _("Print out the values contained in a Fortran COMMON block."));