gcc/fortran/misc.c

   1 /* Miscellaneous stuff that doesn't fit anywhere else.
   2    Copyright (C) 2000-2021 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "coretypes.h"
  24 #include "gfortran.h"
  25 #include "spellcheck.h"
  26 #include "tree.h"
  27
  28
  29 /* Initialize a typespec to unknown.  */
  30
  31 void
  32 gfc_clear_ts (gfc_typespec *ts)
  33 {
  34   ts->type = BT_UNKNOWN;
  35   ts->u.derived = NULL;
  36   ts->kind = 0;
  37   ts->u.cl = NULL;
  38   ts->interface = NULL;
  39   /* flag that says if the type is C interoperable */
  40   ts->is_c_interop = 0;
  41   /* says what f90 type the C kind interops with */
  42   ts->f90_type = BT_UNKNOWN;
  43   /* flag that says whether it's from iso_c_binding or not */
  44   ts->is_iso_c = 0;
  45   ts->deferred = false;
  46 }
  47
  48
  49 /* Open a file for reading.  */
  50
  51 FILE *
  52 gfc_open_file (const char *name)
  53 {
  54   if (!*name)
  55     return stdin;
  56
  57   return fopen (name, "r");
  58 }
  59
  60
  61 /* Return a string for each type.  */
  62
  63 const char *
  64 gfc_basic_typename (bt type)
  65 {
  66   const char *p;
  67
  68   switch (type)
  69     {
  70     case BT_INTEGER:
  71       p = "INTEGER";
  72       break;
  73     case BT_REAL:
  74       p = "REAL";
  75       break;
  76     case BT_COMPLEX:
  77       p = "COMPLEX";
  78       break;
  79     case BT_LOGICAL:
  80       p = "LOGICAL";
  81       break;
  82     case BT_CHARACTER:
  83       p = "CHARACTER";
  84       break;
  85     case BT_HOLLERITH:
  86       p = "HOLLERITH";
  87       break;
  88     case BT_UNION:
  89       p = "UNION";
  90       break;
  91     case BT_DERIVED:
  92       p = "DERIVED";
  93       break;
  94     case BT_CLASS:
  95       p = "CLASS";
  96       break;
  97     case BT_PROCEDURE:
  98       p = "PROCEDURE";
  99       break;
 100     case BT_VOID:
 101       p = "VOID";
 102       break;
 103     case BT_BOZ:
 104       p = "BOZ";
 105       break;
 106     case BT_UNKNOWN:
 107       p = "UNKNOWN";
 108       break;
 109     case BT_ASSUMED:
 110       p = "TYPE(*)";
 111       break;
 112     default:
 113       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 114     }
 115
 116   return p;
 117 }
 118
 119
 120 /* Return a string describing the type and kind of a typespec.  Because
 121    we return alternating buffers, this subroutine can appear twice in
 122    the argument list of a single statement.  */
 123
 124 const char *
 125 gfc_typename (gfc_typespec *ts, bool for_hash)
 126 {
 127   /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0',
 128      or "CLASS()" + '\0'.  */
 129   static char buffer1[GFC_MAX_SYMBOL_LEN + 8];
 130   static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
 131   static int flag = 0;
 132   char *buffer;
 133   gfc_typespec *ts1;
 134   gfc_charlen_t length = 0;
 135
 136   buffer = flag ? buffer1 : buffer2;
 137   flag = !flag;
 138
 139   switch (ts->type)
 140     {
 141     case BT_INTEGER:
 142       sprintf (buffer, "INTEGER(%d)", ts->kind);
 143       break;
 144     case BT_REAL:
 145       sprintf (buffer, "REAL(%d)", ts->kind);
 146       break;
 147     case BT_COMPLEX:
 148       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 149       break;
 150     case BT_LOGICAL:
 151       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 152       break;
 153     case BT_CHARACTER:
 154       if (for_hash)
 155         {
 156           sprintf (buffer, "CHARACTER(%d)", ts->kind);
 157           break;
 158         }
 159
 160       if (ts->u.cl && ts->u.cl->length)
 161         length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
 162       if (ts->kind == gfc_default_character_kind)
 163         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
 164       else
 165         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
 166                  ts->kind);
 167       break;
 168     case BT_HOLLERITH:
 169       sprintf (buffer, "HOLLERITH");
 170       break;
 171     case BT_UNION:
 172       sprintf (buffer, "UNION(%s)", ts->u.derived->name);
 173       break;
 174     case BT_DERIVED:
 175       if (ts->u.derived == NULL)
 176         {
 177           sprintf (buffer, "invalid type");
 178           break;
 179         }
 180       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
 181       break;
 182     case BT_CLASS:
 183       if (ts->u.derived == NULL)
 184         {
 185           sprintf (buffer, "invalid class");
 186           break;
 187         }
 188       ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
 189       if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
 190         sprintf (buffer, "CLASS(*)");
 191       else
 192         sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
 193       break;
 194     case BT_ASSUMED:
 195       sprintf (buffer, "TYPE(*)");
 196       break;
 197     case BT_PROCEDURE:
 198       strcpy (buffer, "PROCEDURE");
 199       break;
 200     case BT_BOZ:
 201       strcpy (buffer, "BOZ");
 202       break;
 203     case BT_UNKNOWN:
 204       strcpy (buffer, "UNKNOWN");
 205       break;
 206     default:
 207       gfc_internal_error ("gfc_typename(): Undefined type");
 208     }
 209
 210   return buffer;
 211 }
 212
 213
 214 const char *
 215 gfc_typename (gfc_expr *ex)
 216 {
 217   /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
 218      add 19 for the extra width and 1 for '\0' */
 219   static char buffer1[34];
 220   static char buffer2[34];
 221   static bool flag = false;
 222   char *buffer;
 223   gfc_charlen_t length;
 224   buffer = flag ? buffer1 : buffer2;
 225   flag = !flag;
 226
 227   if (ex->ts.type == BT_CHARACTER)
 228     {
 229       if (ex->expr_type == EXPR_CONSTANT)
 230         length = ex->value.character.length;
 231       else if (ex->ts.deferred)
 232         {
 233           if (ex->ts.kind == gfc_default_character_kind)
 234             return "CHARACTER(:)";
 235           sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
 236           return buffer;
 237         }
 238       else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
 239         {
 240           if (ex->ts.kind == gfc_default_character_kind)
 241             return "CHARACTER(*)";
 242           sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
 243           return buffer;
 244         }
 245       else if (ex->ts.u.cl == NULL
 246                || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
 247         {
 248           if (ex->ts.kind == gfc_default_character_kind)
 249             return "CHARACTER";
 250           sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
 251           return buffer;
 252         }
 253       else
 254         length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
 255       if (ex->ts.kind == gfc_default_character_kind)
 256         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
 257       else
 258         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
 259                  ex->ts.kind);
 260       return buffer;
 261     }
 262   return gfc_typename(&ex->ts);
 263 }
 264
 265 /* The type of a dummy variable can also be CHARACTER(*).  */
 266
 267 const char *
 268 gfc_dummy_typename (gfc_typespec *ts)
 269 {
 270   static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
 271   static char buffer2[15];
 272   static bool flag = false;
 273   char *buffer;
 274
 275   buffer = flag ? buffer1 : buffer2;
 276   flag = !flag;
 277
 278   if (ts->type == BT_CHARACTER)
 279     {
 280       bool has_length = false;
 281       if (ts->u.cl)
 282         has_length = ts->u.cl->length != NULL;
 283       if (!has_length)
 284         {
 285           if (ts->kind == gfc_default_character_kind)
 286             sprintf(buffer, "CHARACTER(*)");
 287           else if (ts->kind < 10)
 288             sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
 289           else
 290             sprintf(buffer, "CHARACTER(*,?)");
 291           return buffer;
 292         }
 293     }
 294   return gfc_typename(ts);
 295 }
 296
 297
 298 /* Given an mstring array and a code, locate the code in the table,
 299    returning a pointer to the string.  */
 300
 301 const char *
 302 gfc_code2string (const mstring *m, int code)
 303 {
 304   while (m->string != NULL)
 305     {
 306       if (m->tag == code)
 307         return m->string;
 308       m++;
 309     }
 310
 311   gfc_internal_error ("gfc_code2string(): Bad code");
 312   /* Not reached */
 313 }
 314
 315
 316 /* Given an mstring array and a string, returns the value of the tag
 317    field.  Returns the final tag if no matches to the string are found.  */
 318
 319 int
 320 gfc_string2code (const mstring *m, const char *string)
 321 {
 322   for (; m->string != NULL; m++)
 323     if (strcmp (m->string, string) == 0)
 324       return m->tag;
 325
 326   return m->tag;
 327 }
 328
 329
 330 /* Convert an intent code to a string.  */
 331 /* TODO: move to gfortran.h as define.  */
 332
 333 const char *
 334 gfc_intent_string (sym_intent i)
 335 {
 336   return gfc_code2string (intents, i);
 337 }
 338
 339
 340 /***************** Initialization functions ****************/
 341
 342 /* Top level initialization.  */
 343
 344 void
 345 gfc_init_1 (void)
 346 {
 347   gfc_error_init_1 ();
 348   gfc_scanner_init_1 ();
 349   gfc_arith_init_1 ();
 350   gfc_intrinsic_init_1 ();
 351 }
 352
 353
 354 /* Per program unit initialization.  */
 355
 356 void
 357 gfc_init_2 (void)
 358 {
 359   gfc_symbol_init_2 ();
 360   gfc_module_init_2 ();
 361 }
 362
 363
 364 /******************* Destructor functions ******************/
 365
 366 /* Call all of the top level destructors.  */
 367
 368 void
 369 gfc_done_1 (void)
 370 {
 371   gfc_scanner_done_1 ();
 372   gfc_intrinsic_done_1 ();
 373   gfc_arith_done_1 ();
 374 }
 375
 376
 377 /* Per program unit destructors.  */
 378
 379 void
 380 gfc_done_2 (void)
 381 {
 382   gfc_symbol_done_2 ();
 383   gfc_module_done_2 ();
 384 }
 385
 386
 387 /* Returns the index into the table of C interoperable kinds where the
 388    kind with the given name (c_kind_name) was found.  */
 389
 390 int
 391 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 392 {
 393   int index = 0;
 394
 395   for (index = 0; index < ISOCBINDING_LAST; index++)
 396     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 397       return index;
 398
 399   return ISOCBINDING_INVALID;
 400 }
 401
 402
 403 /* For a given name TYPO, determine the best candidate from CANDIDATES
 404    using get_edit_distance.  Frees CANDIDATES before returning.  */
 405
 406 const char *
 407 gfc_closest_fuzzy_match (const char *typo, char **candidates)
 408 {
 409   /* Determine closest match.  */
 410   const char *best = NULL;
 411   char **cand = candidates;
 412   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
 413   const size_t tl = strlen (typo);
 414
 415   while (cand && *cand)
 416     {
 417       edit_distance_t dist = get_edit_distance (typo, tl, *cand,
 418           strlen (*cand));
 419       if (dist < best_distance)
 420         {
 421            best_distance = dist;
 422            best = *cand;
 423         }
 424       cand++;
 425     }
 426   /* If more than half of the letters were misspelled, the suggestion is
 427      likely to be meaningless.  */
 428   if (best)
 429     {
 430       unsigned int cutoff = MAX (tl, strlen (best));
 431
 432       if (best_distance > cutoff)
 433         {
 434           XDELETEVEC (candidates);
 435           return NULL;
 436         }
 437       XDELETEVEC (candidates);
 438     }
 439   return best;
 440 }
 441
 442 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
 443
 444 HOST_WIDE_INT
 445 gfc_mpz_get_hwi (mpz_t op)
 446 {
 447   /* Using long_long_integer_type_node as that is the integer type
 448      node that closest matches HOST_WIDE_INT; both are guaranteed to
 449      be at least 64 bits.  */
 450   const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
 451   return w.to_shwi ();
 452 }
 453
 454
 455 void
 456 gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
 457 {
 458   const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
 459   wi::to_mpz (w, rop, SIGNED);
 460 }