1 /* Support for printing Fortran values for GDB, the GNU debugger.
2 Copyright 1993, 1994 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., 675 Mass Ave, Cambridge, MA 02139, USA. */
26 #include "expression.h"
36 extern struct obstack dont_print_obstack
;
38 extern unsigned int print_max
; /* No of array elements to print */
40 extern int calc_f77_array_dims
PARAMS ((struct type
*));
42 int f77_array_offset_tbl
[MAX_FORTRAN_DIMS
+1][2];
44 /* Array which holds offsets to be applied to get a row's elements
45 for a given array. Array also holds the size of each subarray. */
47 /* The following macro gives us the size of the nth dimension, Where
50 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
52 /* The following gives us the offset for row n where n is 1-based. */
54 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
57 f77_get_dynamic_lowerbound (type
, lower_bound
)
61 CORE_ADDR current_frame_addr
;
62 CORE_ADDR ptr_to_lower_bound
;
64 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type
))
66 case BOUND_BY_VALUE_ON_STACK
:
67 current_frame_addr
= selected_frame
->frame
;
68 if (current_frame_addr
> 0)
71 read_memory_integer (current_frame_addr
+
72 TYPE_ARRAY_LOWER_BOUND_VALUE (type
),
77 *lower_bound
= DEFAULT_LOWER_BOUND
;
78 return BOUND_FETCH_ERROR
;
83 *lower_bound
= TYPE_ARRAY_LOWER_BOUND_VALUE (type
);
86 case BOUND_CANNOT_BE_DETERMINED
:
87 error ("Lower bound may not be '*' in F77");
90 case BOUND_BY_REF_ON_STACK
:
91 current_frame_addr
= selected_frame
->frame
;
92 if (current_frame_addr
> 0)
95 read_memory_integer (current_frame_addr
+
96 TYPE_ARRAY_LOWER_BOUND_VALUE (type
),
98 *lower_bound
= read_memory_integer (ptr_to_lower_bound
, 4);
102 *lower_bound
= DEFAULT_LOWER_BOUND
;
103 return BOUND_FETCH_ERROR
;
107 case BOUND_BY_REF_IN_REG
:
108 case BOUND_BY_VALUE_IN_REG
:
110 error ("??? unhandled dynamic array bound type ???");
113 return BOUND_FETCH_OK
;
117 f77_get_dynamic_upperbound (type
, upper_bound
)
121 CORE_ADDR current_frame_addr
= 0;
122 CORE_ADDR ptr_to_upper_bound
;
124 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type
))
126 case BOUND_BY_VALUE_ON_STACK
:
127 current_frame_addr
= selected_frame
->frame
;
128 if (current_frame_addr
> 0)
131 read_memory_integer (current_frame_addr
+
132 TYPE_ARRAY_UPPER_BOUND_VALUE (type
),
137 *upper_bound
= DEFAULT_UPPER_BOUND
;
138 return BOUND_FETCH_ERROR
;
143 *upper_bound
= TYPE_ARRAY_UPPER_BOUND_VALUE (type
);
146 case BOUND_CANNOT_BE_DETERMINED
:
147 /* we have an assumed size array on our hands. Assume that
148 upper_bound == lower_bound so that we show at least
149 1 element.If the user wants to see more elements, let
150 him manually ask for 'em and we'll subscript the
151 array and show him */
152 f77_get_dynamic_lowerbound (type
, upper_bound
);
155 case BOUND_BY_REF_ON_STACK
:
156 current_frame_addr
= selected_frame
->frame
;
157 if (current_frame_addr
> 0)
160 read_memory_integer (current_frame_addr
+
161 TYPE_ARRAY_UPPER_BOUND_VALUE (type
),
163 *upper_bound
= read_memory_integer(ptr_to_upper_bound
, 4);
167 *upper_bound
= DEFAULT_UPPER_BOUND
;
168 return BOUND_FETCH_ERROR
;
172 case BOUND_BY_REF_IN_REG
:
173 case BOUND_BY_VALUE_IN_REG
:
175 error ("??? unhandled dynamic array bound type ???");
178 return BOUND_FETCH_OK
;
181 /* Obtain F77 adjustable array dimensions */
184 f77_get_dynamic_length_of_aggregate (type
)
187 int upper_bound
= -1;
191 /* Recursively go all the way down into a possibly multi-dimensional
192 F77 array and get the bounds. For simple arrays, this is pretty
193 easy but when the bounds are dynamic, we must be very careful
194 to add up all the lengths correctly. Not doing this right
195 will lead to horrendous-looking arrays in parameter lists.
197 This function also works for strings which behave very
198 similarly to arrays. */
200 if (TYPE_CODE(TYPE_TARGET_TYPE (type
)) == TYPE_CODE_ARRAY
201 || TYPE_CODE(TYPE_TARGET_TYPE (type
)) == TYPE_CODE_STRING
)
202 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type
));
204 /* Recursion ends here, start setting up lengths. */
205 retcode
= f77_get_dynamic_lowerbound (type
, &lower_bound
);
206 if (retcode
== BOUND_FETCH_ERROR
)
207 error ("Cannot obtain valid array lower bound");
209 retcode
= f77_get_dynamic_upperbound (type
, &upper_bound
);
210 if (retcode
== BOUND_FETCH_ERROR
)
211 error ("Cannot obtain valid array upper bound");
213 /* Patch in a valid length value. */
216 (upper_bound
- lower_bound
+ 1) * TYPE_LENGTH (TYPE_TARGET_TYPE (type
));
219 /* Function that sets up the array offset,size table for the array
223 f77_create_arrayprint_offset_tbl (type
, stream
)
227 struct type
*tmp_type
;
230 int upper
, lower
, retcode
;
234 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
236 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type
) == BOUND_CANNOT_BE_DETERMINED
)
237 fprintf_filtered (stream
, "<assumed size array> ");
239 retcode
= f77_get_dynamic_upperbound (tmp_type
, &upper
);
240 if (retcode
== BOUND_FETCH_ERROR
)
241 error ("Cannot obtain dynamic upper bound");
243 retcode
= f77_get_dynamic_lowerbound(tmp_type
,&lower
);
244 if (retcode
== BOUND_FETCH_ERROR
)
245 error("Cannot obtain dynamic lower bound");
247 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
250 F77_DIM_OFFSET (ndimen
) = 1;
252 F77_DIM_OFFSET (ndimen
) =
253 F77_DIM_OFFSET (ndimen
- 1) * F77_DIM_SIZE(ndimen
- 1);
255 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
259 eltlen
= TYPE_LENGTH (tmp_type
);
261 /* Now we multiply eltlen by all the offsets, so that later we
262 can print out array elements correctly. Up till now we
263 know an offset to apply to get the item but we also
264 have to know how much to add to get to the next item */
269 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
271 F77_DIM_OFFSET (ndimen
) *= eltlen
;
273 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
277 /* Actual function which prints out F77 arrays, Valaddr == address in
278 the superior. Address == the address in the inferior. */
281 f77_print_array_1 (nss
, ndimensions
, type
, valaddr
, address
,
282 stream
, format
, deref_ref
, recurse
, pretty
)
292 enum val_prettyprint pretty
;
296 if (nss
!= ndimensions
)
298 for (i
= 0; i
< F77_DIM_SIZE(nss
); i
++)
300 fprintf_filtered (stream
, "( ");
301 f77_print_array_1 (nss
+ 1, ndimensions
, TYPE_TARGET_TYPE (type
),
302 valaddr
+ i
* F77_DIM_OFFSET (nss
),
303 address
+ i
* F77_DIM_OFFSET (nss
),
304 stream
, format
, deref_ref
, recurse
, pretty
, i
);
305 fprintf_filtered (stream
, ") ");
310 for (i
= 0; (i
< F77_DIM_SIZE (nss
) && i
< print_max
); i
++)
312 val_print (TYPE_TARGET_TYPE (type
),
313 valaddr
+ i
* F77_DIM_OFFSET (ndimensions
),
314 address
+ i
* F77_DIM_OFFSET (ndimensions
),
315 stream
, format
, deref_ref
, recurse
, pretty
);
317 if (i
!= (F77_DIM_SIZE (nss
) - 1))
318 fprintf_filtered (stream
, ", ");
320 if (i
== print_max
- 1)
321 fprintf_filtered (stream
, "...");
326 /* This function gets called to print an F77 array, we set up some
327 stuff and then immediately call f77_print_array_1() */
330 f77_print_array (type
, valaddr
, address
, stream
, format
, deref_ref
, recurse
,
339 enum val_prettyprint pretty
;
343 ndimensions
= calc_f77_array_dims (type
);
345 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
346 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
347 ndimensions
, MAX_FORTRAN_DIMS
);
349 /* Since F77 arrays are stored column-major, we set up an
350 offset table to get at the various row's elements. The
351 offset table contains entries for both offset and subarray size. */
353 f77_create_arrayprint_offset_tbl (type
, stream
);
355 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
, format
,
356 deref_ref
, recurse
, pretty
);
360 /* Print data of type TYPE located at VALADDR (within GDB), which came from
361 the inferior at address ADDRESS, onto stdio stream STREAM according to
362 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
365 If the data are a string pointer, returns the number of string characters
368 If DEREF_REF is nonzero, then dereference references, otherwise just print
371 The PRETTY parameter controls prettyprinting. */
374 f_val_print (type
, valaddr
, address
, stream
, format
, deref_ref
, recurse
,
383 enum val_prettyprint pretty
;
385 register unsigned int i
= 0; /* Number of characters printed */
387 struct type
*elttype
;
393 switch (TYPE_CODE (type
))
395 case TYPE_CODE_STRING
:
396 f77_get_dynamic_length_of_aggregate (type
);
397 LA_PRINT_STRING (stream
, valaddr
, TYPE_LENGTH (type
), 0);
400 case TYPE_CODE_ARRAY
:
401 fprintf_filtered (stream
, "(");
402 f77_print_array (type
, valaddr
, address
, stream
, format
,
403 deref_ref
, recurse
, pretty
);
404 fprintf_filtered (stream
, ")");
407 /* Array of unspecified length: treat like pointer to first elt. */
408 valaddr
= (char *) &address
;
412 if (format
&& format
!= 's')
414 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
419 addr
= unpack_pointer (type
, valaddr
);
420 elttype
= TYPE_TARGET_TYPE (type
);
422 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
424 /* Try to print what function it points to. */
425 print_address_demangle (addr
, stream
, demangle
);
426 /* Return value is irrelevant except for string pointers. */
430 if (addressprint
&& format
!= 's')
431 fprintf_filtered (stream
, "0x%x", addr
);
433 /* For a pointer to char or unsigned char, also print the string
434 pointed to, unless pointer is null. */
435 if (TYPE_LENGTH (elttype
) == 1
436 && TYPE_CODE (elttype
) == TYPE_CODE_INT
437 && (format
== 0 || format
== 's')
439 i
= val_print_string (addr
, 0, stream
);
441 /* Return number of characters printed, plus one for the
442 terminating null if we have "reached the end". */
443 return (i
+ (print_max
&& i
!= print_max
));
450 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
453 /* FIXME, we should consider, at least for ANSI C language, eliminating
454 the distinction made between FUNCs and POINTERs to FUNCs. */
455 fprintf_filtered (stream
, "{");
456 type_print (type
, "", stream
, -1);
457 fprintf_filtered (stream
, "} ");
458 /* Try to print what function it points to, and its address. */
459 print_address_demangle (address
, stream
, demangle
);
463 format
= format
? format
: output_format
;
465 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
468 val_print_type_code_int (type
, valaddr
, stream
);
469 /* C and C++ has no single byte int type, char is used instead.
470 Since we don't know whether the value is really intended to
471 be used as an integer or a character, print the character
472 equivalent as well. */
473 if (TYPE_LENGTH (type
) == 1)
475 fputs_filtered (" ", stream
);
476 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
484 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
486 print_floating (valaddr
, type
, stream
);
490 fprintf_filtered (stream
, "VOID");
493 case TYPE_CODE_ERROR
:
494 fprintf_filtered (stream
, "<error type>");
497 case TYPE_CODE_RANGE
:
498 /* FIXME, we should not ever have to print one of these yet. */
499 fprintf_filtered (stream
, "<range type>");
503 format
= format
? format
: output_format
;
505 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
509 switch (TYPE_LENGTH(type
))
512 val
= unpack_long (builtin_type_f_logical_s1
, valaddr
);
516 val
= unpack_long (builtin_type_f_logical_s2
, valaddr
);
520 val
= unpack_long (builtin_type_f_logical
, valaddr
);
524 error ("Logicals of length %d bytes not supported",
530 fprintf_filtered (stream
, ".FALSE.");
533 fprintf_filtered (stream
, ".TRUE.");
535 /* Not a legitimate logical type, print as an integer. */
537 /* Bash the type code temporarily. */
538 TYPE_CODE (type
) = TYPE_CODE_INT
;
539 f_val_print (type
, valaddr
, address
, stream
, format
,
540 deref_ref
, recurse
, pretty
);
541 /* Restore the type code so later uses work as intended. */
542 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
547 case TYPE_CODE_COMPLEX
:
548 switch (TYPE_LENGTH (type
))
550 case 8: type
= builtin_type_f_real
; break;
551 case 16: type
= builtin_type_f_real_s8
; break;
552 case 32: type
= builtin_type_f_real_s16
; break;
554 error ("Cannot print out complex*%d variables", TYPE_LENGTH(type
));
556 fputs_filtered ("(", stream
);
557 print_floating (valaddr
, type
, stream
);
558 fputs_filtered (",", stream
);
559 print_floating (valaddr
, type
, stream
);
560 fputs_filtered (")", stream
);
563 case TYPE_CODE_UNDEF
:
564 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
565 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
566 and no complete type for struct foo in that file. */
567 fprintf_filtered (stream
, "<incomplete type>");
571 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type
));
578 list_all_visible_commons (funname
)
581 SAVED_F77_COMMON_PTR tmp
;
583 tmp
= head_common_list
;
585 printf_filtered ("All COMMON blocks visible at this level:\n\n");
589 if (STREQ(tmp
->owning_function
,funname
))
590 printf_filtered ("%s\n", tmp
->name
);
596 /* This function is used to print out the values in a given COMMON
597 block. It will always use the most local common block of the
601 info_common_command (comname
, from_tty
)
605 SAVED_F77_COMMON_PTR the_common
;
606 COMMON_ENTRY_PTR entry
;
607 struct frame_info
*fi
;
608 register char *funname
= 0;
611 /* We have been told to display the contents of F77 COMMON
612 block supposedly visible in this function. Let us
613 first make sure that it is visible and if so, let
614 us display its contents */
619 error ("No frame selected");
621 /* The following is generally ripped off from stack.c's routine
622 print_frame_info() */
624 func
= find_pc_function (fi
->pc
);
627 /* In certain pathological cases, the symtabs give the wrong
628 function (when we are in the first function in a file which
629 is compiled without debugging symbols, the previous function
630 is compiled with debugging symbols, and the "foo.o" symbol
631 that is supposed to tell us where the file with debugging symbols
632 ends has been truncated by ar because it is longer than 15
635 So look in the minimal symbol tables as well, and if it comes
636 up with a larger address for the function use that instead.
637 I don't think this can ever cause any problems; there shouldn't
638 be any minimal symbols in the middle of a function.
639 FIXME: (Not necessarily true. What about text labels) */
641 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
644 && (SYMBOL_VALUE_ADDRESS (msymbol
)
645 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
646 funname
= SYMBOL_NAME (msymbol
);
648 funname
= SYMBOL_NAME (func
);
652 register struct minimal_symbol
*msymbol
=
653 lookup_minimal_symbol_by_pc (fi
->pc
);
656 funname
= SYMBOL_NAME (msymbol
);
659 /* If comname is NULL, we assume the user wishes to see the
660 which COMMON blocks are visible here and then return */
664 list_all_visible_commons (funname
);
668 the_common
= find_common_for_function (comname
,funname
);
672 if (STREQ(comname
,BLANK_COMMON_NAME_LOCAL
))
673 printf_filtered ("Contents of blank COMMON block:\n");
675 printf_filtered ("Contents of F77 COMMON block '%s':\n",comname
);
677 printf_filtered ("\n");
678 entry
= the_common
->entries
;
680 while (entry
!= NULL
)
682 printf_filtered ("%s = ",SYMBOL_NAME(entry
->symbol
));
683 print_variable_value (entry
->symbol
,fi
,stdout
);
684 printf_filtered ("\n");
689 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
693 /* This function is used to determine whether there is a
694 F77 common block visible at the current scope called 'comname'. */
697 there_is_a_visible_common_named (comname
)
700 SAVED_F77_COMMON_PTR the_common
;
701 struct frame_info
*fi
;
702 register char *funname
= 0;
706 error ("Cannot deal with NULL common name!");
711 error ("No frame selected");
713 /* The following is generally ripped off from stack.c's routine
714 print_frame_info() */
716 func
= find_pc_function (fi
->pc
);
719 /* In certain pathological cases, the symtabs give the wrong
720 function (when we are in the first function in a file which
721 is compiled without debugging symbols, the previous function
722 is compiled with debugging symbols, and the "foo.o" symbol
723 that is supposed to tell us where the file with debugging symbols
724 ends has been truncated by ar because it is longer than 15
727 So look in the minimal symbol tables as well, and if it comes
728 up with a larger address for the function use that instead.
729 I don't think this can ever cause any problems; there shouldn't
730 be any minimal symbols in the middle of a function.
731 FIXME: (Not necessarily true. What about text labels) */
733 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
736 && (SYMBOL_VALUE_ADDRESS (msymbol
)
737 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
738 funname
= SYMBOL_NAME (msymbol
);
740 funname
= SYMBOL_NAME (func
);
744 register struct minimal_symbol
*msymbol
=
745 lookup_minimal_symbol_by_pc (fi
->pc
);
748 funname
= SYMBOL_NAME (msymbol
);
751 the_common
= find_common_for_function (comname
, funname
);
753 return (the_common
? 1 : 0);
757 _initialize_f_valprint ()
759 add_info ("common", info_common_command
,
760 "Print out the values contained in a Fortran COMMON block.");