]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Miscellaneous stuff that doesn't fit anywhere else. |
a945c346 | 2 | Copyright (C) 2000-2024 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Andy Vaught |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
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 | |
d234d788 | 9 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 10 | version. |
6de9cd9a | 11 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
18 | along with GCC; see the file COPYING3. If not see |
19 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a | 20 | |
6de9cd9a | 21 | #include "config.h" |
d22e4895 | 22 | #include "system.h" |
953bee7c | 23 | #include "coretypes.h" |
6de9cd9a | 24 | #include "gfortran.h" |
bcc478b9 | 25 | #include "spellcheck.h" |
f622221a | 26 | #include "tree.h" |
6de9cd9a | 27 | |
6de9cd9a | 28 | |
6de9cd9a DN |
29 | /* Initialize a typespec to unknown. */ |
30 | ||
31 | void | |
edf1eac2 | 32 | gfc_clear_ts (gfc_typespec *ts) |
6de9cd9a | 33 | { |
6de9cd9a | 34 | ts->type = BT_UNKNOWN; |
bc21d315 | 35 | ts->u.derived = NULL; |
1c8bcdf7 | 36 | ts->kind = 0; |
bc21d315 | 37 | ts->u.cl = NULL; |
ed54a884 | 38 | ts->interface = NULL; |
a8b3b0b6 CR |
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; | |
e69afb29 | 45 | ts->deferred = false; |
6de9cd9a DN |
46 | } |
47 | ||
48 | ||
49 | /* Open a file for reading. */ | |
50 | ||
51 | FILE * | |
52 | gfc_open_file (const char *name) | |
53 | { | |
6de9cd9a DN |
54 | if (!*name) |
55 | return stdin; | |
56 | ||
6de9cd9a DN |
57 | return fopen (name, "r"); |
58 | } | |
59 | ||
60 | ||
6de9cd9a DN |
61 | /* Return a string for each type. */ |
62 | ||
63 | const char * | |
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; | |
d3642f89 FW |
85 | case BT_HOLLERITH: |
86 | p = "HOLLERITH"; | |
87 | break; | |
f6288c24 FR |
88 | case BT_UNION: |
89 | p = "UNION"; | |
90 | break; | |
6de9cd9a DN |
91 | case BT_DERIVED: |
92 | p = "DERIVED"; | |
93 | break; | |
cf2b3c22 TB |
94 | case BT_CLASS: |
95 | p = "CLASS"; | |
96 | break; | |
6de9cd9a DN |
97 | case BT_PROCEDURE: |
98 | p = "PROCEDURE"; | |
99 | break; | |
e6ef7325 TB |
100 | case BT_VOID: |
101 | p = "VOID"; | |
102 | break; | |
8dc63166 SK |
103 | case BT_BOZ: |
104 | p = "BOZ"; | |
105 | break; | |
6de9cd9a DN |
106 | case BT_UNKNOWN: |
107 | p = "UNKNOWN"; | |
108 | break; | |
45a69325 TB |
109 | case BT_ASSUMED: |
110 | p = "TYPE(*)"; | |
111 | break; | |
6de9cd9a DN |
112 | default: |
113 | gfc_internal_error ("gfc_basic_typename(): Undefined type"); | |
114 | } | |
115 | ||
116 | return p; | |
117 | } | |
118 | ||
119 | ||
1f2959f0 | 120 | /* Return a string describing the type and kind of a typespec. Because |
6de9cd9a DN |
121 | we return alternating buffers, this subroutine can appear twice in |
122 | the argument list of a single statement. */ | |
123 | ||
124 | const char * | |
5958b926 | 125 | gfc_typename (gfc_typespec *ts, bool for_hash) |
6de9cd9a | 126 | { |
01685676 SK |
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]; | |
6de9cd9a DN |
131 | static int flag = 0; |
132 | char *buffer; | |
f61e54e5 | 133 | gfc_charlen_t length = 0; |
6de9cd9a DN |
134 | |
135 | buffer = flag ? buffer1 : buffer2; | |
136 | flag = !flag; | |
137 | ||
138 | switch (ts->type) | |
139 | { | |
140 | case BT_INTEGER: | |
8d2130a4 PAA |
141 | if (ts->f90_type == BT_VOID |
142 | && ts->u.derived | |
143 | && ts->u.derived->from_intmod == INTMOD_ISO_C_BINDING) | |
144 | sprintf (buffer, "TYPE(%s)", ts->u.derived->name); | |
145 | else | |
146 | sprintf (buffer, "INTEGER(%d)", ts->kind); | |
6de9cd9a DN |
147 | break; |
148 | case BT_REAL: | |
149 | sprintf (buffer, "REAL(%d)", ts->kind); | |
150 | break; | |
151 | case BT_COMPLEX: | |
152 | sprintf (buffer, "COMPLEX(%d)", ts->kind); | |
153 | break; | |
154 | case BT_LOGICAL: | |
155 | sprintf (buffer, "LOGICAL(%d)", ts->kind); | |
156 | break; | |
157 | case BT_CHARACTER: | |
5958b926 TK |
158 | if (for_hash) |
159 | { | |
160 | sprintf (buffer, "CHARACTER(%d)", ts->kind); | |
161 | break; | |
162 | } | |
163 | ||
f61e54e5 ME |
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 (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length); | |
168 | else | |
169 | sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length, | |
170 | ts->kind); | |
6de9cd9a | 171 | break; |
d3642f89 FW |
172 | case BT_HOLLERITH: |
173 | sprintf (buffer, "HOLLERITH"); | |
174 | break; | |
f6288c24 FR |
175 | case BT_UNION: |
176 | sprintf (buffer, "UNION(%s)", ts->u.derived->name); | |
177 | break; | |
6de9cd9a | 178 | case BT_DERIVED: |
f812dfe8 TK |
179 | if (ts->u.derived == NULL) |
180 | { | |
181 | sprintf (buffer, "invalid type"); | |
182 | break; | |
183 | } | |
bc21d315 | 184 | sprintf (buffer, "TYPE(%s)", ts->u.derived->name); |
6de9cd9a | 185 | break; |
cf2b3c22 | 186 | case BT_CLASS: |
017665f6 TB |
187 | if (!ts->u.derived || !ts->u.derived->components |
188 | || !ts->u.derived->components->ts.u.derived) | |
f812dfe8 TK |
189 | { |
190 | sprintf (buffer, "invalid class"); | |
191 | break; | |
192 | } | |
017665f6 | 193 | if (ts->u.derived->components->ts.u.derived->attr.unlimited_polymorphic) |
8b704316 PT |
194 | sprintf (buffer, "CLASS(*)"); |
195 | else | |
017665f6 TB |
196 | sprintf (buffer, "CLASS(%s)", |
197 | ts->u.derived->components->ts.u.derived->name); | |
cf2b3c22 | 198 | break; |
45a69325 TB |
199 | case BT_ASSUMED: |
200 | sprintf (buffer, "TYPE(*)"); | |
201 | break; | |
6de9cd9a DN |
202 | case BT_PROCEDURE: |
203 | strcpy (buffer, "PROCEDURE"); | |
204 | break; | |
8dc63166 SK |
205 | case BT_BOZ: |
206 | strcpy (buffer, "BOZ"); | |
207 | break; | |
6de9cd9a DN |
208 | case BT_UNKNOWN: |
209 | strcpy (buffer, "UNKNOWN"); | |
210 | break; | |
211 | default: | |
a9f6f1f2 | 212 | gfc_internal_error ("gfc_typename(): Undefined type"); |
6de9cd9a DN |
213 | } |
214 | ||
215 | return buffer; | |
216 | } | |
217 | ||
218 | ||
f61e54e5 ME |
219 | const char * |
220 | 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 | 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 | { | |
81372618 | 234 | if (ex->expr_type == EXPR_CONSTANT) |
f61e54e5 | 235 | length = ex->value.character.length; |
81372618 JJ |
236 | else if (ex->ts.deferred) |
237 | { | |
238 | if (ex->ts.kind == gfc_default_character_kind) | |
239 | return "CHARACTER(:)"; | |
240 | sprintf (buffer, "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 (buffer, "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 (buffer, "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); | |
f61e54e5 ME |
260 | if (ex->ts.kind == gfc_default_character_kind) |
261 | sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length); | |
262 | else | |
263 | sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length, | |
264 | ex->ts.kind); | |
265 | return buffer; | |
266 | } | |
267 | return gfc_typename(&ex->ts); | |
268 | } | |
269 | ||
270 | /* The type of a dummy variable can also be CHARACTER(*). */ | |
271 | ||
272 | const char * | |
273 | gfc_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(buffer, "CHARACTER(*)"); | |
6b8b9596 | 292 | else if (ts->kind >= 0 && ts->kind < 10) |
f61e54e5 ME |
293 | sprintf(buffer, "CHARACTER(*,%d)", ts->kind); |
294 | else | |
295 | sprintf(buffer, "CHARACTER(*,?)"); | |
296 | return buffer; | |
297 | } | |
298 | } | |
299 | return gfc_typename(ts); | |
300 | } | |
301 | ||
302 | ||
6de9cd9a DN |
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 * | |
edf1eac2 | 307 | gfc_code2string (const mstring *m, int code) |
6de9cd9a | 308 | { |
6de9cd9a DN |
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 | |
edf1eac2 | 322 | field. Returns the final tag if no matches to the string are found. */ |
6de9cd9a DN |
323 | |
324 | int | |
edf1eac2 | 325 | gfc_string2code (const mstring *m, const char *string) |
6de9cd9a | 326 | { |
6de9cd9a DN |
327 | for (; m->string != NULL; m++) |
328 | if (strcmp (m->string, 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. */ | |
edf1eac2 | 337 | |
6de9cd9a DN |
338 | const char * |
339 | gfc_intent_string (sym_intent i) | |
340 | { | |
6de9cd9a DN |
341 | return gfc_code2string (intents, i); |
342 | } | |
343 | ||
344 | ||
345 | /***************** Initialization functions ****************/ | |
346 | ||
347 | /* Top level initialization. */ | |
348 | ||
349 | void | |
350 | gfc_init_1 (void) | |
351 | { | |
6de9cd9a DN |
352 | gfc_error_init_1 (); |
353 | gfc_scanner_init_1 (); | |
354 | gfc_arith_init_1 (); | |
355 | gfc_intrinsic_init_1 (); | |
6de9cd9a DN |
356 | } |
357 | ||
358 | ||
359 | /* Per program unit initialization. */ | |
360 | ||
361 | void | |
362 | gfc_init_2 (void) | |
363 | { | |
6de9cd9a DN |
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 | ||
373 | void | |
374 | gfc_done_1 (void) | |
375 | { | |
6de9cd9a DN |
376 | gfc_scanner_done_1 (); |
377 | gfc_intrinsic_done_1 (); | |
6de9cd9a DN |
378 | gfc_arith_done_1 (); |
379 | } | |
380 | ||
381 | ||
382 | /* Per program unit destructors. */ | |
383 | ||
384 | void | |
385 | gfc_done_2 (void) | |
386 | { | |
6de9cd9a DN |
387 | gfc_symbol_done_2 (); |
388 | gfc_module_done_2 (); | |
389 | } | |
390 | ||
a8b3b0b6 CR |
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 | get_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 (kinds_table[index].name, c_kind_name) == 0) | |
402 | return index; | |
403 | ||
404 | return ISOCBINDING_INVALID; | |
405 | } | |
bcc478b9 BRF |
406 | |
407 | ||
408 | /* For a given name TYPO, determine the best candidate from CANDIDATES | |
b80a188b | 409 | using get_edit_distance. Frees CANDIDATES before returning. */ |
bcc478b9 BRF |
410 | |
411 | const char * | |
412 | gfc_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 (typo); | |
419 | ||
420 | while (cand && *cand) | |
421 | { | |
b80a188b | 422 | edit_distance_t dist = get_edit_distance (typo, tl, *cand, |
bcc478b9 BRF |
423 | strlen (*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 | { | |
640e05e0 | 435 | unsigned int cutoff = MAX (tl, strlen (best)); |
bcc478b9 BRF |
436 | |
437 | if (best_distance > cutoff) | |
438 | { | |
439 | XDELETEVEC (candidates); | |
440 | return NULL; | |
441 | } | |
442 | XDELETEVEC (candidates); | |
443 | } | |
444 | return best; | |
445 | } | |
f622221a JB |
446 | |
447 | /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */ | |
448 | ||
449 | HOST_WIDE_INT | |
450 | 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 | const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true); | |
456 | return w.to_shwi (); | |
457 | } | |
458 | ||
459 | ||
460 | void | |
461 | gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op) | |
462 | { | |
463 | const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT); | |
464 | wi::to_mpz (w, rop, SIGNED); | |
465 | } |