gcc/fortran/misc.c

   1 /* Miscellaneous stuff that doesn't fit anywhere else.
   2    Copyright (C) 2000-2018 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_UNKNOWN:
 104       p = "UNKNOWN";
 105       break;
 106     case BT_ASSUMED:
 107       p = "TYPE(*)";
 108       break;
 109     default:
 110       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 111     }
 112
 113   return p;
 114 }
 115
 116
 117 /* Return a string describing the type and kind of a typespec.  Because
 118    we return alternating buffers, this subroutine can appear twice in
 119    the argument list of a single statement.  */
 120
 121 const char *
 122 gfc_typename (gfc_typespec *ts)
 123 {
 124   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
 125   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
 126   static int flag = 0;
 127   char *buffer;
 128
 129   buffer = flag ? buffer1 : buffer2;
 130   flag = !flag;
 131
 132   switch (ts->type)
 133     {
 134     case BT_INTEGER:
 135       sprintf (buffer, "INTEGER(%d)", ts->kind);
 136       break;
 137     case BT_REAL:
 138       sprintf (buffer, "REAL(%d)", ts->kind);
 139       break;
 140     case BT_COMPLEX:
 141       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 142       break;
 143     case BT_LOGICAL:
 144       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 145       break;
 146     case BT_CHARACTER:
 147       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 148       break;
 149     case BT_HOLLERITH:
 150       sprintf (buffer, "HOLLERITH");
 151       break;
 152     case BT_UNION:
 153       sprintf (buffer, "UNION(%s)", ts->u.derived->name);
 154       break;
 155     case BT_DERIVED:
 156       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
 157       break;
 158     case BT_CLASS:
 159       if (ts->u.derived->components)
 160         ts = &ts->u.derived->components->ts;
 161       if (ts->u.derived->attr.unlimited_polymorphic)
 162         sprintf (buffer, "CLASS(*)");
 163       else
 164         sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
 165       break;
 166     case BT_ASSUMED:
 167       sprintf (buffer, "TYPE(*)");
 168       break;
 169     case BT_PROCEDURE:
 170       strcpy (buffer, "PROCEDURE");
 171       break;
 172     case BT_UNKNOWN:
 173       strcpy (buffer, "UNKNOWN");
 174       break;
 175     default:
 176       gfc_internal_error ("gfc_typename(): Undefined type");
 177     }
 178
 179   return buffer;
 180 }
 181
 182
 183 /* Given an mstring array and a code, locate the code in the table,
 184    returning a pointer to the string.  */
 185
 186 const char *
 187 gfc_code2string (const mstring *m, int code)
 188 {
 189   while (m->string != NULL)
 190     {
 191       if (m->tag == code)
 192         return m->string;
 193       m++;
 194     }
 195
 196   gfc_internal_error ("gfc_code2string(): Bad code");
 197   /* Not reached */
 198 }
 199
 200
 201 /* Given an mstring array and a string, returns the value of the tag
 202    field.  Returns the final tag if no matches to the string are found.  */
 203
 204 int
 205 gfc_string2code (const mstring *m, const char *string)
 206 {
 207   for (; m->string != NULL; m++)
 208     if (strcmp (m->string, string) == 0)
 209       return m->tag;
 210
 211   return m->tag;
 212 }
 213
 214
 215 /* Convert an intent code to a string.  */
 216 /* TODO: move to gfortran.h as define.  */
 217
 218 const char *
 219 gfc_intent_string (sym_intent i)
 220 {
 221   return gfc_code2string (intents, i);
 222 }
 223
 224
 225 /***************** Initialization functions ****************/
 226
 227 /* Top level initialization.  */
 228
 229 void
 230 gfc_init_1 (void)
 231 {
 232   gfc_error_init_1 ();
 233   gfc_scanner_init_1 ();
 234   gfc_arith_init_1 ();
 235   gfc_intrinsic_init_1 ();
 236 }
 237
 238
 239 /* Per program unit initialization.  */
 240
 241 void
 242 gfc_init_2 (void)
 243 {
 244   gfc_symbol_init_2 ();
 245   gfc_module_init_2 ();
 246 }
 247
 248
 249 /******************* Destructor functions ******************/
 250
 251 /* Call all of the top level destructors.  */
 252
 253 void
 254 gfc_done_1 (void)
 255 {
 256   gfc_scanner_done_1 ();
 257   gfc_intrinsic_done_1 ();
 258   gfc_arith_done_1 ();
 259 }
 260
 261
 262 /* Per program unit destructors.  */
 263
 264 void
 265 gfc_done_2 (void)
 266 {
 267   gfc_symbol_done_2 ();
 268   gfc_module_done_2 ();
 269 }
 270
 271
 272 /* Returns the index into the table of C interoperable kinds where the
 273    kind with the given name (c_kind_name) was found.  */
 274
 275 int
 276 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 277 {
 278   int index = 0;
 279
 280   for (index = 0; index < ISOCBINDING_LAST; index++)
 281     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 282       return index;
 283
 284   return ISOCBINDING_INVALID;
 285 }
 286
 287
 288 /* For a given name TYPO, determine the best candidate from CANDIDATES
 289    perusing Levenshtein distance.  Frees CANDIDATES before returning.  */
 290
 291 const char *
 292 gfc_closest_fuzzy_match (const char *typo, char **candidates)
 293 {
 294   /* Determine closest match.  */
 295   const char *best = NULL;
 296   char **cand = candidates;
 297   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
 298   const size_t tl = strlen (typo);
 299
 300   while (cand && *cand)
 301     {
 302       edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
 303           strlen (*cand));
 304       if (dist < best_distance)
 305         {
 306            best_distance = dist;
 307            best = *cand;
 308         }
 309       cand++;
 310     }
 311   /* If more than half of the letters were misspelled, the suggestion is
 312      likely to be meaningless.  */
 313   if (best)
 314     {
 315       unsigned int cutoff = MAX (tl, strlen (best)) / 2;
 316
 317       if (best_distance > cutoff)
 318         {
 319           XDELETEVEC (candidates);
 320           return NULL;
 321         }
 322       XDELETEVEC (candidates);
 323     }
 324   return best;
 325 }
 326
 327 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
 328
 329 HOST_WIDE_INT
 330 gfc_mpz_get_hwi (mpz_t op)
 331 {
 332   /* Using long_long_integer_type_node as that is the integer type
 333      node that closest matches HOST_WIDE_INT; both are guaranteed to
 334      be at least 64 bits.  */
 335   const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
 336   return w.to_shwi ();
 337 }
 338
 339
 340 void
 341 gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
 342 {
 343   const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
 344   wi::to_mpz (w, rop, SIGNED);
 345 }