Line data Source code
1 : /* Miscellaneous stuff that doesn't fit anywhere else.
2 : Copyright (C) 2000-2026 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 138277034 : gfc_clear_ts (gfc_typespec *ts)
33 : {
34 138277034 : ts->type = BT_UNKNOWN;
35 138277034 : ts->u.derived = NULL;
36 138277034 : ts->kind = 0;
37 138277034 : ts->u.cl = NULL;
38 138277034 : ts->interface = NULL;
39 : /* flag that says if the type is C interoperable */
40 138277034 : ts->is_c_interop = 0;
41 : /* says what f90 type the C kind interops with */
42 138277034 : ts->f90_type = BT_UNKNOWN;
43 : /* flag that says whether it's from iso_c_binding or not */
44 138277034 : ts->is_iso_c = 0;
45 138277034 : ts->deferred = false;
46 138277034 : }
47 :
48 :
49 : /* Open a file for reading. */
50 :
51 : FILE *
52 63213 : gfc_open_file (const char *name)
53 : {
54 63213 : if (!*name)
55 0 : return stdin;
56 :
57 63213 : return fopen (name, "r");
58 : }
59 :
60 :
61 : /* Return a string for each type. */
62 :
63 : const char *
64 17651 : gfc_basic_typename (bt type)
65 : {
66 17651 : const char *p;
67 :
68 17651 : 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 6084 : case BT_REAL:
77 6084 : p = "REAL";
78 6084 : break;
79 601 : case BT_COMPLEX:
80 601 : p = "COMPLEX";
81 601 : break;
82 195 : case BT_LOGICAL:
83 195 : p = "LOGICAL";
84 195 : break;
85 5455 : case BT_CHARACTER:
86 5455 : p = "CHARACTER";
87 5455 : 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 119 : case BT_DERIVED:
95 119 : p = "DERIVED";
96 119 : 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 3 : case BT_BOZ:
107 3 : p = "BOZ";
108 3 : break;
109 238 : case BT_UNKNOWN:
110 238 : p = "UNKNOWN";
111 238 : 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 17651 : 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 26755 : 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 26755 : static char buffer1[GFC_MAX_SYMBOL_LEN + 8];
133 26755 : static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
134 26755 : static int flag = 0;
135 26755 : char *buffer;
136 26755 : gfc_charlen_t length = 0;
137 :
138 26755 : buffer = flag ? buffer1 : buffer2;
139 26755 : flag = !flag;
140 :
141 26755 : switch (ts->type)
142 : {
143 13168 : case BT_INTEGER:
144 13168 : 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 13167 : 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 8324 : case BT_REAL:
155 8324 : sprintf (buffer, "REAL(%d)", ts->kind);
156 8324 : break;
157 2190 : case BT_COMPLEX:
158 2190 : sprintf (buffer, "COMPLEX(%d)", ts->kind);
159 2190 : break;
160 661 : case BT_LOGICAL:
161 661 : sprintf (buffer, "LOGICAL(%d)", ts->kind);
162 661 : break;
163 332 : case BT_CHARACTER:
164 332 : if (for_hash)
165 : {
166 263 : sprintf (buffer, "CHARACTER(%d)", ts->kind);
167 263 : break;
168 : }
169 :
170 69 : if (ts->u.cl && ts->u.cl->length)
171 68 : length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
172 69 : if (ts->kind == gfc_default_character_kind)
173 69 : 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 120 : case BT_DERIVED:
185 120 : if (ts->u.derived == NULL)
186 : {
187 1 : sprintf (buffer, "invalid type");
188 1 : break;
189 : }
190 119 : sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
191 119 : 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 404 : case BT_UNKNOWN:
215 404 : strcpy (buffer, "UNKNOWN");
216 404 : 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 26755 : return buffer;
225 : }
226 :
227 :
228 : const char *
229 1377 : 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 1377 : static char buffer1[34];
234 1377 : static char buffer2[34];
235 1377 : static bool flag = false;
236 1377 : char *buffer;
237 1377 : gfc_charlen_t length;
238 1377 : buffer = flag ? buffer1 : buffer2;
239 1377 : flag = !flag;
240 :
241 1377 : if (ex->ts.type == BT_CHARACTER)
242 : {
243 1015 : if (ex->expr_type == EXPR_CONSTANT)
244 918 : 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 1010 : if (ex->ts.kind == gfc_default_character_kind)
270 930 : 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 1010 : 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 10950960 : gfc_code2string (const mstring *m, int code)
317 : {
318 68202761 : while (m->string != NULL)
319 : {
320 68202761 : if (m->tag == code)
321 10950960 : return m->string;
322 57251801 : 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 11617573 : gfc_string2code (const mstring *m, const char *string)
335 : {
336 70736673 : for (; m->string != NULL; m++)
337 70736673 : if (strcmp (m->string, string) == 0)
338 11617573 : 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 31306 : gfc_init_1 (void)
360 : {
361 31306 : gfc_error_init_1 ();
362 31306 : gfc_scanner_init_1 ();
363 31306 : gfc_arith_init_1 ();
364 31306 : gfc_intrinsic_init_1 ();
365 31306 : }
366 :
367 :
368 : /* Per program unit initialization. */
369 :
370 : void
371 80034 : gfc_init_2 (void)
372 : {
373 80034 : gfc_symbol_init_2 ();
374 80034 : gfc_module_init_2 ();
375 80034 : }
376 :
377 :
378 : /******************* Destructor functions ******************/
379 :
380 : /* Call all of the top level destructors. */
381 :
382 : void
383 31287 : gfc_done_1 (void)
384 : {
385 31287 : gfc_scanner_done_1 ();
386 31287 : gfc_intrinsic_done_1 ();
387 31287 : gfc_arith_done_1 ();
388 31287 : }
389 :
390 :
391 : /* Per program unit destructors. */
392 :
393 : void
394 80368 : gfc_done_2 (void)
395 : {
396 80368 : gfc_symbol_done_2 ();
397 80368 : gfc_module_done_2 ();
398 80368 : }
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 8607 : get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
406 : {
407 8607 : int index = 0;
408 :
409 370101 : for (index = 0; index < ISOCBINDING_LAST; index++)
410 370101 : 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 278 : gfc_closest_fuzzy_match (const char *typo, char **candidates)
422 : {
423 : /* Determine closest match. */
424 278 : const char *best = NULL;
425 278 : char **cand = candidates;
426 278 : edit_distance_t best_distance = MAX_EDIT_DISTANCE;
427 278 : const size_t tl = strlen (typo);
428 :
429 879 : while (cand && *cand)
430 : {
431 1202 : edit_distance_t dist = get_edit_distance (typo, tl, *cand,
432 601 : strlen (*cand));
433 601 : if (dist < best_distance)
434 : {
435 193 : best_distance = dist;
436 193 : best = *cand;
437 : }
438 601 : cand++;
439 : }
440 : /* If more than half of the letters were misspelled, the suggestion is
441 : likely to be meaningless. */
442 278 : if (best)
443 : {
444 127 : unsigned int cutoff = MAX (tl, strlen (best));
445 :
446 127 : if (best_distance > cutoff)
447 : {
448 81 : XDELETEVEC (candidates);
449 81 : return NULL;
450 : }
451 46 : 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 12477 : 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 12477 : const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
465 12477 : return w.to_shwi ();
466 12477 : }
467 :
468 :
469 : void
470 2409 : gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
471 : {
472 2409 : const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
473 2409 : wi::to_mpz (w, rop, SIGNED);
474 2409 : }
475 :
476 :
477 : /* Extract a name suitable for use in the name of the select type temporary
478 : variable. We pick the last component name in the data reference if there
479 : is one, otherwise the user variable name, and return the empty string by
480 : default. */
481 :
482 : const char *
483 7479 : gfc_var_name_for_select_type_temp (gfc_expr *e)
484 : {
485 7479 : const char *name = "";
486 7479 : if (e->symtree)
487 7479 : name = e->symtree->name;
488 12217 : for (gfc_ref *r = e->ref; r; r = r->next)
489 4738 : if (r->type == REF_COMPONENT
490 3727 : && !(strcmp (r->u.c.component->name, "_data") == 0
491 3727 : || strcmp (r->u.c.component->name, "_vptr") == 0))
492 4738 : name = r->u.c.component->name;
493 :
494 7479 : return name;
495 : }
|
