OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [misc.c] - Blame information for rev 304

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 285 jeremybenn
/* 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
}
81
 
82
 
83
/* Open a file for reading.  */
84
 
85
FILE *
86
gfc_open_file (const char *name)
87
{
88
  struct stat statbuf;
89
 
90
  if (!*name)
91
    return stdin;
92
 
93
  if (stat (name, &statbuf) < 0)
94
    return NULL;
95
 
96
  if (!S_ISREG (statbuf.st_mode))
97
    return NULL;
98
 
99
  return fopen (name, "r");
100
}
101
 
102
 
103
/* Return a string for each type.  */
104
 
105
const char *
106
gfc_basic_typename (bt type)
107
{
108
  const char *p;
109
 
110
  switch (type)
111
    {
112
    case BT_INTEGER:
113
      p = "INTEGER";
114
      break;
115
    case BT_REAL:
116
      p = "REAL";
117
      break;
118
    case BT_COMPLEX:
119
      p = "COMPLEX";
120
      break;
121
    case BT_LOGICAL:
122
      p = "LOGICAL";
123
      break;
124
    case BT_CHARACTER:
125
      p = "CHARACTER";
126
      break;
127
    case BT_HOLLERITH:
128
      p = "HOLLERITH";
129
      break;
130
    case BT_DERIVED:
131
      p = "DERIVED";
132
      break;
133
    case BT_CLASS:
134
      p = "CLASS";
135
      break;
136
    case BT_PROCEDURE:
137
      p = "PROCEDURE";
138
      break;
139
    case BT_VOID:
140
      p = "VOID";
141
      break;
142
    case BT_UNKNOWN:
143
      p = "UNKNOWN";
144
      break;
145
    default:
146
      gfc_internal_error ("gfc_basic_typename(): Undefined type");
147
    }
148
 
149
  return p;
150
}
151
 
152
 
153
/* Return a string describing the type and kind of a typespec.  Because
154
   we return alternating buffers, this subroutine can appear twice in
155
   the argument list of a single statement.  */
156
 
157
const char *
158
gfc_typename (gfc_typespec *ts)
159
{
160
  static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
161
  static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
162
  static int flag = 0;
163
  char *buffer;
164
 
165
  buffer = flag ? buffer1 : buffer2;
166
  flag = !flag;
167
 
168
  switch (ts->type)
169
    {
170
    case BT_INTEGER:
171
      sprintf (buffer, "INTEGER(%d)", ts->kind);
172
      break;
173
    case BT_REAL:
174
      sprintf (buffer, "REAL(%d)", ts->kind);
175
      break;
176
    case BT_COMPLEX:
177
      sprintf (buffer, "COMPLEX(%d)", ts->kind);
178
      break;
179
    case BT_LOGICAL:
180
      sprintf (buffer, "LOGICAL(%d)", ts->kind);
181
      break;
182
    case BT_CHARACTER:
183
      sprintf (buffer, "CHARACTER(%d)", ts->kind);
184
      break;
185
    case BT_HOLLERITH:
186
      sprintf (buffer, "HOLLERITH");
187
      break;
188
    case BT_DERIVED:
189
      sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
190
      break;
191
    case BT_CLASS:
192
      sprintf (buffer, "CLASS(%s)",
193
               ts->u.derived->components->ts.u.derived->name);
194
      break;
195
    case BT_PROCEDURE:
196
      strcpy (buffer, "PROCEDURE");
197
      break;
198
    case BT_UNKNOWN:
199
      strcpy (buffer, "UNKNOWN");
200
      break;
201
    default:
202
      gfc_internal_error ("gfc_typename(): Undefined type");
203
    }
204
 
205
  return buffer;
206
}
207
 
208
 
209
/* Given an mstring array and a code, locate the code in the table,
210
   returning a pointer to the string.  */
211
 
212
const char *
213
gfc_code2string (const mstring *m, int code)
214
{
215
  while (m->string != NULL)
216
    {
217
      if (m->tag == code)
218
        return m->string;
219
      m++;
220
    }
221
 
222
  gfc_internal_error ("gfc_code2string(): Bad code");
223
  /* Not reached */
224
}
225
 
226
 
227
/* Given an mstring array and a string, returns the value of the tag
228
   field.  Returns the final tag if no matches to the string are found.  */
229
 
230
int
231
gfc_string2code (const mstring *m, const char *string)
232
{
233
  for (; m->string != NULL; m++)
234
    if (strcmp (m->string, string) == 0)
235
      return m->tag;
236
 
237
  return m->tag;
238
}
239
 
240
 
241
/* Convert an intent code to a string.  */
242
/* TODO: move to gfortran.h as define.  */
243
 
244
const char *
245
gfc_intent_string (sym_intent i)
246
{
247
  return gfc_code2string (intents, i);
248
}
249
 
250
 
251
/***************** Initialization functions ****************/
252
 
253
/* Top level initialization.  */
254
 
255
void
256
gfc_init_1 (void)
257
{
258
  gfc_error_init_1 ();
259
  gfc_scanner_init_1 ();
260
  gfc_arith_init_1 ();
261
  gfc_intrinsic_init_1 ();
262
}
263
 
264
 
265
/* Per program unit initialization.  */
266
 
267
void
268
gfc_init_2 (void)
269
{
270
  gfc_symbol_init_2 ();
271
  gfc_module_init_2 ();
272
}
273
 
274
 
275
/******************* Destructor functions ******************/
276
 
277
/* Call all of the top level destructors.  */
278
 
279
void
280
gfc_done_1 (void)
281
{
282
  gfc_scanner_done_1 ();
283
  gfc_intrinsic_done_1 ();
284
  gfc_arith_done_1 ();
285
}
286
 
287
 
288
/* Per program unit destructors.  */
289
 
290
void
291
gfc_done_2 (void)
292
{
293
  gfc_symbol_done_2 ();
294
  gfc_module_done_2 ();
295
}
296
 
297
 
298
/* Returns the index into the table of C interoperable kinds where the
299
   kind with the given name (c_kind_name) was found.  */
300
 
301
int
302
get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
303
{
304
  int index = 0;
305
 
306
  for (index = 0; index < ISOCBINDING_LAST; index++)
307
    if (strcmp (kinds_table[index].name, c_kind_name) == 0)
308
      return index;
309
 
310
  return ISOCBINDING_INVALID;
311
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.