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 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 recurse
,
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
, 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
, 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
,
214 int recurse
, const struct value_print_options
*options
)
219 ndimensions
= calc_f77_array_dims (type
);
221 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
222 error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
223 ndimensions
, MAX_FORTRAN_DIMS
);
225 /* Since F77 arrays are stored column-major, we set up an
226 offset table to get at the various row's elements. The
227 offset table contains entries for both offset and subarray size. */
229 f77_create_arrayprint_offset_tbl (type
, stream
);
231 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
,
232 recurse
, options
, &elts
);
236 /* Print data of type TYPE located at VALADDR (within GDB), which came from
237 the inferior at address ADDRESS, onto stdio stream STREAM according to
238 OPTIONS. The data at VALADDR is in target byte order.
240 If the data are a string pointer, returns the number of string characters
244 f_val_print (struct type
*type
, const gdb_byte
*valaddr
, int embedded_offset
,
245 CORE_ADDR address
, struct ui_file
*stream
, int recurse
,
246 const struct value_print_options
*options
)
248 struct gdbarch
*gdbarch
= get_type_arch (type
);
249 unsigned int i
= 0; /* Number of characters printed */
250 struct type
*elttype
;
255 CHECK_TYPEDEF (type
);
256 switch (TYPE_CODE (type
))
258 case TYPE_CODE_STRING
:
259 f77_get_dynamic_length_of_aggregate (type
);
260 LA_PRINT_STRING (stream
, builtin_type (gdbarch
)->builtin_char
,
261 valaddr
, TYPE_LENGTH (type
), 0, options
);
264 case TYPE_CODE_ARRAY
:
265 fprintf_filtered (stream
, "(");
266 f77_print_array (type
, valaddr
, address
, stream
, recurse
, options
);
267 fprintf_filtered (stream
, ")");
271 if (options
->format
&& options
->format
!= 's')
273 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
278 addr
= unpack_pointer (type
, valaddr
);
279 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
281 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
283 /* Try to print what function it points to. */
284 print_address_demangle (gdbarch
, addr
, stream
, demangle
);
285 /* Return value is irrelevant except for string pointers. */
289 if (options
->addressprint
&& options
->format
!= 's')
290 fputs_filtered (paddress (gdbarch
, addr
), stream
);
292 /* For a pointer to char or unsigned char, also print the string
293 pointed to, unless pointer is null. */
294 if (TYPE_LENGTH (elttype
) == 1
295 && TYPE_CODE (elttype
) == TYPE_CODE_INT
296 && (options
->format
== 0 || options
->format
== 's')
298 i
= val_print_string (TYPE_TARGET_TYPE (type
), addr
, -1, stream
,
301 /* Return number of characters printed, including the terminating
302 '\0' if we reached the end. val_print_string takes care including
303 the terminating '\0' if necessary. */
309 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
310 if (options
->addressprint
)
313 = extract_typed_address (valaddr
+ embedded_offset
, type
);
314 fprintf_filtered (stream
, "@");
315 fputs_filtered (paddress (gdbarch
, addr
), stream
);
316 if (options
->deref_ref
)
317 fputs_filtered (": ", stream
);
319 /* De-reference the reference. */
320 if (options
->deref_ref
)
322 if (TYPE_CODE (elttype
) != TYPE_CODE_UNDEF
)
324 struct value
*deref_val
=
326 (TYPE_TARGET_TYPE (type
),
327 unpack_pointer (type
, valaddr
+ embedded_offset
));
328 common_val_print (deref_val
, stream
, recurse
,
329 options
, current_language
);
332 fputs_filtered ("???", stream
);
339 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
342 /* FIXME, we should consider, at least for ANSI C language, eliminating
343 the distinction made between FUNCs and POINTERs to FUNCs. */
344 fprintf_filtered (stream
, "{");
345 type_print (type
, "", stream
, -1);
346 fprintf_filtered (stream
, "} ");
347 /* Try to print what function it points to, and its address. */
348 print_address_demangle (gdbarch
, address
, stream
, demangle
);
352 if (options
->format
|| options
->output_format
)
354 struct value_print_options opts
= *options
;
355 opts
.format
= (options
->format
? options
->format
356 : options
->output_format
);
357 print_scalar_formatted (valaddr
, type
, &opts
, 0, stream
);
361 val_print_type_code_int (type
, valaddr
, stream
);
362 /* C and C++ has no single byte int type, char is used instead.
363 Since we don't know whether the value is really intended to
364 be used as an integer or a character, print the character
365 equivalent as well. */
366 if (TYPE_LENGTH (type
) == 1)
368 fputs_filtered (" ", stream
);
369 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
375 case TYPE_CODE_FLAGS
:
377 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
379 val_print_type_code_flags (type
, valaddr
, stream
);
384 print_scalar_formatted (valaddr
, type
, options
, 0, stream
);
386 print_floating (valaddr
, type
, stream
);
390 fprintf_filtered (stream
, "VOID");
393 case TYPE_CODE_ERROR
:
394 fprintf_filtered (stream
, "<error type>");
397 case TYPE_CODE_RANGE
:
398 /* FIXME, we should not ever have to print one of these yet. */
399 fprintf_filtered (stream
, "<range type>");
403 if (options
->format
|| options
->output_format
)
405 struct value_print_options opts
= *options
;
406 opts
.format
= (options
->format
? options
->format
407 : options
->output_format
);
408 print_scalar_formatted (valaddr
, type
, &opts
, 0, stream
);
412 val
= extract_unsigned_integer (valaddr
, TYPE_LENGTH (type
));
415 fprintf_filtered (stream
, ".FALSE.");
417 fprintf_filtered (stream
, ".TRUE.");
419 /* Not a legitimate logical type, print as an integer. */
421 /* Bash the type code temporarily. */
422 TYPE_CODE (type
) = TYPE_CODE_INT
;
423 f_val_print (type
, valaddr
, 0, address
, stream
, recurse
, options
);
424 /* Restore the type code so later uses work as intended. */
425 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
430 case TYPE_CODE_COMPLEX
:
431 type
= TYPE_TARGET_TYPE (type
);
432 fputs_filtered ("(", stream
);
433 print_floating (valaddr
, type
, stream
);
434 fputs_filtered (",", stream
);
435 print_floating (valaddr
+ TYPE_LENGTH (type
), type
, stream
);
436 fputs_filtered (")", stream
);
439 case TYPE_CODE_UNDEF
:
440 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
441 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
442 and no complete type for struct foo in that file. */
443 fprintf_filtered (stream
, "<incomplete type>");
446 case TYPE_CODE_STRUCT
:
447 case TYPE_CODE_UNION
:
448 /* Starting from the Fortran 90 standard, Fortran supports derived
450 fprintf_filtered (stream
, "( ");
451 for (index
= 0; index
< TYPE_NFIELDS (type
); index
++)
453 int offset
= TYPE_FIELD_BITPOS (type
, index
) / 8;
454 f_val_print (TYPE_FIELD_TYPE (type
, index
), valaddr
+ offset
,
455 embedded_offset
, address
, stream
, recurse
, options
);
456 if (index
!= TYPE_NFIELDS (type
) - 1)
457 fputs_filtered (", ", stream
);
459 fprintf_filtered (stream
, " )");
463 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type
));
470 list_all_visible_commons (char *funname
)
472 SAVED_F77_COMMON_PTR tmp
;
474 tmp
= head_common_list
;
476 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
480 if (strcmp (tmp
->owning_function
, funname
) == 0)
481 printf_filtered ("%s\n", tmp
->name
);
487 /* This function is used to print out the values in a given COMMON
488 block. It will always use the most local common block of the
492 info_common_command (char *comname
, int from_tty
)
494 SAVED_F77_COMMON_PTR the_common
;
495 COMMON_ENTRY_PTR entry
;
496 struct frame_info
*fi
;
500 /* We have been told to display the contents of F77 COMMON
501 block supposedly visible in this function. Let us
502 first make sure that it is visible and if so, let
503 us display its contents */
505 fi
= get_selected_frame (_("No frame selected"));
507 /* The following is generally ripped off from stack.c's routine
508 print_frame_info() */
510 func
= find_pc_function (get_frame_pc (fi
));
513 /* In certain pathological cases, the symtabs give the wrong
514 function (when we are in the first function in a file which
515 is compiled without debugging symbols, the previous function
516 is compiled with debugging symbols, and the "foo.o" symbol
517 that is supposed to tell us where the file with debugging symbols
518 ends has been truncated by ar because it is longer than 15
521 So look in the minimal symbol tables as well, and if it comes
522 up with a larger address for the function use that instead.
523 I don't think this can ever cause any problems; there shouldn't
524 be any minimal symbols in the middle of a function.
525 FIXME: (Not necessarily true. What about text labels) */
527 struct minimal_symbol
*msymbol
=
528 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
531 && (SYMBOL_VALUE_ADDRESS (msymbol
)
532 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
533 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
535 funname
= SYMBOL_LINKAGE_NAME (func
);
539 struct minimal_symbol
*msymbol
=
540 lookup_minimal_symbol_by_pc (get_frame_pc (fi
));
543 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
544 else /* Got no 'funname', code below will fail. */
545 error (_("No function found for frame."));
548 /* If comname is NULL, we assume the user wishes to see the
549 which COMMON blocks are visible here and then return */
553 list_all_visible_commons (funname
);
557 the_common
= find_common_for_function (comname
, funname
);
561 if (strcmp (comname
, BLANK_COMMON_NAME_LOCAL
) == 0)
562 printf_filtered (_("Contents of blank COMMON block:\n"));
564 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname
);
566 printf_filtered ("\n");
567 entry
= the_common
->entries
;
569 while (entry
!= NULL
)
571 print_variable_and_value (NULL
, entry
->symbol
, fi
, gdb_stdout
, 0);
576 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
580 /* This function is used to determine whether there is a
581 F77 common block visible at the current scope called 'comname'. */
585 there_is_a_visible_common_named (char *comname
)
587 SAVED_F77_COMMON_PTR the_common
;
588 struct frame_info
*fi
;
593 error (_("Cannot deal with NULL common name!"));
595 fi
= get_selected_frame (_("No frame selected"));
597 /* The following is generally ripped off from stack.c's routine
598 print_frame_info() */
600 func
= find_pc_function (fi
->pc
);
603 /* In certain pathological cases, the symtabs give the wrong
604 function (when we are in the first function in a file which
605 is compiled without debugging symbols, the previous function
606 is compiled with debugging symbols, and the "foo.o" symbol
607 that is supposed to tell us where the file with debugging symbols
608 ends has been truncated by ar because it is longer than 15
611 So look in the minimal symbol tables as well, and if it comes
612 up with a larger address for the function use that instead.
613 I don't think this can ever cause any problems; there shouldn't
614 be any minimal symbols in the middle of a function.
615 FIXME: (Not necessarily true. What about text labels) */
617 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
620 && (SYMBOL_VALUE_ADDRESS (msymbol
)
621 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
622 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
624 funname
= SYMBOL_LINKAGE_NAME (func
);
628 struct minimal_symbol
*msymbol
=
629 lookup_minimal_symbol_by_pc (fi
->pc
);
632 funname
= SYMBOL_LINKAGE_NAME (msymbol
);
635 the_common
= find_common_for_function (comname
, funname
);
637 return (the_common
? 1 : 0);
642 _initialize_f_valprint (void)
644 add_info ("common", info_common_command
,
645 _("Print out the values contained in a Fortran COMMON block."));
647 add_com ("lc", class_info
, info_common_command
,
648 _("Print out the values contained in a Fortran COMMON block."));