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 (type->arch ())->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         struct type *void_type = builtin_f_type (type->arch ())->builtin_void;
 346         fprintf_filtered (stream, "%*s%s", level, "", void_type->name ());
 347       }
 348       break;
 349
 350     case TYPE_CODE_UNDEF:
 351       fprintf_filtered (stream, "%*sstruct <unknown>", level, "");
 352       break;
 353
 354     case TYPE_CODE_ERROR:
 355       fprintf_filtered (stream, "%*s%s", level, "", TYPE_ERROR_NAME (type));
 356       break;
 357
 358     case TYPE_CODE_RANGE:
 359       /* This should not occur.  */
 360       fprintf_filtered (stream, "%*s<range type>", level, "");
 361       break;
 362
 363     case TYPE_CODE_CHAR:
 364     case TYPE_CODE_INT:
 365       /* There may be some character types that attempt to come
 366          through as TYPE_CODE_INT since dbxstclass.h is so
 367          C-oriented, we must change these to "character" from "char".  */
 368
 369       if (strcmp (type->name (), "char") == 0)
 370         fprintf_filtered (stream, "%*scharacter", level, "");
 371       else
 372         goto default_case;
 373       break;
 374
 375     case TYPE_CODE_STRING:
 376       /* Strings may have dynamic upperbounds (lengths) like arrays.  We
 377          check specifically for the PROP_CONST case to indicate that the
 378          dynamic type has been resolved.  If we arrive here having been
 379          asked to print the type of a value with a dynamic type then the
 380          bounds will not have been resolved.  */
 381
 382       if (type->bounds ()->high.kind () == PROP_CONST)
 383         {
 384           LONGEST upper_bound = f77_get_upperbound (type);
 385
 386           fprintf_filtered (stream, "character*%s", pulongest (upper_bound));
 387         }
 388       else
 389         fprintf_filtered (stream, "%*scharacter*(*)", level, "");
 390       break;
 391
 392     case TYPE_CODE_STRUCT:
 393     case TYPE_CODE_UNION:
 394       if (type->code () == TYPE_CODE_UNION)
 395         fprintf_filtered (stream, "%*sType, C_Union :: ", level, "");
 396       else
 397         fprintf_filtered (stream, "%*sType ", level, "");
 398       fputs_filtered (type->name (), stream);
 399       /* According to the definition,
 400          we only print structure elements in case show > 0.  */
 401       if (show > 0)
 402         {
 403           fputs_filtered ("\n", stream);
 404           for (index = 0; index < type->num_fields (); index++)
 405             {
 406               f_type_print_base (type->field (index).type (), stream,
 407                                  show - 1, level + 4);
 408               fputs_filtered (" :: ", stream);
 409               fputs_styled (TYPE_FIELD_NAME (type, index),
 410                             variable_name_style.style (), stream);
 411               f_type_print_varspec_suffix (type->field (index).type (),
 412                                            stream, show - 1, 0, 0, 0, false);
 413               fputs_filtered ("\n", stream);
 414             }
 415           fprintf_filtered (stream, "%*sEnd Type ", level, "");
 416           fputs_filtered (type->name (), stream);
 417         }
 418       break;
 419
 420     case TYPE_CODE_MODULE:
 421       fprintf_filtered (stream, "%*smodule %s", level, "", type->name ());
 422       break;
 423
 424     default_case:
 425     default:
 426       /* Handle types not explicitly handled by the other cases,
 427          such as fundamental types.  For these, just print whatever
 428          the type name is, as recorded in the type itself.  If there
 429          is no type name, then complain.  */
 430       if (type->name () != NULL)
 431         fprintf_filtered (stream, "%*s%s", level, "", type->name ());
 432       else
 433         error (_("Invalid type code (%d) in symbol table."), type->code ());
 434       break;
 435     }
 436
 437   if (TYPE_IS_ALLOCATABLE (type))
 438     fprintf_filtered (stream, ", allocatable");
 439 }