1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2021 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
gfc_clear_ts(gfc_typespec * ts)32 gfc_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
51 FILE *
gfc_open_file(const char * name)52 gfc_open_file (const char *name)
53 {
54 if (!*name)
55 return stdin;
56
57 return fopen (name, "r");
58 }
59
60
61 /* Return a string for each type. */
62
63 const char *
gfc_basic_typename(bt type)64 gfc_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
124 const char *
gfc_typename(gfc_typespec * ts,bool for_hash)125 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 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_typespec *ts1;
134 gfc_charlen_t length = 0;
135
136 buffer = flag ? buffer1 : buffer2;
137 flag = !flag;
138
139 switch (ts->type)
140 {
141 case BT_INTEGER:
142 sprintf (buffer, "INTEGER(%d)", ts->kind);
143 break;
144 case BT_REAL:
145 sprintf (buffer, "REAL(%d)", ts->kind);
146 break;
147 case BT_COMPLEX:
148 sprintf (buffer, "COMPLEX(%d)", ts->kind);
149 break;
150 case BT_LOGICAL:
151 sprintf (buffer, "LOGICAL(%d)", ts->kind);
152 break;
153 case BT_CHARACTER:
154 if (for_hash)
155 {
156 sprintf (buffer, "CHARACTER(%d)", ts->kind);
157 break;
158 }
159
160 if (ts->u.cl && ts->u.cl->length)
161 length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
162 if (ts->kind == gfc_default_character_kind)
163 sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
164 else
165 sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
166 ts->kind);
167 break;
168 case BT_HOLLERITH:
169 sprintf (buffer, "HOLLERITH");
170 break;
171 case BT_UNION:
172 sprintf (buffer, "UNION(%s)", ts->u.derived->name);
173 break;
174 case BT_DERIVED:
175 if (ts->u.derived == NULL)
176 {
177 sprintf (buffer, "invalid type");
178 break;
179 }
180 sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
181 break;
182 case BT_CLASS:
183 if (ts->u.derived == NULL)
184 {
185 sprintf (buffer, "invalid class");
186 break;
187 }
188 ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
189 if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
190 sprintf (buffer, "CLASS(*)");
191 else
192 sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
193 break;
194 case BT_ASSUMED:
195 sprintf (buffer, "TYPE(*)");
196 break;
197 case BT_PROCEDURE:
198 strcpy (buffer, "PROCEDURE");
199 break;
200 case BT_BOZ:
201 strcpy (buffer, "BOZ");
202 break;
203 case BT_UNKNOWN:
204 strcpy (buffer, "UNKNOWN");
205 break;
206 default:
207 gfc_internal_error ("gfc_typename(): Undefined type");
208 }
209
210 return buffer;
211 }
212
213
214 const char *
gfc_typename(gfc_expr * ex)215 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 static char buffer1[34];
220 static char buffer2[34];
221 static bool flag = false;
222 char *buffer;
223 gfc_charlen_t length;
224 buffer = flag ? buffer1 : buffer2;
225 flag = !flag;
226
227 if (ex->ts.type == BT_CHARACTER)
228 {
229 if (ex->expr_type == EXPR_CONSTANT)
230 length = ex->value.character.length;
231 else if (ex->ts.deferred)
232 {
233 if (ex->ts.kind == gfc_default_character_kind)
234 return "CHARACTER(:)";
235 sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
236 return buffer;
237 }
238 else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
239 {
240 if (ex->ts.kind == gfc_default_character_kind)
241 return "CHARACTER(*)";
242 sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
243 return buffer;
244 }
245 else if (ex->ts.u.cl == NULL
246 || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
247 {
248 if (ex->ts.kind == gfc_default_character_kind)
249 return "CHARACTER";
250 sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
251 return buffer;
252 }
253 else
254 length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
255 if (ex->ts.kind == gfc_default_character_kind)
256 sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
257 else
258 sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
259 ex->ts.kind);
260 return buffer;
261 }
262 return gfc_typename(&ex->ts);
263 }
264
265 /* The type of a dummy variable can also be CHARACTER(*). */
266
267 const char *
gfc_dummy_typename(gfc_typespec * ts)268 gfc_dummy_typename (gfc_typespec *ts)
269 {
270 static char buffer1[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */
271 static char buffer2[15];
272 static bool flag = false;
273 char *buffer;
274
275 buffer = flag ? buffer1 : buffer2;
276 flag = !flag;
277
278 if (ts->type == BT_CHARACTER)
279 {
280 bool has_length = false;
281 if (ts->u.cl)
282 has_length = ts->u.cl->length != NULL;
283 if (!has_length)
284 {
285 if (ts->kind == gfc_default_character_kind)
286 sprintf(buffer, "CHARACTER(*)");
287 else if (ts->kind < 10)
288 sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
289 else
290 sprintf(buffer, "CHARACTER(*,?)");
291 return buffer;
292 }
293 }
294 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 *
gfc_code2string(const mstring * m,int code)302 gfc_code2string (const mstring *m, int code)
303 {
304 while (m->string != NULL)
305 {
306 if (m->tag == code)
307 return m->string;
308 m++;
309 }
310
311 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
gfc_string2code(const mstring * m,const char * string)320 gfc_string2code (const mstring *m, const char *string)
321 {
322 for (; m->string != NULL; m++)
323 if (strcmp (m->string, string) == 0)
324 return m->tag;
325
326 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 *
gfc_intent_string(sym_intent i)334 gfc_intent_string (sym_intent i)
335 {
336 return gfc_code2string (intents, i);
337 }
338
339
340 /***************** Initialization functions ****************/
341
342 /* Top level initialization. */
343
344 void
gfc_init_1(void)345 gfc_init_1 (void)
346 {
347 gfc_error_init_1 ();
348 gfc_scanner_init_1 ();
349 gfc_arith_init_1 ();
350 gfc_intrinsic_init_1 ();
351 }
352
353
354 /* Per program unit initialization. */
355
356 void
gfc_init_2(void)357 gfc_init_2 (void)
358 {
359 gfc_symbol_init_2 ();
360 gfc_module_init_2 ();
361 }
362
363
364 /******************* Destructor functions ******************/
365
366 /* Call all of the top level destructors. */
367
368 void
gfc_done_1(void)369 gfc_done_1 (void)
370 {
371 gfc_scanner_done_1 ();
372 gfc_intrinsic_done_1 ();
373 gfc_arith_done_1 ();
374 }
375
376
377 /* Per program unit destructors. */
378
379 void
gfc_done_2(void)380 gfc_done_2 (void)
381 {
382 gfc_symbol_done_2 ();
383 gfc_module_done_2 ();
384 }
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
get_c_kind(const char * c_kind_name,CInteropKind_t kinds_table[])391 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
392 {
393 int index = 0;
394
395 for (index = 0; index < ISOCBINDING_LAST; index++)
396 if (strcmp (kinds_table[index].name, c_kind_name) == 0)
397 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 *
gfc_closest_fuzzy_match(const char * typo,char ** candidates)407 gfc_closest_fuzzy_match (const char *typo, char **candidates)
408 {
409 /* Determine closest match. */
410 const char *best = NULL;
411 char **cand = candidates;
412 edit_distance_t best_distance = MAX_EDIT_DISTANCE;
413 const size_t tl = strlen (typo);
414
415 while (cand && *cand)
416 {
417 edit_distance_t dist = get_edit_distance (typo, tl, *cand,
418 strlen (*cand));
419 if (dist < best_distance)
420 {
421 best_distance = dist;
422 best = *cand;
423 }
424 cand++;
425 }
426 /* If more than half of the letters were misspelled, the suggestion is
427 likely to be meaningless. */
428 if (best)
429 {
430 unsigned int cutoff = MAX (tl, strlen (best));
431
432 if (best_distance > cutoff)
433 {
434 XDELETEVEC (candidates);
435 return NULL;
436 }
437 XDELETEVEC (candidates);
438 }
439 return best;
440 }
441
442 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */
443
444 HOST_WIDE_INT
gfc_mpz_get_hwi(mpz_t op)445 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 const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
451 return w.to_shwi ();
452 }
453
454
455 void
gfc_mpz_set_hwi(mpz_t rop,const HOST_WIDE_INT op)456 gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
457 {
458 const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
459 wi::to_mpz (w, rop, SIGNED);
460 }
461