]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Miscellaneous stuff that doesn't fit anywhere else. |
edf1eac2 SK |
2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 |
3 | Free Software Foundation, Inc. | |
6de9cd9a DN |
4 | Contributed by Andy Vaught |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
10 | Software Foundation; either version 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 19 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
20 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
21 | 02110-1301, USA. */ | |
6de9cd9a | 22 | |
6de9cd9a | 23 | #include "config.h" |
d22e4895 | 24 | #include "system.h" |
6de9cd9a DN |
25 | #include "gfortran.h" |
26 | ||
6de9cd9a DN |
27 | /* Get a block of memory. Many callers assume that the memory we |
28 | return is zeroed. */ | |
29 | ||
30 | void * | |
31 | gfc_getmem (size_t n) | |
32 | { | |
33 | void *p; | |
34 | ||
35 | if (n == 0) | |
36 | return NULL; | |
37 | ||
38 | p = xmalloc (n); | |
39 | if (p == NULL) | |
40 | gfc_fatal_error ("Out of memory-- malloc() failed"); | |
41 | memset (p, 0, n); | |
42 | return p; | |
43 | } | |
44 | ||
45 | ||
46 | /* gfortran.h defines free to something that triggers a syntax error, | |
47 | but we need free() here. */ | |
48 | ||
49 | #define temp free | |
50 | #undef free | |
51 | ||
52 | void | |
53 | gfc_free (void *p) | |
54 | { | |
6de9cd9a DN |
55 | if (p != NULL) |
56 | free (p); | |
57 | } | |
58 | ||
59 | #define free temp | |
60 | #undef temp | |
61 | ||
62 | ||
edf1eac2 | 63 | /* Get terminal width. */ |
6de9cd9a DN |
64 | |
65 | int | |
edf1eac2 | 66 | gfc_terminal_width (void) |
6de9cd9a DN |
67 | { |
68 | return 80; | |
69 | } | |
70 | ||
71 | ||
72 | /* Initialize a typespec to unknown. */ | |
73 | ||
74 | void | |
edf1eac2 | 75 | gfc_clear_ts (gfc_typespec *ts) |
6de9cd9a | 76 | { |
6de9cd9a DN |
77 | ts->type = BT_UNKNOWN; |
78 | ts->kind = 0; | |
79 | ts->derived = NULL; | |
80 | ts->cl = NULL; | |
a8b3b0b6 CR |
81 | /* flag that says if the type is C interoperable */ |
82 | ts->is_c_interop = 0; | |
83 | /* says what f90 type the C kind interops with */ | |
84 | ts->f90_type = BT_UNKNOWN; | |
85 | /* flag that says whether it's from iso_c_binding or not */ | |
86 | ts->is_iso_c = 0; | |
6de9cd9a DN |
87 | } |
88 | ||
89 | ||
90 | /* Open a file for reading. */ | |
91 | ||
92 | FILE * | |
93 | gfc_open_file (const char *name) | |
94 | { | |
95 | struct stat statbuf; | |
96 | ||
97 | if (!*name) | |
98 | return stdin; | |
99 | ||
100 | if (stat (name, &statbuf) < 0) | |
101 | return NULL; | |
102 | ||
103 | if (!S_ISREG (statbuf.st_mode)) | |
104 | return NULL; | |
105 | ||
106 | return fopen (name, "r"); | |
107 | } | |
108 | ||
109 | ||
6de9cd9a DN |
110 | /* Return a string for each type. */ |
111 | ||
112 | const char * | |
113 | gfc_basic_typename (bt type) | |
114 | { | |
115 | const char *p; | |
116 | ||
117 | switch (type) | |
118 | { | |
119 | case BT_INTEGER: | |
120 | p = "INTEGER"; | |
121 | break; | |
122 | case BT_REAL: | |
123 | p = "REAL"; | |
124 | break; | |
125 | case BT_COMPLEX: | |
126 | p = "COMPLEX"; | |
127 | break; | |
128 | case BT_LOGICAL: | |
129 | p = "LOGICAL"; | |
130 | break; | |
131 | case BT_CHARACTER: | |
132 | p = "CHARACTER"; | |
133 | break; | |
d3642f89 FW |
134 | case BT_HOLLERITH: |
135 | p = "HOLLERITH"; | |
136 | break; | |
6de9cd9a DN |
137 | case BT_DERIVED: |
138 | p = "DERIVED"; | |
139 | break; | |
140 | case BT_PROCEDURE: | |
141 | p = "PROCEDURE"; | |
142 | break; | |
143 | case BT_UNKNOWN: | |
144 | p = "UNKNOWN"; | |
145 | break; | |
146 | default: | |
147 | gfc_internal_error ("gfc_basic_typename(): Undefined type"); | |
148 | } | |
149 | ||
150 | return p; | |
151 | } | |
152 | ||
153 | ||
1f2959f0 | 154 | /* Return a string describing the type and kind of a typespec. Because |
6de9cd9a DN |
155 | we return alternating buffers, this subroutine can appear twice in |
156 | the argument list of a single statement. */ | |
157 | ||
158 | const char * | |
edf1eac2 | 159 | gfc_typename (gfc_typespec *ts) |
6de9cd9a | 160 | { |
64e56cf2 SK |
161 | static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */ |
162 | static char buffer2[GFC_MAX_SYMBOL_LEN + 7]; | |
6de9cd9a DN |
163 | static int flag = 0; |
164 | char *buffer; | |
165 | ||
166 | buffer = flag ? buffer1 : buffer2; | |
167 | flag = !flag; | |
168 | ||
169 | switch (ts->type) | |
170 | { | |
171 | case BT_INTEGER: | |
172 | sprintf (buffer, "INTEGER(%d)", ts->kind); | |
173 | break; | |
174 | case BT_REAL: | |
175 | sprintf (buffer, "REAL(%d)", ts->kind); | |
176 | break; | |
177 | case BT_COMPLEX: | |
178 | sprintf (buffer, "COMPLEX(%d)", ts->kind); | |
179 | break; | |
180 | case BT_LOGICAL: | |
181 | sprintf (buffer, "LOGICAL(%d)", ts->kind); | |
182 | break; | |
183 | case BT_CHARACTER: | |
184 | sprintf (buffer, "CHARACTER(%d)", ts->kind); | |
185 | break; | |
d3642f89 FW |
186 | case BT_HOLLERITH: |
187 | sprintf (buffer, "HOLLERITH"); | |
188 | break; | |
6de9cd9a DN |
189 | case BT_DERIVED: |
190 | sprintf (buffer, "TYPE(%s)", ts->derived->name); | |
191 | break; | |
192 | case BT_PROCEDURE: | |
193 | strcpy (buffer, "PROCEDURE"); | |
194 | break; | |
195 | case BT_UNKNOWN: | |
196 | strcpy (buffer, "UNKNOWN"); | |
197 | break; | |
198 | default: | |
a9f6f1f2 | 199 | gfc_internal_error ("gfc_typename(): Undefined type"); |
6de9cd9a DN |
200 | } |
201 | ||
202 | return buffer; | |
203 | } | |
204 | ||
205 | ||
206 | /* Given an mstring array and a code, locate the code in the table, | |
207 | returning a pointer to the string. */ | |
208 | ||
209 | const char * | |
edf1eac2 | 210 | gfc_code2string (const mstring *m, int code) |
6de9cd9a | 211 | { |
6de9cd9a DN |
212 | while (m->string != NULL) |
213 | { | |
214 | if (m->tag == code) | |
215 | return m->string; | |
216 | m++; | |
217 | } | |
218 | ||
219 | gfc_internal_error ("gfc_code2string(): Bad code"); | |
220 | /* Not reached */ | |
221 | } | |
222 | ||
223 | ||
224 | /* Given an mstring array and a string, returns the value of the tag | |
edf1eac2 | 225 | field. Returns the final tag if no matches to the string are found. */ |
6de9cd9a DN |
226 | |
227 | int | |
edf1eac2 | 228 | gfc_string2code (const mstring *m, const char *string) |
6de9cd9a | 229 | { |
6de9cd9a DN |
230 | for (; m->string != NULL; m++) |
231 | if (strcmp (m->string, string) == 0) | |
232 | return m->tag; | |
233 | ||
234 | return m->tag; | |
235 | } | |
236 | ||
237 | ||
238 | /* Convert an intent code to a string. */ | |
239 | /* TODO: move to gfortran.h as define. */ | |
edf1eac2 | 240 | |
6de9cd9a DN |
241 | const char * |
242 | gfc_intent_string (sym_intent i) | |
243 | { | |
6de9cd9a DN |
244 | return gfc_code2string (intents, i); |
245 | } | |
246 | ||
247 | ||
248 | /***************** Initialization functions ****************/ | |
249 | ||
250 | /* Top level initialization. */ | |
251 | ||
252 | void | |
253 | gfc_init_1 (void) | |
254 | { | |
6de9cd9a DN |
255 | gfc_error_init_1 (); |
256 | gfc_scanner_init_1 (); | |
257 | gfc_arith_init_1 (); | |
258 | gfc_intrinsic_init_1 (); | |
6de9cd9a DN |
259 | } |
260 | ||
261 | ||
262 | /* Per program unit initialization. */ | |
263 | ||
264 | void | |
265 | gfc_init_2 (void) | |
266 | { | |
6de9cd9a DN |
267 | gfc_symbol_init_2 (); |
268 | gfc_module_init_2 (); | |
269 | } | |
270 | ||
271 | ||
272 | /******************* Destructor functions ******************/ | |
273 | ||
274 | /* Call all of the top level destructors. */ | |
275 | ||
276 | void | |
277 | gfc_done_1 (void) | |
278 | { | |
6de9cd9a DN |
279 | gfc_scanner_done_1 (); |
280 | gfc_intrinsic_done_1 (); | |
6de9cd9a DN |
281 | gfc_arith_done_1 (); |
282 | } | |
283 | ||
284 | ||
285 | /* Per program unit destructors. */ | |
286 | ||
287 | void | |
288 | gfc_done_2 (void) | |
289 | { | |
6de9cd9a DN |
290 | gfc_symbol_done_2 (); |
291 | gfc_module_done_2 (); | |
292 | } | |
293 | ||
a8b3b0b6 CR |
294 | |
295 | /* Returns the index into the table of C interoperable kinds where the | |
296 | kind with the given name (c_kind_name) was found. */ | |
297 | ||
298 | int | |
299 | get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[]) | |
300 | { | |
301 | int index = 0; | |
302 | ||
303 | for (index = 0; index < ISOCBINDING_LAST; index++) | |
304 | if (strcmp (kinds_table[index].name, c_kind_name) == 0) | |
305 | return index; | |
306 | ||
307 | return ISOCBINDING_INVALID; | |
308 | } |