1/* Miscellaneous stuff that doesn't fit anywhere else.
2   Copyright (C) 2000-2015 Free Software Foundation, Inc.
3   Contributed by Andy Vaught
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along 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
29void
30gfc_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
49FILE *
50gfc_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
61const char *
62gfc_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_DERIVED:
87      p = "DERIVED";
88      break;
89    case BT_CLASS:
90      p = "CLASS";
91      break;
92    case BT_PROCEDURE:
93      p = "PROCEDURE";
94      break;
95    case BT_VOID:
96      p = "VOID";
97      break;
98    case BT_UNKNOWN:
99      p = "UNKNOWN";
100      break;
101    case BT_ASSUMED:
102      p = "TYPE(*)";
103      break;
104    default:
105      gfc_internal_error ("gfc_basic_typename(): Undefined type");
106    }
107
108  return p;
109}
110
111
112/* Return a string describing the type and kind of a typespec.  Because
113   we return alternating buffers, this subroutine can appear twice in
114   the argument list of a single statement.  */
115
116const char *
117gfc_typename (gfc_typespec *ts)
118{
119  static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
120  static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
121  static int flag = 0;
122  char *buffer;
123
124  buffer = flag ? buffer1 : buffer2;
125  flag = !flag;
126
127  switch (ts->type)
128    {
129    case BT_INTEGER:
130      sprintf (buffer, "INTEGER(%d)", ts->kind);
131      break;
132    case BT_REAL:
133      sprintf (buffer, "REAL(%d)", ts->kind);
134      break;
135    case BT_COMPLEX:
136      sprintf (buffer, "COMPLEX(%d)", ts->kind);
137      break;
138    case BT_LOGICAL:
139      sprintf (buffer, "LOGICAL(%d)", ts->kind);
140      break;
141    case BT_CHARACTER:
142      sprintf (buffer, "CHARACTER(%d)", ts->kind);
143      break;
144    case BT_HOLLERITH:
145      sprintf (buffer, "HOLLERITH");
146      break;
147    case BT_DERIVED:
148      sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
149      break;
150    case BT_CLASS:
151      ts = &ts->u.derived->components->ts;
152      if (ts->u.derived->attr.unlimited_polymorphic)
153	sprintf (buffer, "CLASS(*)");
154      else
155	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
156      break;
157    case BT_ASSUMED:
158      sprintf (buffer, "TYPE(*)");
159      break;
160    case BT_PROCEDURE:
161      strcpy (buffer, "PROCEDURE");
162      break;
163    case BT_UNKNOWN:
164      strcpy (buffer, "UNKNOWN");
165      break;
166    default:
167      gfc_internal_error ("gfc_typename(): Undefined type");
168    }
169
170  return buffer;
171}
172
173
174/* Given an mstring array and a code, locate the code in the table,
175   returning a pointer to the string.  */
176
177const char *
178gfc_code2string (const mstring *m, int code)
179{
180  while (m->string != NULL)
181    {
182      if (m->tag == code)
183	return m->string;
184      m++;
185    }
186
187  gfc_internal_error ("gfc_code2string(): Bad code");
188  /* Not reached */
189}
190
191
192/* Given an mstring array and a string, returns the value of the tag
193   field.  Returns the final tag if no matches to the string are found.  */
194
195int
196gfc_string2code (const mstring *m, const char *string)
197{
198  for (; m->string != NULL; m++)
199    if (strcmp (m->string, string) == 0)
200      return m->tag;
201
202  return m->tag;
203}
204
205
206/* Convert an intent code to a string.  */
207/* TODO: move to gfortran.h as define.  */
208
209const char *
210gfc_intent_string (sym_intent i)
211{
212  return gfc_code2string (intents, i);
213}
214
215
216/***************** Initialization functions ****************/
217
218/* Top level initialization.  */
219
220void
221gfc_init_1 (void)
222{
223  gfc_error_init_1 ();
224  gfc_scanner_init_1 ();
225  gfc_arith_init_1 ();
226  gfc_intrinsic_init_1 ();
227}
228
229
230/* Per program unit initialization.  */
231
232void
233gfc_init_2 (void)
234{
235  gfc_symbol_init_2 ();
236  gfc_module_init_2 ();
237}
238
239
240/******************* Destructor functions ******************/
241
242/* Call all of the top level destructors.  */
243
244void
245gfc_done_1 (void)
246{
247  gfc_scanner_done_1 ();
248  gfc_intrinsic_done_1 ();
249  gfc_arith_done_1 ();
250}
251
252
253/* Per program unit destructors.  */
254
255void
256gfc_done_2 (void)
257{
258  gfc_symbol_done_2 ();
259  gfc_module_done_2 ();
260}
261
262
263/* Returns the index into the table of C interoperable kinds where the
264   kind with the given name (c_kind_name) was found.  */
265
266int
267get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
268{
269  int index = 0;
270
271  for (index = 0; index < ISOCBINDING_LAST; index++)
272    if (strcmp (kinds_table[index].name, c_kind_name) == 0)
273      return index;
274
275  return ISOCBINDING_INVALID;
276}
277