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 /* Print a FORTRAN COMPLEX value of type TYPE, pointed to in GDB by VALADDR,
220 on STREAM. which_complex indicates precision, which may be regular,
224 f77_print_cmplx (valaddr
, type
, stream
, which_complex
)
233 switch (which_complex
)
235 case TARGET_COMPLEX_BIT
:
236 f1
= (float *) valaddr
;
237 f2
= (float *) (valaddr
+ sizeof(float));
238 fprintf_filtered (stream
, "(%.7e,%.7e)", *f1
, *f2
);
241 case TARGET_DOUBLE_COMPLEX_BIT
:
242 d1
= (double *) valaddr
;
243 d2
= (double *) (valaddr
+ sizeof(double));
244 fprintf_filtered (stream
, "(%.16e,%.16e)", *d1
, *d2
);
247 case TARGET_EXT_COMPLEX_BIT
:
248 fprintf_filtered (stream
, "<complex*32 format unavailable, "
249 "printing raw data>\n");
251 fprintf_filtered (stream
, "( [ ");
254 fprintf_filtered (stream
, "0x%x ",
255 * ( (unsigned int *) valaddr
+i
));
257 fprintf_filtered (stream
, "],\n [ ");
260 fprintf_filtered (stream
, "0x%x ",
261 * ((unsigned int *) valaddr
+i
));
263 fprintf_filtered (stream
, "] )");
268 fprintf_filtered (stream
, "<cannot handle complex of this type>");
273 /* Function that sets up the array offset,size table for the array
277 f77_create_arrayprint_offset_tbl (type
, stream
)
281 struct type
*tmp_type
;
284 int upper
, lower
, retcode
;
288 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
290 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type
) == BOUND_CANNOT_BE_DETERMINED
)
291 fprintf_filtered (stream
, "<assumed size array> ");
293 retcode
= f77_get_dynamic_upperbound (tmp_type
, &upper
);
294 if (retcode
== BOUND_FETCH_ERROR
)
295 error ("Cannot obtain dynamic upper bound");
297 retcode
= f77_get_dynamic_lowerbound(tmp_type
,&lower
);
298 if (retcode
== BOUND_FETCH_ERROR
)
299 error("Cannot obtain dynamic lower bound");
301 F77_DIM_SIZE (ndimen
) = upper
- lower
+ 1;
304 F77_DIM_OFFSET (ndimen
) = 1;
306 F77_DIM_OFFSET (ndimen
) =
307 F77_DIM_OFFSET (ndimen
- 1) * F77_DIM_SIZE(ndimen
- 1);
309 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
313 eltlen
= TYPE_LENGTH (tmp_type
);
315 /* Now we multiply eltlen by all the offsets, so that later we
316 can print out array elements correctly. Up till now we
317 know an offset to apply to get the item but we also
318 have to know how much to add to get to the next item */
323 while ((TYPE_CODE (tmp_type
) == TYPE_CODE_ARRAY
))
325 F77_DIM_OFFSET (ndimen
) *= eltlen
;
327 tmp_type
= TYPE_TARGET_TYPE (tmp_type
);
331 /* Actual function which prints out F77 arrays, Valaddr == address in
332 the superior. Address == the address in the inferior. */
335 f77_print_array_1 (nss
, ndimensions
, type
, valaddr
, address
,
336 stream
, format
, deref_ref
, recurse
, pretty
)
346 enum val_prettyprint pretty
;
350 if (nss
!= ndimensions
)
352 for (i
= 0; i
< F77_DIM_SIZE(nss
); i
++)
354 fprintf_filtered (stream
, "( ");
355 f77_print_array_1 (nss
+ 1, ndimensions
, TYPE_TARGET_TYPE (type
),
356 valaddr
+ i
* F77_DIM_OFFSET (nss
),
357 address
+ i
* F77_DIM_OFFSET (nss
),
358 stream
, format
, deref_ref
, recurse
, pretty
, i
);
359 fprintf_filtered (stream
, ") ");
364 for (i
= 0; (i
< F77_DIM_SIZE (nss
) && i
< print_max
); i
++)
366 val_print (TYPE_TARGET_TYPE (type
),
367 valaddr
+ i
* F77_DIM_OFFSET (ndimensions
),
368 address
+ i
* F77_DIM_OFFSET (ndimensions
),
369 stream
, format
, deref_ref
, recurse
, pretty
);
371 if (i
!= (F77_DIM_SIZE (nss
) - 1))
372 fprintf_filtered (stream
, ", ");
374 if (i
== print_max
- 1)
375 fprintf_filtered (stream
, "...");
380 /* This function gets called to print an F77 array, we set up some
381 stuff and then immediately call f77_print_array_1() */
384 f77_print_array (type
, valaddr
, address
, stream
, format
, deref_ref
, recurse
,
393 enum val_prettyprint pretty
;
397 ndimensions
= calc_f77_array_dims (type
);
399 if (ndimensions
> MAX_FORTRAN_DIMS
|| ndimensions
< 0)
400 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
401 ndimensions
, MAX_FORTRAN_DIMS
);
403 /* Since F77 arrays are stored column-major, we set up an
404 offset table to get at the various row's elements. The
405 offset table contains entries for both offset and subarray size. */
407 f77_create_arrayprint_offset_tbl (type
, stream
);
409 f77_print_array_1 (1, ndimensions
, type
, valaddr
, address
, stream
, format
,
410 deref_ref
, recurse
, pretty
);
414 /* Print data of type TYPE located at VALADDR (within GDB), which came from
415 the inferior at address ADDRESS, onto stdio stream STREAM according to
416 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
419 If the data are a string pointer, returns the number of string characters
422 If DEREF_REF is nonzero, then dereference references, otherwise just print
425 The PRETTY parameter controls prettyprinting. */
428 f_val_print (type
, valaddr
, address
, stream
, format
, deref_ref
, recurse
,
437 enum val_prettyprint pretty
;
439 register unsigned int i
= 0; /* Number of characters printed */
441 struct type
*elttype
;
447 switch (TYPE_CODE (type
))
449 case TYPE_CODE_LITERAL_STRING
:
450 /* It is trivial to print out F77 strings allocated in the
451 superior process. The address field is actually a
452 pointer to the bytes of the literal. For an internalvar,
453 valaddr points to a ptr. which points to
454 VALUE_LITERAL_DATA(value->internalvar->value)
455 and for straight literals (i.e. of the form 'hello world'),
456 valaddr points a ptr to VALUE_LITERAL_DATA(value). */
458 /* First dereference valaddr. This relies on valaddr pointing to the
459 aligner union of a struct value (so we are now fetching the
460 literal_data pointer from that union). FIXME: Is this always
463 straddr
= * (char **) valaddr
;
467 len
= TYPE_LENGTH (type
);
468 localstr
= alloca (len
+ 1);
469 strncpy (localstr
, straddr
, len
);
470 localstr
[len
] = '\0';
471 fprintf_filtered (stream
, "'%s'", localstr
);
474 fprintf_filtered (stream
, "Unable to print literal F77 string");
477 /* Strings are a little bit funny. They can be viewed as
478 monolithic arrays that are dealt with as atomic data
479 items. As such they are the only atomic data items whose
480 contents are not located in the superior process. Instead
481 instead of having the actual data, they contain pointers
482 to addresses in the inferior where data is located. Thus
483 instead of using valaddr, we use address. */
485 case TYPE_CODE_STRING
:
486 f77_get_dynamic_length_of_aggregate (type
);
487 val_print_string (address
, TYPE_LENGTH (type
), stream
);
490 case TYPE_CODE_ARRAY
:
491 fprintf_filtered (stream
, "(");
492 f77_print_array (type
, valaddr
, address
, stream
, format
,
493 deref_ref
, recurse
, pretty
);
494 fprintf_filtered (stream
, ")");
497 /* Array of unspecified length: treat like pointer to first elt. */
498 valaddr
= (char *) &address
;
502 if (format
&& format
!= 's')
504 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
509 addr
= unpack_pointer (type
, valaddr
);
510 elttype
= TYPE_TARGET_TYPE (type
);
512 if (TYPE_CODE (elttype
) == TYPE_CODE_FUNC
)
514 /* Try to print what function it points to. */
515 print_address_demangle (addr
, stream
, demangle
);
516 /* Return value is irrelevant except for string pointers. */
520 if (addressprint
&& format
!= 's')
521 fprintf_filtered (stream
, "0x%x", addr
);
523 /* For a pointer to char or unsigned char, also print the string
524 pointed to, unless pointer is null. */
525 if (TYPE_LENGTH (elttype
) == 1
526 && TYPE_CODE (elttype
) == TYPE_CODE_INT
527 && (format
== 0 || format
== 's')
529 i
= val_print_string (addr
, 0, stream
);
531 /* Return number of characters printed, plus one for the
532 terminating null if we have "reached the end". */
533 return (i
+ (print_max
&& i
!= print_max
));
540 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
543 /* FIXME, we should consider, at least for ANSI C language, eliminating
544 the distinction made between FUNCs and POINTERs to FUNCs. */
545 fprintf_filtered (stream
, "{");
546 type_print (type
, "", stream
, -1);
547 fprintf_filtered (stream
, "} ");
548 /* Try to print what function it points to, and its address. */
549 print_address_demangle (address
, stream
, demangle
);
553 format
= format
? format
: output_format
;
555 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
558 val_print_type_code_int (type
, valaddr
, stream
);
559 /* C and C++ has no single byte int type, char is used instead.
560 Since we don't know whether the value is really intended to
561 be used as an integer or a character, print the character
562 equivalent as well. */
563 if (TYPE_LENGTH (type
) == 1)
565 fputs_filtered (" ", stream
);
566 LA_PRINT_CHAR ((unsigned char) unpack_long (type
, valaddr
),
574 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
576 print_floating (valaddr
, type
, stream
);
580 fprintf_filtered (stream
, "VOID");
583 case TYPE_CODE_ERROR
:
584 fprintf_filtered (stream
, "<error type>");
587 case TYPE_CODE_RANGE
:
588 /* FIXME, we should not ever have to print one of these yet. */
589 fprintf_filtered (stream
, "<range type>");
593 format
= format
? format
: output_format
;
595 print_scalar_formatted (valaddr
, type
, format
, 0, stream
);
599 switch (TYPE_LENGTH(type
))
602 val
= unpack_long (builtin_type_f_logical_s1
, valaddr
);
606 val
= unpack_long (builtin_type_f_logical_s2
, valaddr
);
610 val
= unpack_long (builtin_type_f_logical
, valaddr
);
614 error ("Logicals of length %d bytes not supported",
620 fprintf_filtered (stream
, ".FALSE.");
623 fprintf_filtered (stream
, ".TRUE.");
625 /* Not a legitimate logical type, print as an integer. */
627 /* Bash the type code temporarily. */
628 TYPE_CODE (type
) = TYPE_CODE_INT
;
629 f_val_print (type
, valaddr
, address
, stream
, format
,
630 deref_ref
, recurse
, pretty
);
631 /* Restore the type code so later uses work as intended. */
632 TYPE_CODE (type
) = TYPE_CODE_BOOL
;
637 case TYPE_CODE_LITERAL_COMPLEX
:
638 /* We know that the literal complex is stored in the superior
639 process not the inferior and that it is 16 bytes long.
640 Just like the case above with a literal array, the
641 bytes for the the literal complex number are stored
642 at the address pointed to by valaddr */
644 if (TYPE_LENGTH (type
) == 32)
645 error ("Cannot currently print out complex*32 literals");
647 /* First dereference valaddr. */
649 addr
= * (CORE_ADDR
*) valaddr
;
653 fprintf_filtered (stream
, "(");
655 if (TYPE_LENGTH(type
) == 16)
657 fprintf_filtered (stream
, "%.16f", * (double *) addr
);
658 fprintf_filtered (stream
, ", %.16f", * (double *)
659 (addr
+ sizeof(double)));
663 fprintf_filtered (stream
, "%.8f", * (float *) addr
);
664 fprintf_filtered (stream
, ", %.8f", * (float *)
665 (addr
+ sizeof(float)));
667 fprintf_filtered (stream
, ") ");
670 fprintf_filtered (stream
, "Unable to print literal F77 array");
673 case TYPE_CODE_COMPLEX
:
674 switch (TYPE_LENGTH (type
))
677 f77_print_cmplx (valaddr
, type
, stream
, TARGET_COMPLEX_BIT
);
681 f77_print_cmplx(valaddr
, type
, stream
, TARGET_DOUBLE_COMPLEX_BIT
);
685 f77_print_cmplx(valaddr
, type
, stream
, TARGET_EXT_COMPLEX_BIT
);
689 error ("Cannot print out complex*%d variables", TYPE_LENGTH(type
));
693 case TYPE_CODE_UNDEF
:
694 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
695 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
696 and no complete type for struct foo in that file. */
697 fprintf_filtered (stream
, "<incomplete type>");
701 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type
));
708 list_all_visible_commons (funname
)
711 SAVED_F77_COMMON_PTR tmp
;
713 tmp
= head_common_list
;
715 printf_filtered ("All COMMON blocks visible at this level:\n\n");
719 if (STREQ(tmp
->owning_function
,funname
))
720 printf_filtered ("%s\n", tmp
->name
);
726 /* This function is used to print out the values in a given COMMON
727 block. It will always use the most local common block of the
731 info_common_command (comname
, from_tty
)
735 SAVED_F77_COMMON_PTR the_common
;
736 COMMON_ENTRY_PTR entry
;
737 struct frame_info
*fi
;
738 register char *funname
= 0;
741 /* We have been told to display the contents of F77 COMMON
742 block supposedly visible in this function. Let us
743 first make sure that it is visible and if so, let
744 us display its contents */
749 error ("No frame selected");
751 /* The following is generally ripped off from stack.c's routine
752 print_frame_info() */
754 func
= find_pc_function (fi
->pc
);
757 /* In certain pathological cases, the symtabs give the wrong
758 function (when we are in the first function in a file which
759 is compiled without debugging symbols, the previous function
760 is compiled with debugging symbols, and the "foo.o" symbol
761 that is supposed to tell us where the file with debugging symbols
762 ends has been truncated by ar because it is longer than 15
765 So look in the minimal symbol tables as well, and if it comes
766 up with a larger address for the function use that instead.
767 I don't think this can ever cause any problems; there shouldn't
768 be any minimal symbols in the middle of a function.
769 FIXME: (Not necessarily true. What about text labels) */
771 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
774 && (SYMBOL_VALUE_ADDRESS (msymbol
)
775 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
776 funname
= SYMBOL_NAME (msymbol
);
778 funname
= SYMBOL_NAME (func
);
782 register struct minimal_symbol
*msymbol
=
783 lookup_minimal_symbol_by_pc (fi
->pc
);
786 funname
= SYMBOL_NAME (msymbol
);
789 /* If comnname is NULL, we assume the user wishes to see the
790 which COMMON blocks are visible here and then return */
792 if (strlen (comname
) == 0)
794 list_all_visible_commons (funname
);
798 the_common
= find_common_for_function (comname
,funname
);
802 if (STREQ(comname
,BLANK_COMMON_NAME_LOCAL
))
803 printf_filtered ("Contents of blank COMMON block:\n");
805 printf_filtered ("Contents of F77 COMMON block '%s':\n",comname
);
807 printf_filtered ("\n");
808 entry
= the_common
->entries
;
810 while (entry
!= NULL
)
812 printf_filtered ("%s = ",SYMBOL_NAME(entry
->symbol
));
813 print_variable_value (entry
->symbol
,fi
,stdout
);
814 printf_filtered ("\n");
819 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
823 /* This function is used to determine whether there is a
824 F77 common block visible at the current scope called 'comname'. */
827 there_is_a_visible_common_named (comname
)
830 SAVED_F77_COMMON_PTR the_common
;
831 struct frame_info
*fi
;
832 register char *funname
= 0;
836 error ("Cannot deal with NULL common name!");
841 error ("No frame selected");
843 /* The following is generally ripped off from stack.c's routine
844 print_frame_info() */
846 func
= find_pc_function (fi
->pc
);
849 /* In certain pathological cases, the symtabs give the wrong
850 function (when we are in the first function in a file which
851 is compiled without debugging symbols, the previous function
852 is compiled with debugging symbols, and the "foo.o" symbol
853 that is supposed to tell us where the file with debugging symbols
854 ends has been truncated by ar because it is longer than 15
857 So look in the minimal symbol tables as well, and if it comes
858 up with a larger address for the function use that instead.
859 I don't think this can ever cause any problems; there shouldn't
860 be any minimal symbols in the middle of a function.
861 FIXME: (Not necessarily true. What about text labels) */
863 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
866 && (SYMBOL_VALUE_ADDRESS (msymbol
)
867 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
868 funname
= SYMBOL_NAME (msymbol
);
870 funname
= SYMBOL_NAME (func
);
874 register struct minimal_symbol
*msymbol
=
875 lookup_minimal_symbol_by_pc (fi
->pc
);
878 funname
= SYMBOL_NAME (msymbol
);
881 the_common
= find_common_for_function (comname
, funname
);
883 return (the_common
? 1 : 0);
887 _initialize_f_valprint ()
889 add_info ("common", info_common_command
,
890 "Print out the values contained in a Fortran COMMON block.");