]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/misc.c
PR 78534 Change character length from int to size_t
[thirdparty/gcc.git] / gcc / fortran / misc.c
1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2017 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 "tree.h"
26
27
28 /* Initialize a typespec to unknown. */
29
30 void
31 gfc_clear_ts (gfc_typespec *ts)
32 {
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;
45 }
46
47
48 /* Open a file for reading. */
49
50 FILE *
51 gfc_open_file (const char *name)
52 {
53 if (!*name)
54 return stdin;
55
56 return fopen (name, "r");
57 }
58
59
60 /* Return a string for each type. */
61
62 const char *
63 gfc_basic_typename (bt type)
64 {
65 const char *p;
66
67 switch (type)
68 {
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");
110 }
111
112 return p;
113 }
114
115
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. */
119
120 const char *
121 gfc_typename (gfc_typespec *ts)
122 {
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;
127
128 buffer = flag ? buffer1 : buffer2;
129 flag = !flag;
130
131 switch (ts->type)
132 {
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");
175 }
176
177 return buffer;
178 }
179
180
181 /* Given an mstring array and a code, locate the code in the table,
182 returning a pointer to the string. */
183
184 const char *
185 gfc_code2string (const mstring *m, int code)
186 {
187 while (m->string != NULL)
188 {
189 if (m->tag == code)
190 return m->string;
191 m++;
192 }
193
194 gfc_internal_error ("gfc_code2string(): Bad code");
195 /* Not reached */
196 }
197
198
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. */
201
202 int
203 gfc_string2code (const mstring *m, const char *string)
204 {
205 for (; m->string != NULL; m++)
206 if (strcmp (m->string, string) == 0)
207 return m->tag;
208
209 return m->tag;
210 }
211
212
213 /* Convert an intent code to a string. */
214 /* TODO: move to gfortran.h as define. */
215
216 const char *
217 gfc_intent_string (sym_intent i)
218 {
219 return gfc_code2string (intents, i);
220 }
221
222
223 /***************** Initialization functions ****************/
224
225 /* Top level initialization. */
226
227 void
228 gfc_init_1 (void)
229 {
230 gfc_error_init_1 ();
231 gfc_scanner_init_1 ();
232 gfc_arith_init_1 ();
233 gfc_intrinsic_init_1 ();
234 }
235
236
237 /* Per program unit initialization. */
238
239 void
240 gfc_init_2 (void)
241 {
242 gfc_symbol_init_2 ();
243 gfc_module_init_2 ();
244 }
245
246
247 /******************* Destructor functions ******************/
248
249 /* Call all of the top level destructors. */
250
251 void
252 gfc_done_1 (void)
253 {
254 gfc_scanner_done_1 ();
255 gfc_intrinsic_done_1 ();
256 gfc_arith_done_1 ();
257 }
258
259
260 /* Per program unit destructors. */
261
262 void
263 gfc_done_2 (void)
264 {
265 gfc_symbol_done_2 ();
266 gfc_module_done_2 ();
267 }
268
269
270 /* Returns the index into the table of C interoperable kinds where the
271 kind with the given name (c_kind_name) was found. */
272
273 int
274 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
275 {
276 int index = 0;
277
278 for (index = 0; index < ISOCBINDING_LAST; index++)
279 if (strcmp (kinds_table[index].name, c_kind_name) == 0)
280 return index;
281
282 return ISOCBINDING_INVALID;
283 }
284
285
286 /* Convert between GMP integers (mpz_t) and HOST_WIDE_INT. */
287
288 HOST_WIDE_INT
289 gfc_mpz_get_hwi (mpz_t op)
290 {
291 /* Using long_long_integer_type_node as that is the integer type
292 node that closest matches HOST_WIDE_INT; both are guaranteed to
293 be at least 64 bits. */
294 const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
295 return w.to_shwi ();
296 }
297
298
299 void
300 gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
301 {
302 const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
303 wi::to_mpz (w, rop, SIGNED);
304 }