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_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
)
97 /* Recursively go all the way down into a possibly multi-dimensional
98 F77 array and get the bounds. For simple arrays, this is pretty
99 easy but when the bounds are dynamic, we must be very careful
100 to add up all the lengths correctly. Not doing this right
101 will lead to horrendous-looking arrays in parameter lists.
103 This function also works for strings which behave very
104 similarly to arrays. */
106 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
107 || TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
108 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
110 /* Recursion ends here, start setting up lengths. */
111 lower_bound
= f77_get_lowerbound (type
);
112 upper_bound
= f77_get_upperbound (type
);
114 /* Patch in a valid length value. */
117 (upper_bound
- lower_bound
+ 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
120 /* Function that sets up the array offset,size table for the array
124 f77_create_arrayprint_offset_tbl (struct type
*type
, struct ui_file
*stream
)
126 struct type
*tmp_type
;
129 int upper
, lower
, retcode
;
133 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
135 upper
= f77_get_upperbound (tmp_type
);
136 lower
= f77_get_lowerbound (tmp_type
);
138 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
140 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
144 /* Now we multiply eltlen by all the offsets, so that later we
145 can print out array elements correctly. Up till now we
146 know an offset to apply to get the item but we also
147 have to know how much to add to get to the next item */
150 eltlen
= TYPE_LENGTH (tmp_type
);
151 F77_DIM_OFFSET (ndimen
) = eltlen
;
154 eltlen
*= F77_DIM_SIZE (ndimen
+ 1);
155 F77_DIM_OFFSET (ndimen
) = eltlen
;
161 /* Actual function which prints out F77 arrays, Valaddr == address in
162 the superior. Address == the address in the inferior. */
165 f77_print_array_1 (int nss
, int ndimensions
, struct type
*type
,
166 const gdb_byte
*valaddr
, CORE_ADDR address
,
167 struct ui_file
*stream
, int format
,
168 int deref_ref
, int recurse
, enum val_prettyprint pretty
,
173 if (nss
!= ndimensions
)
175 for (i
= 0; (i
< F77_DIM_SIZE (nss
) && (*elts
) < 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
, format
, deref_ref
, recurse
, pretty
, elts
);
182 fprintf_filtered (stream
, ") ");
184 if (*elts
>= print_max
&& i
< F77_DIM_SIZE (nss
))
185 fprintf_filtered (stream
, "...");
189 for (i
= 0; i
< F77_DIM_SIZE (nss
) && (*elts
) < 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
, format
, deref_ref
, recurse
, pretty
,
199 if (i
!= (F77_DIM_SIZE (nss
) - 1))
200 fprintf_filtered (stream
, ", ");
202 if ((*elts
== print_max
- 1) && (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
,
214 int format
, int deref_ref
, int recurse
,
215 enum val_prettyprint pretty
)
220 ndimensions
= calc_f77_array_dims (type
);
222 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
223 error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
224 ndimensions
, MAX_FORTRAN_DIMS
);
226 /* Since F77 arrays are stored column-major, we set up an
227 offset table to get at the various row's elements. The
228 offset table contains entries for both offset and subarray size. */
230 f77_create_arrayprint_offset_tbl (type
, stream
);
232 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
, format
,
233 deref_ref
, recurse
, pretty
, &elts
);
237 /* Print data of type TYPE located at VALADDR (within GDB), which came from
238 the inferior at address ADDRESS, onto stdio stream STREAM according to
239 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
242 If the data are a string pointer, returns the number of string characters
245 If DEREF_REF is nonzero, then dereference references, otherwise just print
248 The PRETTY parameter controls prettyprinting. */
251 f_val_print (struct type
*type
, const gdb_byte
*valaddr
, int embedded_offset
,
252 CORE_ADDR address
, struct ui_file
*stream
, int format
,
253 int deref_ref
, int recurse
, enum val_prettyprint pretty
)
255 unsigned int i
= 0; /* Number of characters printed */
256 struct type
*elttype
;
261 CHECK_TYPEDEF (type
);
262 switch (TYPE_CODE (type
))
264 case TYPE_CODE_STRING
:
265 f77_get_dynamic_length_of_aggregate (type
);
266 LA_PRINT_STRING (stream
, valaddr
, TYPE_LENGTH (type
), 1, 0);
269 case TYPE_CODE_ARRAY
:
270 fprintf_filtered (stream
, "(");
271 f77_print_array (type
, valaddr
, address
, stream
, format
,
272 deref_ref
, recurse
, pretty
);
273 fprintf_filtered (stream
, ")");
277 if (format
&& format
!= 's')
279 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
284 addr
= unpack_pointer (type
, valaddr
);
285 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
287 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
289 /* Try to print what function it points to. */
290 print_address_demangle (addr
, stream
, demangle
);
291 /* Return value is irrelevant except for string pointers. */
295 if (addressprint
&& format
!= 's')
296 fputs_filtered (paddress (addr
), stream
);
298 /* For a pointer to char or unsigned char, also print the string
299 pointed to, unless pointer is null. */
300 if (TYPE_LENGTH (elttype
) == 1
301 && TYPE_CODE (elttype
) == TYPE_CODE_INT
302 && (format
== 0 || format
== 's')
304 i
= val_print_string (addr
, -1, TYPE_LENGTH (elttype
), stream
);
306 /* Return number of characters printed, including the terminating
307 '\0' if we reached the end. val_print_string takes care including
308 the terminating '\0' if necessary. */
314 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
318 = extract_typed_address (valaddr
+ embedded_offset
, type
);
319 fprintf_filtered (stream
, "@");
320 fputs_filtered (paddress (addr
), stream
);
322 fputs_filtered (": ", stream
);
324 /* De-reference the reference. */
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
));
333 common_val_print (deref_val
, stream
, format
, deref_ref
, recurse
,
334 pretty
, current_language
);
337 fputs_filtered ("???", stream
);
344 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
347 /* FIXME, we should consider, at least for ANSI C language, eliminating
348 the distinction made between FUNCs and POINTERs to FUNCs. */
349 fprintf_filtered (stream
, "{");
350 type_print (type
, "", stream
, -1);
351 fprintf_filtered (stream
, "} ");
352 /* Try to print what function it points to, and its address. */
353 print_address_demangle (address
, stream
, demangle
);
357 format
= format
? format
: output_format
;
359 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
362 val_print_type_code_int (type
, valaddr
, stream
);
363 /* C and C++ has no single byte int type, char is used instead.
364 Since we don't know whether the value is really intended to
365 be used as an integer or a character, print the character
366 equivalent as well. */
367 if (TYPE_LENGTH (type
) == 1)
369 fputs_filtered (" ", stream
);
370 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
376 case TYPE_CODE_FLAGS
:
378 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
380 val_print_type_code_flags (type
, valaddr
, stream
);
385 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
387 print_floating (valaddr
, type
, stream
);
391 fprintf_filtered (stream
, "VOID");
394 case TYPE_CODE_ERROR
:
395 fprintf_filtered (stream
, "<error type>");
398 case TYPE_CODE_RANGE
:
399 /* FIXME, we should not ever have to print one of these yet. */
400 fprintf_filtered (stream
, "<range type>");
404 format
= format
? format
: output_format
;
406 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
409 val
= extract_unsigned_integer (valaddr
, TYPE_LENGTH (type
));
412 fprintf_filtered (stream
, ".FALSE.");
414 fprintf_filtered (stream
, ".TRUE.");
416 /* Not a legitimate logical type, print as an integer. */
418 /* Bash the type code temporarily. */
419 TYPE_CODE (type
) = TYPE_CODE_INT
;
420 f_val_print (type
, valaddr
, 0, address
, stream
, format
,
421 deref_ref
, recurse
, pretty
);
422 /* Restore the type code so later uses work as intended. */
423 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
428 case TYPE_CODE_COMPLEX
:
429 type
= TYPE_TARGET_TYPE (type
);
430 fputs_filtered ("(", stream
);
431 print_floating (valaddr
, type
, stream
);
432 fputs_filtered (",", stream
);
433 print_floating (valaddr
+ TYPE_LENGTH (type
), type
, stream
);
434 fputs_filtered (")", stream
);
437 case TYPE_CODE_UNDEF
:
438 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
439 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
440 and no complete type for struct foo in that file. */
441 fprintf_filtered (stream
, "<incomplete type>");
444 case TYPE_CODE_STRUCT
:
445 case TYPE_CODE_UNION
:
446 /* Starting from the Fortran 90 standard, Fortran supports derived
448 fprintf_filtered (stream
, "( ");
449 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
451 int offset
= TYPE_FIELD_BITPOS (type
, index
) / 8;
452 f_val_print (TYPE_FIELD_TYPE (type
, index
), valaddr
+ offset
,
453 embedded_offset
, address
, stream
,
454 format
, deref_ref
, recurse
, pretty
);
455 if (index
!= TYPE_NFIELDS (type
) - 1)
456 fputs_filtered (", ", stream
);
458 fprintf_filtered (stream
, " )");
462 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type
));
469 list_all_visible_commons (char *funname
)
471 SAVED_F77_COMMON_PTR tmp
;
473 tmp
= head_common_list
;
475 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
479 if (strcmp (tmp
->owning_function
, funname
) == 0)
480 printf_filtered ("%s\n", tmp
->name
);
486 /* This function is used to print out the values in a given COMMON
487 block. It will always use the most local common block of the
491 info_common_command (char *comname
, int from_tty
)
493 SAVED_F77_COMMON_PTR the_common
;
494 COMMON_ENTRY_PTR entry
;
495 struct frame_info
*fi
;
499 /* We have been told to display the contents of F77 COMMON
500 block supposedly visible in this function. Let us
501 first make sure that it is visible and if so, let
502 us display its contents */
504 fi
= get_selected_frame (_("No frame selected"));
506 /* The following is generally ripped off from stack.c's routine
507 print_frame_info() */
509 func
= find_pc_function (get_frame_pc (fi
));
512 /* In certain pathological cases, the symtabs give the wrong
513 function (when we are in the first function in a file which
514 is compiled without debugging symbols, the previous function
515 is compiled with debugging symbols, and the "foo.o" symbol
516 that is supposed to tell us where the file with debugging symbols
517 ends has been truncated by ar because it is longer than 15
520 So look in the minimal symbol tables as well, and if it comes
521 up with a larger address for the function use that instead.
522 I don't think this can ever cause any problems; there shouldn't
523 be any minimal symbols in the middle of a function.
524 FIXME: (Not necessarily true. What about text labels) */
526 struct minimal_symbol
*msymbol
=
527 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
530 && (SYMBOL_VALUE_ADDRESS (msymbol
)
531 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
532 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
534 funname
= SYMBOL_LINKAGE_NAME (func
);
538 struct minimal_symbol
*msymbol
=
539 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
542 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
543 else /* Got no 'funname', code below will fail. */
544 error (_("No function found for frame."));
547 /* If comname is NULL, we assume the user wishes to see the
548 which COMMON blocks are visible here and then return */
552 list_all_visible_commons (funname
);
556 the_common
= find_common_for_function (comname
, funname
);
560 if (strcmp (comname
, BLANK_COMMON_NAME_LOCAL
) == 0)
561 printf_filtered (_("Contents of blank COMMON block:\n"));
563 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname
);
565 printf_filtered ("\n");
566 entry
= the_common
->entries
;
568 while (entry
!= NULL
)
570 printf_filtered ("%s = ", SYMBOL_PRINT_NAME (entry
->symbol
));
571 print_variable_value (entry
->symbol
, fi
, gdb_stdout
);
572 printf_filtered ("\n");
577 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
581 /* This function is used to determine whether there is a
582 F77 common block visible at the current scope called 'comname'. */
586 there_is_a_visible_common_named (char *comname
)
588 SAVED_F77_COMMON_PTR the_common
;
589 struct frame_info
*fi
;
594 error (_("Cannot deal with NULL common name!"));
596 fi
= get_selected_frame (_("No frame selected"));
598 /* The following is generally ripped off from stack.c's routine
599 print_frame_info() */
601 func
= find_pc_function (fi
->pc
);
604 /* In certain pathological cases, the symtabs give the wrong
605 function (when we are in the first function in a file which
606 is compiled without debugging symbols, the previous function
607 is compiled with debugging symbols, and the "foo.o" symbol
608 that is supposed to tell us where the file with debugging symbols
609 ends has been truncated by ar because it is longer than 15
612 So look in the minimal symbol tables as well, and if it comes
613 up with a larger address for the function use that instead.
614 I don't think this can ever cause any problems; there shouldn't
615 be any minimal symbols in the middle of a function.
616 FIXME: (Not necessarily true. What about text labels) */
618 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
621 && (SYMBOL_VALUE_ADDRESS (msymbol
)
622 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
623 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
625 funname
= SYMBOL_LINKAGE_NAME (func
);
629 struct minimal_symbol
*msymbol
=
630 lookup_minimal_symbol_by_pc (fi
->pc
);
633 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
636 the_common
= find_common_for_function (comname
, funname
);
638 return (the_common
? 1 : 0);
643 _initialize_f_valprint (void)
645 add_info ("common", info_common_command
,
646 _("Print out the values contained in a Fortran COMMON block."));
648 add_com ("lc", class_info
, info_common_command
,
649 _("Print out the values contained in a Fortran COMMON block."));