]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Miscellaneous stuff that doesn't fit anywhere else. |
ec378180 KH |
2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 |
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 DN |
22 | |
23 | ||
24 | #include "config.h" | |
d22e4895 | 25 | #include "system.h" |
6de9cd9a DN |
26 | #include "gfortran.h" |
27 | ||
28 | ||
29 | /* Get a block of memory. Many callers assume that the memory we | |
30 | return is zeroed. */ | |
31 | ||
32 | void * | |
33 | gfc_getmem (size_t n) | |
34 | { | |
35 | void *p; | |
36 | ||
37 | if (n == 0) | |
38 | return NULL; | |
39 | ||
40 | p = xmalloc (n); | |
41 | if (p == NULL) | |
42 | gfc_fatal_error ("Out of memory-- malloc() failed"); | |
43 | memset (p, 0, n); | |
44 | return p; | |
45 | } | |
46 | ||
47 | ||
48 | /* gfortran.h defines free to something that triggers a syntax error, | |
49 | but we need free() here. */ | |
50 | ||
51 | #define temp free | |
52 | #undef free | |
53 | ||
54 | void | |
55 | gfc_free (void *p) | |
56 | { | |
57 | ||
58 | if (p != NULL) | |
59 | free (p); | |
60 | } | |
61 | ||
62 | #define free temp | |
63 | #undef temp | |
64 | ||
65 | ||
66 | /* Get terminal width */ | |
67 | ||
68 | int | |
69 | gfc_terminal_width(void) | |
70 | { | |
71 | return 80; | |
72 | } | |
73 | ||
74 | ||
75 | /* Initialize a typespec to unknown. */ | |
76 | ||
77 | void | |
78 | gfc_clear_ts (gfc_typespec * ts) | |
79 | { | |
80 | ||
81 | ts->type = BT_UNKNOWN; | |
82 | ts->kind = 0; | |
83 | ts->derived = NULL; | |
84 | ts->cl = NULL; | |
85 | } | |
86 | ||
87 | ||
88 | /* Open a file for reading. */ | |
89 | ||
90 | FILE * | |
91 | gfc_open_file (const char *name) | |
92 | { | |
93 | struct stat statbuf; | |
94 | ||
95 | if (!*name) | |
96 | return stdin; | |
97 | ||
98 | if (stat (name, &statbuf) < 0) | |
99 | return NULL; | |
100 | ||
101 | if (!S_ISREG (statbuf.st_mode)) | |
102 | return NULL; | |
103 | ||
104 | return fopen (name, "r"); | |
105 | } | |
106 | ||
107 | ||
108 | /* Given a word, return the correct article. */ | |
109 | ||
110 | const char * | |
111 | gfc_article (const char *word) | |
112 | { | |
113 | const char *p; | |
114 | ||
115 | switch (*word) | |
116 | { | |
117 | case 'a': | |
118 | case 'A': | |
119 | case 'e': | |
120 | case 'E': | |
121 | case 'i': | |
122 | case 'I': | |
123 | case 'o': | |
124 | case 'O': | |
125 | case 'u': | |
126 | case 'U': | |
127 | p = "an"; | |
128 | break; | |
129 | ||
130 | default: | |
131 | p = "a"; | |
132 | } | |
133 | ||
134 | return p; | |
135 | } | |
136 | ||
137 | ||
138 | /* Return a string for each type. */ | |
139 | ||
140 | const char * | |
141 | gfc_basic_typename (bt type) | |
142 | { | |
143 | const char *p; | |
144 | ||
145 | switch (type) | |
146 | { | |
147 | case BT_INTEGER: | |
148 | p = "INTEGER"; | |
149 | break; | |
150 | case BT_REAL: | |
151 | p = "REAL"; | |
152 | break; | |
153 | case BT_COMPLEX: | |
154 | p = "COMPLEX"; | |
155 | break; | |
156 | case BT_LOGICAL: | |
157 | p = "LOGICAL"; | |
158 | break; | |
159 | case BT_CHARACTER: | |
160 | p = "CHARACTER"; | |
161 | break; | |
162 | case BT_DERIVED: | |
163 | p = "DERIVED"; | |
164 | break; | |
165 | case BT_PROCEDURE: | |
166 | p = "PROCEDURE"; | |
167 | break; | |
168 | case BT_UNKNOWN: | |
169 | p = "UNKNOWN"; | |
170 | break; | |
171 | default: | |
172 | gfc_internal_error ("gfc_basic_typename(): Undefined type"); | |
173 | } | |
174 | ||
175 | return p; | |
176 | } | |
177 | ||
178 | ||
1f2959f0 | 179 | /* Return a string describing the type and kind of a typespec. Because |
6de9cd9a DN |
180 | we return alternating buffers, this subroutine can appear twice in |
181 | the argument list of a single statement. */ | |
182 | ||
183 | const char * | |
184 | gfc_typename (gfc_typespec * ts) | |
185 | { | |
186 | static char buffer1[60], buffer2[60]; | |
187 | static int flag = 0; | |
188 | char *buffer; | |
189 | ||
190 | buffer = flag ? buffer1 : buffer2; | |
191 | flag = !flag; | |
192 | ||
193 | switch (ts->type) | |
194 | { | |
195 | case BT_INTEGER: | |
196 | sprintf (buffer, "INTEGER(%d)", ts->kind); | |
197 | break; | |
198 | case BT_REAL: | |
199 | sprintf (buffer, "REAL(%d)", ts->kind); | |
200 | break; | |
201 | case BT_COMPLEX: | |
202 | sprintf (buffer, "COMPLEX(%d)", ts->kind); | |
203 | break; | |
204 | case BT_LOGICAL: | |
205 | sprintf (buffer, "LOGICAL(%d)", ts->kind); | |
206 | break; | |
207 | case BT_CHARACTER: | |
208 | sprintf (buffer, "CHARACTER(%d)", ts->kind); | |
209 | break; | |
210 | case BT_DERIVED: | |
211 | sprintf (buffer, "TYPE(%s)", ts->derived->name); | |
212 | break; | |
213 | case BT_PROCEDURE: | |
214 | strcpy (buffer, "PROCEDURE"); | |
215 | break; | |
216 | case BT_UNKNOWN: | |
217 | strcpy (buffer, "UNKNOWN"); | |
218 | break; | |
219 | default: | |
220 | gfc_internal_error ("gfc_typespec(): Undefined type"); | |
221 | } | |
222 | ||
223 | return buffer; | |
224 | } | |
225 | ||
226 | ||
227 | /* Given an mstring array and a code, locate the code in the table, | |
228 | returning a pointer to the string. */ | |
229 | ||
230 | const char * | |
231 | gfc_code2string (const mstring * m, int code) | |
232 | { | |
233 | ||
234 | while (m->string != NULL) | |
235 | { | |
236 | if (m->tag == code) | |
237 | return m->string; | |
238 | m++; | |
239 | } | |
240 | ||
241 | gfc_internal_error ("gfc_code2string(): Bad code"); | |
242 | /* Not reached */ | |
243 | } | |
244 | ||
245 | ||
246 | /* Given an mstring array and a string, returns the value of the tag | |
247 | field. Returns the final tag if no matches to the string are | |
248 | found. */ | |
249 | ||
250 | int | |
251 | gfc_string2code (const mstring * m, const char *string) | |
252 | { | |
253 | ||
254 | for (; m->string != NULL; m++) | |
255 | if (strcmp (m->string, string) == 0) | |
256 | return m->tag; | |
257 | ||
258 | return m->tag; | |
259 | } | |
260 | ||
261 | ||
262 | /* Convert an intent code to a string. */ | |
263 | /* TODO: move to gfortran.h as define. */ | |
264 | const char * | |
265 | gfc_intent_string (sym_intent i) | |
266 | { | |
267 | ||
268 | return gfc_code2string (intents, i); | |
269 | } | |
270 | ||
271 | ||
272 | /***************** Initialization functions ****************/ | |
273 | ||
274 | /* Top level initialization. */ | |
275 | ||
276 | void | |
277 | gfc_init_1 (void) | |
278 | { | |
6de9cd9a DN |
279 | gfc_error_init_1 (); |
280 | gfc_scanner_init_1 (); | |
281 | gfc_arith_init_1 (); | |
282 | gfc_intrinsic_init_1 (); | |
6de9cd9a DN |
283 | gfc_simplify_init_1 (); |
284 | } | |
285 | ||
286 | ||
287 | /* Per program unit initialization. */ | |
288 | ||
289 | void | |
290 | gfc_init_2 (void) | |
291 | { | |
292 | ||
293 | gfc_symbol_init_2 (); | |
294 | gfc_module_init_2 (); | |
295 | } | |
296 | ||
297 | ||
298 | /******************* Destructor functions ******************/ | |
299 | ||
300 | /* Call all of the top level destructors. */ | |
301 | ||
302 | void | |
303 | gfc_done_1 (void) | |
304 | { | |
6de9cd9a DN |
305 | gfc_scanner_done_1 (); |
306 | gfc_intrinsic_done_1 (); | |
6de9cd9a DN |
307 | gfc_arith_done_1 (); |
308 | } | |
309 | ||
310 | ||
311 | /* Per program unit destructors. */ | |
312 | ||
313 | void | |
314 | gfc_done_2 (void) | |
315 | { | |
316 | ||
317 | gfc_symbol_done_2 (); | |
318 | gfc_module_done_2 (); | |
319 | } | |
320 |