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