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 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 2 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, write to the Free Software
23 Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 Boston, MA 02110-1301, USA. */
27 #include "gdb_string.h"
30 #include "expression.h"
41 static int there_is_a_visible_common_named (char *);
44 extern void _initialize_f_valprint (void);
45 static void info_common_command (char *, int);
46 static void list_all_visible_commons (char *);
47 static void f77_create_arrayprint_offset_tbl (struct type *,
49 static void f77_get_dynamic_length_of_aggregate (struct type *);
51 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
53 /* Array which holds offsets to be applied to get a row's elements
54 for a given array. Array also holds the size of each subarray. */
56 /* The following macro gives us the size of the nth dimension, Where
59 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
61 /* The following gives us the offset for row n where n is 1-based. */
63 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
66 f77_get_dynamic_lowerbound (struct type *type, int *lower_bound)
68 CORE_ADDR current_frame_addr;
69 CORE_ADDR ptr_to_lower_bound;
71 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
73 case BOUND_BY_VALUE_ON_STACK:
74 current_frame_addr = get_frame_base (deprecated_selected_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 current_frame_addr = get_frame_base (deprecated_selected_frame);
99 if (current_frame_addr > 0)
102 read_memory_typed_address (current_frame_addr +
103 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
104 builtin_type_void_data_ptr);
105 *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
109 *lower_bound = DEFAULT_LOWER_BOUND;
110 return BOUND_FETCH_ERROR;
114 case BOUND_BY_REF_IN_REG:
115 case BOUND_BY_VALUE_IN_REG:
117 error (_("??? unhandled dynamic array bound type ???"));
120 return BOUND_FETCH_OK;
124 f77_get_dynamic_upperbound (struct type *type, int *upper_bound)
126 CORE_ADDR current_frame_addr = 0;
127 CORE_ADDR ptr_to_upper_bound;
129 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
131 case BOUND_BY_VALUE_ON_STACK:
132 current_frame_addr = get_frame_base (deprecated_selected_frame);
133 if (current_frame_addr > 0)
136 read_memory_integer (current_frame_addr +
137 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
142 *upper_bound = DEFAULT_UPPER_BOUND;
143 return BOUND_FETCH_ERROR;
148 *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
151 case BOUND_CANNOT_BE_DETERMINED:
152 /* we have an assumed size array on our hands. Assume that
153 upper_bound == lower_bound so that we show at least
154 1 element.If the user wants to see more elements, let
155 him manually ask for 'em and we'll subscript the
156 array and show him */
157 f77_get_dynamic_lowerbound (type, upper_bound);
160 case BOUND_BY_REF_ON_STACK:
161 current_frame_addr = get_frame_base (deprecated_selected_frame);
162 if (current_frame_addr > 0)
165 read_memory_typed_address (current_frame_addr +
166 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
167 builtin_type_void_data_ptr);
168 *upper_bound = read_memory_integer (ptr_to_upper_bound, 4);
172 *upper_bound = DEFAULT_UPPER_BOUND;
173 return BOUND_FETCH_ERROR;
177 case BOUND_BY_REF_IN_REG:
178 case BOUND_BY_VALUE_IN_REG:
180 error (_("??? unhandled dynamic array bound type ???"));
183 return BOUND_FETCH_OK;
186 /* Obtain F77 adjustable array dimensions */
189 f77_get_dynamic_length_of_aggregate (struct type *type)
191 int upper_bound = -1;
195 /* Recursively go all the way down into a possibly multi-dimensional
196 F77 array and get the bounds. For simple arrays, this is pretty
197 easy but when the bounds are dynamic, we must be very careful
198 to add up all the lengths correctly. Not doing this right
199 will lead to horrendous-looking arrays in parameter lists.
201 This function also works for strings which behave very
202 similarly to arrays. */
204 if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
205 || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
206 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
208 /* Recursion ends here, start setting up lengths. */
209 retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
210 if (retcode == BOUND_FETCH_ERROR)
211 error (_("Cannot obtain valid array lower bound"));
213 retcode = f77_get_dynamic_upperbound (type, &upper_bound);
214 if (retcode == BOUND_FETCH_ERROR)
215 error (_("Cannot obtain valid array upper bound"));
217 /* Patch in a valid length value. */
220 (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
223 /* Function that sets up the array offset,size table for the array
227 f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
229 struct type *tmp_type;
232 int upper, lower, retcode;
236 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
238 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
239 fprintf_filtered (stream, "<assumed size array> ");
241 retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
242 if (retcode == BOUND_FETCH_ERROR)
243 error (_("Cannot obtain dynamic upper bound"));
245 retcode = f77_get_dynamic_lowerbound (tmp_type, &lower);
246 if (retcode == BOUND_FETCH_ERROR)
247 error (_("Cannot obtain dynamic lower bound"));
249 F77_DIM_SIZE (ndimen) = upper - lower + 1;
251 tmp_type = TYPE_TARGET_TYPE (tmp_type);
255 /* Now we multiply eltlen by all the offsets, so that later we
256 can print out array elements correctly. Up till now we
257 know an offset to apply to get the item but we also
258 have to know how much to add to get to the next item */
261 eltlen = TYPE_LENGTH (tmp_type);
262 F77_DIM_OFFSET (ndimen) = eltlen;
265 eltlen *= F77_DIM_SIZE (ndimen + 1);
266 F77_DIM_OFFSET (ndimen) = eltlen;
272 /* Actual function which prints out F77 arrays, Valaddr == address in
273 the superior. Address == the address in the inferior. */
276 f77_print_array_1 (int nss, int ndimensions, struct type *type,
277 const gdb_byte *valaddr, CORE_ADDR address,
278 struct ui_file *stream, int format,
279 int deref_ref, int recurse, enum val_prettyprint pretty,
284 if (nss != ndimensions)
286 for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++)
288 fprintf_filtered (stream, "( ");
289 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
290 valaddr + i * F77_DIM_OFFSET (nss),
291 address + i * F77_DIM_OFFSET (nss),
292 stream, format, deref_ref, recurse, pretty, elts);
293 fprintf_filtered (stream, ") ");
295 if (*elts >= print_max && i < F77_DIM_SIZE (nss))
296 fprintf_filtered (stream, "...");
300 for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max;
303 val_print (TYPE_TARGET_TYPE (type),
304 valaddr + i * F77_DIM_OFFSET (ndimensions),
306 address + i * F77_DIM_OFFSET (ndimensions),
307 stream, format, deref_ref, recurse, pretty);
309 if (i != (F77_DIM_SIZE (nss) - 1))
310 fprintf_filtered (stream, ", ");
312 if ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
313 fprintf_filtered (stream, "...");
318 /* This function gets called to print an F77 array, we set up some
319 stuff and then immediately call f77_print_array_1() */
322 f77_print_array (struct type *type, const gdb_byte *valaddr,
323 CORE_ADDR address, struct ui_file *stream,
324 int format, int deref_ref, int recurse,
325 enum val_prettyprint pretty)
330 ndimensions = calc_f77_array_dims (type);
332 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
333 error (_("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
334 ndimensions, MAX_FORTRAN_DIMS);
336 /* Since F77 arrays are stored column-major, we set up an
337 offset table to get at the various row's elements. The
338 offset table contains entries for both offset and subarray size. */
340 f77_create_arrayprint_offset_tbl (type, stream);
342 f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
343 deref_ref, recurse, pretty, &elts);
347 /* Print data of type TYPE located at VALADDR (within GDB), which came from
348 the inferior at address ADDRESS, onto stdio stream STREAM according to
349 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
352 If the data are a string pointer, returns the number of string characters
355 If DEREF_REF is nonzero, then dereference references, otherwise just print
358 The PRETTY parameter controls prettyprinting. */
361 f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
362 CORE_ADDR address, struct ui_file *stream, int format,
363 int deref_ref, int recurse, enum val_prettyprint pretty)
365 unsigned int i = 0; /* Number of characters printed */
366 struct type *elttype;
370 CHECK_TYPEDEF (type);
371 switch (TYPE_CODE (type))
373 case TYPE_CODE_STRING:
374 f77_get_dynamic_length_of_aggregate (type);
375 LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
378 case TYPE_CODE_ARRAY:
379 fprintf_filtered (stream, "(");
380 f77_print_array (type, valaddr, address, stream, format,
381 deref_ref, recurse, pretty);
382 fprintf_filtered (stream, ")");
386 if (format && format != 's')
388 print_scalar_formatted (valaddr, type, format, 0, stream);
393 addr = unpack_pointer (type, valaddr);
394 elttype = check_typedef (TYPE_TARGET_TYPE (type));
396 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
398 /* Try to print what function it points to. */
399 print_address_demangle (addr, stream, demangle);
400 /* Return value is irrelevant except for string pointers. */
404 if (addressprint && format != 's')
405 deprecated_print_address_numeric (addr, 1, stream);
407 /* For a pointer to char or unsigned char, also print the string
408 pointed to, unless pointer is null. */
409 if (TYPE_LENGTH (elttype) == 1
410 && TYPE_CODE (elttype) == TYPE_CODE_INT
411 && (format == 0 || format == 's')
413 i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
415 /* Return number of characters printed, including the terminating
416 '\0' if we reached the end. val_print_string takes care including
417 the terminating '\0' if necessary. */
423 elttype = check_typedef (TYPE_TARGET_TYPE (type));
427 = extract_typed_address (valaddr + embedded_offset, type);
428 fprintf_filtered (stream, "@");
429 deprecated_print_address_numeric (addr, 1, stream);
431 fputs_filtered (": ", stream);
433 /* De-reference the reference. */
436 if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
438 struct value *deref_val =
440 (TYPE_TARGET_TYPE (type),
441 unpack_pointer (lookup_pointer_type (builtin_type_void),
442 valaddr + embedded_offset));
443 common_val_print (deref_val, stream, format, deref_ref, recurse,
447 fputs_filtered ("???", stream);
454 print_scalar_formatted (valaddr, type, format, 0, stream);
457 /* FIXME, we should consider, at least for ANSI C language, eliminating
458 the distinction made between FUNCs and POINTERs to FUNCs. */
459 fprintf_filtered (stream, "{");
460 type_print (type, "", stream, -1);
461 fprintf_filtered (stream, "} ");
462 /* Try to print what function it points to, and its address. */
463 print_address_demangle (address, stream, demangle);
467 format = format ? format : output_format;
469 print_scalar_formatted (valaddr, type, format, 0, stream);
472 val_print_type_code_int (type, valaddr, stream);
473 /* C and C++ has no single byte int type, char is used instead.
474 Since we don't know whether the value is really intended to
475 be used as an integer or a character, print the character
476 equivalent as well. */
477 if (TYPE_LENGTH (type) == 1)
479 fputs_filtered (" ", stream);
480 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
486 case TYPE_CODE_FLAGS:
488 print_scalar_formatted (valaddr, type, format, 0, stream);
490 val_print_type_code_flags (type, valaddr, stream);
495 print_scalar_formatted (valaddr, type, format, 0, stream);
497 print_floating (valaddr, type, stream);
501 fprintf_filtered (stream, "VOID");
504 case TYPE_CODE_ERROR:
505 fprintf_filtered (stream, "<error type>");
508 case TYPE_CODE_RANGE:
509 /* FIXME, we should not ever have to print one of these yet. */
510 fprintf_filtered (stream, "<range type>");
514 format = format ? format : output_format;
516 print_scalar_formatted (valaddr, type, format, 0, stream);
520 switch (TYPE_LENGTH (type))
523 val = unpack_long (builtin_type_f_logical_s1, valaddr);
527 val = unpack_long (builtin_type_f_logical_s2, valaddr);
531 val = unpack_long (builtin_type_f_logical, valaddr);
535 error (_("Logicals of length %d bytes not supported"),
541 fprintf_filtered (stream, ".FALSE.");
543 fprintf_filtered (stream, ".TRUE.");
545 /* Not a legitimate logical type, print as an integer. */
547 /* Bash the type code temporarily. */
548 TYPE_CODE (type) = TYPE_CODE_INT;
549 f_val_print (type, valaddr, 0, address, stream, format,
550 deref_ref, recurse, pretty);
551 /* Restore the type code so later uses work as intended. */
552 TYPE_CODE (type) = TYPE_CODE_BOOL;
557 case TYPE_CODE_COMPLEX:
558 switch (TYPE_LENGTH (type))
561 type = builtin_type_f_real;
564 type = builtin_type_f_real_s8;
567 type = builtin_type_f_real_s16;
570 error (_("Cannot print out complex*%d variables"), TYPE_LENGTH (type));
572 fputs_filtered ("(", stream);
573 print_floating (valaddr, type, stream);
574 fputs_filtered (",", stream);
575 print_floating (valaddr + TYPE_LENGTH (type), type, stream);
576 fputs_filtered (")", stream);
579 case TYPE_CODE_UNDEF:
580 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
581 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
582 and no complete type for struct foo in that file. */
583 fprintf_filtered (stream, "<incomplete type>");
587 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
594 list_all_visible_commons (char *funname)
596 SAVED_F77_COMMON_PTR tmp;
598 tmp = head_common_list;
600 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
604 if (strcmp (tmp->owning_function, funname) == 0)
605 printf_filtered ("%s\n", tmp->name);
611 /* This function is used to print out the values in a given COMMON
612 block. It will always use the most local common block of the
616 info_common_command (char *comname, int from_tty)
618 SAVED_F77_COMMON_PTR the_common;
619 COMMON_ENTRY_PTR entry;
620 struct frame_info *fi;
624 /* We have been told to display the contents of F77 COMMON
625 block supposedly visible in this function. Let us
626 first make sure that it is visible and if so, let
627 us display its contents */
629 fi = deprecated_selected_frame;
632 error (_("No frame selected"));
634 /* The following is generally ripped off from stack.c's routine
635 print_frame_info() */
637 func = find_pc_function (get_frame_pc (fi));
640 /* In certain pathological cases, the symtabs give the wrong
641 function (when we are in the first function in a file which
642 is compiled without debugging symbols, the previous function
643 is compiled with debugging symbols, and the "foo.o" symbol
644 that is supposed to tell us where the file with debugging symbols
645 ends has been truncated by ar because it is longer than 15
648 So look in the minimal symbol tables as well, and if it comes
649 up with a larger address for the function use that instead.
650 I don't think this can ever cause any problems; there shouldn't
651 be any minimal symbols in the middle of a function.
652 FIXME: (Not necessarily true. What about text labels) */
654 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
657 && (SYMBOL_VALUE_ADDRESS (msymbol)
658 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
659 funname = DEPRECATED_SYMBOL_NAME (msymbol);
661 funname = DEPRECATED_SYMBOL_NAME (func);
665 struct minimal_symbol *msymbol =
666 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
669 funname = DEPRECATED_SYMBOL_NAME (msymbol);
672 /* If comname is NULL, we assume the user wishes to see the
673 which COMMON blocks are visible here and then return */
677 list_all_visible_commons (funname);
681 the_common = find_common_for_function (comname, funname);
685 if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
686 printf_filtered (_("Contents of blank COMMON block:\n"));
688 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
690 printf_filtered ("\n");
691 entry = the_common->entries;
693 while (entry != NULL)
695 printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol));
696 print_variable_value (entry->symbol, fi, gdb_stdout);
697 printf_filtered ("\n");
702 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
706 /* This function is used to determine whether there is a
707 F77 common block visible at the current scope called 'comname'. */
711 there_is_a_visible_common_named (char *comname)
713 SAVED_F77_COMMON_PTR the_common;
714 struct frame_info *fi;
719 error (_("Cannot deal with NULL common name!"));
721 fi = deprecated_selected_frame;
724 error (_("No frame selected"));
726 /* The following is generally ripped off from stack.c's routine
727 print_frame_info() */
729 func = find_pc_function (fi->pc);
732 /* In certain pathological cases, the symtabs give the wrong
733 function (when we are in the first function in a file which
734 is compiled without debugging symbols, the previous function
735 is compiled with debugging symbols, and the "foo.o" symbol
736 that is supposed to tell us where the file with debugging symbols
737 ends has been truncated by ar because it is longer than 15
740 So look in the minimal symbol tables as well, and if it comes
741 up with a larger address for the function use that instead.
742 I don't think this can ever cause any problems; there shouldn't
743 be any minimal symbols in the middle of a function.
744 FIXME: (Not necessarily true. What about text labels) */
746 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
749 && (SYMBOL_VALUE_ADDRESS (msymbol)
750 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
751 funname = DEPRECATED_SYMBOL_NAME (msymbol);
753 funname = DEPRECATED_SYMBOL_NAME (func);
757 struct minimal_symbol *msymbol =
758 lookup_minimal_symbol_by_pc (fi->pc);
761 funname = DEPRECATED_SYMBOL_NAME (msymbol);
764 the_common = find_common_for_function (comname, funname);
766 return (the_common ? 1 : 0);
771 _initialize_f_valprint (void)
773 add_info ("common", info_common_command,
774 _("Print out the values contained in a Fortran COMMON block."));
776 add_com ("lc", class_info, info_common_command,
777 _("Print out the values contained in a Fortran COMMON block."));