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)
103 read_memory_typed_address (current_frame_addr +
104 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
105 builtin_type_void_data_ptr);
106 *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
110 *lower_bound = DEFAULT_LOWER_BOUND;
111 return BOUND_FETCH_ERROR;
115 case BOUND_BY_REF_IN_REG:
116 case BOUND_BY_VALUE_IN_REG:
118 error (_("??? unhandled dynamic array bound type ???"));
121 return BOUND_FETCH_OK;
125 f77_get_dynamic_upperbound (struct type *type, int *upper_bound)
127 struct frame_info *frame;
128 CORE_ADDR current_frame_addr = 0;
129 CORE_ADDR ptr_to_upper_bound;
131 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
133 case BOUND_BY_VALUE_ON_STACK:
134 frame = deprecated_safe_get_selected_frame ();
135 current_frame_addr = get_frame_base (frame);
136 if (current_frame_addr > 0)
139 read_memory_integer (current_frame_addr +
140 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
145 *upper_bound = DEFAULT_UPPER_BOUND;
146 return BOUND_FETCH_ERROR;
151 *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
154 case BOUND_CANNOT_BE_DETERMINED:
155 /* we have an assumed size array on our hands. Assume that
156 upper_bound == lower_bound so that we show at least
157 1 element.If the user wants to see more elements, let
158 him manually ask for 'em and we'll subscript the
159 array and show him */
160 f77_get_dynamic_lowerbound (type, upper_bound);
163 case BOUND_BY_REF_ON_STACK:
164 frame = deprecated_safe_get_selected_frame ();
165 current_frame_addr = get_frame_base (frame);
166 if (current_frame_addr > 0)
169 read_memory_typed_address (current_frame_addr +
170 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
171 builtin_type_void_data_ptr);
172 *upper_bound = read_memory_integer (ptr_to_upper_bound, 4);
176 *upper_bound = DEFAULT_UPPER_BOUND;
177 return BOUND_FETCH_ERROR;
181 case BOUND_BY_REF_IN_REG:
182 case BOUND_BY_VALUE_IN_REG:
184 error (_("??? unhandled dynamic array bound type ???"));
187 return BOUND_FETCH_OK;
190 /* Obtain F77 adjustable array dimensions */
193 f77_get_dynamic_length_of_aggregate (struct type *type)
195 int upper_bound = -1;
199 /* Recursively go all the way down into a possibly multi-dimensional
200 F77 array and get the bounds. For simple arrays, this is pretty
201 easy but when the bounds are dynamic, we must be very careful
202 to add up all the lengths correctly. Not doing this right
203 will lead to horrendous-looking arrays in parameter lists.
205 This function also works for strings which behave very
206 similarly to arrays. */
208 if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
209 || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
210 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
212 /* Recursion ends here, start setting up lengths. */
213 retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
214 if (retcode == BOUND_FETCH_ERROR)
215 error (_("Cannot obtain valid array lower bound"));
217 retcode = f77_get_dynamic_upperbound (type, &upper_bound);
218 if (retcode == BOUND_FETCH_ERROR)
219 error (_("Cannot obtain valid array upper bound"));
221 /* Patch in a valid length value. */
224 (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
227 /* Function that sets up the array offset,size table for the array
231 f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
233 struct type *tmp_type;
236 int upper, lower, retcode;
240 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
242 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
243 fprintf_filtered (stream, "<assumed size array> ");
245 retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
246 if (retcode == BOUND_FETCH_ERROR)
247 error (_("Cannot obtain dynamic upper bound"));
249 retcode = f77_get_dynamic_lowerbound (tmp_type, &lower);
250 if (retcode == BOUND_FETCH_ERROR)
251 error (_("Cannot obtain dynamic lower bound"));
253 F77_DIM_SIZE (ndimen) = upper - lower + 1;
255 tmp_type = TYPE_TARGET_TYPE (tmp_type);
259 /* Now we multiply eltlen by all the offsets, so that later we
260 can print out array elements correctly. Up till now we
261 know an offset to apply to get the item but we also
262 have to know how much to add to get to the next item */
265 eltlen = TYPE_LENGTH (tmp_type);
266 F77_DIM_OFFSET (ndimen) = eltlen;
269 eltlen *= F77_DIM_SIZE (ndimen + 1);
270 F77_DIM_OFFSET (ndimen) = eltlen;
276 /* Actual function which prints out F77 arrays, Valaddr == address in
277 the superior. Address == the address in the inferior. */
280 f77_print_array_1 (int nss, int ndimensions, struct type *type,
281 const gdb_byte *valaddr, CORE_ADDR address,
282 struct ui_file *stream, int format,
283 int deref_ref, int recurse, enum val_prettyprint pretty,
288 if (nss != ndimensions)
290 for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++)
292 fprintf_filtered (stream, "( ");
293 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
294 valaddr + i * F77_DIM_OFFSET (nss),
295 address + i * F77_DIM_OFFSET (nss),
296 stream, format, deref_ref, recurse, pretty, elts);
297 fprintf_filtered (stream, ") ");
299 if (*elts >= print_max && i < F77_DIM_SIZE (nss))
300 fprintf_filtered (stream, "...");
304 for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max;
307 val_print (TYPE_TARGET_TYPE (type),
308 valaddr + i * F77_DIM_OFFSET (ndimensions),
310 address + i * F77_DIM_OFFSET (ndimensions),
311 stream, format, deref_ref, recurse, pretty,
314 if (i != (F77_DIM_SIZE (nss) - 1))
315 fprintf_filtered (stream, ", ");
317 if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
318 fprintf_filtered (stream, "...");
323 /* This function gets called to print an F77 array, we set up some
324 stuff and then immediately call f77_print_array_1() */
327 f77_print_array (struct type *type, const gdb_byte *valaddr,
328 CORE_ADDR address, struct ui_file *stream,
329 int format, int deref_ref, int recurse,
330 enum val_prettyprint pretty)
335 ndimensions = calc_f77_array_dims (type);
337 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
338 error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
339 ndimensions, MAX_FORTRAN_DIMS);
341 /* Since F77 arrays are stored column-major, we set up an
342 offset table to get at the various row's elements. The
343 offset table contains entries for both offset and subarray size. */
345 f77_create_arrayprint_offset_tbl (type, stream);
347 f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
348 deref_ref, recurse, pretty, &elts);
352 /* Print data of type TYPE located at VALADDR (within GDB), which came from
353 the inferior at address ADDRESS, onto stdio stream STREAM according to
354 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
357 If the data are a string pointer, returns the number of string characters
360 If DEREF_REF is nonzero, then dereference references, otherwise just print
363 The PRETTY parameter controls prettyprinting. */
366 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
367 CORE_ADDR address, struct ui_file *stream, int format,
368 int deref_ref, int recurse, enum val_prettyprint pretty)
370 unsigned int i = 0; /* Number of characters printed */
371 struct type *elttype;
376 CHECK_TYPEDEF (type);
377 switch (TYPE_CODE (type))
379 case TYPE_CODE_STRING:
380 f77_get_dynamic_length_of_aggregate (type);
381 LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
384 case TYPE_CODE_ARRAY:
385 fprintf_filtered (stream, "(");
386 f77_print_array (type, valaddr, address, stream, format,
387 deref_ref, recurse, pretty);
388 fprintf_filtered (stream, ")");
392 if (format && format != 's')
394 print_scalar_formatted (valaddr, type, format, 0, stream);
399 addr = unpack_pointer (type, valaddr);
400 elttype = check_typedef (TYPE_TARGET_TYPE (type));
402 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
404 /* Try to print what function it points to. */
405 print_address_demangle (addr, stream, demangle);
406 /* Return value is irrelevant except for string pointers. */
410 if (addressprint && format != 's')
411 fputs_filtered (paddress (addr), stream);
413 /* For a pointer to char or unsigned char, also print the string
414 pointed to, unless pointer is null. */
415 if (TYPE_LENGTH (elttype) == 1
416 && TYPE_CODE (elttype) == TYPE_CODE_INT
417 && (format == 0 || format == 's')
419 i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
421 /* Return number of characters printed, including the terminating
422 '\0' if we reached the end. val_print_string takes care including
423 the terminating '\0' if necessary. */
429 elttype = check_typedef (TYPE_TARGET_TYPE (type));
433 = extract_typed_address (valaddr + embedded_offset, type);
434 fprintf_filtered (stream, "@");
435 fputs_filtered (paddress (addr), stream);
437 fputs_filtered (": ", stream);
439 /* De-reference the reference. */
442 if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
444 struct value *deref_val =
446 (TYPE_TARGET_TYPE (type),
447 unpack_pointer (type, valaddr + embedded_offset));
448 common_val_print (deref_val, stream, format, deref_ref, recurse,
449 pretty, current_language);
452 fputs_filtered ("???", stream);
459 print_scalar_formatted (valaddr, type, format, 0, stream);
462 /* FIXME, we should consider, at least for ANSI C language, eliminating
463 the distinction made between FUNCs and POINTERs to FUNCs. */
464 fprintf_filtered (stream, "{");
465 type_print (type, "", stream, -1);
466 fprintf_filtered (stream, "} ");
467 /* Try to print what function it points to, and its address. */
468 print_address_demangle (address, stream, demangle);
472 format = format ? format : output_format;
474 print_scalar_formatted (valaddr, type, format, 0, stream);
477 val_print_type_code_int (type, valaddr, stream);
478 /* C and C++ has no single byte int type, char is used instead.
479 Since we don't know whether the value is really intended to
480 be used as an integer or a character, print the character
481 equivalent as well. */
482 if (TYPE_LENGTH (type) == 1)
484 fputs_filtered (" ", stream);
485 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
491 case TYPE_CODE_FLAGS:
493 print_scalar_formatted (valaddr, type, format, 0, stream);
495 val_print_type_code_flags (type, valaddr, stream);
500 print_scalar_formatted (valaddr, type, format, 0, stream);
502 print_floating (valaddr, type, stream);
506 fprintf_filtered (stream, "VOID");
509 case TYPE_CODE_ERROR:
510 fprintf_filtered (stream, "<error type>");
513 case TYPE_CODE_RANGE:
514 /* FIXME, we should not ever have to print one of these yet. */
515 fprintf_filtered (stream, "<range type>");
519 format = format ? format : output_format;
521 print_scalar_formatted (valaddr, type, format, 0, stream);
525 switch (TYPE_LENGTH (type))
528 val = unpack_long (builtin_type_f_logical_s1, valaddr);
532 val = unpack_long (builtin_type_f_logical_s2, valaddr);
536 val = unpack_long (builtin_type_f_logical, valaddr);
540 error (_("Logicals of length %d bytes not supported"),
546 fprintf_filtered (stream, ".FALSE.");
548 fprintf_filtered (stream, ".TRUE.");
550 /* Not a legitimate logical type, print as an integer. */
552 /* Bash the type code temporarily. */
553 TYPE_CODE (type) = TYPE_CODE_INT;
554 f_val_print (type, valaddr, 0, address, stream, format,
555 deref_ref, recurse, pretty);
556 /* Restore the type code so later uses work as intended. */
557 TYPE_CODE (type) = TYPE_CODE_BOOL;
562 case TYPE_CODE_COMPLEX:
563 switch (TYPE_LENGTH (type))
566 type = builtin_type_f_real;
569 type = builtin_type_f_real_s8;
572 type = builtin_type_f_real_s16;
575 error (_("Cannot print out complex*%d variables"), TYPE_LENGTH (type));
577 fputs_filtered ("(", stream);
578 print_floating (valaddr, type, stream);
579 fputs_filtered (",", stream);
580 print_floating (valaddr + TYPE_LENGTH (type), type, stream);
581 fputs_filtered (")", stream);
584 case TYPE_CODE_UNDEF:
585 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
586 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
587 and no complete type for struct foo in that file. */
588 fprintf_filtered (stream, "<incomplete type>");
591 case TYPE_CODE_STRUCT:
592 case TYPE_CODE_UNION:
593 /* Starting from the Fortran 90 standard, Fortran supports derived
595 fprintf_filtered (stream, "( ");
596 for (index = 0; index < TYPE_NFIELDS (type); index++)
598 int offset = TYPE_FIELD_BITPOS (type, index) / 8;
599 f_val_print (TYPE_FIELD_TYPE (type, index), valaddr + offset,
600 embedded_offset, address, stream,
601 format, deref_ref, recurse, pretty);
602 if (index != TYPE_NFIELDS (type) - 1)
603 fputs_filtered (", ", stream);
605 fprintf_filtered (stream, " )");
609 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
616 list_all_visible_commons (char *funname)
618 SAVED_F77_COMMON_PTR tmp;
620 tmp = head_common_list;
622 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
626 if (strcmp (tmp->owning_function, funname) == 0)
627 printf_filtered ("%s\n", tmp->name);
633 /* This function is used to print out the values in a given COMMON
634 block. It will always use the most local common block of the
638 info_common_command (char *comname, int from_tty)
640 SAVED_F77_COMMON_PTR the_common;
641 COMMON_ENTRY_PTR entry;
642 struct frame_info *fi;
646 /* We have been told to display the contents of F77 COMMON
647 block supposedly visible in this function. Let us
648 first make sure that it is visible and if so, let
649 us display its contents */
651 fi = get_selected_frame (_("No frame selected"));
653 /* The following is generally ripped off from stack.c's routine
654 print_frame_info() */
656 func = find_pc_function (get_frame_pc (fi));
659 /* In certain pathological cases, the symtabs give the wrong
660 function (when we are in the first function in a file which
661 is compiled without debugging symbols, the previous function
662 is compiled with debugging symbols, and the "foo.o" symbol
663 that is supposed to tell us where the file with debugging symbols
664 ends has been truncated by ar because it is longer than 15
667 So look in the minimal symbol tables as well, and if it comes
668 up with a larger address for the function use that instead.
669 I don't think this can ever cause any problems; there shouldn't
670 be any minimal symbols in the middle of a function.
671 FIXME: (Not necessarily true. What about text labels) */
673 struct minimal_symbol *msymbol =
674 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
677 && (SYMBOL_VALUE_ADDRESS (msymbol)
678 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
679 funname = SYMBOL_LINKAGE_NAME (msymbol);
681 funname = SYMBOL_LINKAGE_NAME (func);
685 struct minimal_symbol *msymbol =
686 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
689 funname = SYMBOL_LINKAGE_NAME (msymbol);
690 else /* Got no 'funname', code below will fail. */
691 error (_("No function found for frame."));
694 /* If comname is NULL, we assume the user wishes to see the
695 which COMMON blocks are visible here and then return */
699 list_all_visible_commons (funname);
703 the_common = find_common_for_function (comname, funname);
707 if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
708 printf_filtered (_("Contents of blank COMMON block:\n"));
710 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
712 printf_filtered ("\n");
713 entry = the_common->entries;
715 while (entry != NULL)
717 printf_filtered ("%s = ", SYMBOL_PRINT_NAME (entry->symbol));
718 print_variable_value (entry->symbol, fi, gdb_stdout);
719 printf_filtered ("\n");
724 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
728 /* This function is used to determine whether there is a
729 F77 common block visible at the current scope called 'comname'. */
733 there_is_a_visible_common_named (char *comname)
735 SAVED_F77_COMMON_PTR the_common;
736 struct frame_info *fi;
741 error (_("Cannot deal with NULL common name!"));
743 fi = get_selected_frame (_("No frame selected"));
745 /* The following is generally ripped off from stack.c's routine
746 print_frame_info() */
748 func = find_pc_function (fi->pc);
751 /* In certain pathological cases, the symtabs give the wrong
752 function (when we are in the first function in a file which
753 is compiled without debugging symbols, the previous function
754 is compiled with debugging symbols, and the "foo.o" symbol
755 that is supposed to tell us where the file with debugging symbols
756 ends has been truncated by ar because it is longer than 15
759 So look in the minimal symbol tables as well, and if it comes
760 up with a larger address for the function use that instead.
761 I don't think this can ever cause any problems; there shouldn't
762 be any minimal symbols in the middle of a function.
763 FIXME: (Not necessarily true. What about text labels) */
765 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
768 && (SYMBOL_VALUE_ADDRESS (msymbol)
769 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
770 funname = SYMBOL_LINKAGE_NAME (msymbol);
772 funname = SYMBOL_LINKAGE_NAME (func);
776 struct minimal_symbol *msymbol =
777 lookup_minimal_symbol_by_pc (fi->pc);
780 funname = SYMBOL_LINKAGE_NAME (msymbol);
783 the_common = find_common_for_function (comname, funname);
785 return (the_common ? 1 : 0);
790 _initialize_f_valprint (void)
792 add_info ("common", info_common_command,
793 _("Print out the values contained in a Fortran COMMON block."));
795 add_com ("lc", class_info, info_common_command,
796 _("Print out the values contained in a Fortran COMMON block."));