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