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