1/* Support for printing Fortran types for GDB, the GNU debugger.
2
3   Copyright (C) 1986-2023 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 "defs.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
38void
39f_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
48void
49f_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
92void
93f_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
147void
148f_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		&& PROP_CONST != TYPE_ASSOCIATED_PROP (type)->kind ())
180	       || (TYPE_ALLOCATED_PROP (type)
181		   && PROP_CONST != TYPE_ALLOCATED_PROP (type)->kind ())
182	       || (TYPE_DATA_LOCATION (type)
183		   && PROP_CONST != TYPE_DATA_LOCATION (type)->kind ()))
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
287void
288f_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
300void
301f_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.kind () == PROP_CONST)
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