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   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
 128   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
 129   static int flag = 0;
 130   char *buffer;
 131   gfc_typespec *ts1;
 132   gfc_charlen_t length = 0;
 133
 134   buffer = flag ? buffer1 : buffer2;
 135   flag = !flag;
 136
 137   switch (ts->type)
 138     {
 139     case BT_INTEGER:
 140       sprintf (buffer, "INTEGER(%d)", ts->kind);
 141       break;
 142     case BT_REAL:
 143       sprintf (buffer, "REAL(%d)", ts->kind);
 144       break;
 145     case BT_COMPLEX:
 146       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 147       break;
 148     case BT_LOGICAL:
 149       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 150       break;
 151     case BT_CHARACTER:
 152       if (for_hash)
 153         {
 154           sprintf (buffer, "CHARACTER(%d)", ts->kind);
 155           break;
 156         }
 157
 158       if (ts->u.cl && ts->u.cl->length)
 159         length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
 160       if (ts->kind == gfc_default_character_kind)
 161         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
 162       else
 163         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
 164                  ts->kind);
 165       break;
 166     case BT_HOLLERITH:
 167       sprintf (buffer, "HOLLERITH");
 168       break;
 169     case BT_UNION:
 170       sprintf (buffer, "UNION(%s)", ts->u.derived->name);
 171       break;
 172     case BT_DERIVED:
 173       if (ts->u.derived == NULL)
 174         {
 175           sprintf (buffer, "invalid type");
 176           break;
 177         }
 178       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
 179       break;
 180     case BT_CLASS:
 181       if (ts->u.derived == NULL)
 182         {
 183           sprintf (buffer, "invalid class");
 184           break;
 185         }
 186       ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
 187       if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
 188         sprintf (buffer, "CLASS(*)");
 189       else
 190         sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
 191       break;
 192     case BT_ASSUMED:
 193       sprintf (buffer, "TYPE(*)");
 194       break;
 195     case BT_PROCEDURE:
 196       strcpy (buffer, "PROCEDURE");
 197       break;
 198     case BT_BOZ:
 199       strcpy (buffer, "BOZ");
 200       break;
 201     case BT_UNKNOWN:
 202       strcpy (buffer, "UNKNOWN");
 203       break;
 204     default:
 205       gfc_internal_error ("gfc_typename(): Undefined type");
 206     }
 207
 208   return buffer;
 209 }
 210
 211
 212 const char *
 213 gfc_typename (gfc_expr *ex)
 214 {
 215   /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
 216      add 19 for the extra width and 1 for '\0' */
 217   static char buffer1[34];
 218   static char buffer2[34];
 219   static bool flag = false;
 220   char *buffer;
 221   gfc_charlen_t length;
 222   buffer = flag ? buffer1 : buffer2;
 223   flag = !flag;
 224
 225   if (ex->ts.type == BT_CHARACTER)
 226     {
 227       if (ex->expr_type == EXPR_CONSTANT)
 228         length = ex->value.character.length;
 229       else if (ex->ts.deferred)
 230         {
 231           if (ex->ts.kind == gfc_default_character_kind)
 232             return "CHARACTER(:)";
 233           sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
 234           return buffer;
 235         }
 236       else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
 237         {
 238           if (ex->ts.kind == gfc_default_character_kind)
 239             return "CHARACTER(*)";
 240           sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
 241           return buffer;
 242         }
 243       else if (ex->ts.u.cl == NULL
 244                || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
 245         {
 246           if (ex->ts.kind == gfc_default_character_kind)
 247             return "CHARACTER";
 248           sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
 249           return buffer;
 250         }
 251       else
 252         length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
 253       if (ex->ts.kind == gfc_default_character_kind)
 254         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
 255       else
 256         sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
 257                  ex->ts.kind);
 258       return buffer;
 259     }
 260   return gfc_typename(&ex->ts);
 261 }
 262
 263 /* The type of a dummy variable can also be CHARACTER(*).  */
 264
 265 const char *
 266 gfc_dummy_typename (gfc_typespec *ts)
 267 {
 268   static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
 269   static char buffer2[15];
 270   static bool flag = false;
 271   char *buffer;
 272
 273   buffer = flag ? buffer1 : buffer2;
 274   flag = !flag;
 275
 276   if (ts->type == BT_CHARACTER)
 277     {
 278       bool has_length = false;
 279       if (ts->u.cl)
 280         has_length = ts->u.cl->length != NULL;
 281       if (!has_length)
 282         {
 283           if (ts->kind == gfc_default_character_kind)
 284             sprintf(buffer, "CHARACTER(*)");
 285           else if (ts->kind < 10)
 286             sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
 287           else
 288             sprintf(buffer, "CHARACTER(*,?)");
 289           return buffer;
 290         }
 291     }
 292   return gfc_typename(ts);
 293 }
 294
 295
 296 /* Given an mstring array and a code, locate the code in the table,
 297    returning a pointer to the string.  */
 298
 299 const char *
 300 gfc_code2string (const mstring *m, int code)
 301 {
 302   while (m->string != NULL)
 303     {
 304       if (m->tag == code)
 305         return m->string;
 306       m++;
 307     }
 308
 309   gfc_internal_error ("gfc_code2string(): Bad code");
 310   /* Not reached */
 311 }
 312
 313
 314 /* Given an mstring array and a string, returns the value of the tag
 315    field.  Returns the final tag if no matches to the string are found.  */
 316
 317 int
 318 gfc_string2code (const mstring *m, const char *string)
 319 {
 320   for (; m->string != NULL; m++)
 321     if (strcmp (m->string, string) == 0)
 322       return m->tag;
 323
 324   return m->tag;
 325 }
 326
 327
 328 /* Convert an intent code to a string.  */
 329 /* TODO: move to gfortran.h as define.  */
 330
 331 const char *
 332 gfc_intent_string (sym_intent i)
 333 {
 334   return gfc_code2string (intents, i);
 335 }
 336
 337
 338 /***************** Initialization functions ****************/
 339
 340 /* Top level initialization.  */
 341
 342 void
 343 gfc_init_1 (void)
 344 {
 345   gfc_error_init_1 ();
 346   gfc_scanner_init_1 ();
 347   gfc_arith_init_1 ();
 348   gfc_intrinsic_init_1 ();
 349 }
 350
 351
 352 /* Per program unit initialization.  */
 353
 354 void
 355 gfc_init_2 (void)
 356 {
 357   gfc_symbol_init_2 ();
 358   gfc_module_init_2 ();
 359 }
 360
 361
 362 /******************* Destructor functions ******************/
 363
 364 /* Call all of the top level destructors.  */
 365
 366 void
 367 gfc_done_1 (void)
 368 {
 369   gfc_scanner_done_1 ();
 370   gfc_intrinsic_done_1 ();
 371   gfc_arith_done_1 ();
 372 }
 373
 374
 375 /* Per program unit destructors.  */
 376
 377 void
 378 gfc_done_2 (void)
 379 {
 380   gfc_symbol_done_2 ();
 381   gfc_module_done_2 ();
 382 }
 383
 384
 385 /* Returns the index into the table of C interoperable kinds where the
 386    kind with the given name (c_kind_name) was found.  */
 387
 388 int
 389 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 390 {
 391   int index = 0;
 392
 393   for (index = 0; index < ISOCBINDING_LAST; index++)
 394     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 395       return index;
 396
 397   return ISOCBINDING_INVALID;
 398 }
 399
 400
 401 /* For a given name TYPO, determine the best candidate from CANDIDATES
 402    using get_edit_distance.  Frees CANDIDATES before returning.  */
 403
 404 const char *
 405 gfc_closest_fuzzy_match (const char *typo, char **candidates)
 406 {
 407   /* Determine closest match.  */
 408   const char *best = NULL;
 409   char **cand = candidates;
 410   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
 411   const size_t tl = strlen (typo);
 412
 413   while (cand && *cand)
 414     {
 415       edit_distance_t dist = get_edit_distance (typo, tl, *cand,
 416           strlen (*cand));
 417       if (dist < best_distance)
 418         {
 419            best_distance = dist;
 420            best = *cand;
 421         }
 422       cand++;
 423     }
 424   /* If more than half of the letters were misspelled, the suggestion is
 425      likely to be meaningless.  */
 426   if (best)
 427     {
 428       unsigned int cutoff = MAX (tl, strlen (best));
 429
 430       if (best_distance > cutoff)
 431         {
 432           XDELETEVEC (candidates);
 433           return NULL;
 434         }
 435       XDELETEVEC (candidates);
 436     }
 437   return best;
 438 }
 439
 440 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
 441
 442 HOST_WIDE_INT
 443 gfc_mpz_get_hwi (mpz_t op)
 444 {
 445   /* Using long_long_integer_type_node as that is the integer type
 446      node that closest matches HOST_WIDE_INT; both are guaranteed to
 447      be at least 64 bits.  */
 448   const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
 449   return w.to_shwi ();
 450 }
 451
 452
 453 void
 454 gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
 455 {
 456   const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
 457   wi::to_mpz (w, rop, SIGNED);
 458 }