gdb/f-typeprint.c

   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
  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
  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
  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
 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
 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
 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 }