gcc/fortran/misc.c

   1 /* Miscellaneous stuff that doesn't fit anywhere else.
   2    Copyright (C) 2000-2017 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
  27
  28 /* Initialize a typespec to unknown.  */
  29
  30 void
  31 gfc_clear_ts (gfc_typespec *ts)
  32 {
  33   ts->type = BT_UNKNOWN;
  34   ts->u.derived = NULL;
  35   ts->kind = 0;
  36   ts->u.cl = NULL;
  37   ts->interface = NULL;
  38   /* flag that says if the type is C interoperable */
  39   ts->is_c_interop = 0;
  40   /* says what f90 type the C kind interops with */
  41   ts->f90_type = BT_UNKNOWN;
  42   /* flag that says whether it's from iso_c_binding or not */
  43   ts->is_iso_c = 0;
  44   ts->deferred = false;
  45 }
  46
  47
  48 /* Open a file for reading.  */
  49
  50 FILE *
  51 gfc_open_file (const char *name)
  52 {
  53   if (!*name)
  54     return stdin;
  55
  56   return fopen (name, "r");
  57 }
  58
  59
  60 /* Return a string for each type.  */
  61
  62 const char *
  63 gfc_basic_typename (bt type)
  64 {
  65   const char *p;
  66
  67   switch (type)
  68     {
  69     case BT_INTEGER:
  70       p = "INTEGER";
  71       break;
  72     case BT_REAL:
  73       p = "REAL";
  74       break;
  75     case BT_COMPLEX:
  76       p = "COMPLEX";
  77       break;
  78     case BT_LOGICAL:
  79       p = "LOGICAL";
  80       break;
  81     case BT_CHARACTER:
  82       p = "CHARACTER";
  83       break;
  84     case BT_HOLLERITH:
  85       p = "HOLLERITH";
  86       break;
  87     case BT_UNION:
  88       p = "UNION";
  89       break;
  90     case BT_DERIVED:
  91       p = "DERIVED";
  92       break;
  93     case BT_CLASS:
  94       p = "CLASS";
  95       break;
  96     case BT_PROCEDURE:
  97       p = "PROCEDURE";
  98       break;
  99     case BT_VOID:
 100       p = "VOID";
 101       break;
 102     case BT_UNKNOWN:
 103       p = "UNKNOWN";
 104       break;
 105     case BT_ASSUMED:
 106       p = "TYPE(*)";
 107       break;
 108     default:
 109       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 110     }
 111
 112   return p;
 113 }
 114
 115
 116 /* Return a string describing the type and kind of a typespec.  Because
 117    we return alternating buffers, this subroutine can appear twice in
 118    the argument list of a single statement.  */
 119
 120 const char *
 121 gfc_typename (gfc_typespec *ts)
 122 {
 123   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
 124   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
 125   static int flag = 0;
 126   char *buffer;
 127
 128   buffer = flag ? buffer1 : buffer2;
 129   flag = !flag;
 130
 131   switch (ts->type)
 132     {
 133     case BT_INTEGER:
 134       sprintf (buffer, "INTEGER(%d)", ts->kind);
 135       break;
 136     case BT_REAL:
 137       sprintf (buffer, "REAL(%d)", ts->kind);
 138       break;
 139     case BT_COMPLEX:
 140       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 141       break;
 142     case BT_LOGICAL:
 143       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 144       break;
 145     case BT_CHARACTER:
 146       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 147       break;
 148     case BT_HOLLERITH:
 149       sprintf (buffer, "HOLLERITH");
 150       break;
 151     case BT_UNION:
 152       sprintf (buffer, "UNION(%s)", ts->u.derived->name);
 153       break;
 154     case BT_DERIVED:
 155       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
 156       break;
 157     case BT_CLASS:
 158       ts = &ts->u.derived->components->ts;
 159       if (ts->u.derived->attr.unlimited_polymorphic)
 160         sprintf (buffer, "CLASS(*)");
 161       else
 162         sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
 163       break;
 164     case BT_ASSUMED:
 165       sprintf (buffer, "TYPE(*)");
 166       break;
 167     case BT_PROCEDURE:
 168       strcpy (buffer, "PROCEDURE");
 169       break;
 170     case BT_UNKNOWN:
 171       strcpy (buffer, "UNKNOWN");
 172       break;
 173     default:
 174       gfc_internal_error ("gfc_typename(): Undefined type");
 175     }
 176
 177   return buffer;
 178 }
 179
 180
 181 /* Given an mstring array and a code, locate the code in the table,
 182    returning a pointer to the string.  */
 183
 184 const char *
 185 gfc_code2string (const mstring *m, int code)
 186 {
 187   while (m->string != NULL)
 188     {
 189       if (m->tag == code)
 190         return m->string;
 191       m++;
 192     }
 193
 194   gfc_internal_error ("gfc_code2string(): Bad code");
 195   /* Not reached */
 196 }
 197
 198
 199 /* Given an mstring array and a string, returns the value of the tag
 200    field.  Returns the final tag if no matches to the string are found.  */
 201
 202 int
 203 gfc_string2code (const mstring *m, const char *string)
 204 {
 205   for (; m->string != NULL; m++)
 206     if (strcmp (m->string, string) == 0)
 207       return m->tag;
 208
 209   return m->tag;
 210 }
 211
 212
 213 /* Convert an intent code to a string.  */
 214 /* TODO: move to gfortran.h as define.  */
 215
 216 const char *
 217 gfc_intent_string (sym_intent i)
 218 {
 219   return gfc_code2string (intents, i);
 220 }
 221
 222
 223 /***************** Initialization functions ****************/
 224
 225 /* Top level initialization.  */
 226
 227 void
 228 gfc_init_1 (void)
 229 {
 230   gfc_error_init_1 ();
 231   gfc_scanner_init_1 ();
 232   gfc_arith_init_1 ();
 233   gfc_intrinsic_init_1 ();
 234 }
 235
 236
 237 /* Per program unit initialization.  */
 238
 239 void
 240 gfc_init_2 (void)
 241 {
 242   gfc_symbol_init_2 ();
 243   gfc_module_init_2 ();
 244 }
 245
 246
 247 /******************* Destructor functions ******************/
 248
 249 /* Call all of the top level destructors.  */
 250
 251 void
 252 gfc_done_1 (void)
 253 {
 254   gfc_scanner_done_1 ();
 255   gfc_intrinsic_done_1 ();
 256   gfc_arith_done_1 ();
 257 }
 258
 259
 260 /* Per program unit destructors.  */
 261
 262 void
 263 gfc_done_2 (void)
 264 {
 265   gfc_symbol_done_2 ();
 266   gfc_module_done_2 ();
 267 }
 268
 269
 270 /* Returns the index into the table of C interoperable kinds where the
 271    kind with the given name (c_kind_name) was found.  */
 272
 273 int
 274 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 275 {
 276   int index = 0;
 277
 278   for (index = 0; index < ISOCBINDING_LAST; index++)
 279     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 280       return index;
 281
 282   return ISOCBINDING_INVALID;
 283 }
 284
 285
 286 /* For a given name TYPO, determine the best candidate from CANDIDATES
 287    perusing Levenshtein distance.  Frees CANDIDATES before returning.  */
 288
 289 const char *
 290 gfc_closest_fuzzy_match (const char *typo, char **candidates)
 291 {
 292   /* Determine closest match.  */
 293   const char *best = NULL;
 294   char **cand = candidates;
 295   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
 296   const size_t tl = strlen (typo);
 297
 298   while (cand && *cand)
 299     {
 300       edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
 301           strlen (*cand));
 302       if (dist < best_distance)
 303         {
 304            best_distance = dist;
 305            best = *cand;
 306         }
 307       cand++;
 308     }
 309   /* If more than half of the letters were misspelled, the suggestion is
 310      likely to be meaningless.  */
 311   if (best)
 312     {
 313       unsigned int cutoff = MAX (tl, strlen (best)) / 2;
 314
 315       if (best_distance > cutoff)
 316         {
 317           XDELETEVEC (candidates);
 318           return NULL;
 319         }
 320       XDELETEVEC (candidates);
 321     }
 322   return best;
 323 }