1 /* Miscellaneous stuff that doesn't fit anywhere else.
2 Copyright (C) 2000-2016 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
26
27 /* Initialize a typespec to unknown. */
28
29 void
gfc_clear_ts(gfc_typespec * ts)30 gfc_clear_ts (gfc_typespec *ts)
31 {
32 ts->type = BT_UNKNOWN;
33 ts->u.derived = NULL;
34 ts->kind = 0;
35 ts->u.cl = NULL;
36 ts->interface = NULL;
37 /* flag that says if the type is C interoperable */
38 ts->is_c_interop = 0;
39 /* says what f90 type the C kind interops with */
40 ts->f90_type = BT_UNKNOWN;
41 /* flag that says whether it's from iso_c_binding or not */
42 ts->is_iso_c = 0;
43 ts->deferred = false;
44 }
45
46
47 /* Open a file for reading. */
48
49 FILE *
gfc_open_file(const char * name)50 gfc_open_file (const char *name)
51 {
52 if (!*name)
53 return stdin;
54
55 return fopen (name, "r");
56 }
57
58
59 /* Return a string for each type. */
60
61 const char *
gfc_basic_typename(bt type)62 gfc_basic_typename (bt type)
63 {
64 const char *p;
65
66 switch (type)
67 {
68 case BT_INTEGER:
69 p = "INTEGER";
70 break;
71 case BT_REAL:
72 p = "REAL";
73 break;
74 case BT_COMPLEX:
75 p = "COMPLEX";
76 break;
77 case BT_LOGICAL:
78 p = "LOGICAL";
79 break;
80 case BT_CHARACTER:
81 p = "CHARACTER";
82 break;
83 case BT_HOLLERITH:
84 p = "HOLLERITH";
85 break;
86 case BT_UNION:
87 p = "UNION";
88 break;
89 case BT_DERIVED:
90 p = "DERIVED";
91 break;
92 case BT_CLASS:
93 p = "CLASS";
94 break;
95 case BT_PROCEDURE:
96 p = "PROCEDURE";
97 break;
98 case BT_VOID:
99 p = "VOID";
100 break;
101 case BT_UNKNOWN:
102 p = "UNKNOWN";
103 break;
104 case BT_ASSUMED:
105 p = "TYPE(*)";
106 break;
107 default:
108 gfc_internal_error ("gfc_basic_typename(): Undefined type");
109 }
110
111 return p;
112 }
113
114
115 /* Return a string describing the type and kind of a typespec. Because
116 we return alternating buffers, this subroutine can appear twice in
117 the argument list of a single statement. */
118
119 const char *
gfc_typename(gfc_typespec * ts)120 gfc_typename (gfc_typespec *ts)
121 {
122 static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */
123 static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
124 static int flag = 0;
125 char *buffer;
126
127 buffer = flag ? buffer1 : buffer2;
128 flag = !flag;
129
130 switch (ts->type)
131 {
132 case BT_INTEGER:
133 sprintf (buffer, "INTEGER(%d)", ts->kind);
134 break;
135 case BT_REAL:
136 sprintf (buffer, "REAL(%d)", ts->kind);
137 break;
138 case BT_COMPLEX:
139 sprintf (buffer, "COMPLEX(%d)", ts->kind);
140 break;
141 case BT_LOGICAL:
142 sprintf (buffer, "LOGICAL(%d)", ts->kind);
143 break;
144 case BT_CHARACTER:
145 sprintf (buffer, "CHARACTER(%d)", ts->kind);
146 break;
147 case BT_HOLLERITH:
148 sprintf (buffer, "HOLLERITH");
149 break;
150 case BT_UNION:
151 sprintf (buffer, "UNION(%s)", ts->u.derived->name);
152 break;
153 case BT_DERIVED:
154 sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
155 break;
156 case BT_CLASS:
157 ts = &ts->u.derived->components->ts;
158 if (ts->u.derived->attr.unlimited_polymorphic)
159 sprintf (buffer, "CLASS(*)");
160 else
161 sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
162 break;
163 case BT_ASSUMED:
164 sprintf (buffer, "TYPE(*)");
165 break;
166 case BT_PROCEDURE:
167 strcpy (buffer, "PROCEDURE");
168 break;
169 case BT_UNKNOWN:
170 strcpy (buffer, "UNKNOWN");
171 break;
172 default:
173 gfc_internal_error ("gfc_typename(): Undefined type");
174 }
175
176 return buffer;
177 }
178
179
180 /* Given an mstring array and a code, locate the code in the table,
181 returning a pointer to the string. */
182
183 const char *
gfc_code2string(const mstring * m,int code)184 gfc_code2string (const mstring *m, int code)
185 {
186 while (m->string != NULL)
187 {
188 if (m->tag == code)
189 return m->string;
190 m++;
191 }
192
193 gfc_internal_error ("gfc_code2string(): Bad code");
194 /* Not reached */
195 }
196
197
198 /* Given an mstring array and a string, returns the value of the tag
199 field. Returns the final tag if no matches to the string are found. */
200
201 int
gfc_string2code(const mstring * m,const char * string)202 gfc_string2code (const mstring *m, const char *string)
203 {
204 for (; m->string != NULL; m++)
205 if (strcmp (m->string, string) == 0)
206 return m->tag;
207
208 return m->tag;
209 }
210
211
212 /* Convert an intent code to a string. */
213 /* TODO: move to gfortran.h as define. */
214
215 const char *
gfc_intent_string(sym_intent i)216 gfc_intent_string (sym_intent i)
217 {
218 return gfc_code2string (intents, i);
219 }
220
221
222 /***************** Initialization functions ****************/
223
224 /* Top level initialization. */
225
226 void
gfc_init_1(void)227 gfc_init_1 (void)
228 {
229 gfc_error_init_1 ();
230 gfc_scanner_init_1 ();
231 gfc_arith_init_1 ();
232 gfc_intrinsic_init_1 ();
233 }
234
235
236 /* Per program unit initialization. */
237
238 void
gfc_init_2(void)239 gfc_init_2 (void)
240 {
241 gfc_symbol_init_2 ();
242 gfc_module_init_2 ();
243 }
244
245
246 /******************* Destructor functions ******************/
247
248 /* Call all of the top level destructors. */
249
250 void
gfc_done_1(void)251 gfc_done_1 (void)
252 {
253 gfc_scanner_done_1 ();
254 gfc_intrinsic_done_1 ();
255 gfc_arith_done_1 ();
256 }
257
258
259 /* Per program unit destructors. */
260
261 void
gfc_done_2(void)262 gfc_done_2 (void)
263 {
264 gfc_symbol_done_2 ();
265 gfc_module_done_2 ();
266 }
267
268
269 /* Returns the index into the table of C interoperable kinds where the
270 kind with the given name (c_kind_name) was found. */
271
272 int
get_c_kind(const char * c_kind_name,CInteropKind_t kinds_table[])273 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
274 {
275 int index = 0;
276
277 for (index = 0; index < ISOCBINDING_LAST; index++)
278 if (strcmp (kinds_table[index].name, c_kind_name) == 0)
279 return index;
280
281 return ISOCBINDING_INVALID;
282 }
283