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