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