1 /* Miscellaneous stuff that doesn't fit anywhere else. 2 Copyright (C) 2000-2019 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 gfc_typespec *ts1; 129 130 buffer = flag ? buffer1 : buffer2; 131 flag = !flag; 132 133 switch (ts->type) 134 { 135 case BT_INTEGER: 136 sprintf (buffer, "INTEGER(%d)", ts->kind); 137 break; 138 case BT_REAL: 139 sprintf (buffer, "REAL(%d)", ts->kind); 140 break; 141 case BT_COMPLEX: 142 sprintf (buffer, "COMPLEX(%d)", ts->kind); 143 break; 144 case BT_LOGICAL: 145 sprintf (buffer, "LOGICAL(%d)", ts->kind); 146 break; 147 case BT_CHARACTER: 148 sprintf (buffer, "CHARACTER(%d)", ts->kind); 149 break; 150 case BT_HOLLERITH: 151 sprintf (buffer, "HOLLERITH"); 152 break; 153 case BT_UNION: 154 sprintf (buffer, "UNION(%s)", ts->u.derived->name); 155 break; 156 case BT_DERIVED: 157 sprintf (buffer, "TYPE(%s)", ts->u.derived->name); 158 break; 159 case BT_CLASS: 160 ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL; 161 if (ts1 && ts1->u.derived && ts1->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 using get_edit_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 = get_edit_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 } 346