1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2018 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
)
110 gfc_internal_error ("gfc_basic_typename(): Undefined type");
117 /* Return a string describing the type and kind of a typespec. Because
118 we return alternating buffers, this subroutine can appear twice in
119 the argument list of a single statement. */
122 gfc_typename (gfc_typespec
*ts
)
124 static char buffer1
[GFC_MAX_SYMBOL_LEN
+ 7]; /* 7 for "TYPE()" + '\0'. */
125 static char buffer2
[GFC_MAX_SYMBOL_LEN
+ 7];
129 buffer
= flag
? buffer1
: buffer2
;
135 sprintf (buffer
, "INTEGER(%d)", ts
->kind
);
138 sprintf (buffer
, "REAL(%d)", ts
->kind
);
141 sprintf (buffer
, "COMPLEX(%d)", ts
->kind
);
144 sprintf (buffer
, "LOGICAL(%d)", ts
->kind
);
147 sprintf (buffer
, "CHARACTER(%d)", ts
->kind
);
150 sprintf (buffer
, "HOLLERITH");
153 sprintf (buffer
, "UNION(%s)", ts
->u
.derived
->name
);
156 sprintf (buffer
, "TYPE(%s)", ts
->u
.derived
->name
);
159 ts
= &ts
->u
.derived
->components
->ts
;
160 if (ts
->u
.derived
->attr
.unlimited_polymorphic
)
161 sprintf (buffer
, "CLASS(*)");
163 sprintf (buffer
, "CLASS(%s)", ts
->u
.derived
->name
);
166 sprintf (buffer
, "TYPE(*)");
169 strcpy (buffer
, "PROCEDURE");
172 strcpy (buffer
, "UNKNOWN");
175 gfc_internal_error ("gfc_typename(): Undefined type");
182 /* Given an mstring array and a code, locate the code in the table,
183 returning a pointer to the string. */
186 gfc_code2string (const mstring
*m
, int code
)
188 while (m
->string
!= NULL
)
195 gfc_internal_error ("gfc_code2string(): Bad code");
200 /* Given an mstring array and a string, returns the value of the tag
201 field. Returns the final tag if no matches to the string are found. */
204 gfc_string2code (const mstring
*m
, const char *string
)
206 for (; m
->string
!= NULL
; m
++)
207 if (strcmp (m
->string
, string
) == 0)
214 /* Convert an intent code to a string. */
215 /* TODO: move to gfortran.h as define. */
218 gfc_intent_string (sym_intent i
)
220 return gfc_code2string (intents
, i
);
224 /***************** Initialization functions ****************/
226 /* Top level initialization. */
232 gfc_scanner_init_1 ();
234 gfc_intrinsic_init_1 ();
238 /* Per program unit initialization. */
243 gfc_symbol_init_2 ();
244 gfc_module_init_2 ();
248 /******************* Destructor functions ******************/
250 /* Call all of the top level destructors. */
255 gfc_scanner_done_1 ();
256 gfc_intrinsic_done_1 ();
261 /* Per program unit destructors. */
266 gfc_symbol_done_2 ();
267 gfc_module_done_2 ();
271 /* Returns the index into the table of C interoperable kinds where the
272 kind with the given name (c_kind_name) was found. */
275 get_c_kind(const char *c_kind_name
, CInteropKind_t kinds_table
[])
279 for (index
= 0; index
< ISOCBINDING_LAST
; index
++)
280 if (strcmp (kinds_table
[index
].name
, c_kind_name
) == 0)
283 return ISOCBINDING_INVALID
;
287 /* For a given name TYPO, determine the best candidate from CANDIDATES
288 perusing Levenshtein distance. Frees CANDIDATES before returning. */
291 gfc_closest_fuzzy_match (const char *typo
, char **candidates
)
293 /* Determine closest match. */
294 const char *best
= NULL
;
295 char **cand
= candidates
;
296 edit_distance_t best_distance
= MAX_EDIT_DISTANCE
;
297 const size_t tl
= strlen (typo
);
299 while (cand
&& *cand
)
301 edit_distance_t dist
= levenshtein_distance (typo
, tl
, *cand
,
303 if (dist
< best_distance
)
305 best_distance
= dist
;
310 /* If more than half of the letters were misspelled, the suggestion is
311 likely to be meaningless. */
314 unsigned int cutoff
= MAX (tl
, strlen (best
)) / 2;
316 if (best_distance
> cutoff
)
318 XDELETEVEC (candidates
);
321 XDELETEVEC (candidates
);
326 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */
329 gfc_mpz_get_hwi (mpz_t op
)
331 /* Using long_long_integer_type_node as that is the integer type
332 node that closest matches HOST_WIDE_INT; both are guaranteed to
333 be at least 64 bits. */
334 const wide_int w
= wi::from_mpz (long_long_integer_type_node
, op
, true);
340 gfc_mpz_set_hwi (mpz_t rop
, const HOST_WIDE_INT op
)
342 const wide_int w
= wi::shwi (op
, HOST_BITS_PER_WIDE_INT
);
343 wi::to_mpz (w
, rop
, SIGNED
);