1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2020 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
gfc_clear_ts(gfc_typespec * ts)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 *
gfc_open_file(const char * name)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 *
gfc_basic_typename(bt type)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 *
gfc_typename(gfc_typespec * ts,bool for_hash)125 gfc_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
212 const char *
gfc_typename(gfc_expr * ex)213 gfc_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
265 const char *
gfc_dummy_typename(gfc_typespec * ts)266 gfc_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
299 const char *
gfc_code2string(const mstring * m,int code)300 gfc_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
317 int
gfc_string2code(const mstring * m,const char * string)318 gfc_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
331 const char *
gfc_intent_string(sym_intent i)332 gfc_intent_string (sym_intent i)
333 {
334 return gfc_code2string (intents, i);
335 }
336
337
338 /***************** Initialization functions ****************/
339
340 /* Top level initialization. */
341
342 void
gfc_init_1(void)343 gfc_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
354 void
gfc_init_2(void)355 gfc_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
366 void
gfc_done_1(void)367 gfc_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
377 void
gfc_done_2(void)378 gfc_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
388 int
get_c_kind(const char * c_kind_name,CInteropKind_t kinds_table[])389 get_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
404 const char *
gfc_closest_fuzzy_match(const char * typo,char ** candidates)405 gfc_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
442 HOST_WIDE_INT
gfc_mpz_get_hwi(mpz_t op)443 gfc_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
453 void
gfc_mpz_set_hwi(mpz_t rop,const HOST_WIDE_INT op)454 gfc_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