Branch data Line data Source code
1 : : /* Miscellaneous stuff that doesn't fit anywhere else.
2 : : Copyright (C) 2000-2025 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 : 137645862 : gfc_clear_ts (gfc_typespec *ts)
33 : : {
34 : 137645862 : ts->type = BT_UNKNOWN;
35 : 137645862 : ts->u.derived = NULL;
36 : 137645862 : ts->kind = 0;
37 : 137645862 : ts->u.cl = NULL;
38 : 137645862 : ts->interface = NULL;
39 : : /* flag that says if the type is C interoperable */
40 : 137645862 : ts->is_c_interop = 0;
41 : : /* says what f90 type the C kind interops with */
42 : 137645862 : ts->f90_type = BT_UNKNOWN;
43 : : /* flag that says whether it's from iso_c_binding or not */
44 : 137645862 : ts->is_iso_c = 0;
45 : 137645862 : ts->deferred = false;
46 : 137645862 : }
47 : :
48 : :
49 : : /* Open a file for reading. */
50 : :
51 : : FILE *
52 : 61784 : gfc_open_file (const char *name)
53 : : {
54 : 61784 : if (!*name)
55 : 0 : return stdin;
56 : :
57 : 61784 : return fopen (name, "r");
58 : : }
59 : :
60 : :
61 : : /* Return a string for each type. */
62 : :
63 : : const char *
64 : 16784 : gfc_basic_typename (bt type)
65 : : {
66 : 16784 : const char *p;
67 : :
68 : 16784 : switch (type)
69 : : {
70 : : case BT_INTEGER:
71 : : p = "INTEGER";
72 : : break;
73 : 72 : case BT_UNSIGNED:
74 : 72 : p = "UNSIGNED";
75 : 72 : break;
76 : 5664 : case BT_REAL:
77 : 5664 : p = "REAL";
78 : 5664 : break;
79 : 493 : case BT_COMPLEX:
80 : 493 : p = "COMPLEX";
81 : 493 : break;
82 : 104 : case BT_LOGICAL:
83 : 104 : p = "LOGICAL";
84 : 104 : break;
85 : 5405 : case BT_CHARACTER:
86 : 5405 : p = "CHARACTER";
87 : 5405 : break;
88 : 19 : case BT_HOLLERITH:
89 : 19 : p = "HOLLERITH";
90 : 19 : break;
91 : 0 : case BT_UNION:
92 : 0 : p = "UNION";
93 : 0 : break;
94 : 118 : case BT_DERIVED:
95 : 118 : p = "DERIVED";
96 : 118 : break;
97 : 38 : case BT_CLASS:
98 : 38 : p = "CLASS";
99 : 38 : break;
100 : 28 : case BT_PROCEDURE:
101 : 28 : p = "PROCEDURE";
102 : 28 : break;
103 : 6 : case BT_VOID:
104 : 6 : p = "VOID";
105 : 6 : break;
106 : 0 : case BT_BOZ:
107 : 0 : p = "BOZ";
108 : 0 : break;
109 : 236 : case BT_UNKNOWN:
110 : 236 : p = "UNKNOWN";
111 : 236 : break;
112 : 0 : case BT_ASSUMED:
113 : 0 : p = "TYPE(*)";
114 : 0 : break;
115 : 0 : default:
116 : 0 : gfc_internal_error ("gfc_basic_typename(): Undefined type");
117 : : }
118 : :
119 : 16784 : return p;
120 : : }
121 : :
122 : :
123 : : /* Return a string describing the type and kind of a typespec. Because
124 : : we return alternating buffers, this subroutine can appear twice in
125 : : the argument list of a single statement. */
126 : :
127 : : const char *
128 : 25769 : gfc_typename (gfc_typespec *ts, bool for_hash)
129 : : {
130 : : /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0',
131 : : or "CLASS()" + '\0'. */
132 : 25769 : static char buffer1[GFC_MAX_SYMBOL_LEN + 8];
133 : 25769 : static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
134 : 25769 : static int flag = 0;
135 : 25769 : char *buffer;
136 : 25769 : gfc_charlen_t length = 0;
137 : :
138 : 25769 : buffer = flag ? buffer1 : buffer2;
139 : 25769 : flag = !flag;
140 : :
141 : 25769 : switch (ts->type)
142 : : {
143 : 12672 : case BT_INTEGER:
144 : 12672 : if (ts->f90_type == BT_VOID
145 : 1 : && ts->u.derived
146 : 1 : && ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
147 : 1 : sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
148 : : else
149 : 12671 : sprintf (buffer, "INTEGER(%d)", ts->kind);
150 : : break;
151 : 130 : case BT_UNSIGNED:
152 : 130 : sprintf (buffer, "UNSIGNED(%d)", ts->kind);
153 : 130 : break;
154 : 8071 : case BT_REAL:
155 : 8071 : sprintf (buffer, "REAL(%d)", ts->kind);
156 : 8071 : break;
157 : 2118 : case BT_COMPLEX:
158 : 2118 : sprintf (buffer, "COMPLEX(%d)", ts->kind);
159 : 2118 : break;
160 : 645 : case BT_LOGICAL:
161 : 645 : sprintf (buffer, "LOGICAL(%d)", ts->kind);
162 : 645 : break;
163 : 325 : case BT_CHARACTER:
164 : 325 : if (for_hash)
165 : : {
166 : 257 : sprintf (buffer, "CHARACTER(%d)", ts->kind);
167 : 257 : break;
168 : : }
169 : :
170 : 68 : if (ts->u.cl && ts->u.cl->length)
171 : 67 : length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
172 : 68 : if (ts->kind == gfc_default_character_kind)
173 : 68 : sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
174 : : else
175 : 0 : sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
176 : : ts->kind);
177 : : break;
178 : 1365 : case BT_HOLLERITH:
179 : 1365 : sprintf (buffer, "HOLLERITH");
180 : 1365 : break;
181 : 0 : case BT_UNION:
182 : 0 : sprintf (buffer, "UNION(%s)", ts->u.derived->name);
183 : 0 : break;
184 : 119 : case BT_DERIVED:
185 : 119 : if (ts->u.derived == NULL)
186 : : {
187 : 1 : sprintf (buffer, "invalid type");
188 : 1 : break;
189 : : }
190 : 118 : sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
191 : 118 : break;
192 : 28 : case BT_CLASS:
193 : 28 : if (!ts->u.derived || !ts->u.derived->components
194 : 26 : || !ts->u.derived->components->ts.u.derived)
195 : : {
196 : 3 : sprintf (buffer, "invalid class");
197 : 3 : break;
198 : : }
199 : 25 : if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
200 : 2 : sprintf (buffer, "CLASS(*)");
201 : : else
202 : 23 : sprintf (buffer, "CLASS(%s)",
203 : : ts->u.derived->components->ts.u.derived->name);
204 : : break;
205 : 6 : case BT_ASSUMED:
206 : 6 : sprintf (buffer, "TYPE(*)");
207 : 6 : break;
208 : 16 : case BT_PROCEDURE:
209 : 16 : strcpy (buffer, "PROCEDURE");
210 : 16 : break;
211 : 2 : case BT_BOZ:
212 : 2 : strcpy (buffer, "BOZ");
213 : 2 : break;
214 : 263 : case BT_UNKNOWN:
215 : 263 : strcpy (buffer, "UNKNOWN");
216 : 263 : break;
217 : 9 : case BT_VOID:
218 : 9 : strcpy (buffer, "VOID");
219 : 9 : break;
220 : 0 : default:
221 : 0 : gfc_internal_error ("gfc_typename(): Undefined type");
222 : : }
223 : :
224 : 25769 : return buffer;
225 : : }
226 : :
227 : :
228 : : const char *
229 : 1351 : gfc_typename (gfc_expr *ex)
230 : : {
231 : : /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
232 : : add 19 for the extra width and 1 for '\0' */
233 : 1351 : static char buffer1[34];
234 : 1351 : static char buffer2[34];
235 : 1351 : static bool flag = false;
236 : 1351 : char *buffer;
237 : 1351 : gfc_charlen_t length;
238 : 1351 : buffer = flag ? buffer1 : buffer2;
239 : 1351 : flag = !flag;
240 : :
241 : 1351 : if (ex->ts.type == BT_CHARACTER)
242 : : {
243 : 989 : if (ex->expr_type == EXPR_CONSTANT)
244 : 892 : length = ex->value.character.length;
245 : 97 : else if (ex->ts.deferred)
246 : : {
247 : 2 : if (ex->ts.kind == gfc_default_character_kind)
248 : : return "CHARACTER(:)";
249 : 0 : sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
250 : 0 : return buffer;
251 : : }
252 : 95 : else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
253 : : {
254 : 1 : if (ex->ts.kind == gfc_default_character_kind)
255 : : return "CHARACTER(*)";
256 : 0 : sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
257 : 0 : return buffer;
258 : : }
259 : 94 : else if (ex->ts.u.cl == NULL
260 : 94 : || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
261 : : {
262 : 2 : if (ex->ts.kind == gfc_default_character_kind)
263 : : return "CHARACTER";
264 : 0 : sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
265 : 0 : return buffer;
266 : : }
267 : : else
268 : 92 : length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
269 : 984 : if (ex->ts.kind == gfc_default_character_kind)
270 : 904 : sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
271 : : else
272 : 80 : sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
273 : : ex->ts.kind);
274 : 984 : return buffer;
275 : : }
276 : 362 : return gfc_typename(&ex->ts);
277 : : }
278 : :
279 : : /* The type of a dummy variable can also be CHARACTER(*). */
280 : :
281 : : const char *
282 : 1624 : gfc_dummy_typename (gfc_typespec *ts)
283 : : {
284 : 1624 : static char buffer1[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */
285 : 1624 : static char buffer2[15];
286 : 1624 : static bool flag = false;
287 : 1624 : char *buffer;
288 : :
289 : 1624 : buffer = flag ? buffer1 : buffer2;
290 : 1624 : flag = !flag;
291 : :
292 : 1624 : if (ts->type == BT_CHARACTER)
293 : : {
294 : 166 : bool has_length = false;
295 : 166 : if (ts->u.cl)
296 : 45 : has_length = ts->u.cl->length != NULL;
297 : 45 : if (!has_length)
298 : : {
299 : 131 : if (ts->kind == gfc_default_character_kind)
300 : 128 : sprintf(buffer, "CHARACTER(*)");
301 : 3 : else if (ts->kind >= 0 && ts->kind < 10)
302 : 3 : sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
303 : : else
304 : 0 : sprintf(buffer, "CHARACTER(*,?)");
305 : 131 : return buffer;
306 : : }
307 : : }
308 : 1493 : return gfc_typename(ts);
309 : : }
310 : :
311 : :
312 : : /* Given an mstring array and a code, locate the code in the table,
313 : : returning a pointer to the string. */
314 : :
315 : : const char *
316 : 10486675 : gfc_code2string (const mstring *m, int code)
317 : : {
318 : 65377493 : while (m->string != NULL)
319 : : {
320 : 65377493 : if (m->tag == code)
321 : 10486675 : return m->string;
322 : 54890818 : m++;
323 : : }
324 : :
325 : 0 : gfc_internal_error ("gfc_code2string(): Bad code");
326 : : /* Not reached */
327 : : }
328 : :
329 : :
330 : : /* Given an mstring array and a string, returns the value of the tag
331 : : field. Returns the final tag if no matches to the string are found. */
332 : :
333 : : int
334 : 11135546 : gfc_string2code (const mstring *m, const char *string)
335 : : {
336 : 67835868 : for (; m->string != NULL; m++)
337 : 67835868 : if (strcmp (m->string, string) == 0)
338 : 11135546 : return m->tag;
339 : :
340 : 0 : return m->tag;
341 : : }
342 : :
343 : :
344 : : /* Convert an intent code to a string. */
345 : : /* TODO: move to gfortran.h as define. */
346 : :
347 : : const char *
348 : 19 : gfc_intent_string (sym_intent i)
349 : : {
350 : 19 : return gfc_code2string (intents, i);
351 : : }
352 : :
353 : :
354 : : /***************** Initialization functions ****************/
355 : :
356 : : /* Top level initialization. */
357 : :
358 : : void
359 : 30591 : gfc_init_1 (void)
360 : : {
361 : 30591 : gfc_error_init_1 ();
362 : 30591 : gfc_scanner_init_1 ();
363 : 30591 : gfc_arith_init_1 ();
364 : 30591 : gfc_intrinsic_init_1 ();
365 : 30591 : }
366 : :
367 : :
368 : : /* Per program unit initialization. */
369 : :
370 : : void
371 : 78116 : gfc_init_2 (void)
372 : : {
373 : 78116 : gfc_symbol_init_2 ();
374 : 78116 : gfc_module_init_2 ();
375 : 78116 : }
376 : :
377 : :
378 : : /******************* Destructor functions ******************/
379 : :
380 : : /* Call all of the top level destructors. */
381 : :
382 : : void
383 : 30573 : gfc_done_1 (void)
384 : : {
385 : 30573 : gfc_scanner_done_1 ();
386 : 30573 : gfc_intrinsic_done_1 ();
387 : 30573 : gfc_arith_done_1 ();
388 : 30573 : }
389 : :
390 : :
391 : : /* Per program unit destructors. */
392 : :
393 : : void
394 : 78444 : gfc_done_2 (void)
395 : : {
396 : 78444 : gfc_symbol_done_2 ();
397 : 78444 : gfc_module_done_2 ();
398 : 78444 : }
399 : :
400 : :
401 : : /* Returns the index into the table of C interoperable kinds where the
402 : : kind with the given name (c_kind_name) was found. */
403 : :
404 : : int
405 : 8567 : get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
406 : : {
407 : 8567 : int index = 0;
408 : :
409 : 368381 : for (index = 0; index < ISOCBINDING_LAST; index++)
410 : 368381 : if (strcmp (kinds_table[index].name, c_kind_name) == 0)
411 : : return index;
412 : :
413 : : return ISOCBINDING_INVALID;
414 : : }
415 : :
416 : :
417 : : /* For a given name TYPO, determine the best candidate from CANDIDATES
418 : : using get_edit_distance. Frees CANDIDATES before returning. */
419 : :
420 : : const char *
421 : 259 : gfc_closest_fuzzy_match (const char *typo, char **candidates)
422 : : {
423 : : /* Determine closest match. */
424 : 259 : const char *best = NULL;
425 : 259 : char **cand = candidates;
426 : 259 : edit_distance_t best_distance = MAX_EDIT_DISTANCE;
427 : 259 : const size_t tl = strlen (typo);
428 : :
429 : 842 : while (cand && *cand)
430 : : {
431 : 1166 : edit_distance_t dist = get_edit_distance (typo, tl, *cand,
432 : 583 : strlen (*cand));
433 : 583 : if (dist < best_distance)
434 : : {
435 : 188 : best_distance = dist;
436 : 188 : best = *cand;
437 : : }
438 : 583 : cand++;
439 : : }
440 : : /* If more than half of the letters were misspelled, the suggestion is
441 : : likely to be meaningless. */
442 : 259 : if (best)
443 : : {
444 : 122 : unsigned int cutoff = MAX (tl, strlen (best));
445 : :
446 : 122 : if (best_distance > cutoff)
447 : : {
448 : 78 : XDELETEVEC (candidates);
449 : 78 : return NULL;
450 : : }
451 : 44 : XDELETEVEC (candidates);
452 : : }
453 : : return best;
454 : : }
455 : :
456 : : /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */
457 : :
458 : : HOST_WIDE_INT
459 : 12237 : gfc_mpz_get_hwi (mpz_t op)
460 : : {
461 : : /* Using long_long_integer_type_node as that is the integer type
462 : : node that closest matches HOST_WIDE_INT; both are guaranteed to
463 : : be at least 64 bits. */
464 : 12237 : const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
465 : 12237 : return w.to_shwi ();
466 : 12237 : }
467 : :
468 : :
469 : : void
470 : 2343 : gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
471 : : {
472 : 2343 : const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
473 : 2343 : wi::to_mpz (w, rop, SIGNED);
474 : 2343 : }
|
