1 /* Support for printing Fortran types for GDB, the GNU debugger.
2 Copyright 1986, 1988, 1989, 1991 Free Software Foundation, Inc.
3 Contributed by Motorola. Adapted from the C version by Farooq Butt
4 (fmbutt@engage.sps.mot.com).
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. */
27 #include "expression.h"
36 #include "typeprint.h"
37 #include "frame.h" /* ??? */
42 static void f_type_print_args
PARAMS ((struct type
*, FILE *));
44 static void f_type_print_varspec_suffix
PARAMS ((struct type
*, FILE *,
47 void f_type_print_varspec_prefix
PARAMS ((struct type
*, FILE *, int, int));
49 void f_type_print_base
PARAMS ((struct type
*, FILE *, int, int));
52 /* LEVEL is the depth to indent lines by. */
55 f_print_type (type
, varstring
, stream
, show
, level
)
62 register enum type_code code
;
65 f_type_print_base (type
, stream
, show
, level
);
66 code
= TYPE_CODE (type
);
67 if ((varstring
!= NULL
&& *varstring
!= '\0')
69 /* Need a space if going to print stars or brackets;
70 but not if we will print just a type name. */
71 ((show
> 0 || TYPE_NAME (type
) == 0)
73 (code
== TYPE_CODE_PTR
|| code
== TYPE_CODE_FUNC
74 || code
== TYPE_CODE_METHOD
75 || code
== TYPE_CODE_ARRAY
76 || code
== TYPE_CODE_MEMBER
77 || code
== TYPE_CODE_REF
)))
78 fputs_filtered (" ", stream
);
79 f_type_print_varspec_prefix (type
, stream
, show
, 0);
81 fputs_filtered (varstring
, stream
);
83 /* For demangled function names, we have the arglist as part of the name,
84 so don't print an additional pair of ()'s */
86 demangled_args
= varstring
[strlen(varstring
) - 1] == ')';
87 f_type_print_varspec_suffix (type
, stream
, show
, 0, demangled_args
);
90 /* Print any asterisks or open-parentheses needed before the
91 variable name (to describe its type).
93 On outermost call, pass 0 for PASSED_A_PTR.
94 On outermost call, SHOW > 0 means should ignore
95 any typename for TYPE and show its details.
96 SHOW is always zero on recursive calls. */
99 f_type_print_varspec_prefix (type
, stream
, show
, passed_a_ptr
)
109 if (TYPE_NAME (type
) && show
<= 0)
114 switch (TYPE_CODE (type
))
117 f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type
), stream
, 0, 1);
121 f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type
), stream
, 0, 0);
123 fprintf_filtered (stream
, "(");
126 case TYPE_CODE_ARRAY
:
127 f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type
), stream
, 0, 0);
130 case TYPE_CODE_UNDEF
:
131 case TYPE_CODE_STRUCT
:
132 case TYPE_CODE_UNION
:
137 case TYPE_CODE_ERROR
:
141 case TYPE_CODE_RANGE
:
142 case TYPE_CODE_STRING
:
143 /* These types need no prefix. They are listed here so that
144 gcc -Wall will reveal any types that haven't been handled. */
150 f_type_print_args (type
, stream
)
157 fprintf_filtered (stream
, "(");
158 args
= TYPE_ARG_TYPES (type
);
163 fprintf_filtered (stream
, "...");
167 for (i
= 1; args
[i
] != NULL
&& args
[i
]->code
!= TYPE_CODE_VOID
; i
++)
169 f_print_type (args
[i
], "", stream
, -1, 0);
170 if (args
[i
+1] == NULL
)
171 fprintf_filtered (stream
, "...");
172 else if (args
[i
+1]->code
!= TYPE_CODE_VOID
)
174 fprintf_filtered (stream
, ",");
180 fprintf_filtered (stream
, ")");
183 /* Print any array sizes, function arguments or close parentheses
184 needed after the variable name (to describe its type).
185 Args work like c_type_print_varspec_prefix. */
188 f_type_print_varspec_suffix (type
, stream
, show
, passed_a_ptr
, demangled_args
)
195 CORE_ADDR current_frame_addr
= 0;
196 int upper_bound
,lower_bound
;
197 int lower_bound_was_default
= 0;
198 static int arrayprint_recurse_level
= 0;
204 if (TYPE_NAME (type
) && show
<= 0)
209 switch (TYPE_CODE (type
))
211 case TYPE_CODE_ARRAY
:
212 arrayprint_recurse_level
++;
214 if (arrayprint_recurse_level
== 1)
215 fprintf_filtered(stream
,"(");
217 fprintf_filtered(stream
,",");
219 retcode
= f77_get_dynamic_lowerbound (type
,&lower_bound
);
221 lower_bound_was_default
= 0;
223 if (retcode
== BOUND_FETCH_ERROR
)
224 fprintf_filtered (stream
,"???");
226 if (lower_bound
== 1) /* The default */
227 lower_bound_was_default
= 1;
229 fprintf_filtered (stream
,"%d",lower_bound
);
231 if (lower_bound_was_default
)
232 lower_bound_was_default
= 0;
234 fprintf_filtered(stream
,":");
236 /* Make sure that, if we have an assumed size array, we
237 print out a warning and print the upperbound as '*' */
239 if (TYPE_ARRAY_UPPER_BOUND_TYPE(type
) == BOUND_CANNOT_BE_DETERMINED
)
240 fprintf_filtered (stream
, "*");
243 retcode
= f77_get_dynamic_upperbound(type
,&upper_bound
);
245 if (retcode
== BOUND_FETCH_ERROR
)
246 fprintf_filtered(stream
,"???");
248 fprintf_filtered(stream
,"%d",upper_bound
);
251 f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type
), stream
, 0, 0, 0);
252 if (arrayprint_recurse_level
== 1)
253 fprintf_filtered (stream
, ")");
254 arrayprint_recurse_level
--;
259 f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type
), stream
, 0, 1, 0);
260 fprintf_filtered(stream
,")");
264 f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type
), stream
, 0,
267 fprintf_filtered (stream
, ")");
269 fprintf_filtered (stream
, "()");
272 case TYPE_CODE_UNDEF
:
273 case TYPE_CODE_STRUCT
:
274 case TYPE_CODE_UNION
:
279 case TYPE_CODE_ERROR
:
283 case TYPE_CODE_RANGE
:
284 case TYPE_CODE_LITERAL_STRING
:
285 case TYPE_CODE_STRING
:
286 /* These types do not need a suffix. They are listed so that
287 gcc -Wall will report types that may not have been considered. */
294 print_equivalent_f77_float_type (type
, stream
)
298 /* Override type name "float" and make it the
299 appropriate real. XLC stupidly outputs -12 as a type
300 for real when it really should be outputting -18 */
302 switch (TYPE_LENGTH (type
))
305 fprintf_filtered (stream
, "real*4");
309 fprintf_filtered(stream
,"real*8");
314 /* Print the name of the type (or the ultimate pointer target,
315 function value or array element), or the description of a
318 SHOW nonzero means don't print this type as just its name;
319 show its real definition even if it has a name.
320 SHOW zero means print just typename or struct tag if there is one
321 SHOW negative means abbreviate structure elements.
322 SHOW is decremented for printing of structure elements.
324 LEVEL is the depth to indent by.
325 We increase it for some recursive calls. */
328 f_type_print_base (type
, stream
, show
, level
)
337 register int lastval
;
339 char *demangled_name
;
340 enum {s_none
, s_public
, s_private
, s_protected
} section_type
;
341 int retcode
,upper_bound
;
347 fputs_filtered ("<type unknown>", stream
);
351 /* When SHOW is zero or less, and there is a valid type name, then always
352 just print the type name directly from the type. */
354 if ((show
<= 0) && (TYPE_NAME (type
) != NULL
))
356 /* Damn builtin types on RS6000! They call a float "float"
357 so we gotta translate to appropriate F77'isms */
359 if (TYPE_CODE (type
) == TYPE_CODE_FLT
)
360 print_equivalent_f77_float_type (type
, stream
);
362 fputs_filtered (TYPE_NAME (type
), stream
);
366 switch (TYPE_CODE (type
))
368 case TYPE_CODE_ARRAY
:
369 f_type_print_base (TYPE_TARGET_TYPE (type
), stream
, show
, level
);
373 f_type_print_base (TYPE_TARGET_TYPE (type
), stream
, show
, level
);
377 fprintf_filtered (stream
, "PTR TO -> ( ");
378 f_type_print_base (TYPE_TARGET_TYPE (type
), stream
, show
, level
);
382 fprintf_filtered (stream
, "VOID");
385 case TYPE_CODE_UNDEF
:
386 fprintf_filtered (stream
, "struct <unknown>");
389 case TYPE_CODE_ERROR
:
390 fprintf_filtered (stream
, "<unknown type>");
393 case TYPE_CODE_RANGE
:
394 /* This should not occur */
395 fprintf_filtered (stream
, "<range type>");
399 /* Override name "char" and make it "character" */
400 fprintf_filtered (stream
, "character");
404 /* There may be some character types that attempt to come
405 through as TYPE_CODE_INT since dbxstclass.h is so
406 C-oriented, we must change these to "character" from "char". */
408 if (STREQ(TYPE_NAME(type
),"char"))
409 fprintf_filtered (stream
,"character");
414 case TYPE_CODE_COMPLEX
:
415 case TYPE_CODE_LITERAL_COMPLEX
:
416 fprintf_filtered (stream
,"complex*");
417 fprintf_filtered (stream
,"%d",TYPE_LENGTH(type
));
421 print_equivalent_f77_float_type(type
,stream
);
424 case TYPE_CODE_LITERAL_STRING
:
425 fprintf_filtered (stream
, "character*%d",
426 TYPE_ARRAY_UPPER_BOUND_VALUE (type
));
429 case TYPE_CODE_STRING
:
430 /* Strings may have dynamic upperbounds (lengths) like arrays */
432 if (TYPE_ARRAY_UPPER_BOUND_TYPE (type
) == BOUND_CANNOT_BE_DETERMINED
)
433 fprintf_filtered("character*(*)");
436 retcode
= f77_get_dynamic_upperbound(type
,&upper_bound
);
438 if (retcode
== BOUND_FETCH_ERROR
)
439 fprintf_filtered(stream
,"character*???");
441 fprintf_filtered(stream
,"character*%d",upper_bound
);
447 /* Handle types not explicitly handled by the other cases,
448 such as fundamental types. For these, just print whatever
449 the type name is, as recorded in the type itself. If there
450 is no type name, then complain. */
451 if (TYPE_NAME (type
) != NULL
)
452 fputs_filtered (TYPE_NAME (type
), stream
);
454 error ("Invalid type code (%d) in symbol table.", TYPE_CODE (type
));