gdb/f-typeprint.c

   1 /* Support for printing Fortran types for GDB, the GNU debugger.
   2
   3    Copyright (C) 1986-2022 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
  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 (type)->code () == TYPE_CODE_FUNC
  68                       || (TYPE_TARGET_TYPE (type)->code ()
  69                           == TYPE_CODE_METHOD)
  70                       || (TYPE_TARGET_TYPE (type)->code ()
  71                           == TYPE_CODE_ARRAY))))))
  72     fputs_filtered (" ", stream);
  73   f_type_print_varspec_prefix (type, stream, show, 0);
  74
  75   if (varstring != NULL)
  76     {
  77       int demangled_args;
  78
  79       fputs_filtered (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 (type), stream, 0, 1);
 109       break;
 110
 111     case TYPE_CODE_FUNC:
 112       f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
 113       if (passed_a_ptr)
 114         fprintf_filtered (stream, "(");
 115       break;
 116
 117     case TYPE_CODE_ARRAY:
 118       f_type_print_varspec_prefix (TYPE_TARGET_TYPE (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         fprintf_filtered (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 (type)->code () == TYPE_CODE_ARRAY)
 191         f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
 192                                      0, 0, arrayprint_recurse_level,
 193                                      print_rank_only);
 194
 195       if (print_rank_only)
 196         fprintf_filtered (stream, ":");
 197       else
 198         {
 199           LONGEST lower_bound = f77_get_lowerbound (type);
 200           if (lower_bound != 1) /* Not the default.  */
 201             fprintf_filtered (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             fprintf_filtered (stream, "*");
 208           else
 209             {
 210               LONGEST upper_bound = f77_get_upperbound (type);
 211
 212               fputs_filtered (plongest (upper_bound), stream);
 213             }
 214         }
 215
 216       if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_ARRAY)
 217         f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
 218                                      0, 0, arrayprint_recurse_level,
 219                                      print_rank_only);
 220
 221       if (arrayprint_recurse_level == 1)
 222         fprintf_filtered (stream, ")");
 223       else
 224         fprintf_filtered (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 (type), stream, 0, 1, 0,
 231                                    arrayprint_recurse_level, false);
 232       fprintf_filtered (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 (type), stream, 0,
 240                                      passed_a_ptr, 0,
 241                                      arrayprint_recurse_level, false);
 242         if (passed_a_ptr)
 243           fprintf_filtered (stream, ") ");
 244         fprintf_filtered (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                   fputs_filtered (", ", stream);
 254                   stream->wrap_here (4);
 255                 }
 256               print_type (type->field (i).type (), "", stream, -1, 0, 0);
 257             }
 258         fprintf_filtered (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_base (struct type *type, struct ui_file *stream,
 289                                int show, int level) const
 290 {
 291   int index;
 292
 293   QUIT;
 294
 295   stream->wrap_here (4);
 296   if (type == NULL)
 297     {
 298       fputs_styled ("<type unknown>", metadata_style.style (), stream);
 299       return;
 300     }
 301
 302   /* When SHOW is zero or less, and there is a valid type name, then always
 303      just print the type name directly from the type.  */
 304
 305   if ((show <= 0) && (type->name () != NULL))
 306     {
 307       const char *prefix = "";
 308       if (type->code () == TYPE_CODE_UNION)
 309         prefix = "Type, C_Union :: ";
 310       else if (type->code () == TYPE_CODE_STRUCT
 311                || type->code () == TYPE_CODE_NAMELIST)
 312         prefix = "Type ";
 313       fprintf_filtered (stream, "%*s%s%s", level, "", prefix, type->name ());
 314       return;
 315     }
 316
 317   if (type->code () != TYPE_CODE_TYPEDEF)
 318     type = check_typedef (type);
 319
 320   switch (type->code ())
 321     {
 322     case TYPE_CODE_TYPEDEF:
 323       f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
 324       break;
 325
 326     case TYPE_CODE_ARRAY:
 327       f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
 328       break;
 329     case TYPE_CODE_FUNC:
 330       if (TYPE_TARGET_TYPE (type) == NULL)
 331         type_print_unknown_return_type (stream);
 332       else
 333         f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
 334       break;
 335
 336     case TYPE_CODE_PTR:
 337       fprintf_filtered (stream, "%*sPTR TO -> ( ", level, "");
 338       f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, 0);
 339       break;
 340
 341     case TYPE_CODE_REF:
 342       fprintf_filtered (stream, "%*sREF TO -> ( ", level, "");
 343       f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, 0);
 344       break;
 345
 346     case TYPE_CODE_VOID:
 347       {
 348         struct type *void_type = builtin_f_type (type->arch ())->builtin_void;
 349         fprintf_filtered (stream, "%*s%s", level, "", void_type->name ());
 350       }
 351       break;
 352
 353     case TYPE_CODE_UNDEF:
 354       fprintf_filtered (stream, "%*sstruct <unknown>", level, "");
 355       break;
 356
 357     case TYPE_CODE_ERROR:
 358       fprintf_filtered (stream, "%*s%s", level, "", TYPE_ERROR_NAME (type));
 359       break;
 360
 361     case TYPE_CODE_RANGE:
 362       /* This should not occur.  */
 363       fprintf_filtered (stream, "%*s<range type>", level, "");
 364       break;
 365
 366     case TYPE_CODE_CHAR:
 367     case TYPE_CODE_INT:
 368       /* There may be some character types that attempt to come
 369          through as TYPE_CODE_INT since dbxstclass.h is so
 370          C-oriented, we must change these to "character" from "char".  */
 371
 372       if (strcmp (type->name (), "char") == 0)
 373         fprintf_filtered (stream, "%*scharacter", level, "");
 374       else
 375         goto default_case;
 376       break;
 377
 378     case TYPE_CODE_STRING:
 379       /* Strings may have dynamic upperbounds (lengths) like arrays.  We
 380          check specifically for the PROP_CONST case to indicate that the
 381          dynamic type has been resolved.  If we arrive here having been
 382          asked to print the type of a value with a dynamic type then the
 383          bounds will not have been resolved.  */
 384
 385       if (type->bounds ()->high.kind () == PROP_CONST)
 386         {
 387           LONGEST upper_bound = f77_get_upperbound (type);
 388
 389           fprintf_filtered (stream, "character*%s", pulongest (upper_bound));
 390         }
 391       else
 392         fprintf_filtered (stream, "%*scharacter*(*)", level, "");
 393       break;
 394
 395     case TYPE_CODE_STRUCT:
 396     case TYPE_CODE_UNION:
 397     case TYPE_CODE_NAMELIST:
 398       if (type->code () == TYPE_CODE_UNION)
 399         fprintf_filtered (stream, "%*sType, C_Union :: ", level, "");
 400       else
 401         fprintf_filtered (stream, "%*sType ", level, "");
 402       fputs_filtered (type->name (), stream);
 403       /* According to the definition,
 404          we only print structure elements in case show > 0.  */
 405       if (show > 0)
 406         {
 407           fputs_filtered ("\n", stream);
 408           for (index = 0; index < type->num_fields (); index++)
 409             {
 410               f_type_print_base (type->field (index).type (), stream,
 411                                  show - 1, level + 4);
 412               fputs_filtered (" :: ", stream);
 413               fputs_styled (type->field (index).name (),
 414                             variable_name_style.style (), stream);
 415               f_type_print_varspec_suffix (type->field (index).type (),
 416                                            stream, show - 1, 0, 0, 0, false);
 417               fputs_filtered ("\n", stream);
 418             }
 419           fprintf_filtered (stream, "%*sEnd Type ", level, "");
 420           fputs_filtered (type->name (), stream);
 421         }
 422       break;
 423
 424     case TYPE_CODE_MODULE:
 425       fprintf_filtered (stream, "%*smodule %s", level, "", type->name ());
 426       break;
 427
 428     default_case:
 429     default:
 430       /* Handle types not explicitly handled by the other cases,
 431          such as fundamental types.  For these, just print whatever
 432          the type name is, as recorded in the type itself.  If there
 433          is no type name, then complain.  */
 434       if (type->name () != NULL)
 435         fprintf_filtered (stream, "%*s%s", level, "", type->name ());
 436       else
 437         error (_("Invalid type code (%d) in symbol table."), type->code ());
 438       break;
 439     }
 440
 441   if (TYPE_IS_ALLOCATABLE (type))
 442     fprintf_filtered (stream, ", allocatable");
 443 }