1 /* Support for printing Fortran types for GDB, the GNU debugger.
2
3 Copyright (C) 1986-2024 Free Software Foundation, Inc.
4
5 Contributed by Motorola. Adapted from the C version by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
7
8 This file is part of GDB.
9
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 3 of the License, or
13 (at your option) any later version.
14
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22
23 #include "event-top.h"
24 #include "gdbsupport/gdb_obstack.h"
25 #include "bfd.h"
26 #include "symtab.h"
27 #include "gdbtypes.h"
28 #include "expression.h"
29 #include "value.h"
30 #include "gdbcore.h"
31 #include "target.h"
32 #include "f-lang.h"
33 #include "typeprint.h"
34 #include "cli/cli-style.h"
35
36 /* See f-lang.h. */
37
38 void
print_typedef(struct type * type,struct symbol * new_symbol,struct ui_file * stream)39 f_language::print_typedef (struct type *type, struct symbol *new_symbol,
40 struct ui_file *stream) const
41 {
42 type = check_typedef (type);
43 print_type (type, "", stream, 0, 0, &type_print_raw_options);
44 }
45
46 /* See f-lang.h. */
47
48 void
print_type(struct type * type,const char * varstring,struct ui_file * stream,int show,int level,const struct type_print_options * flags)49 f_language::print_type (struct type *type, const char *varstring,
50 struct ui_file *stream, int show, int level,
51 const struct type_print_options *flags) const
52 {
53 enum type_code code;
54
55 f_type_print_base (type, stream, show, level);
56 code = type->code ();
57 if ((varstring != NULL && *varstring != '\0')
58 /* Need a space if going to print stars or brackets; but not if we
59 will print just a type name. */
60 || ((show > 0
61 || type->name () == 0)
62 && (code == TYPE_CODE_FUNC
63 || code == TYPE_CODE_METHOD
64 || code == TYPE_CODE_ARRAY
65 || ((code == TYPE_CODE_PTR
66 || code == TYPE_CODE_REF)
67 && (type->target_type ()->code () == TYPE_CODE_FUNC
68 || (type->target_type ()->code ()
69 == TYPE_CODE_METHOD)
70 || (type->target_type ()->code ()
71 == TYPE_CODE_ARRAY))))))
72 gdb_puts (" ", stream);
73 f_type_print_varspec_prefix (type, stream, show, 0);
74
75 if (varstring != NULL)
76 {
77 int demangled_args;
78
79 gdb_puts (varstring, stream);
80
81 /* For demangled function names, we have the arglist as part of the name,
82 so don't print an additional pair of ()'s. */
83
84 demangled_args = (*varstring != '\0'
85 && varstring[strlen (varstring) - 1] == ')');
86 f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0, false);
87 }
88 }
89
90 /* See f-lang.h. */
91
92 void
f_type_print_varspec_prefix(struct type * type,struct ui_file * stream,int show,int passed_a_ptr)93 f_language::f_type_print_varspec_prefix (struct type *type,
94 struct ui_file *stream,
95 int show, int passed_a_ptr) const
96 {
97 if (type == 0)
98 return;
99
100 if (type->name () && show <= 0)
101 return;
102
103 QUIT;
104
105 switch (type->code ())
106 {
107 case TYPE_CODE_PTR:
108 f_type_print_varspec_prefix (type->target_type (), stream, 0, 1);
109 break;
110
111 case TYPE_CODE_FUNC:
112 f_type_print_varspec_prefix (type->target_type (), stream, 0, 0);
113 if (passed_a_ptr)
114 gdb_printf (stream, "(");
115 break;
116
117 case TYPE_CODE_ARRAY:
118 f_type_print_varspec_prefix (type->target_type (), stream, 0, 0);
119 break;
120
121 case TYPE_CODE_UNDEF:
122 case TYPE_CODE_STRUCT:
123 case TYPE_CODE_UNION:
124 case TYPE_CODE_NAMELIST:
125 case TYPE_CODE_ENUM:
126 case TYPE_CODE_INT:
127 case TYPE_CODE_FLT:
128 case TYPE_CODE_VOID:
129 case TYPE_CODE_ERROR:
130 case TYPE_CODE_CHAR:
131 case TYPE_CODE_BOOL:
132 case TYPE_CODE_SET:
133 case TYPE_CODE_RANGE:
134 case TYPE_CODE_STRING:
135 case TYPE_CODE_METHOD:
136 case TYPE_CODE_REF:
137 case TYPE_CODE_COMPLEX:
138 case TYPE_CODE_TYPEDEF:
139 /* These types need no prefix. They are listed here so that
140 gcc -Wall will reveal any types that haven't been handled. */
141 break;
142 }
143 }
144
145 /* See f-lang.h. */
146
147 void
f_type_print_varspec_suffix(struct type * type,struct ui_file * stream,int show,int passed_a_ptr,int demangled_args,int arrayprint_recurse_level,bool print_rank_only)148 f_language::f_type_print_varspec_suffix (struct type *type,
149 struct ui_file *stream,
150 int show, int passed_a_ptr,
151 int demangled_args,
152 int arrayprint_recurse_level,
153 bool print_rank_only) const
154 {
155 /* No static variables are permitted as an error call may occur during
156 execution of this function. */
157
158 if (type == 0)
159 return;
160
161 if (type->name () && show <= 0)
162 return;
163
164 QUIT;
165
166 switch (type->code ())
167 {
168 case TYPE_CODE_ARRAY:
169 arrayprint_recurse_level++;
170
171 if (arrayprint_recurse_level == 1)
172 gdb_printf (stream, "(");
173
174 if (type_not_associated (type))
175 print_rank_only = true;
176 else if (type_not_allocated (type))
177 print_rank_only = true;
178 else if ((TYPE_ASSOCIATED_PROP (type)
179 && !TYPE_ASSOCIATED_PROP (type)->is_constant ())
180 || (TYPE_ALLOCATED_PROP (type)
181 && !TYPE_ALLOCATED_PROP (type)->is_constant ())
182 || (TYPE_DATA_LOCATION (type)
183 && !TYPE_DATA_LOCATION (type)->is_constant ()))
184 {
185 /* This case exist when we ptype a typename which has the dynamic
186 properties but cannot be resolved as there is no object. */
187 print_rank_only = true;
188 }
189
190 if (type->target_type ()->code () == TYPE_CODE_ARRAY)
191 f_type_print_varspec_suffix (type->target_type (), stream, 0,
192 0, 0, arrayprint_recurse_level,
193 print_rank_only);
194
195 if (print_rank_only)
196 gdb_printf (stream, ":");
197 else
198 {
199 LONGEST lower_bound = f77_get_lowerbound (type);
200 if (lower_bound != 1) /* Not the default. */
201 gdb_printf (stream, "%s:", plongest (lower_bound));
202
203 /* Make sure that, if we have an assumed size array, we
204 print out a warning and print the upperbound as '*'. */
205
206 if (type->bounds ()->high.kind () == PROP_UNDEFINED)
207 gdb_printf (stream, "*");
208 else
209 {
210 LONGEST upper_bound = f77_get_upperbound (type);
211
212 gdb_puts (plongest (upper_bound), stream);
213 }
214 }
215
216 if (type->target_type ()->code () != TYPE_CODE_ARRAY)
217 f_type_print_varspec_suffix (type->target_type (), stream, 0,
218 0, 0, arrayprint_recurse_level,
219 print_rank_only);
220
221 if (arrayprint_recurse_level == 1)
222 gdb_printf (stream, ")");
223 else
224 gdb_printf (stream, ",");
225 arrayprint_recurse_level--;
226 break;
227
228 case TYPE_CODE_PTR:
229 case TYPE_CODE_REF:
230 f_type_print_varspec_suffix (type->target_type (), stream, 0, 1, 0,
231 arrayprint_recurse_level, false);
232 gdb_printf (stream, " )");
233 break;
234
235 case TYPE_CODE_FUNC:
236 {
237 int i, nfields = type->num_fields ();
238
239 f_type_print_varspec_suffix (type->target_type (), stream, 0,
240 passed_a_ptr, 0,
241 arrayprint_recurse_level, false);
242 if (passed_a_ptr)
243 gdb_printf (stream, ") ");
244 gdb_printf (stream, "(");
245 if (nfields == 0 && type->is_prototyped ())
246 print_type (builtin_f_type (type->arch ())->builtin_void,
247 "", stream, -1, 0, 0);
248 else
249 for (i = 0; i < nfields; i++)
250 {
251 if (i > 0)
252 {
253 gdb_puts (", ", stream);
254 stream->wrap_here (4);
255 }
256 print_type (type->field (i).type (), "", stream, -1, 0, 0);
257 }
258 gdb_printf (stream, ")");
259 }
260 break;
261
262 case TYPE_CODE_UNDEF:
263 case TYPE_CODE_STRUCT:
264 case TYPE_CODE_UNION:
265 case TYPE_CODE_NAMELIST:
266 case TYPE_CODE_ENUM:
267 case TYPE_CODE_INT:
268 case TYPE_CODE_FLT:
269 case TYPE_CODE_VOID:
270 case TYPE_CODE_ERROR:
271 case TYPE_CODE_CHAR:
272 case TYPE_CODE_BOOL:
273 case TYPE_CODE_SET:
274 case TYPE_CODE_RANGE:
275 case TYPE_CODE_STRING:
276 case TYPE_CODE_METHOD:
277 case TYPE_CODE_COMPLEX:
278 case TYPE_CODE_TYPEDEF:
279 /* These types do not need a suffix. They are listed so that
280 gcc -Wall will report types that may not have been considered. */
281 break;
282 }
283 }
284
285 /* See f-lang.h. */
286
287 void
f_type_print_derivation_info(struct type * type,struct ui_file * stream)288 f_language::f_type_print_derivation_info (struct type *type,
289 struct ui_file *stream) const
290 {
291 /* Fortran doesn't support multiple inheritance. */
292 const int i = 0;
293
294 if (TYPE_N_BASECLASSES (type) > 0)
295 gdb_printf (stream, ", extends(%s) ::", TYPE_BASECLASS (type, i)->name ());
296 }
297
298 /* See f-lang.h. */
299
300 void
f_type_print_base(struct type * type,struct ui_file * stream,int show,int level)301 f_language::f_type_print_base (struct type *type, struct ui_file *stream,
302 int show, int level) const
303 {
304 int index;
305
306 QUIT;
307
308 stream->wrap_here (4);
309 if (type == NULL)
310 {
311 fputs_styled ("<type unknown>", metadata_style.style (), stream);
312 return;
313 }
314
315 /* When SHOW is zero or less, and there is a valid type name, then always
316 just print the type name directly from the type. */
317
318 if ((show <= 0) && (type->name () != NULL))
319 {
320 const char *prefix = "";
321 if (type->code () == TYPE_CODE_UNION)
322 prefix = "Type, C_Union :: ";
323 else if (type->code () == TYPE_CODE_STRUCT
324 || type->code () == TYPE_CODE_NAMELIST)
325 prefix = "Type ";
326 gdb_printf (stream, "%*s%s%s", level, "", prefix, type->name ());
327 return;
328 }
329
330 if (type->code () != TYPE_CODE_TYPEDEF)
331 type = check_typedef (type);
332
333 switch (type->code ())
334 {
335 case TYPE_CODE_TYPEDEF:
336 f_type_print_base (type->target_type (), stream, 0, level);
337 break;
338
339 case TYPE_CODE_ARRAY:
340 f_type_print_base (type->target_type (), stream, show, level);
341 break;
342 case TYPE_CODE_FUNC:
343 if (type->target_type () == NULL)
344 type_print_unknown_return_type (stream);
345 else
346 f_type_print_base (type->target_type (), stream, show, level);
347 break;
348
349 case TYPE_CODE_PTR:
350 gdb_printf (stream, "%*sPTR TO -> ( ", level, "");
351 f_type_print_base (type->target_type (), stream, show, 0);
352 break;
353
354 case TYPE_CODE_REF:
355 gdb_printf (stream, "%*sREF TO -> ( ", level, "");
356 f_type_print_base (type->target_type (), stream, show, 0);
357 break;
358
359 case TYPE_CODE_VOID:
360 {
361 struct type *void_type = builtin_f_type (type->arch ())->builtin_void;
362 gdb_printf (stream, "%*s%s", level, "", void_type->name ());
363 }
364 break;
365
366 case TYPE_CODE_UNDEF:
367 gdb_printf (stream, "%*sstruct <unknown>", level, "");
368 break;
369
370 case TYPE_CODE_ERROR:
371 gdb_printf (stream, "%*s%s", level, "", TYPE_ERROR_NAME (type));
372 break;
373
374 case TYPE_CODE_RANGE:
375 /* This should not occur. */
376 gdb_printf (stream, "%*s<range type>", level, "");
377 break;
378
379 case TYPE_CODE_CHAR:
380 case TYPE_CODE_INT:
381 /* There may be some character types that attempt to come
382 through as TYPE_CODE_INT since dbxstclass.h is so
383 C-oriented, we must change these to "character" from "char". */
384
385 if (strcmp (type->name (), "char") == 0)
386 gdb_printf (stream, "%*scharacter", level, "");
387 else
388 goto default_case;
389 break;
390
391 case TYPE_CODE_STRING:
392 /* Strings may have dynamic upperbounds (lengths) like arrays. We
393 check specifically for the PROP_CONST case to indicate that the
394 dynamic type has been resolved. If we arrive here having been
395 asked to print the type of a value with a dynamic type then the
396 bounds will not have been resolved. */
397
398 if (type->bounds ()->high.is_constant ())
399 {
400 LONGEST upper_bound = f77_get_upperbound (type);
401
402 gdb_printf (stream, "character*%s", pulongest (upper_bound));
403 }
404 else
405 gdb_printf (stream, "%*scharacter*(*)", level, "");
406 break;
407
408 case TYPE_CODE_STRUCT:
409 case TYPE_CODE_UNION:
410 case TYPE_CODE_NAMELIST:
411 if (type->code () == TYPE_CODE_UNION)
412 gdb_printf (stream, "%*sType, C_Union ::", level, "");
413 else
414 gdb_printf (stream, "%*sType", level, "");
415
416 if (show > 0)
417 f_type_print_derivation_info (type, stream);
418
419 gdb_puts (" ", stream);
420
421 gdb_puts (type->name (), stream);
422
423 /* According to the definition,
424 we only print structure elements in case show > 0. */
425 if (show > 0)
426 {
427 gdb_puts ("\n", stream);
428 for (index = 0; index < type->num_fields (); index++)
429 {
430 f_type_print_base (type->field (index).type (), stream,
431 show - 1, level + 4);
432 gdb_puts (" :: ", stream);
433 fputs_styled (type->field (index).name (),
434 variable_name_style.style (), stream);
435 f_type_print_varspec_suffix (type->field (index).type (),
436 stream, show - 1, 0, 0, 0, false);
437 gdb_puts ("\n", stream);
438 }
439 gdb_printf (stream, "%*sEnd Type ", level, "");
440 gdb_puts (type->name (), stream);
441 }
442 break;
443
444 case TYPE_CODE_MODULE:
445 gdb_printf (stream, "%*smodule %s", level, "", type->name ());
446 break;
447
448 default_case:
449 default:
450 /* Handle types not explicitly handled by the other cases,
451 such as fundamental types. For these, just print whatever
452 the type name is, as recorded in the type itself. If there
453 is no type name, then complain. */
454 if (type->name () != NULL)
455 gdb_printf (stream, "%*s%s", level, "", type->name ());
456 else
457 error (_("Invalid type code (%d) in symbol table."), type->code ());
458 break;
459 }
460
461 if (TYPE_IS_ALLOCATABLE (type))
462 gdb_printf (stream, ", allocatable");
463 }
464