gdb/f-typeprint.c

   1 /* Support for printing Fortran types for GDB, the GNU debugger.
   2
   3    Copyright (C) 1986-2021 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 "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_ENUM:
 125     case TYPE_CODE_INT:
 126     case TYPE_CODE_FLT:
 127     case TYPE_CODE_VOID:
 128     case TYPE_CODE_ERROR:
 129     case TYPE_CODE_CHAR:
 130     case TYPE_CODE_BOOL:
 131     case TYPE_CODE_SET:
 132     case TYPE_CODE_RANGE:
 133     case TYPE_CODE_STRING:
 134     case TYPE_CODE_METHOD:
 135     case TYPE_CODE_REF:
 136     case TYPE_CODE_COMPLEX:
 137     case TYPE_CODE_TYPEDEF:
 138       /* These types need no prefix.  They are listed here so that
 139          gcc -Wall will reveal any types that haven't been handled.  */
 140       break;
 141     }
 142 }
 143
 144 /* See f-lang.h.  */
 145
 146 void
 147 f_language::f_type_print_varspec_suffix (struct type *type,
 148                                          struct ui_file *stream,
 149                                          int show, int passed_a_ptr,
 150                                          int demangled_args,
 151                                          int arrayprint_recurse_level,
 152                                          bool print_rank_only) const
 153 {
 154   /* No static variables are permitted as an error call may occur during
 155      execution of this function.  */
 156
 157   if (type == 0)
 158     return;
 159
 160   if (type->name () && show <= 0)
 161     return;
 162
 163   QUIT;
 164
 165   switch (type->code ())
 166     {
 167     case TYPE_CODE_ARRAY:
 168       arrayprint_recurse_level++;
 169
 170       if (arrayprint_recurse_level == 1)
 171         fprintf_filtered (stream, "(");
 172
 173       if (type_not_associated (type))
 174         print_rank_only = true;
 175       else if (type_not_allocated (type))
 176         print_rank_only = true;
 177       else if ((TYPE_ASSOCIATED_PROP (type)
 178                 && PROP_CONST != TYPE_ASSOCIATED_PROP (type)->kind ())
 179                || (TYPE_ALLOCATED_PROP (type)
 180                    && PROP_CONST != TYPE_ALLOCATED_PROP (type)->kind ())
 181                || (TYPE_DATA_LOCATION (type)
 182                    && PROP_CONST != TYPE_DATA_LOCATION (type)->kind ()))
 183         {
 184           /* This case exist when we ptype a typename which has the dynamic
 185              properties but cannot be resolved as there is no object.  */
 186           print_rank_only = true;
 187         }
 188
 189       if (TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_ARRAY)
 190         f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
 191                                      0, 0, arrayprint_recurse_level,
 192                                      print_rank_only);
 193
 194       if (print_rank_only)
 195         fprintf_filtered (stream, ":");
 196       else
 197         {
 198           LONGEST lower_bound = f77_get_lowerbound (type);
 199           if (lower_bound != 1) /* Not the default.  */
 200             fprintf_filtered (stream, "%s:", plongest (lower_bound));
 201
 202           /* Make sure that, if we have an assumed size array, we
 203                print out a warning and print the upperbound as '*'.  */
 204
 205           if (type->bounds ()->high.kind () == PROP_UNDEFINED)
 206             fprintf_filtered (stream, "*");
 207           else
 208             {
 209               LONGEST upper_bound = f77_get_upperbound (type);
 210
 211               fputs_filtered (plongest (upper_bound), stream);
 212             }
 213         }
 214
 215       if (TYPE_TARGET_TYPE (type)->code () != TYPE_CODE_ARRAY)
 216         f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
 217                                      0, 0, arrayprint_recurse_level,
 218                                      print_rank_only);
 219
 220       if (arrayprint_recurse_level == 1)
 221         fprintf_filtered (stream, ")");
 222       else
 223         fprintf_filtered (stream, ",");
 224       arrayprint_recurse_level--;
 225       break;
 226
 227     case TYPE_CODE_PTR:
 228     case TYPE_CODE_REF:
 229       f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0,
 230                                    arrayprint_recurse_level, false);
 231       fprintf_filtered (stream, " )");
 232       break;
 233
 234     case TYPE_CODE_FUNC:
 235       {
 236         int i, nfields = type->num_fields ();
 237
 238         f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
 239                                      passed_a_ptr, 0,
 240                                      arrayprint_recurse_level, false);
 241         if (passed_a_ptr)
 242           fprintf_filtered (stream, ") ");
 243         fprintf_filtered (stream, "(");
 244         if (nfields == 0 && type->is_prototyped ())
 245           print_type (builtin_f_type (get_type_arch (type))->builtin_void,
 246                         "", stream, -1, 0, 0);
 247         else
 248           for (i = 0; i < nfields; i++)
 249             {
 250               if (i > 0)
 251                 {
 252                   fputs_filtered (", ", stream);
 253                   wrap_here ("    ");
 254                 }
 255               print_type (type->field (i).type (), "", stream, -1, 0, 0);
 256             }
 257         fprintf_filtered (stream, ")");
 258       }
 259       break;
 260
 261     case TYPE_CODE_UNDEF:
 262     case TYPE_CODE_STRUCT:
 263     case TYPE_CODE_UNION:
 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_base (struct type *type, struct ui_file *stream,
 287                                int show, int level) const
 288 {
 289   int index;
 290
 291   QUIT;
 292
 293   wrap_here ("    ");
 294   if (type == NULL)
 295     {
 296       fputs_styled ("<type unknown>", metadata_style.style (), stream);
 297       return;
 298     }
 299
 300   /* When SHOW is zero or less, and there is a valid type name, then always
 301      just print the type name directly from the type.  */
 302
 303   if ((show <= 0) && (type->name () != NULL))
 304     {
 305       const char *prefix = "";
 306       if (type->code () == TYPE_CODE_UNION)
 307         prefix = "Type, C_Union :: ";
 308       else if (type->code () == TYPE_CODE_STRUCT)
 309         prefix = "Type ";
 310       fprintf_filtered (stream, "%*s%s%s", level, "", prefix, type->name ());
 311       return;
 312     }
 313
 314   if (type->code () != TYPE_CODE_TYPEDEF)
 315     type = check_typedef (type);
 316
 317   switch (type->code ())
 318     {
 319     case TYPE_CODE_TYPEDEF:
 320       f_type_print_base (TYPE_TARGET_TYPE (type), stream, 0, level);
 321       break;
 322
 323     case TYPE_CODE_ARRAY:
 324       f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
 325       break;
 326     case TYPE_CODE_FUNC:
 327       if (TYPE_TARGET_TYPE (type) == NULL)
 328         type_print_unknown_return_type (stream);
 329       else
 330         f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
 331       break;
 332
 333     case TYPE_CODE_PTR:
 334       fprintf_filtered (stream, "%*sPTR TO -> ( ", level, "");
 335       f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, 0);
 336       break;
 337
 338     case TYPE_CODE_REF:
 339       fprintf_filtered (stream, "%*sREF TO -> ( ", level, "");
 340       f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, 0);
 341       break;
 342
 343     case TYPE_CODE_VOID:
 344       {
 345         gdbarch *gdbarch = get_type_arch (type);
 346         struct type *void_type = builtin_f_type (gdbarch)->builtin_void;
 347         fprintf_filtered (stream, "%*s%s", level, "", void_type->name ());
 348       }
 349       break;
 350
 351     case TYPE_CODE_UNDEF:
 352       fprintf_filtered (stream, "%*sstruct <unknown>", level, "");
 353       break;
 354
 355     case TYPE_CODE_ERROR:
 356       fprintf_filtered (stream, "%*s%s", level, "", TYPE_ERROR_NAME (type));
 357       break;
 358
 359     case TYPE_CODE_RANGE:
 360       /* This should not occur.  */
 361       fprintf_filtered (stream, "%*s<range type>", level, "");
 362       break;
 363
 364     case TYPE_CODE_CHAR:
 365     case TYPE_CODE_INT:
 366       /* There may be some character types that attempt to come
 367          through as TYPE_CODE_INT since dbxstclass.h is so
 368          C-oriented, we must change these to "character" from "char".  */
 369
 370       if (strcmp (type->name (), "char") == 0)
 371         fprintf_filtered (stream, "%*scharacter", level, "");
 372       else
 373         goto default_case;
 374       break;
 375
 376     case TYPE_CODE_STRING:
 377       /* Strings may have dynamic upperbounds (lengths) like arrays.  We
 378          check specifically for the PROP_CONST case to indicate that the
 379          dynamic type has been resolved.  If we arrive here having been
 380          asked to print the type of a value with a dynamic type then the
 381          bounds will not have been resolved.  */
 382
 383       if (type->bounds ()->high.kind () == PROP_CONST)
 384         {
 385           LONGEST upper_bound = f77_get_upperbound (type);
 386
 387           fprintf_filtered (stream, "character*%s", pulongest (upper_bound));
 388         }
 389       else
 390         fprintf_filtered (stream, "%*scharacter*(*)", level, "");
 391       break;
 392
 393     case TYPE_CODE_STRUCT:
 394     case TYPE_CODE_UNION:
 395       if (type->code () == TYPE_CODE_UNION)
 396         fprintf_filtered (stream, "%*sType, C_Union :: ", level, "");
 397       else
 398         fprintf_filtered (stream, "%*sType ", level, "");
 399       fputs_filtered (type->name (), stream);
 400       /* According to the definition,
 401          we only print structure elements in case show > 0.  */
 402       if (show > 0)
 403         {
 404           fputs_filtered ("\n", stream);
 405           for (index = 0; index < type->num_fields (); index++)
 406             {
 407               f_type_print_base (type->field (index).type (), stream,
 408                                  show - 1, level + 4);
 409               fputs_filtered (" :: ", stream);
 410               fputs_styled (TYPE_FIELD_NAME (type, index),
 411                             variable_name_style.style (), stream);
 412               f_type_print_varspec_suffix (type->field (index).type (),
 413                                            stream, show - 1, 0, 0, 0, false);
 414               fputs_filtered ("\n", stream);
 415             }
 416           fprintf_filtered (stream, "%*sEnd Type ", level, "");
 417           fputs_filtered (type->name (), stream);
 418         }
 419       break;
 420
 421     case TYPE_CODE_MODULE:
 422       fprintf_filtered (stream, "%*smodule %s", level, "", type->name ());
 423       break;
 424
 425     default_case:
 426     default:
 427       /* Handle types not explicitly handled by the other cases,
 428          such as fundamental types.  For these, just print whatever
 429          the type name is, as recorded in the type itself.  If there
 430          is no type name, then complain.  */
 431       if (type->name () != NULL)
 432         fprintf_filtered (stream, "%*s%s", level, "", type->name ());
 433       else
 434         error (_("Invalid type code (%d) in symbol table."), type->code ());
 435       break;
 436     }
 437
 438   if (TYPE_IS_ALLOCATABLE (type))
 439     fprintf_filtered (stream, ", allocatable");
 440 }