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