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,
21 Boston, MA 02111-1307, USA. */
24 #include "gdb_string.h"
27 #include "expression.h"
38 static int there_is_a_visible_common_named
PARAMS ((char *));
41 extern void _initialize_f_valprint
PARAMS ((void));
42 static void info_common_command
PARAMS ((char *, int));
43 static void list_all_visible_commons
PARAMS ((char *));
44 static void f77_print_array
PARAMS ((struct type
*, char *, CORE_ADDR
,
45 GDB_FILE
*, int, int, int,
46 enum val_prettyprint
));
47 static void f77_print_array_1
PARAMS ((int, int, struct type
*, char *,
48 CORE_ADDR
, GDB_FILE
*, int, int, int,
49 enum val_prettyprint
));
50 static void f77_create_arrayprint_offset_tbl
PARAMS ((struct type
*,
52 static void f77_get_dynamic_length_of_aggregate
PARAMS ((struct type
*));
54 int f77_array_offset_tbl
[MAX_FORTRAN_DIMS
+ 1][2];
56 /* Array which holds offsets to be applied to get a row's elements
57 for a given array. Array also holds the size of each subarray. */
59 /* The following macro gives us the size of the nth dimension, Where
62 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
64 /* The following gives us the offset for row n where n is 1-based. */
66 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
69 f77_get_dynamic_lowerbound (type
, lower_bound
)
73 CORE_ADDR current_frame_addr
;
74 CORE_ADDR ptr_to_lower_bound
;
76 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type
))
78 case BOUND_BY_VALUE_ON_STACK
:
79 current_frame_addr
= selected_frame
->frame
;
80 if (current_frame_addr
> 0)
83 read_memory_integer (current_frame_addr
+
84 TYPE_ARRAY_LOWER_BOUND_VALUE (type
),
89 *lower_bound
= DEFAULT_LOWER_BOUND
;
90 return BOUND_FETCH_ERROR
;
95 *lower_bound
= TYPE_ARRAY_LOWER_BOUND_VALUE (type
);
98 case BOUND_CANNOT_BE_DETERMINED
:
99 error ("Lower bound may not be '*' in F77");
102 case BOUND_BY_REF_ON_STACK
:
103 current_frame_addr
= selected_frame
->frame
;
104 if (current_frame_addr
> 0)
107 read_memory_integer (current_frame_addr
+
108 TYPE_ARRAY_LOWER_BOUND_VALUE (type
),
110 *lower_bound
= read_memory_integer (ptr_to_lower_bound
, 4);
114 *lower_bound
= DEFAULT_LOWER_BOUND
;
115 return BOUND_FETCH_ERROR
;
119 case BOUND_BY_REF_IN_REG
:
120 case BOUND_BY_VALUE_IN_REG
:
122 error ("??? unhandled dynamic array bound type ???");
125 return BOUND_FETCH_OK
;
129 f77_get_dynamic_upperbound (type
, upper_bound
)
133 CORE_ADDR current_frame_addr
= 0;
134 CORE_ADDR ptr_to_upper_bound
;
136 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type
))
138 case BOUND_BY_VALUE_ON_STACK
:
139 current_frame_addr
= selected_frame
->frame
;
140 if (current_frame_addr
> 0)
143 read_memory_integer (current_frame_addr
+
144 TYPE_ARRAY_UPPER_BOUND_VALUE (type
),
149 *upper_bound
= DEFAULT_UPPER_BOUND
;
150 return BOUND_FETCH_ERROR
;
155 *upper_bound
= TYPE_ARRAY_UPPER_BOUND_VALUE (type
);
158 case BOUND_CANNOT_BE_DETERMINED
:
159 /* we have an assumed size array on our hands. Assume that
160 upper_bound == lower_bound so that we show at least
161 1 element.If the user wants to see more elements, let
162 him manually ask for 'em and we'll subscript the
163 array and show him */
164 f77_get_dynamic_lowerbound (type
, upper_bound
);
167 case BOUND_BY_REF_ON_STACK
:
168 current_frame_addr
= selected_frame
->frame
;
169 if (current_frame_addr
> 0)
172 read_memory_integer (current_frame_addr
+
173 TYPE_ARRAY_UPPER_BOUND_VALUE (type
),
175 *upper_bound
= read_memory_integer (ptr_to_upper_bound
, 4);
179 *upper_bound
= DEFAULT_UPPER_BOUND
;
180 return BOUND_FETCH_ERROR
;
184 case BOUND_BY_REF_IN_REG
:
185 case BOUND_BY_VALUE_IN_REG
:
187 error ("??? unhandled dynamic array bound type ???");
190 return BOUND_FETCH_OK
;
193 /* Obtain F77 adjustable array dimensions */
196 f77_get_dynamic_length_of_aggregate (type
)
199 int upper_bound
= -1;
203 /* Recursively go all the way down into a possibly multi-dimensional
204 F77 array and get the bounds. For simple arrays, this is pretty
205 easy but when the bounds are dynamic, we must be very careful
206 to add up all the lengths correctly. Not doing this right
207 will lead to horrendous-looking arrays in parameter lists.
209 This function also works for strings which behave very
210 similarly to arrays. */
212 if (TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
213 || TYPE_CODE (TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
214 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
216 /* Recursion ends here, start setting up lengths. */
217 retcode
= f77_get_dynamic_lowerbound (type
, &lower_bound
);
218 if (retcode
== BOUND_FETCH_ERROR
)
219 error ("Cannot obtain valid array lower bound");
221 retcode
= f77_get_dynamic_upperbound (type
, &upper_bound
);
222 if (retcode
== BOUND_FETCH_ERROR
)
223 error ("Cannot obtain valid array upper bound");
225 /* Patch in a valid length value. */
228 (upper_bound
- lower_bound
+ 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type
)));
231 /* Function that sets up the array offset,size table for the array
235 f77_create_arrayprint_offset_tbl (type
, stream
)
239 struct type
*tmp_type
;
242 int upper
, lower
, retcode
;
246 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
248 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type
) == BOUND_CANNOT_BE_DETERMINED
)
249 fprintf_filtered (stream
, "<assumed size array> ");
251 retcode
= f77_get_dynamic_upperbound (tmp_type
, &upper
);
252 if (retcode
== BOUND_FETCH_ERROR
)
253 error ("Cannot obtain dynamic upper bound");
255 retcode
= f77_get_dynamic_lowerbound (tmp_type
, &lower
);
256 if (retcode
== BOUND_FETCH_ERROR
)
257 error ("Cannot obtain dynamic lower bound");
259 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
261 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
265 /* Now we multiply eltlen by all the offsets, so that later we
266 can print out array elements correctly. Up till now we
267 know an offset to apply to get the item but we also
268 have to know how much to add to get to the next item */
271 eltlen
= TYPE_LENGTH (tmp_type
);
272 F77_DIM_OFFSET (ndimen
) = eltlen
;
275 eltlen
*= F77_DIM_SIZE (ndimen
+ 1);
276 F77_DIM_OFFSET (ndimen
) = eltlen
;
280 /* Actual function which prints out F77 arrays, Valaddr == address in
281 the superior. Address == the address in the inferior. */
284 f77_print_array_1 (nss
, ndimensions
, type
, valaddr
, address
,
285 stream
, format
, deref_ref
, recurse
, pretty
)
295 enum val_prettyprint pretty
;
299 if (nss
!= ndimensions
)
301 for (i
= 0; i
< F77_DIM_SIZE (nss
); i
++)
303 fprintf_filtered (stream
, "( ");
304 f77_print_array_1 (nss
+ 1, ndimensions
, TYPE_TARGET_TYPE (type
),
305 valaddr
+ i
* F77_DIM_OFFSET (nss
),
306 address
+ i
* F77_DIM_OFFSET (nss
),
307 stream
, format
, deref_ref
, recurse
, pretty
);
308 fprintf_filtered (stream
, ") ");
313 for (i
= 0; (i
< F77_DIM_SIZE (nss
) && i
< print_max
); i
++)
315 val_print (TYPE_TARGET_TYPE (type
),
316 valaddr
+ i
* F77_DIM_OFFSET (ndimensions
),
318 address
+ i
* F77_DIM_OFFSET (ndimensions
),
319 stream
, format
, deref_ref
, recurse
, pretty
);
321 if (i
!= (F77_DIM_SIZE (nss
) - 1))
322 fprintf_filtered (stream
, ", ");
324 if (i
== print_max
- 1)
325 fprintf_filtered (stream
, "...");
330 /* This function gets called to print an F77 array, we set up some
331 stuff and then immediately call f77_print_array_1() */
334 f77_print_array (type
, valaddr
, address
, stream
, format
, deref_ref
, recurse
,
343 enum val_prettyprint pretty
;
347 ndimensions
= calc_f77_array_dims (type
);
349 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
350 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
351 ndimensions
, MAX_FORTRAN_DIMS
);
353 /* Since F77 arrays are stored column-major, we set up an
354 offset table to get at the various row's elements. The
355 offset table contains entries for both offset and subarray size. */
357 f77_create_arrayprint_offset_tbl (type
, stream
);
359 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
, format
,
360 deref_ref
, recurse
, pretty
);
364 /* Print data of type TYPE located at VALADDR (within GDB), which came from
365 the inferior at address ADDRESS, onto stdio stream STREAM according to
366 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
369 If the data are a string pointer, returns the number of string characters
372 If DEREF_REF is nonzero, then dereference references, otherwise just print
375 The PRETTY parameter controls prettyprinting. */
378 f_val_print (type
, valaddr
, embedded_offset
, address
, stream
, format
, deref_ref
, recurse
,
388 enum val_prettyprint pretty
;
390 register unsigned int i
= 0; /* Number of characters printed */
391 struct type
*elttype
;
395 CHECK_TYPEDEF (type
);
396 switch (TYPE_CODE (type
))
398 case TYPE_CODE_STRING
:
399 f77_get_dynamic_length_of_aggregate (type
);
400 LA_PRINT_STRING (stream
, valaddr
, TYPE_LENGTH (type
), 1, 0);
403 case TYPE_CODE_ARRAY
:
404 fprintf_filtered (stream
, "(");
405 f77_print_array (type
, valaddr
, address
, stream
, format
,
406 deref_ref
, recurse
, pretty
);
407 fprintf_filtered (stream
, ")");
410 /* Array of unspecified length: treat like pointer to first elt. */
411 valaddr
= (char *) &address
;
415 if (format
&& format
!= 's')
417 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
422 addr
= unpack_pointer (type
, valaddr
);
423 elttype
= check_typedef (TYPE_TARGET_TYPE (type
));
425 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
427 /* Try to print what function it points to. */
428 print_address_demangle (addr
, stream
, demangle
);
429 /* Return value is irrelevant except for string pointers. */
433 if (addressprint
&& format
!= 's')
434 fprintf_filtered (stream
, "0x%x", addr
);
436 /* For a pointer to char or unsigned char, also print the string
437 pointed to, unless pointer is null. */
438 if (TYPE_LENGTH (elttype
) == 1
439 && TYPE_CODE (elttype
) == TYPE_CODE_INT
440 && (format
== 0 || format
== 's')
442 i
= val_print_string (addr
, -1, TYPE_LENGTH (elttype
), stream
);
444 /* Return number of characters printed, plus one for the
445 terminating null if we have "reached the end". */
446 return (i
+ (print_max
&& i
!= print_max
));
453 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
456 /* FIXME, we should consider, at least for ANSI C language, eliminating
457 the distinction made between FUNCs and POINTERs to FUNCs. */
458 fprintf_filtered (stream
, "{");
459 type_print (type
, "", stream
, -1);
460 fprintf_filtered (stream
, "} ");
461 /* Try to print what function it points to, and its address. */
462 print_address_demangle (address
, stream
, demangle
);
466 format
= format
? format
: output_format
;
468 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
471 val_print_type_code_int (type
, valaddr
, stream
);
472 /* C and C++ has no single byte int type, char is used instead.
473 Since we don't know whether the value is really intended to
474 be used as an integer or a character, print the character
475 equivalent as well. */
476 if (TYPE_LENGTH (type
) == 1)
478 fputs_filtered (" ", stream
);
479 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
487 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
489 print_floating (valaddr
, type
, stream
);
493 fprintf_filtered (stream
, "VOID");
496 case TYPE_CODE_ERROR
:
497 fprintf_filtered (stream
, "<error type>");
500 case TYPE_CODE_RANGE
:
501 /* FIXME, we should not ever have to print one of these yet. */
502 fprintf_filtered (stream
, "<range type>");
506 format
= format
? format
: output_format
;
508 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
512 switch (TYPE_LENGTH (type
))
515 val
= unpack_long (builtin_type_f_logical_s1
, valaddr
);
519 val
= unpack_long (builtin_type_f_logical_s2
, valaddr
);
523 val
= unpack_long (builtin_type_f_logical
, valaddr
);
527 error ("Logicals of length %d bytes not supported",
533 fprintf_filtered (stream
, ".FALSE.");
535 fprintf_filtered (stream
, ".TRUE.");
537 /* Not a legitimate logical type, print as an integer. */
539 /* Bash the type code temporarily. */
540 TYPE_CODE (type
) = TYPE_CODE_INT
;
541 f_val_print (type
, valaddr
, 0, address
, stream
, format
,
542 deref_ref
, recurse
, pretty
);
543 /* Restore the type code so later uses work as intended. */
544 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
549 case TYPE_CODE_COMPLEX
:
550 switch (TYPE_LENGTH (type
))
553 type
= builtin_type_f_real
;
556 type
= builtin_type_f_real_s8
;
559 type
= builtin_type_f_real_s16
;
562 error ("Cannot print out complex*%d variables", TYPE_LENGTH (type
));
564 fputs_filtered ("(", stream
);
565 print_floating (valaddr
, type
, stream
);
566 fputs_filtered (",", stream
);
567 print_floating (valaddr
, type
, stream
);
568 fputs_filtered (")", stream
);
571 case TYPE_CODE_UNDEF
:
572 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
573 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
574 and no complete type for struct foo in that file. */
575 fprintf_filtered (stream
, "<incomplete type>");
579 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type
));
586 list_all_visible_commons (funname
)
589 SAVED_F77_COMMON_PTR tmp
;
591 tmp
= head_common_list
;
593 printf_filtered ("All COMMON blocks visible at this level:\n\n");
597 if (STREQ (tmp
->owning_function
, funname
))
598 printf_filtered ("%s\n", tmp
->name
);
604 /* This function is used to print out the values in a given COMMON
605 block. It will always use the most local common block of the
609 info_common_command (comname
, from_tty
)
613 SAVED_F77_COMMON_PTR the_common
;
614 COMMON_ENTRY_PTR entry
;
615 struct frame_info
*fi
;
616 register char *funname
= 0;
619 /* We have been told to display the contents of F77 COMMON
620 block supposedly visible in this function. Let us
621 first make sure that it is visible and if so, let
622 us display its contents */
627 error ("No frame selected");
629 /* The following is generally ripped off from stack.c's routine
630 print_frame_info() */
632 func
= find_pc_function (fi
->pc
);
635 /* In certain pathological cases, the symtabs give the wrong
636 function (when we are in the first function in a file which
637 is compiled without debugging symbols, the previous function
638 is compiled with debugging symbols, and the "foo.o" symbol
639 that is supposed to tell us where the file with debugging symbols
640 ends has been truncated by ar because it is longer than 15
643 So look in the minimal symbol tables as well, and if it comes
644 up with a larger address for the function use that instead.
645 I don't think this can ever cause any problems; there shouldn't
646 be any minimal symbols in the middle of a function.
647 FIXME: (Not necessarily true. What about text labels) */
649 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
652 && (SYMBOL_VALUE_ADDRESS (msymbol
)
653 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
654 funname
= SYMBOL_NAME (msymbol
);
656 funname
= SYMBOL_NAME (func
);
660 register struct minimal_symbol
*msymbol
=
661 lookup_minimal_symbol_by_pc (fi
->pc
);
664 funname
= SYMBOL_NAME (msymbol
);
667 /* If comname is NULL, we assume the user wishes to see the
668 which COMMON blocks are visible here and then return */
672 list_all_visible_commons (funname
);
676 the_common
= find_common_for_function (comname
, funname
);
680 if (STREQ (comname
, BLANK_COMMON_NAME_LOCAL
))
681 printf_filtered ("Contents of blank COMMON block:\n");
683 printf_filtered ("Contents of F77 COMMON block '%s':\n", comname
);
685 printf_filtered ("\n");
686 entry
= the_common
->entries
;
688 while (entry
!= NULL
)
690 printf_filtered ("%s = ", SYMBOL_NAME (entry
->symbol
));
691 print_variable_value (entry
->symbol
, fi
, gdb_stdout
);
692 printf_filtered ("\n");
697 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
701 /* This function is used to determine whether there is a
702 F77 common block visible at the current scope called 'comname'. */
706 there_is_a_visible_common_named (comname
)
709 SAVED_F77_COMMON_PTR the_common
;
710 struct frame_info
*fi
;
711 register char *funname
= 0;
715 error ("Cannot deal with NULL common name!");
720 error ("No frame selected");
722 /* The following is generally ripped off from stack.c's routine
723 print_frame_info() */
725 func
= find_pc_function (fi
->pc
);
728 /* In certain pathological cases, the symtabs give the wrong
729 function (when we are in the first function in a file which
730 is compiled without debugging symbols, the previous function
731 is compiled with debugging symbols, and the "foo.o" symbol
732 that is supposed to tell us where the file with debugging symbols
733 ends has been truncated by ar because it is longer than 15
736 So look in the minimal symbol tables as well, and if it comes
737 up with a larger address for the function use that instead.
738 I don't think this can ever cause any problems; there shouldn't
739 be any minimal symbols in the middle of a function.
740 FIXME: (Not necessarily true. What about text labels) */
742 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
745 && (SYMBOL_VALUE_ADDRESS (msymbol
)
746 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
747 funname
= SYMBOL_NAME (msymbol
);
749 funname
= SYMBOL_NAME (func
);
753 register struct minimal_symbol
*msymbol
=
754 lookup_minimal_symbol_by_pc (fi
->pc
);
757 funname
= SYMBOL_NAME (msymbol
);
760 the_common
= find_common_for_function (comname
, funname
);
762 return (the_common
? 1 : 0);
767 _initialize_f_valprint ()
769 add_info ("common", info_common_command
,
770 "Print out the values contained in a Fortran COMMON block.");
772 add_com ("lc", class_info
, info_common_command
,
773 "Print out the values contained in a Fortran COMMON block.");