1 /* Support for printing Fortran values for GDB, the GNU debugger.
2 Copyright 1993, 1994, 1995 Free Software Foundation, Inc.
3 Contributed by Motorola. Adapted from the C definitions by Farooq Butt
4 (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
23 #include "gdb_string.h"
26 #include "expression.h"
37 static int there_is_a_visible_common_named PARAMS ((char *));
40 static void info_common_command PARAMS ((char *, int));
41 static void list_all_visible_commons PARAMS ((char *));
42 static void f77_print_array PARAMS ((struct type *, char *, CORE_ADDR,
43 GDB_FILE *, int, int, int,
44 enum val_prettyprint));
45 static void f77_print_array_1 PARAMS ((int, int, struct type *, char *,
46 CORE_ADDR, GDB_FILE *, int, int, int,
47 enum val_prettyprint));
48 static void f77_create_arrayprint_offset_tbl PARAMS ((struct type *,
50 static void f77_get_dynamic_length_of_aggregate PARAMS ((struct type *));
52 int f77_array_offset_tbl[MAX_FORTRAN_DIMS+1][2];
54 /* Array which holds offsets to be applied to get a row's elements
55 for a given array. Array also holds the size of each subarray. */
57 /* The following macro gives us the size of the nth dimension, Where
60 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
62 /* The following gives us the offset for row n where n is 1-based. */
64 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
67 f77_get_dynamic_lowerbound (type, lower_bound)
71 CORE_ADDR current_frame_addr;
72 CORE_ADDR ptr_to_lower_bound;
74 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
76 case BOUND_BY_VALUE_ON_STACK:
77 current_frame_addr = selected_frame->frame;
78 if (current_frame_addr > 0)
81 read_memory_integer (current_frame_addr +
82 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
87 *lower_bound = DEFAULT_LOWER_BOUND;
88 return BOUND_FETCH_ERROR;
93 *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
96 case BOUND_CANNOT_BE_DETERMINED:
97 error ("Lower bound may not be '*' in F77");
100 case BOUND_BY_REF_ON_STACK:
101 current_frame_addr = selected_frame->frame;
102 if (current_frame_addr > 0)
105 read_memory_integer (current_frame_addr +
106 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
108 *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
112 *lower_bound = DEFAULT_LOWER_BOUND;
113 return BOUND_FETCH_ERROR;
117 case BOUND_BY_REF_IN_REG:
118 case BOUND_BY_VALUE_IN_REG:
120 error ("??? unhandled dynamic array bound type ???");
123 return BOUND_FETCH_OK;
127 f77_get_dynamic_upperbound (type, upper_bound)
131 CORE_ADDR current_frame_addr = 0;
132 CORE_ADDR ptr_to_upper_bound;
134 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
136 case BOUND_BY_VALUE_ON_STACK:
137 current_frame_addr = selected_frame->frame;
138 if (current_frame_addr > 0)
141 read_memory_integer (current_frame_addr +
142 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
147 *upper_bound = DEFAULT_UPPER_BOUND;
148 return BOUND_FETCH_ERROR;
153 *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
156 case BOUND_CANNOT_BE_DETERMINED:
157 /* we have an assumed size array on our hands. Assume that
158 upper_bound == lower_bound so that we show at least
159 1 element.If the user wants to see more elements, let
160 him manually ask for 'em and we'll subscript the
161 array and show him */
162 f77_get_dynamic_lowerbound (type, upper_bound);
165 case BOUND_BY_REF_ON_STACK:
166 current_frame_addr = selected_frame->frame;
167 if (current_frame_addr > 0)
170 read_memory_integer (current_frame_addr +
171 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
173 *upper_bound = read_memory_integer(ptr_to_upper_bound, 4);
177 *upper_bound = DEFAULT_UPPER_BOUND;
178 return BOUND_FETCH_ERROR;
182 case BOUND_BY_REF_IN_REG:
183 case BOUND_BY_VALUE_IN_REG:
185 error ("??? unhandled dynamic array bound type ???");
188 return BOUND_FETCH_OK;
191 /* Obtain F77 adjustable array dimensions */
194 f77_get_dynamic_length_of_aggregate (type)
197 int upper_bound = -1;
201 /* Recursively go all the way down into a possibly multi-dimensional
202 F77 array and get the bounds. For simple arrays, this is pretty
203 easy but when the bounds are dynamic, we must be very careful
204 to add up all the lengths correctly. Not doing this right
205 will lead to horrendous-looking arrays in parameter lists.
207 This function also works for strings which behave very
208 similarly to arrays. */
210 if (TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
211 || TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
212 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
214 /* Recursion ends here, start setting up lengths. */
215 retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
216 if (retcode == BOUND_FETCH_ERROR)
217 error ("Cannot obtain valid array lower bound");
219 retcode = f77_get_dynamic_upperbound (type, &upper_bound);
220 if (retcode == BOUND_FETCH_ERROR)
221 error ("Cannot obtain valid array upper bound");
223 /* Patch in a valid length value. */
226 (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
229 /* Function that sets up the array offset,size table for the array
233 f77_create_arrayprint_offset_tbl (type, stream)
237 struct type *tmp_type;
240 int upper, lower, retcode;
244 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
246 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
247 fprintf_filtered (stream, "<assumed size array> ");
249 retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
250 if (retcode == BOUND_FETCH_ERROR)
251 error ("Cannot obtain dynamic upper bound");
253 retcode = f77_get_dynamic_lowerbound(tmp_type,&lower);
254 if (retcode == BOUND_FETCH_ERROR)
255 error("Cannot obtain dynamic lower bound");
257 F77_DIM_SIZE (ndimen) = upper - lower + 1;
259 tmp_type = TYPE_TARGET_TYPE (tmp_type);
263 /* Now we multiply eltlen by all the offsets, so that later we
264 can print out array elements correctly. Up till now we
265 know an offset to apply to get the item but we also
266 have to know how much to add to get to the next item */
269 eltlen = TYPE_LENGTH (tmp_type);
270 F77_DIM_OFFSET (ndimen) = eltlen;
273 eltlen *= F77_DIM_SIZE (ndimen + 1);
274 F77_DIM_OFFSET (ndimen) = eltlen;
278 /* Actual function which prints out F77 arrays, Valaddr == address in
279 the superior. Address == the address in the inferior. */
282 f77_print_array_1 (nss, ndimensions, type, valaddr, address,
283 stream, format, deref_ref, recurse, pretty)
293 enum val_prettyprint pretty;
297 if (nss != ndimensions)
299 for (i = 0; i< F77_DIM_SIZE(nss); i++)
301 fprintf_filtered (stream, "( ");
302 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
303 valaddr + i * F77_DIM_OFFSET (nss),
304 address + i * F77_DIM_OFFSET (nss),
305 stream, format, deref_ref, recurse, pretty);
306 fprintf_filtered (stream, ") ");
311 for (i = 0; (i < F77_DIM_SIZE (nss) && i < print_max); i++)
313 val_print (TYPE_TARGET_TYPE (type),
314 valaddr + i * F77_DIM_OFFSET (ndimensions),
316 address + i * F77_DIM_OFFSET (ndimensions),
317 stream, format, deref_ref, recurse, pretty);
319 if (i != (F77_DIM_SIZE (nss) - 1))
320 fprintf_filtered (stream, ", ");
322 if (i == print_max - 1)
323 fprintf_filtered (stream, "...");
328 /* This function gets called to print an F77 array, we set up some
329 stuff and then immediately call f77_print_array_1() */
332 f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse,
341 enum val_prettyprint pretty;
345 ndimensions = calc_f77_array_dims (type);
347 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
348 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
349 ndimensions, MAX_FORTRAN_DIMS);
351 /* Since F77 arrays are stored column-major, we set up an
352 offset table to get at the various row's elements. The
353 offset table contains entries for both offset and subarray size. */
355 f77_create_arrayprint_offset_tbl (type, stream);
357 f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
358 deref_ref, recurse, pretty);
362 /* Print data of type TYPE located at VALADDR (within GDB), which came from
363 the inferior at address ADDRESS, onto stdio stream STREAM according to
364 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
367 If the data are a string pointer, returns the number of string characters
370 If DEREF_REF is nonzero, then dereference references, otherwise just print
373 The PRETTY parameter controls prettyprinting. */
376 f_val_print (type, valaddr, embedded_offset, address, stream, format, deref_ref, recurse,
386 enum val_prettyprint pretty;
388 register unsigned int i = 0; /* Number of characters printed */
389 struct type *elttype;
393 CHECK_TYPEDEF (type);
394 switch (TYPE_CODE (type))
396 case TYPE_CODE_STRING:
397 f77_get_dynamic_length_of_aggregate (type);
398 LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
401 case TYPE_CODE_ARRAY:
402 fprintf_filtered (stream, "(");
403 f77_print_array (type, valaddr, address, stream, format,
404 deref_ref, recurse, pretty);
405 fprintf_filtered (stream, ")");
408 /* Array of unspecified length: treat like pointer to first elt. */
409 valaddr = (char *) &address;
413 if (format && format != 's')
415 print_scalar_formatted (valaddr, type, format, 0, stream);
420 addr = unpack_pointer (type, valaddr);
421 elttype = check_typedef (TYPE_TARGET_TYPE (type));
423 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
425 /* Try to print what function it points to. */
426 print_address_demangle (addr, stream, demangle);
427 /* Return value is irrelevant except for string pointers. */
431 if (addressprint && format != 's')
432 fprintf_filtered (stream, "0x%x", addr);
434 /* For a pointer to char or unsigned char, also print the string
435 pointed to, unless pointer is null. */
436 if (TYPE_LENGTH (elttype) == 1
437 && TYPE_CODE (elttype) == TYPE_CODE_INT
438 && (format == 0 || format == 's')
440 i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
442 /* Return number of characters printed, plus one for the
443 terminating null if we have "reached the end". */
444 return (i + (print_max && i != print_max));
451 print_scalar_formatted (valaddr, type, format, 0, stream);
454 /* FIXME, we should consider, at least for ANSI C language, eliminating
455 the distinction made between FUNCs and POINTERs to FUNCs. */
456 fprintf_filtered (stream, "{");
457 type_print (type, "", stream, -1);
458 fprintf_filtered (stream, "} ");
459 /* Try to print what function it points to, and its address. */
460 print_address_demangle (address, stream, demangle);
464 format = format ? format : output_format;
466 print_scalar_formatted (valaddr, type, format, 0, stream);
469 val_print_type_code_int (type, valaddr, stream);
470 /* C and C++ has no single byte int type, char is used instead.
471 Since we don't know whether the value is really intended to
472 be used as an integer or a character, print the character
473 equivalent as well. */
474 if (TYPE_LENGTH (type) == 1)
476 fputs_filtered (" ", stream);
477 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
485 print_scalar_formatted (valaddr, type, format, 0, stream);
487 print_floating (valaddr, type, stream);
491 fprintf_filtered (stream, "VOID");
494 case TYPE_CODE_ERROR:
495 fprintf_filtered (stream, "<error type>");
498 case TYPE_CODE_RANGE:
499 /* FIXME, we should not ever have to print one of these yet. */
500 fprintf_filtered (stream, "<range type>");
504 format = format ? format : output_format;
506 print_scalar_formatted (valaddr, type, format, 0, stream);
510 switch (TYPE_LENGTH(type))
513 val = unpack_long (builtin_type_f_logical_s1, valaddr);
517 val = unpack_long (builtin_type_f_logical_s2, valaddr);
521 val = unpack_long (builtin_type_f_logical, valaddr);
525 error ("Logicals of length %d bytes not supported",
531 fprintf_filtered (stream, ".FALSE.");
534 fprintf_filtered (stream, ".TRUE.");
536 /* Not a legitimate logical type, print as an integer. */
538 /* Bash the type code temporarily. */
539 TYPE_CODE (type) = TYPE_CODE_INT;
540 f_val_print (type, valaddr, 0, address, stream, format,
541 deref_ref, recurse, pretty);
542 /* Restore the type code so later uses work as intended. */
543 TYPE_CODE (type) = TYPE_CODE_BOOL;
548 case TYPE_CODE_COMPLEX:
549 switch (TYPE_LENGTH (type))
551 case 8: type = builtin_type_f_real; break;
552 case 16: type = builtin_type_f_real_s8; break;
553 case 32: type = builtin_type_f_real_s16; break;
555 error ("Cannot print out complex*%d variables", TYPE_LENGTH(type));
557 fputs_filtered ("(", stream);
558 print_floating (valaddr, type, stream);
559 fputs_filtered (",", stream);
560 print_floating (valaddr, type, stream);
561 fputs_filtered (")", stream);
564 case TYPE_CODE_UNDEF:
565 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
566 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
567 and no complete type for struct foo in that file. */
568 fprintf_filtered (stream, "<incomplete type>");
572 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
579 list_all_visible_commons (funname)
582 SAVED_F77_COMMON_PTR tmp;
584 tmp = head_common_list;
586 printf_filtered ("All COMMON blocks visible at this level:\n\n");
590 if (STREQ(tmp->owning_function,funname))
591 printf_filtered ("%s\n", tmp->name);
597 /* This function is used to print out the values in a given COMMON
598 block. It will always use the most local common block of the
602 info_common_command (comname, from_tty)
606 SAVED_F77_COMMON_PTR the_common;
607 COMMON_ENTRY_PTR entry;
608 struct frame_info *fi;
609 register char *funname = 0;
612 /* We have been told to display the contents of F77 COMMON
613 block supposedly visible in this function. Let us
614 first make sure that it is visible and if so, let
615 us display its contents */
620 error ("No frame selected");
622 /* The following is generally ripped off from stack.c's routine
623 print_frame_info() */
625 func = find_pc_function (fi->pc);
628 /* In certain pathological cases, the symtabs give the wrong
629 function (when we are in the first function in a file which
630 is compiled without debugging symbols, the previous function
631 is compiled with debugging symbols, and the "foo.o" symbol
632 that is supposed to tell us where the file with debugging symbols
633 ends has been truncated by ar because it is longer than 15
636 So look in the minimal symbol tables as well, and if it comes
637 up with a larger address for the function use that instead.
638 I don't think this can ever cause any problems; there shouldn't
639 be any minimal symbols in the middle of a function.
640 FIXME: (Not necessarily true. What about text labels) */
642 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
645 && (SYMBOL_VALUE_ADDRESS (msymbol)
646 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
647 funname = SYMBOL_NAME (msymbol);
649 funname = SYMBOL_NAME (func);
653 register struct minimal_symbol *msymbol =
654 lookup_minimal_symbol_by_pc (fi->pc);
657 funname = SYMBOL_NAME (msymbol);
660 /* If comname is NULL, we assume the user wishes to see the
661 which COMMON blocks are visible here and then return */
665 list_all_visible_commons (funname);
669 the_common = find_common_for_function (comname,funname);
673 if (STREQ(comname,BLANK_COMMON_NAME_LOCAL))
674 printf_filtered ("Contents of blank COMMON block:\n");
676 printf_filtered ("Contents of F77 COMMON block '%s':\n",comname);
678 printf_filtered ("\n");
679 entry = the_common->entries;
681 while (entry != NULL)
683 printf_filtered ("%s = ",SYMBOL_NAME(entry->symbol));
684 print_variable_value (entry->symbol, fi, gdb_stdout);
685 printf_filtered ("\n");
690 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
694 /* This function is used to determine whether there is a
695 F77 common block visible at the current scope called 'comname'. */
699 there_is_a_visible_common_named (comname)
702 SAVED_F77_COMMON_PTR the_common;
703 struct frame_info *fi;
704 register char *funname = 0;
708 error ("Cannot deal with NULL common name!");
713 error ("No frame selected");
715 /* The following is generally ripped off from stack.c's routine
716 print_frame_info() */
718 func = find_pc_function (fi->pc);
721 /* In certain pathological cases, the symtabs give the wrong
722 function (when we are in the first function in a file which
723 is compiled without debugging symbols, the previous function
724 is compiled with debugging symbols, and the "foo.o" symbol
725 that is supposed to tell us where the file with debugging symbols
726 ends has been truncated by ar because it is longer than 15
729 So look in the minimal symbol tables as well, and if it comes
730 up with a larger address for the function use that instead.
731 I don't think this can ever cause any problems; there shouldn't
732 be any minimal symbols in the middle of a function.
733 FIXME: (Not necessarily true. What about text labels) */
735 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
738 && (SYMBOL_VALUE_ADDRESS (msymbol)
739 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
740 funname = SYMBOL_NAME (msymbol);
742 funname = SYMBOL_NAME (func);
746 register struct minimal_symbol *msymbol =
747 lookup_minimal_symbol_by_pc (fi->pc);
750 funname = SYMBOL_NAME (msymbol);
753 the_common = find_common_for_function (comname, funname);
755 return (the_common ? 1 : 0);
760 _initialize_f_valprint ()
762 add_info ("common", info_common_command,
763 "Print out the values contained in a Fortran COMMON block.");
765 add_com("lc", class_info, info_common_command,
766 "Print out the values contained in a Fortran COMMON block.");