* tree-vect-loop-manip.c (vect_do_peeling): Do not use
[official-gcc.git] / gcc / fortran / misc.c
blobf47d111ba47e0627f3115fc0773849f27fb0e1c2
1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2017 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
10 version.
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.
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/>. */
21 #include "config.h"
22 #include "system.h"
23 #include "coretypes.h"
24 #include "gfortran.h"
25 #include "spellcheck.h"
28 /* Initialize a typespec to unknown. */
30 void
31 gfc_clear_ts (gfc_typespec *ts)
33 ts->type = BT_UNKNOWN;
34 ts->u.derived = NULL;
35 ts->kind = 0;
36 ts->u.cl = NULL;
37 ts->interface = NULL;
38 /* flag that says if the type is C interoperable */
39 ts->is_c_interop = 0;
40 /* says what f90 type the C kind interops with */
41 ts->f90_type = BT_UNKNOWN;
42 /* flag that says whether it's from iso_c_binding or not */
43 ts->is_iso_c = 0;
44 ts->deferred = false;
48 /* Open a file for reading. */
50 FILE *
51 gfc_open_file (const char *name)
53 if (!*name)
54 return stdin;
56 return fopen (name, "r");
60 /* Return a string for each type. */
62 const char *
63 gfc_basic_typename (bt type)
65 const char *p;
67 switch (type)
69 case BT_INTEGER:
70 p = "INTEGER";
71 break;
72 case BT_REAL:
73 p = "REAL";
74 break;
75 case BT_COMPLEX:
76 p = "COMPLEX";
77 break;
78 case BT_LOGICAL:
79 p = "LOGICAL";
80 break;
81 case BT_CHARACTER:
82 p = "CHARACTER";
83 break;
84 case BT_HOLLERITH:
85 p = "HOLLERITH";
86 break;
87 case BT_UNION:
88 p = "UNION";
89 break;
90 case BT_DERIVED:
91 p = "DERIVED";
92 break;
93 case BT_CLASS:
94 p = "CLASS";
95 break;
96 case BT_PROCEDURE:
97 p = "PROCEDURE";
98 break;
99 case BT_VOID:
100 p = "VOID";
101 break;
102 case BT_UNKNOWN:
103 p = "UNKNOWN";
104 break;
105 case BT_ASSUMED:
106 p = "TYPE(*)";
107 break;
108 default:
109 gfc_internal_error ("gfc_basic_typename(): Undefined type");
112 return p;
116 /* Return a string describing the type and kind of a typespec. Because
117 we return alternating buffers, this subroutine can appear twice in
118 the argument list of a single statement. */
120 const char *
121 gfc_typename (gfc_typespec *ts)
123 static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */
124 static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
125 static int flag = 0;
126 char *buffer;
128 buffer = flag ? buffer1 : buffer2;
129 flag = !flag;
131 switch (ts->type)
133 case BT_INTEGER:
134 sprintf (buffer, "INTEGER(%d)", ts->kind);
135 break;
136 case BT_REAL:
137 sprintf (buffer, "REAL(%d)", ts->kind);
138 break;
139 case BT_COMPLEX:
140 sprintf (buffer, "COMPLEX(%d)", ts->kind);
141 break;
142 case BT_LOGICAL:
143 sprintf (buffer, "LOGICAL(%d)", ts->kind);
144 break;
145 case BT_CHARACTER:
146 sprintf (buffer, "CHARACTER(%d)", ts->kind);
147 break;
148 case BT_HOLLERITH:
149 sprintf (buffer, "HOLLERITH");
150 break;
151 case BT_UNION:
152 sprintf (buffer, "UNION(%s)", ts->u.derived->name);
153 break;
154 case BT_DERIVED:
155 sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
156 break;
157 case BT_CLASS:
158 ts = &ts->u.derived->components->ts;
159 if (ts->u.derived->attr.unlimited_polymorphic)
160 sprintf (buffer, "CLASS(*)");
161 else
162 sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
163 break;
164 case BT_ASSUMED:
165 sprintf (buffer, "TYPE(*)");
166 break;
167 case BT_PROCEDURE:
168 strcpy (buffer, "PROCEDURE");
169 break;
170 case BT_UNKNOWN:
171 strcpy (buffer, "UNKNOWN");
172 break;
173 default:
174 gfc_internal_error ("gfc_typename(): Undefined type");
177 return buffer;
181 /* Given an mstring array and a code, locate the code in the table,
182 returning a pointer to the string. */
184 const char *
185 gfc_code2string (const mstring *m, int code)
187 while (m->string != NULL)
189 if (m->tag == code)
190 return m->string;
191 m++;
194 gfc_internal_error ("gfc_code2string(): Bad code");
195 /* Not reached */
199 /* Given an mstring array and a string, returns the value of the tag
200 field. Returns the final tag if no matches to the string are found. */
203 gfc_string2code (const mstring *m, const char *string)
205 for (; m->string != NULL; m++)
206 if (strcmp (m->string, string) == 0)
207 return m->tag;
209 return m->tag;
213 /* Convert an intent code to a string. */
214 /* TODO: move to gfortran.h as define. */
216 const char *
217 gfc_intent_string (sym_intent i)
219 return gfc_code2string (intents, i);
223 /***************** Initialization functions ****************/
225 /* Top level initialization. */
227 void
228 gfc_init_1 (void)
230 gfc_error_init_1 ();
231 gfc_scanner_init_1 ();
232 gfc_arith_init_1 ();
233 gfc_intrinsic_init_1 ();
237 /* Per program unit initialization. */
239 void
240 gfc_init_2 (void)
242 gfc_symbol_init_2 ();
243 gfc_module_init_2 ();
247 /******************* Destructor functions ******************/
249 /* Call all of the top level destructors. */
251 void
252 gfc_done_1 (void)
254 gfc_scanner_done_1 ();
255 gfc_intrinsic_done_1 ();
256 gfc_arith_done_1 ();
260 /* Per program unit destructors. */
262 void
263 gfc_done_2 (void)
265 gfc_symbol_done_2 ();
266 gfc_module_done_2 ();
270 /* Returns the index into the table of C interoperable kinds where the
271 kind with the given name (c_kind_name) was found. */
274 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
276 int index = 0;
278 for (index = 0; index < ISOCBINDING_LAST; index++)
279 if (strcmp (kinds_table[index].name, c_kind_name) == 0)
280 return index;
282 return ISOCBINDING_INVALID;
286 /* For a given name TYPO, determine the best candidate from CANDIDATES
287 perusing Levenshtein distance. Frees CANDIDATES before returning. */
289 const char *
290 gfc_closest_fuzzy_match (const char *typo, char **candidates)
292 /* Determine closest match. */
293 const char *best = NULL;
294 char **cand = candidates;
295 edit_distance_t best_distance = MAX_EDIT_DISTANCE;
296 const size_t tl = strlen (typo);
298 while (cand && *cand)
300 edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
301 strlen (*cand));
302 if (dist < best_distance)
304 best_distance = dist;
305 best = *cand;
307 cand++;
309 /* If more than half of the letters were misspelled, the suggestion is
310 likely to be meaningless. */
311 if (best)
313 unsigned int cutoff = MAX (tl, strlen (best)) / 2;
315 if (best_distance > cutoff)
317 XDELETEVEC (candidates);
318 return NULL;
320 XDELETEVEC (candidates);
322 return best;