OSDN Git Service

2010-11-02 Steven G. Kargl < kargl@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / misc.c
1 /* Miscellaneous stuff that doesn't fit anywhere else.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
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 3, or (at your option) any later
11 version.
12
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.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22 #include "config.h"
23 #include "system.h"
24 #include "gfortran.h"
25
26 /* Get a block of memory.  Many callers assume that the memory we
27    return is zeroed.  */
28
29 void *
30 gfc_getmem (size_t n)
31 {
32   void *p;
33
34   if (n == 0)
35     return NULL;
36
37   p = xmalloc (n);
38   if (p == NULL)
39     gfc_fatal_error ("Out of memory-- malloc() failed");
40   memset (p, 0, n);
41   return p;
42 }
43
44
45 void
46 gfc_free (void *p)
47 {
48   /* The parentheses around free are needed in order to call not
49      the redefined free of gfortran.h.  */
50   if (p != NULL)
51     (free) (p);
52 }
53
54
55 /* Get terminal width.  */
56
57 int
58 gfc_terminal_width (void)
59 {
60   return 80;
61 }
62
63
64 /* Initialize a typespec to unknown.  */
65
66 void
67 gfc_clear_ts (gfc_typespec *ts)
68 {
69   ts->type = BT_UNKNOWN;
70   ts->u.derived = NULL;
71   ts->kind = 0;
72   ts->u.cl = NULL;
73   ts->interface = NULL;
74   /* flag that says if the type is C interoperable */
75   ts->is_c_interop = 0;
76   /* says what f90 type the C kind interops with */
77   ts->f90_type = BT_UNKNOWN;
78   /* flag that says whether it's from iso_c_binding or not */
79   ts->is_iso_c = 0;
80   ts->deferred = false;
81 }
82
83
84 /* Open a file for reading.  */
85
86 FILE *
87 gfc_open_file (const char *name)
88 {
89   struct stat statbuf;
90
91   if (!*name)
92     return stdin;
93
94   if (stat (name, &statbuf) < 0)
95     return NULL;
96
97   if (!S_ISREG (statbuf.st_mode))
98     return NULL;
99
100   return fopen (name, "r");
101 }
102
103
104 /* Return a string for each type.  */
105
106 const char *
107 gfc_basic_typename (bt type)
108 {
109   const char *p;
110
111   switch (type)
112     {
113     case BT_INTEGER:
114       p = "INTEGER";
115       break;
116     case BT_REAL:
117       p = "REAL";
118       break;
119     case BT_COMPLEX:
120       p = "COMPLEX";
121       break;
122     case BT_LOGICAL:
123       p = "LOGICAL";
124       break;
125     case BT_CHARACTER:
126       p = "CHARACTER";
127       break;
128     case BT_HOLLERITH:
129       p = "HOLLERITH";
130       break;
131     case BT_DERIVED:
132       p = "DERIVED";
133       break;
134     case BT_CLASS:
135       p = "CLASS";
136       break;
137     case BT_PROCEDURE:
138       p = "PROCEDURE";
139       break;
140     case BT_VOID:
141       p = "VOID";
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
154 /* Return a string describing the type and kind of a typespec.  Because
155    we return alternating buffers, this subroutine can appear twice in
156    the argument list of a single statement.  */
157
158 const char *
159 gfc_typename (gfc_typespec *ts)
160 {
161   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
162   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
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;
186     case BT_HOLLERITH:
187       sprintf (buffer, "HOLLERITH");
188       break;
189     case BT_DERIVED:
190       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
191       break;
192     case BT_CLASS:
193       sprintf (buffer, "CLASS(%s)",
194                ts->u.derived->components->ts.u.derived->name);
195       break;
196     case BT_PROCEDURE:
197       strcpy (buffer, "PROCEDURE");
198       break;
199     case BT_UNKNOWN:
200       strcpy (buffer, "UNKNOWN");
201       break;
202     default:
203       gfc_internal_error ("gfc_typename(): Undefined type");
204     }
205
206   return buffer;
207 }
208
209
210 /* Given an mstring array and a code, locate the code in the table,
211    returning a pointer to the string.  */
212
213 const char *
214 gfc_code2string (const mstring *m, int code)
215 {
216   while (m->string != NULL)
217     {
218       if (m->tag == code)
219         return m->string;
220       m++;
221     }
222
223   gfc_internal_error ("gfc_code2string(): Bad code");
224   /* Not reached */
225 }
226
227
228 /* Given an mstring array and a string, returns the value of the tag
229    field.  Returns the final tag if no matches to the string are found.  */
230
231 int
232 gfc_string2code (const mstring *m, const char *string)
233 {
234   for (; m->string != NULL; m++)
235     if (strcmp (m->string, string) == 0)
236       return m->tag;
237
238   return m->tag;
239 }
240
241
242 /* Convert an intent code to a string.  */
243 /* TODO: move to gfortran.h as define.  */
244
245 const char *
246 gfc_intent_string (sym_intent i)
247 {
248   return gfc_code2string (intents, i);
249 }
250
251
252 /***************** Initialization functions ****************/
253
254 /* Top level initialization.  */
255
256 void
257 gfc_init_1 (void)
258 {
259   gfc_error_init_1 ();
260   gfc_scanner_init_1 ();
261   gfc_arith_init_1 ();
262   gfc_intrinsic_init_1 ();
263 }
264
265
266 /* Per program unit initialization.  */
267
268 void
269 gfc_init_2 (void)
270 {
271   gfc_symbol_init_2 ();
272   gfc_module_init_2 ();
273 }
274
275
276 /******************* Destructor functions ******************/
277
278 /* Call all of the top level destructors.  */
279
280 void
281 gfc_done_1 (void)
282 {
283   gfc_scanner_done_1 ();
284   gfc_intrinsic_done_1 ();
285   gfc_arith_done_1 ();
286 }
287
288
289 /* Per program unit destructors.  */
290
291 void
292 gfc_done_2 (void)
293 {
294   gfc_symbol_done_2 ();
295   gfc_module_done_2 ();
296 }
297
298
299 /* Returns the index into the table of C interoperable kinds where the
300    kind with the given name (c_kind_name) was found.  */
301
302 int
303 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
304 {
305   int index = 0;
306
307   for (index = 0; index < ISOCBINDING_LAST; index++)
308     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
309       return index;
310
311   return ISOCBINDING_INVALID;
312 }