1/* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2023 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along 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
31void
32gfc_clear_ts (gfc_typespec *ts)
33{
34 ts->type = BT_UNKNOWN;
35 ts->u.derived = NULL;
36 ts->kind = 0;
37 ts->u.cl = NULL;
38 ts->interface = NULL;
39 /* flag that says if the type is C interoperable */
40 ts->is_c_interop = 0;
41 /* says what f90 type the C kind interops with */
42 ts->f90_type = BT_UNKNOWN;
43 /* flag that says whether it's from iso_c_binding or not */
44 ts->is_iso_c = 0;
45 ts->deferred = false;
46}
47
48
49/* Open a file for reading. */
50
51FILE *
52gfc_open_file (const char *name)
53{
54 if (!*name)
55 return stdin;
56
57 return fopen (filename: name, modes: "r");
58}
59
60
61/* Return a string for each type. */
62
63const char *
64gfc_basic_typename (bt type)
65{
66 const char *p;
67
68 switch (type)
69 {
70 case BT_INTEGER:
71 p = "INTEGER";
72 break;
73 case BT_REAL:
74 p = "REAL";
75 break;
76 case BT_COMPLEX:
77 p = "COMPLEX";
78 break;
79 case BT_LOGICAL:
80 p = "LOGICAL";
81 break;
82 case BT_CHARACTER:
83 p = "CHARACTER";
84 break;
85 case BT_HOLLERITH:
86 p = "HOLLERITH";
87 break;
88 case BT_UNION:
89 p = "UNION";
90 break;
91 case BT_DERIVED:
92 p = "DERIVED";
93 break;
94 case BT_CLASS:
95 p = "CLASS";
96 break;
97 case BT_PROCEDURE:
98 p = "PROCEDURE";
99 break;
100 case BT_VOID:
101 p = "VOID";
102 break;
103 case BT_BOZ:
104 p = "BOZ";
105 break;
106 case BT_UNKNOWN:
107 p = "UNKNOWN";
108 break;
109 case BT_ASSUMED:
110 p = "TYPE(*)";
111 break;
112 default:
113 gfc_internal_error ("gfc_basic_typename(): Undefined type");
114 }
115
116 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
124const char *
125gfc_typename (gfc_typespec *ts, bool for_hash)
126{
127 /* Need to add sufficient padding for "TYPE()" + '\0', "UNION()" + '\0',
128 or "CLASS()" + '\0'. */
129 static char buffer1[GFC_MAX_SYMBOL_LEN + 8];
130 static char buffer2[GFC_MAX_SYMBOL_LEN + 8];
131 static int flag = 0;
132 char *buffer;
133 gfc_charlen_t length = 0;
134
135 buffer = flag ? buffer1 : buffer2;
136 flag = !flag;
137
138 switch (ts->type)
139 {
140 case BT_INTEGER:
141 if (ts->f90_type == BT_VOID
142 && ts->u.derived
143 && ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING)
144 sprintf (s: buffer, format: "TYPE(%s)", ts->u.derived->name);
145 else
146 sprintf (s: buffer, format: "INTEGER(%d)", ts->kind);
147 break;
148 case BT_REAL:
149 sprintf (s: buffer, format: "REAL(%d)", ts->kind);
150 break;
151 case BT_COMPLEX:
152 sprintf (s: buffer, format: "COMPLEX(%d)", ts->kind);
153 break;
154 case BT_LOGICAL:
155 sprintf (s: buffer, format: "LOGICAL(%d)", ts->kind);
156 break;
157 case BT_CHARACTER:
158 if (for_hash)
159 {
160 sprintf (s: buffer, format: "CHARACTER(%d)", ts->kind);
161 break;
162 }
163
164 if (ts->u.cl && ts->u.cl->length)
165 length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
166 if (ts->kind == gfc_default_character_kind)
167 sprintf (s: buffer, format: "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
168 else
169 sprintf (s: buffer, format: "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
170 ts->kind);
171 break;
172 case BT_HOLLERITH:
173 sprintf (s: buffer, format: "HOLLERITH");
174 break;
175 case BT_UNION:
176 sprintf (s: buffer, format: "UNION(%s)", ts->u.derived->name);
177 break;
178 case BT_DERIVED:
179 if (ts->u.derived == NULL)
180 {
181 sprintf (s: buffer, format: "invalid type");
182 break;
183 }
184 sprintf (s: buffer, format: "TYPE(%s)", ts->u.derived->name);
185 break;
186 case BT_CLASS:
187 if (!ts->u.derived || !ts->u.derived->components
188 || !ts->u.derived->components->ts.u.derived)
189 {
190 sprintf (s: buffer, format: "invalid class");
191 break;
192 }
193 if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
194 sprintf (s: buffer, format: "CLASS(*)");
195 else
196 sprintf (s: buffer, format: "CLASS(%s)",
197 ts->u.derived->components->ts.u.derived->name);
198 break;
199 case BT_ASSUMED:
200 sprintf (s: buffer, format: "TYPE(*)");
201 break;
202 case BT_PROCEDURE:
203 strcpy (dest: buffer, src: "PROCEDURE");
204 break;
205 case BT_BOZ:
206 strcpy (dest: buffer, src: "BOZ");
207 break;
208 case BT_UNKNOWN:
209 strcpy (dest: buffer, src: "UNKNOWN");
210 break;
211 default:
212 gfc_internal_error ("gfc_typename(): Undefined type");
213 }
214
215 return buffer;
216}
217
218
219const char *
220gfc_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 static char buffer1[34];
225 static char buffer2[34];
226 static bool flag = false;
227 char *buffer;
228 gfc_charlen_t length;
229 buffer = flag ? buffer1 : buffer2;
230 flag = !flag;
231
232 if (ex->ts.type == BT_CHARACTER)
233 {
234 if (ex->expr_type == EXPR_CONSTANT)
235 length = ex->value.character.length;
236 else if (ex->ts.deferred)
237 {
238 if (ex->ts.kind == gfc_default_character_kind)
239 return "CHARACTER(:)";
240 sprintf (s: buffer, format: "CHARACTER(:,%d)", ex->ts.kind);
241 return buffer;
242 }
243 else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
244 {
245 if (ex->ts.kind == gfc_default_character_kind)
246 return "CHARACTER(*)";
247 sprintf (s: buffer, format: "CHARACTER(*,%d)", ex->ts.kind);
248 return buffer;
249 }
250 else if (ex->ts.u.cl == NULL
251 || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
252 {
253 if (ex->ts.kind == gfc_default_character_kind)
254 return "CHARACTER";
255 sprintf (s: buffer, format: "CHARACTER(KIND=%d)", ex->ts.kind);
256 return buffer;
257 }
258 else
259 length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
260 if (ex->ts.kind == gfc_default_character_kind)
261 sprintf (s: buffer, format: "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
262 else
263 sprintf (s: buffer, format: "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
264 ex->ts.kind);
265 return buffer;
266 }
267 return gfc_typename(ts: &ex->ts);
268}
269
270/* The type of a dummy variable can also be CHARACTER(*). */
271
272const char *
273gfc_dummy_typename (gfc_typespec *ts)
274{
275 static char buffer1[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */
276 static char buffer2[15];
277 static bool flag = false;
278 char *buffer;
279
280 buffer = flag ? buffer1 : buffer2;
281 flag = !flag;
282
283 if (ts->type == BT_CHARACTER)
284 {
285 bool has_length = false;
286 if (ts->u.cl)
287 has_length = ts->u.cl->length != NULL;
288 if (!has_length)
289 {
290 if (ts->kind == gfc_default_character_kind)
291 sprintf(s: buffer, format: "CHARACTER(*)");
292 else if (ts->kind >= 0 && ts->kind < 10)
293 sprintf(s: buffer, format: "CHARACTER(*,%d)", ts->kind);
294 else
295 sprintf(s: buffer, format: "CHARACTER(*,?)");
296 return buffer;
297 }
298 }
299 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
306const char *
307gfc_code2string (const mstring *m, int code)
308{
309 while (m->string != NULL)
310 {
311 if (m->tag == code)
312 return m->string;
313 m++;
314 }
315
316 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
324int
325gfc_string2code (const mstring *m, const char *string)
326{
327 for (; m->string != NULL; m++)
328 if (strcmp (s1: m->string, s2: string) == 0)
329 return m->tag;
330
331 return m->tag;
332}
333
334
335/* Convert an intent code to a string. */
336/* TODO: move to gfortran.h as define. */
337
338const char *
339gfc_intent_string (sym_intent i)
340{
341 return gfc_code2string (m: intents, code: i);
342}
343
344
345/***************** Initialization functions ****************/
346
347/* Top level initialization. */
348
349void
350gfc_init_1 (void)
351{
352 gfc_error_init_1 ();
353 gfc_scanner_init_1 ();
354 gfc_arith_init_1 ();
355 gfc_intrinsic_init_1 ();
356}
357
358
359/* Per program unit initialization. */
360
361void
362gfc_init_2 (void)
363{
364 gfc_symbol_init_2 ();
365 gfc_module_init_2 ();
366}
367
368
369/******************* Destructor functions ******************/
370
371/* Call all of the top level destructors. */
372
373void
374gfc_done_1 (void)
375{
376 gfc_scanner_done_1 ();
377 gfc_intrinsic_done_1 ();
378 gfc_arith_done_1 ();
379}
380
381
382/* Per program unit destructors. */
383
384void
385gfc_done_2 (void)
386{
387 gfc_symbol_done_2 ();
388 gfc_module_done_2 ();
389}
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
395int
396get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
397{
398 int index = 0;
399
400 for (index = 0; index < ISOCBINDING_LAST; index++)
401 if (strcmp (s1: kinds_table[index].name, s2: c_kind_name) == 0)
402 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
411const char *
412gfc_closest_fuzzy_match (const char *typo, char **candidates)
413{
414 /* Determine closest match. */
415 const char *best = NULL;
416 char **cand = candidates;
417 edit_distance_t best_distance = MAX_EDIT_DISTANCE;
418 const size_t tl = strlen (s: typo);
419
420 while (cand && *cand)
421 {
422 edit_distance_t dist = get_edit_distance (s: typo, len_s: tl, t: *cand,
423 len_t: strlen (s: *cand));
424 if (dist < best_distance)
425 {
426 best_distance = dist;
427 best = *cand;
428 }
429 cand++;
430 }
431 /* If more than half of the letters were misspelled, the suggestion is
432 likely to be meaningless. */
433 if (best)
434 {
435 unsigned int cutoff = MAX (tl, strlen (best));
436
437 if (best_distance > cutoff)
438 {
439 XDELETEVEC (candidates);
440 return NULL;
441 }
442 XDELETEVEC (candidates);
443 }
444 return best;
445}
446
447/* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */
448
449HOST_WIDE_INT
450gfc_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 const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
456 return w.to_shwi ();
457}
458
459
460void
461gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
462{
463 const wide_int w = wi::shwi (val: op, HOST_BITS_PER_WIDE_INT);
464 wi::to_mpz (w, rop, SIGNED);
465}
466

source code of gcc/fortran/misc.cc