1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2024 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
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
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
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/>. */
23 #include "coretypes.h"
25 #include "spellcheck.h"
29 /* Initialize a typespec to unknown. */
32 gfc_clear_ts (gfc_typespec
*ts
)
34 ts
->type
= BT_UNKNOWN
;
39 /* flag that says if the type is C interoperable */
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 */
49 /* Open a file for reading. */
52 gfc_open_file (const char *name
)
57 return fopen (name
, "r");
61 /* Return a string for each type. */
64 gfc_basic_typename (bt type
)
113 gfc_internal_error ("gfc_basic_typename(): Undefined type");
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. */
125 gfc_typename (gfc_typespec
*ts
, bool for_hash
)
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];
133 gfc_charlen_t length
= 0;
135 buffer
= flag
? buffer1
: buffer2
;
141 if (ts
->f90_type
== BT_VOID
143 && ts
->u
.derived
->from_intmod
== INTMOD_ISO_C_BINDING
)
144 sprintf (buffer
, "TYPE(%s)", ts
->u
.derived
->name
);
146 sprintf (buffer
, "INTEGER(%d)", ts
->kind
);
149 sprintf (buffer
, "REAL(%d)", ts
->kind
);
152 sprintf (buffer
, "COMPLEX(%d)", ts
->kind
);
155 sprintf (buffer
, "LOGICAL(%d)", ts
->kind
);
160 sprintf (buffer
, "CHARACTER(%d)", ts
->kind
);
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
);
169 sprintf (buffer
, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC
",%d)", length
,
173 sprintf (buffer
, "HOLLERITH");
176 sprintf (buffer
, "UNION(%s)", ts
->u
.derived
->name
);
179 if (ts
->u
.derived
== NULL
)
181 sprintf (buffer
, "invalid type");
184 sprintf (buffer
, "TYPE(%s)", ts
->u
.derived
->name
);
187 if (!ts
->u
.derived
|| !ts
->u
.derived
->components
188 || !ts
->u
.derived
->components
->ts
.u
.derived
)
190 sprintf (buffer
, "invalid class");
193 if (ts
->u
.derived
->components
->ts
.u
.derived
->attr
.unlimited_polymorphic
)
194 sprintf (buffer
, "CLASS(*)");
196 sprintf (buffer
, "CLASS(%s)",
197 ts
->u
.derived
->components
->ts
.u
.derived
->name
);
200 sprintf (buffer
, "TYPE(*)");
203 strcpy (buffer
, "PROCEDURE");
206 strcpy (buffer
, "BOZ");
209 strcpy (buffer
, "UNKNOWN");
212 gfc_internal_error ("gfc_typename(): Undefined type");
220 gfc_typename (gfc_expr
*ex
)
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;
228 gfc_charlen_t length
;
229 buffer
= flag
? buffer1
: buffer2
;
232 if (ex
->ts
.type
== BT_CHARACTER
)
234 if (ex
->expr_type
== EXPR_CONSTANT
)
235 length
= ex
->value
.character
.length
;
236 else if (ex
->ts
.deferred
)
238 if (ex
->ts
.kind
== gfc_default_character_kind
)
239 return "CHARACTER(:)";
240 sprintf (buffer
, "CHARACTER(:,%d)", ex
->ts
.kind
);
243 else if (ex
->ts
.u
.cl
&& ex
->ts
.u
.cl
->length
== NULL
)
245 if (ex
->ts
.kind
== gfc_default_character_kind
)
246 return "CHARACTER(*)";
247 sprintf (buffer
, "CHARACTER(*,%d)", ex
->ts
.kind
);
250 else if (ex
->ts
.u
.cl
== NULL
251 || ex
->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
)
253 if (ex
->ts
.kind
== gfc_default_character_kind
)
255 sprintf (buffer
, "CHARACTER(KIND=%d)", ex
->ts
.kind
);
259 length
= gfc_mpz_get_hwi (ex
->ts
.u
.cl
->length
->value
.integer
);
260 if (ex
->ts
.kind
== gfc_default_character_kind
)
261 sprintf (buffer
, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC
")", length
);
263 sprintf (buffer
, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC
",%d)", length
,
267 return gfc_typename(&ex
->ts
);
270 /* The type of a dummy variable can also be CHARACTER(*). */
273 gfc_dummy_typename (gfc_typespec
*ts
)
275 static char buffer1
[15]; /* 15 for "CHARACTER(*,4)" + '\0'. */
276 static char buffer2
[15];
277 static bool flag
= false;
280 buffer
= flag
? buffer1
: buffer2
;
283 if (ts
->type
== BT_CHARACTER
)
285 bool has_length
= false;
287 has_length
= ts
->u
.cl
->length
!= NULL
;
290 if (ts
->kind
== gfc_default_character_kind
)
291 sprintf(buffer
, "CHARACTER(*)");
292 else if (ts
->kind
>= 0 && ts
->kind
< 10)
293 sprintf(buffer
, "CHARACTER(*,%d)", ts
->kind
);
295 sprintf(buffer
, "CHARACTER(*,?)");
299 return gfc_typename(ts
);
303 /* Given an mstring array and a code, locate the code in the table,
304 returning a pointer to the string. */
307 gfc_code2string (const mstring
*m
, int code
)
309 while (m
->string
!= NULL
)
316 gfc_internal_error ("gfc_code2string(): Bad code");
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. */
325 gfc_string2code (const mstring
*m
, const char *string
)
327 for (; m
->string
!= NULL
; m
++)
328 if (strcmp (m
->string
, string
) == 0)
335 /* Convert an intent code to a string. */
336 /* TODO: move to gfortran.h as define. */
339 gfc_intent_string (sym_intent i
)
341 return gfc_code2string (intents
, i
);
345 /***************** Initialization functions ****************/
347 /* Top level initialization. */
353 gfc_scanner_init_1 ();
355 gfc_intrinsic_init_1 ();
359 /* Per program unit initialization. */
364 gfc_symbol_init_2 ();
365 gfc_module_init_2 ();
369 /******************* Destructor functions ******************/
371 /* Call all of the top level destructors. */
376 gfc_scanner_done_1 ();
377 gfc_intrinsic_done_1 ();
382 /* Per program unit destructors. */
387 gfc_symbol_done_2 ();
388 gfc_module_done_2 ();
392 /* Returns the index into the table of C interoperable kinds where the
393 kind with the given name (c_kind_name) was found. */
396 get_c_kind(const char *c_kind_name
, CInteropKind_t kinds_table
[])
400 for (index
= 0; index
< ISOCBINDING_LAST
; index
++)
401 if (strcmp (kinds_table
[index
].name
, c_kind_name
) == 0)
404 return ISOCBINDING_INVALID
;
408 /* For a given name TYPO, determine the best candidate from CANDIDATES
409 using get_edit_distance. Frees CANDIDATES before returning. */
412 gfc_closest_fuzzy_match (const char *typo
, char **candidates
)
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
);
420 while (cand
&& *cand
)
422 edit_distance_t dist
= get_edit_distance (typo
, tl
, *cand
,
424 if (dist
< best_distance
)
426 best_distance
= dist
;
431 /* If more than half of the letters were misspelled, the suggestion is
432 likely to be meaningless. */
435 unsigned int cutoff
= MAX (tl
, strlen (best
));
437 if (best_distance
> cutoff
)
439 XDELETEVEC (candidates
);
442 XDELETEVEC (candidates
);
447 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */
450 gfc_mpz_get_hwi (mpz_t op
)
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);
461 gfc_mpz_set_hwi (mpz_t rop
, const HOST_WIDE_INT op
)
463 const wide_int w
= wi::shwi (op
, HOST_BITS_PER_WIDE_INT
);
464 wi::to_mpz (w
, rop
, SIGNED
);