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 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 unsigned int i = 0; /* Number of characters printed */
249 struct type *elttype;
254 CHECK_TYPEDEF (type);
255 switch (TYPE_CODE (type))
257 case TYPE_CODE_STRING:
258 f77_get_dynamic_length_of_aggregate (type);
259 LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0, options);
262 case TYPE_CODE_ARRAY:
263 fprintf_filtered (stream, "(");
264 f77_print_array (type, valaddr, address, stream, recurse, options);
265 fprintf_filtered (stream, ")");
269 if (options->format && options->format != 's')
271 print_scalar_formatted (valaddr, type, options, 0, stream);
276 addr = unpack_pointer (type, valaddr);
277 elttype = check_typedef (TYPE_TARGET_TYPE (type));
279 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
281 /* Try to print what function it points to. */
282 print_address_demangle (addr, stream, demangle);
283 /* Return value is irrelevant except for string pointers. */
287 if (options->addressprint && options->format != 's')
288 fputs_filtered (paddress (addr), stream);
290 /* For a pointer to char or unsigned char, also print the string
291 pointed to, unless pointer is null. */
292 if (TYPE_LENGTH (elttype) == 1
293 && TYPE_CODE (elttype) == TYPE_CODE_INT
294 && (options->format == 0 || options->format == 's')
296 i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream,
299 /* Return number of characters printed, including the terminating
300 '\0' if we reached the end. val_print_string takes care including
301 the terminating '\0' if necessary. */
307 elttype = check_typedef (TYPE_TARGET_TYPE (type));
308 if (options->addressprint)
311 = extract_typed_address (valaddr + embedded_offset, type);
312 fprintf_filtered (stream, "@");
313 fputs_filtered (paddress (addr), stream);
314 if (options->deref_ref)
315 fputs_filtered (": ", stream);
317 /* De-reference the reference. */
318 if (options->deref_ref)
320 if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
322 struct value *deref_val =
324 (TYPE_TARGET_TYPE (type),
325 unpack_pointer (type, valaddr + embedded_offset));
326 common_val_print (deref_val, stream, recurse,
327 options, current_language);
330 fputs_filtered ("???", stream);
337 print_scalar_formatted (valaddr, type, options, 0, stream);
340 /* FIXME, we should consider, at least for ANSI C language, eliminating
341 the distinction made between FUNCs and POINTERs to FUNCs. */
342 fprintf_filtered (stream, "{");
343 type_print (type, "", stream, -1);
344 fprintf_filtered (stream, "} ");
345 /* Try to print what function it points to, and its address. */
346 print_address_demangle (address, stream, demangle);
350 if (options->format || options->output_format)
352 struct value_print_options opts = *options;
353 opts.format = (options->format ? options->format
354 : options->output_format);
355 print_scalar_formatted (valaddr, type, &opts, 0, stream);
359 val_print_type_code_int (type, valaddr, stream);
360 /* C and C++ has no single byte int type, char is used instead.
361 Since we don't know whether the value is really intended to
362 be used as an integer or a character, print the character
363 equivalent as well. */
364 if (TYPE_LENGTH (type) == 1)
366 fputs_filtered (" ", stream);
367 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
373 case TYPE_CODE_FLAGS:
375 print_scalar_formatted (valaddr, type, options, 0, stream);
377 val_print_type_code_flags (type, valaddr, stream);
382 print_scalar_formatted (valaddr, type, options, 0, stream);
384 print_floating (valaddr, type, stream);
388 fprintf_filtered (stream, "VOID");
391 case TYPE_CODE_ERROR:
392 fprintf_filtered (stream, "<error type>");
395 case TYPE_CODE_RANGE:
396 /* FIXME, we should not ever have to print one of these yet. */
397 fprintf_filtered (stream, "<range type>");
401 if (options->format || options->output_format)
403 struct value_print_options opts = *options;
404 opts.format = (options->format ? options->format
405 : options->output_format);
406 print_scalar_formatted (valaddr, type, &opts, 0, stream);
410 val = extract_unsigned_integer (valaddr, TYPE_LENGTH (type));
413 fprintf_filtered (stream, ".FALSE.");
415 fprintf_filtered (stream, ".TRUE.");
417 /* Not a legitimate logical type, print as an integer. */
419 /* Bash the type code temporarily. */
420 TYPE_CODE (type) = TYPE_CODE_INT;
421 f_val_print (type, valaddr, 0, address, stream, recurse, options);
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, recurse, options);
454 if (index != TYPE_NFIELDS (type) - 1)
455 fputs_filtered (", ", stream);
457 fprintf_filtered (stream, " )");
461 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
468 list_all_visible_commons (char *funname)
470 SAVED_F77_COMMON_PTR tmp;
472 tmp = head_common_list;
474 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
478 if (strcmp (tmp->owning_function, funname) == 0)
479 printf_filtered ("%s\n", tmp->name);
485 /* This function is used to print out the values in a given COMMON
486 block. It will always use the most local common block of the
490 info_common_command (char *comname, int from_tty)
492 SAVED_F77_COMMON_PTR the_common;
493 COMMON_ENTRY_PTR entry;
494 struct frame_info *fi;
498 /* We have been told to display the contents of F77 COMMON
499 block supposedly visible in this function. Let us
500 first make sure that it is visible and if so, let
501 us display its contents */
503 fi = get_selected_frame (_("No frame selected"));
505 /* The following is generally ripped off from stack.c's routine
506 print_frame_info() */
508 func = find_pc_function (get_frame_pc (fi));
511 /* In certain pathological cases, the symtabs give the wrong
512 function (when we are in the first function in a file which
513 is compiled without debugging symbols, the previous function
514 is compiled with debugging symbols, and the "foo.o" symbol
515 that is supposed to tell us where the file with debugging symbols
516 ends has been truncated by ar because it is longer than 15
519 So look in the minimal symbol tables as well, and if it comes
520 up with a larger address for the function use that instead.
521 I don't think this can ever cause any problems; there shouldn't
522 be any minimal symbols in the middle of a function.
523 FIXME: (Not necessarily true. What about text labels) */
525 struct minimal_symbol *msymbol =
526 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
529 && (SYMBOL_VALUE_ADDRESS (msymbol)
530 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
531 funname = SYMBOL_LINKAGE_NAME (msymbol);
533 funname = SYMBOL_LINKAGE_NAME (func);
537 struct minimal_symbol *msymbol =
538 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
541 funname = SYMBOL_LINKAGE_NAME (msymbol);
542 else /* Got no 'funname', code below will fail. */
543 error (_("No function found for frame."));
546 /* If comname is NULL, we assume the user wishes to see the
547 which COMMON blocks are visible here and then return */
551 list_all_visible_commons (funname);
555 the_common = find_common_for_function (comname, funname);
559 if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
560 printf_filtered (_("Contents of blank COMMON block:\n"));
562 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
564 printf_filtered ("\n");
565 entry = the_common->entries;
567 while (entry != NULL)
569 print_variable_and_value (NULL, entry->symbol, fi, gdb_stdout, 0);
574 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
578 /* This function is used to determine whether there is a
579 F77 common block visible at the current scope called 'comname'. */
583 there_is_a_visible_common_named (char *comname)
585 SAVED_F77_COMMON_PTR the_common;
586 struct frame_info *fi;
591 error (_("Cannot deal with NULL common name!"));
593 fi = get_selected_frame (_("No frame selected"));
595 /* The following is generally ripped off from stack.c's routine
596 print_frame_info() */
598 func = find_pc_function (fi->pc);
601 /* In certain pathological cases, the symtabs give the wrong
602 function (when we are in the first function in a file which
603 is compiled without debugging symbols, the previous function
604 is compiled with debugging symbols, and the "foo.o" symbol
605 that is supposed to tell us where the file with debugging symbols
606 ends has been truncated by ar because it is longer than 15
609 So look in the minimal symbol tables as well, and if it comes
610 up with a larger address for the function use that instead.
611 I don't think this can ever cause any problems; there shouldn't
612 be any minimal symbols in the middle of a function.
613 FIXME: (Not necessarily true. What about text labels) */
615 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
618 && (SYMBOL_VALUE_ADDRESS (msymbol)
619 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
620 funname = SYMBOL_LINKAGE_NAME (msymbol);
622 funname = SYMBOL_LINKAGE_NAME (func);
626 struct minimal_symbol *msymbol =
627 lookup_minimal_symbol_by_pc (fi->pc);
630 funname = SYMBOL_LINKAGE_NAME (msymbol);
633 the_common = find_common_for_function (comname, funname);
635 return (the_common ? 1 : 0);
640 _initialize_f_valprint (void)
642 add_info ("common", info_common_command,
643 _("Print out the values contained in a Fortran COMMON block."));
645 add_com ("lc", class_info, info_common_command,
646 _("Print out the values contained in a Fortran COMMON block."));