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       ts = &ts->u.derived->components->ts;
 160       if (ts->u.derived->attr.unlimited_polymorphic)
 161         sprintf (buffer, "CLASS(*)");
 162       else
 163         sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
 164       break;
 165     case BT_ASSUMED:
 166       sprintf (buffer, "TYPE(*)");
 167       break;
 168     case BT_PROCEDURE:
 169       strcpy (buffer, "PROCEDURE");
 170       break;
 171     case BT_UNKNOWN:
 172       strcpy (buffer, "UNKNOWN");
 173       break;
 174     default:
 175       gfc_internal_error ("gfc_typename(): Undefined type");
 176     }
 177
 178   return buffer;
 179 }
 180
 181
 182 /* Given an mstring array and a code, locate the code in the table,
 183    returning a pointer to the string.  */
 184
 185 const char *
 186 gfc_code2string (const mstring *m, int code)
 187 {
 188   while (m->string != NULL)
 189     {
 190       if (m->tag == code)
 191         return m->string;
 192       m++;
 193     }
 194
 195   gfc_internal_error ("gfc_code2string(): Bad code");
 196   /* Not reached */
 197 }
 198
 199
 200 /* Given an mstring array and a string, returns the value of the tag
 201    field.  Returns the final tag if no matches to the string are found.  */
 202
 203 int
 204 gfc_string2code (const mstring *m, const char *string)
 205 {
 206   for (; m->string != NULL; m++)
 207     if (strcmp (m->string, string) == 0)
 208       return m->tag;
 209
 210   return m->tag;
 211 }
 212
 213
 214 /* Convert an intent code to a string.  */
 215 /* TODO: move to gfortran.h as define.  */
 216
 217 const char *
 218 gfc_intent_string (sym_intent i)
 219 {
 220   return gfc_code2string (intents, i);
 221 }
 222
 223
 224 /***************** Initialization functions ****************/
 225
 226 /* Top level initialization.  */
 227
 228 void
 229 gfc_init_1 (void)
 230 {
 231   gfc_error_init_1 ();
 232   gfc_scanner_init_1 ();
 233   gfc_arith_init_1 ();
 234   gfc_intrinsic_init_1 ();
 235 }
 236
 237
 238 /* Per program unit initialization.  */
 239
 240 void
 241 gfc_init_2 (void)
 242 {
 243   gfc_symbol_init_2 ();
 244   gfc_module_init_2 ();
 245 }
 246
 247
 248 /******************* Destructor functions ******************/
 249
 250 /* Call all of the top level destructors.  */
 251
 252 void
 253 gfc_done_1 (void)
 254 {
 255   gfc_scanner_done_1 ();
 256   gfc_intrinsic_done_1 ();
 257   gfc_arith_done_1 ();
 258 }
 259
 260
 261 /* Per program unit destructors.  */
 262
 263 void
 264 gfc_done_2 (void)
 265 {
 266   gfc_symbol_done_2 ();
 267   gfc_module_done_2 ();
 268 }
 269
 270
 271 /* Returns the index into the table of C interoperable kinds where the
 272    kind with the given name (c_kind_name) was found.  */
 273
 274 int
 275 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 276 {
 277   int index = 0;
 278
 279   for (index = 0; index < ISOCBINDING_LAST; index++)
 280     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 281       return index;
 282
 283   return ISOCBINDING_INVALID;
 284 }
 285
 286
 287 /* For a given name TYPO, determine the best candidate from CANDIDATES
 288    perusing Levenshtein distance.  Frees CANDIDATES before returning.  */
 289
 290 const char *
 291 gfc_closest_fuzzy_match (const char *typo, char **candidates)
 292 {
 293   /* Determine closest match.  */
 294   const char *best = NULL;
 295   char **cand = candidates;
 296   edit_distance_t best_distance = MAX_EDIT_DISTANCE;
 297   const size_t tl = strlen (typo);
 298
 299   while (cand && *cand)
 300     {
 301       edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
 302           strlen (*cand));
 303       if (dist < best_distance)
 304         {
 305            best_distance = dist;
 306            best = *cand;
 307         }
 308       cand++;
 309     }
 310   /* If more than half of the letters were misspelled, the suggestion is
 311      likely to be meaningless.  */
 312   if (best)
 313     {
 314       unsigned int cutoff = MAX (tl, strlen (best)) / 2;
 315
 316       if (best_distance > cutoff)
 317         {
 318           XDELETEVEC (candidates);
 319           return NULL;
 320         }
 321       XDELETEVEC (candidates);
 322     }
 323   return best;
 324 }
 325
 326 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
 327
 328 HOST_WIDE_INT
 329 gfc_mpz_get_hwi (mpz_t op)
 330 {
 331   /* Using long_long_integer_type_node as that is the integer type
 332      node that closest matches HOST_WIDE_INT; both are guaranteed to
 333      be at least 64 bits.  */
 334   const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
 335   return w.to_shwi ();
 336 }
 337
 338
 339 void
 340 gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
 341 {
 342   const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
 343   wi::to_mpz (w, rop, SIGNED);
 344 }