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 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_dynamic_lowerbound (struct type
*type
, int *lower_bound
)
66 struct frame_info
*frame
;
67 CORE_ADDR current_frame_addr
;
68 CORE_ADDR ptr_to_lower_bound
;
70 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type
))
72 case BOUND_BY_VALUE_ON_STACK
:
73 frame
= deprecated_safe_get_selected_frame ();
74 current_frame_addr
= get_frame_base (frame
);
75 if (current_frame_addr
> 0)
78 read_memory_integer (current_frame_addr
+
79 TYPE_ARRAY_LOWER_BOUND_VALUE (type
),
84 *lower_bound
= DEFAULT_LOWER_BOUND
;
85 return BOUND_FETCH_ERROR
;
90 *lower_bound
= TYPE_ARRAY_LOWER_BOUND_VALUE (type
);
93 case BOUND_CANNOT_BE_DETERMINED
:
94 error (_("Lower bound may not be '*' in F77"));
97 case BOUND_BY_REF_ON_STACK
:
98 frame
= deprecated_safe_get_selected_frame ();
99 current_frame_addr
= get_frame_base (frame
);
100 if (current_frame_addr
> 0)
102 struct gdbarch
*arch
= get_frame_arch (frame
);
104 read_memory_typed_address (current_frame_addr
+
105 TYPE_ARRAY_LOWER_BOUND_VALUE (type
),
106 builtin_type (arch
)->builtin_data_ptr
);
107 *lower_bound
= read_memory_integer (ptr_to_lower_bound
, 4);
111 *lower_bound
= DEFAULT_LOWER_BOUND
;
112 return BOUND_FETCH_ERROR
;
116 case BOUND_BY_REF_IN_REG
:
117 case BOUND_BY_VALUE_IN_REG
:
119 error (_("??? unhandled dynamic array bound type ???"));
122 return BOUND_FETCH_OK
;
126 f77_get_dynamic_upperbound (struct type
*type
, int *upper_bound
)
128 struct frame_info
*frame
;
129 CORE_ADDR current_frame_addr
= 0;
130 CORE_ADDR ptr_to_upper_bound
;
132 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type
))
134 case BOUND_BY_VALUE_ON_STACK
:
135 frame
= deprecated_safe_get_selected_frame ();
136 current_frame_addr
= get_frame_base (frame
);
137 if (current_frame_addr
> 0)
140 read_memory_integer (current_frame_addr
+
141 TYPE_ARRAY_UPPER_BOUND_VALUE (type
),
146 *upper_bound
= DEFAULT_UPPER_BOUND
;
147 return BOUND_FETCH_ERROR
;
152 *upper_bound
= TYPE_ARRAY_UPPER_BOUND_VALUE (type
);
155 case BOUND_CANNOT_BE_DETERMINED
:
156 /* we have an assumed size array on our hands. Assume that
157 upper_bound == lower_bound so that we show at least
158 1 element.If the user wants to see more elements, let
159 him manually ask for 'em and we'll subscript the
160 array and show him */
161 f77_get_dynamic_lowerbound (type
, upper_bound
);
164 case BOUND_BY_REF_ON_STACK
:
165 frame
= deprecated_safe_get_selected_frame ();
166 current_frame_addr
= get_frame_base (frame
);
167 if (current_frame_addr
> 0)
169 struct gdbarch
*arch
= get_frame_arch (frame
);
171 read_memory_typed_address (current_frame_addr
+
172 TYPE_ARRAY_UPPER_BOUND_VALUE (type
),
173 builtin_type (arch
)->builtin_data_ptr
);
174 *upper_bound
= read_memory_integer (ptr_to_upper_bound
, 4);
178 *upper_bound
= DEFAULT_UPPER_BOUND
;
179 return BOUND_FETCH_ERROR
;
183 case BOUND_BY_REF_IN_REG
:
184 case BOUND_BY_VALUE_IN_REG
:
186 error (_("??? unhandled dynamic array bound type ???"));
189 return BOUND_FETCH_OK
;
192 /* Obtain F77 adjustable array dimensions */
195 f77_get_dynamic_length_of_aggregate (struct type
*type
)
197 int upper_bound
= -1;
201 /* Recursively go all the way down into a possibly multi-dimensional
202 F77 array and get the bounds. For simple arrays, this is pretty
203 easy but when the bounds are dynamic, we must be very careful
204 to add up all the lengths correctly. Not doing this right
205 will lead to horrendous-looking arrays in parameter lists.
207 This function also works for strings which behave very
208 similarly to arrays. */
210 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
211 || TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
212 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
214 /* Recursion ends here, start setting up lengths. */
215 retcode
= f77_get_dynamic_lowerbound (type
, &lower_bound
);
216 if (retcode
== BOUND_FETCH_ERROR
)
217 error (_("Cannot obtain valid array lower bound"));
219 retcode
= f77_get_dynamic_upperbound (type
, &upper_bound
);
220 if (retcode
== BOUND_FETCH_ERROR
)
221 error (_("Cannot obtain valid array upper bound"));
223 /* Patch in a valid length value. */
226 (upper_bound
- lower_bound
+ 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
229 /* Function that sets up the array offset,size table for the array
233 f77_create_arrayprint_offset_tbl (struct type
*type
, struct ui_file
*stream
)
235 struct type
*tmp_type
;
238 int upper
, lower
, retcode
;
242 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
244 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type
) == BOUND_CANNOT_BE_DETERMINED
)
245 fprintf_filtered (stream
, "<assumed size array> ");
247 retcode
= f77_get_dynamic_upperbound (tmp_type
, &upper
);
248 if (retcode
== BOUND_FETCH_ERROR
)
249 error (_("Cannot obtain dynamic upper bound"));
251 retcode
= f77_get_dynamic_lowerbound (tmp_type
, &lower
);
252 if (retcode
== BOUND_FETCH_ERROR
)
253 error (_("Cannot obtain dynamic lower bound"));
255 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
257 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
261 /* Now we multiply eltlen by all the offsets, so that later we
262 can print out array elements correctly. Up till now we
263 know an offset to apply to get the item but we also
264 have to know how much to add to get to the next item */
267 eltlen
= TYPE_LENGTH (tmp_type
);
268 F77_DIM_OFFSET (ndimen
) = eltlen
;
271 eltlen
*= F77_DIM_SIZE (ndimen
+ 1);
272 F77_DIM_OFFSET (ndimen
) = eltlen
;
278 /* Actual function which prints out F77 arrays, Valaddr == address in
279 the superior. Address == the address in the inferior. */
282 f77_print_array_1 (int nss
, int ndimensions
, struct type
*type
,
283 const gdb_byte
*valaddr
, CORE_ADDR address
,
284 struct ui_file
*stream
, int format
,
285 int deref_ref
, int recurse
, enum val_prettyprint pretty
,
290 if (nss
!= ndimensions
)
292 for (i
= 0; (i
< F77_DIM_SIZE (nss
) && (*elts
) < print_max
); i
++)
294 fprintf_filtered (stream
, "( ");
295 f77_print_array_1 (nss
+ 1, ndimensions
, TYPE_TARGET_TYPE (type
),
296 valaddr
+ i
* F77_DIM_OFFSET (nss
),
297 address
+ i
* F77_DIM_OFFSET (nss
),
298 stream
, format
, deref_ref
, recurse
, pretty
, elts
);
299 fprintf_filtered (stream
, ") ");
301 if (*elts
>= print_max
&& i
< F77_DIM_SIZE (nss
))
302 fprintf_filtered (stream
, "...");
306 for (i
= 0; i
< F77_DIM_SIZE (nss
) && (*elts
) < print_max
;
309 val_print (TYPE_TARGET_TYPE (type
),
310 valaddr
+ i
* F77_DIM_OFFSET (ndimensions
),
312 address
+ i
* F77_DIM_OFFSET (ndimensions
),
313 stream
, format
, deref_ref
, recurse
, pretty
,
316 if (i
!= (F77_DIM_SIZE (nss
) - 1))
317 fprintf_filtered (stream
, ", ");
319 if ((*elts
== print_max
- 1) && (i
!= (F77_DIM_SIZE (nss
) - 1)))
320 fprintf_filtered (stream
, "...");
325 /* This function gets called to print an F77 array, we set up some
326 stuff and then immediately call f77_print_array_1() */
329 f77_print_array (struct type
*type
, const gdb_byte
*valaddr
,
330 CORE_ADDR address
, struct ui_file
*stream
,
331 int format
, int deref_ref
, int recurse
,
332 enum val_prettyprint pretty
)
337 ndimensions
= calc_f77_array_dims (type
);
339 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
340 error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
341 ndimensions
, MAX_FORTRAN_DIMS
);
343 /* Since F77 arrays are stored column-major, we set up an
344 offset table to get at the various row's elements. The
345 offset table contains entries for both offset and subarray size. */
347 f77_create_arrayprint_offset_tbl (type
, stream
);
349 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
, format
,
350 deref_ref
, recurse
, pretty
, &elts
);
354 /* Print data of type TYPE located at VALADDR (within GDB), which came from
355 the inferior at address ADDRESS, onto stdio stream STREAM according to
356 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
359 If the data are a string pointer, returns the number of string characters
362 If DEREF_REF is nonzero, then dereference references, otherwise just print
365 The PRETTY parameter controls prettyprinting. */
368 f_val_print (struct type
*type
, const gdb_byte
*valaddr
, int embedded_offset
,
369 CORE_ADDR address
, struct ui_file
*stream
, int format
,
370 int deref_ref
, int recurse
, enum val_prettyprint pretty
)
372 unsigned int i
= 0; /* Number of characters printed */
373 struct type
*elttype
;
378 CHECK_TYPEDEF (type
);
379 switch (TYPE_CODE (type
))
381 case TYPE_CODE_STRING
:
382 f77_get_dynamic_length_of_aggregate (type
);
383 LA_PRINT_STRING (stream
, valaddr
, TYPE_LENGTH (type
), 1, 0);
386 case TYPE_CODE_ARRAY
:
387 fprintf_filtered (stream
, "(");
388 f77_print_array (type
, valaddr
, address
, stream
, format
,
389 deref_ref
, recurse
, pretty
);
390 fprintf_filtered (stream
, ")");
394 if (format
&& format
!= 's')
396 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
401 addr
= unpack_pointer (type
, valaddr
);
402 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
404 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
406 /* Try to print what function it points to. */
407 print_address_demangle (addr
, stream
, demangle
);
408 /* Return value is irrelevant except for string pointers. */
412 if (addressprint
&& format
!= 's')
413 fputs_filtered (paddress (addr
), stream
);
415 /* For a pointer to char or unsigned char, also print the string
416 pointed to, unless pointer is null. */
417 if (TYPE_LENGTH (elttype
) == 1
418 && TYPE_CODE (elttype
) == TYPE_CODE_INT
419 && (format
== 0 || format
== 's')
421 i
= val_print_string (addr
, -1, TYPE_LENGTH (elttype
), stream
);
423 /* Return number of characters printed, including the terminating
424 '\0' if we reached the end. val_print_string takes care including
425 the terminating '\0' if necessary. */
431 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
435 = extract_typed_address (valaddr
+ embedded_offset
, type
);
436 fprintf_filtered (stream
, "@");
437 fputs_filtered (paddress (addr
), stream
);
439 fputs_filtered (": ", stream
);
441 /* De-reference the reference. */
444 if (TYPE_CODE (elttype
) != TYPE_CODE_UNDEF
)
446 struct value
*deref_val
=
448 (TYPE_TARGET_TYPE (type
),
449 unpack_pointer (type
, valaddr
+ embedded_offset
));
450 common_val_print (deref_val
, stream
, format
, deref_ref
, recurse
,
451 pretty
, current_language
);
454 fputs_filtered ("???", stream
);
461 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
464 /* FIXME, we should consider, at least for ANSI C language, eliminating
465 the distinction made between FUNCs and POINTERs to FUNCs. */
466 fprintf_filtered (stream
, "{");
467 type_print (type
, "", stream
, -1);
468 fprintf_filtered (stream
, "} ");
469 /* Try to print what function it points to, and its address. */
470 print_address_demangle (address
, stream
, demangle
);
474 format
= format
? format
: output_format
;
476 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
479 val_print_type_code_int (type
, valaddr
, stream
);
480 /* C and C++ has no single byte int type, char is used instead.
481 Since we don't know whether the value is really intended to
482 be used as an integer or a character, print the character
483 equivalent as well. */
484 if (TYPE_LENGTH (type
) == 1)
486 fputs_filtered (" ", stream
);
487 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
493 case TYPE_CODE_FLAGS
:
495 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
497 val_print_type_code_flags (type
, valaddr
, stream
);
502 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
504 print_floating (valaddr
, type
, stream
);
508 fprintf_filtered (stream
, "VOID");
511 case TYPE_CODE_ERROR
:
512 fprintf_filtered (stream
, "<error type>");
515 case TYPE_CODE_RANGE
:
516 /* FIXME, we should not ever have to print one of these yet. */
517 fprintf_filtered (stream
, "<range type>");
521 format
= format
? format
: output_format
;
523 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
527 switch (TYPE_LENGTH (type
))
530 val
= unpack_long (builtin_type_f_logical_s1
, valaddr
);
534 val
= unpack_long (builtin_type_f_logical_s2
, valaddr
);
538 val
= unpack_long (builtin_type_f_logical
, valaddr
);
542 error (_("Logicals of length %d bytes not supported"),
548 fprintf_filtered (stream
, ".FALSE.");
550 fprintf_filtered (stream
, ".TRUE.");
552 /* Not a legitimate logical type, print as an integer. */
554 /* Bash the type code temporarily. */
555 TYPE_CODE (type
) = TYPE_CODE_INT
;
556 f_val_print (type
, valaddr
, 0, address
, stream
, format
,
557 deref_ref
, recurse
, pretty
);
558 /* Restore the type code so later uses work as intended. */
559 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
564 case TYPE_CODE_COMPLEX
:
565 switch (TYPE_LENGTH (type
))
568 type
= builtin_type_f_real
;
571 type
= builtin_type_f_real_s8
;
574 type
= builtin_type_f_real_s16
;
577 error (_("Cannot print out complex*%d variables"), TYPE_LENGTH (type
));
579 fputs_filtered ("(", stream
);
580 print_floating (valaddr
, type
, stream
);
581 fputs_filtered (",", stream
);
582 print_floating (valaddr
+ TYPE_LENGTH (type
), type
, stream
);
583 fputs_filtered (")", stream
);
586 case TYPE_CODE_UNDEF
:
587 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
588 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
589 and no complete type for struct foo in that file. */
590 fprintf_filtered (stream
, "<incomplete type>");
593 case TYPE_CODE_STRUCT
:
594 case TYPE_CODE_UNION
:
595 /* Starting from the Fortran 90 standard, Fortran supports derived
597 fprintf_filtered (stream
, "( ");
598 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
600 int offset
= TYPE_FIELD_BITPOS (type
, index
) / 8;
601 f_val_print (TYPE_FIELD_TYPE (type
, index
), valaddr
+ offset
,
602 embedded_offset
, address
, stream
,
603 format
, deref_ref
, recurse
, pretty
);
604 if (index
!= TYPE_NFIELDS (type
) - 1)
605 fputs_filtered (", ", stream
);
607 fprintf_filtered (stream
, " )");
611 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type
));
618 list_all_visible_commons (char *funname
)
620 SAVED_F77_COMMON_PTR tmp
;
622 tmp
= head_common_list
;
624 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
628 if (strcmp (tmp
->owning_function
, funname
) == 0)
629 printf_filtered ("%s\n", tmp
->name
);
635 /* This function is used to print out the values in a given COMMON
636 block. It will always use the most local common block of the
640 info_common_command (char *comname
, int from_tty
)
642 SAVED_F77_COMMON_PTR the_common
;
643 COMMON_ENTRY_PTR entry
;
644 struct frame_info
*fi
;
648 /* We have been told to display the contents of F77 COMMON
649 block supposedly visible in this function. Let us
650 first make sure that it is visible and if so, let
651 us display its contents */
653 fi
= get_selected_frame (_("No frame selected"));
655 /* The following is generally ripped off from stack.c's routine
656 print_frame_info() */
658 func
= find_pc_function (get_frame_pc (fi
));
661 /* In certain pathological cases, the symtabs give the wrong
662 function (when we are in the first function in a file which
663 is compiled without debugging symbols, the previous function
664 is compiled with debugging symbols, and the "foo.o" symbol
665 that is supposed to tell us where the file with debugging symbols
666 ends has been truncated by ar because it is longer than 15
669 So look in the minimal symbol tables as well, and if it comes
670 up with a larger address for the function use that instead.
671 I don't think this can ever cause any problems; there shouldn't
672 be any minimal symbols in the middle of a function.
673 FIXME: (Not necessarily true. What about text labels) */
675 struct minimal_symbol
*msymbol
=
676 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
679 && (SYMBOL_VALUE_ADDRESS (msymbol
)
680 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
681 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
683 funname
= SYMBOL_LINKAGE_NAME (func
);
687 struct minimal_symbol
*msymbol
=
688 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
691 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
692 else /* Got no 'funname', code below will fail. */
693 error (_("No function found for frame."));
696 /* If comname is NULL, we assume the user wishes to see the
697 which COMMON blocks are visible here and then return */
701 list_all_visible_commons (funname
);
705 the_common
= find_common_for_function (comname
, funname
);
709 if (strcmp (comname
, BLANK_COMMON_NAME_LOCAL
) == 0)
710 printf_filtered (_("Contents of blank COMMON block:\n"));
712 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname
);
714 printf_filtered ("\n");
715 entry
= the_common
->entries
;
717 while (entry
!= NULL
)
719 printf_filtered ("%s = ", SYMBOL_PRINT_NAME (entry
->symbol
));
720 print_variable_value (entry
->symbol
, fi
, gdb_stdout
);
721 printf_filtered ("\n");
726 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
730 /* This function is used to determine whether there is a
731 F77 common block visible at the current scope called 'comname'. */
735 there_is_a_visible_common_named (char *comname
)
737 SAVED_F77_COMMON_PTR the_common
;
738 struct frame_info
*fi
;
743 error (_("Cannot deal with NULL common name!"));
745 fi
= get_selected_frame (_("No frame selected"));
747 /* The following is generally ripped off from stack.c's routine
748 print_frame_info() */
750 func
= find_pc_function (fi
->pc
);
753 /* In certain pathological cases, the symtabs give the wrong
754 function (when we are in the first function in a file which
755 is compiled without debugging symbols, the previous function
756 is compiled with debugging symbols, and the "foo.o" symbol
757 that is supposed to tell us where the file with debugging symbols
758 ends has been truncated by ar because it is longer than 15
761 So look in the minimal symbol tables as well, and if it comes
762 up with a larger address for the function use that instead.
763 I don't think this can ever cause any problems; there shouldn't
764 be any minimal symbols in the middle of a function.
765 FIXME: (Not necessarily true. What about text labels) */
767 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
770 && (SYMBOL_VALUE_ADDRESS (msymbol
)
771 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
772 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
774 funname
= SYMBOL_LINKAGE_NAME (func
);
778 struct minimal_symbol
*msymbol
=
779 lookup_minimal_symbol_by_pc (fi
->pc
);
782 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
785 the_common
= find_common_for_function (comname
, funname
);
787 return (the_common
? 1 : 0);
792 _initialize_f_valprint (void)
794 add_info ("common", info_common_command
,
795 _("Print out the values contained in a Fortran COMMON block."));
797 add_com ("lc", class_info
, info_common_command
,
798 _("Print out the values contained in a Fortran COMMON block."));