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->derived = NULL;
  71   ts->kind = 0;
  72   ts->cl = NULL;
  73   ts->interface = NULL;
  74   ts->is_class = 0;
  75   /* flag that says if the type is C interoperable */
  76   ts->is_c_interop = 0;
  77   /* says what f90 type the C kind interops with */
  78   ts->f90_type = BT_UNKNOWN;
  79   /* flag that says whether it's from iso_c_binding or not */
  80   ts->is_iso_c = 0;
  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_PROCEDURE:
 135       p = "PROCEDURE";
 136       break;
 137     case BT_VOID:
 138       p = "VOID";
 139       break;
 140     case BT_UNKNOWN:
 141       p = "UNKNOWN";
 142       break;
 143     default:
 144       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 145     }
 146
 147   return p;
 148 }
 149
 150
 151 /* Return a string describing the type and kind of a typespec.  Because
 152    we return alternating buffers, this subroutine can appear twice in
 153    the argument list of a single statement.  */
 154
 155 const char *
 156 gfc_typename (gfc_typespec *ts)
 157 {
 158   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
 159   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
 160   static int flag = 0;
 161   char *buffer;
 162
 163   buffer = flag ? buffer1 : buffer2;
 164   flag = !flag;
 165
 166   switch (ts->type)
 167     {
 168     case BT_INTEGER:
 169       sprintf (buffer, "INTEGER(%d)", ts->kind);
 170       break;
 171     case BT_REAL:
 172       sprintf (buffer, "REAL(%d)", ts->kind);
 173       break;
 174     case BT_COMPLEX:
 175       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 176       break;
 177     case BT_LOGICAL:
 178       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 179       break;
 180     case BT_CHARACTER:
 181       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 182       break;
 183     case BT_HOLLERITH:
 184       sprintf (buffer, "HOLLERITH");
 185       break;
 186     case BT_DERIVED:
 187       sprintf (buffer, "TYPE(%s)", ts->derived->name);
 188       break;
 189     case BT_PROCEDURE:
 190       strcpy (buffer, "PROCEDURE");
 191       break;
 192     case BT_UNKNOWN:
 193       strcpy (buffer, "UNKNOWN");
 194       break;
 195     default:
 196       gfc_internal_error ("gfc_typename(): Undefined type");
 197     }
 198
 199   return buffer;
 200 }
 201
 202
 203 /* Given an mstring array and a code, locate the code in the table,
 204    returning a pointer to the string.  */
 205
 206 const char *
 207 gfc_code2string (const mstring *m, int code)
 208 {
 209   while (m->string != NULL)
 210     {
 211       if (m->tag == code)
 212         return m->string;
 213       m++;
 214     }
 215
 216   gfc_internal_error ("gfc_code2string(): Bad code");
 217   /* Not reached */
 218 }
 219
 220
 221 /* Given an mstring array and a string, returns the value of the tag
 222    field.  Returns the final tag if no matches to the string are found.  */
 223
 224 int
 225 gfc_string2code (const mstring *m, const char *string)
 226 {
 227   for (; m->string != NULL; m++)
 228     if (strcmp (m->string, string) == 0)
 229       return m->tag;
 230
 231   return m->tag;
 232 }
 233
 234
 235 /* Convert an intent code to a string.  */
 236 /* TODO: move to gfortran.h as define.  */
 237
 238 const char *
 239 gfc_intent_string (sym_intent i)
 240 {
 241   return gfc_code2string (intents, i);
 242 }
 243
 244
 245 /***************** Initialization functions ****************/
 246
 247 /* Top level initialization.  */
 248
 249 void
 250 gfc_init_1 (void)
 251 {
 252   gfc_error_init_1 ();
 253   gfc_scanner_init_1 ();
 254   gfc_arith_init_1 ();
 255   gfc_intrinsic_init_1 ();
 256 }
 257
 258
 259 /* Per program unit initialization.  */
 260
 261 void
 262 gfc_init_2 (void)
 263 {
 264   gfc_symbol_init_2 ();
 265   gfc_module_init_2 ();
 266 }
 267
 268
 269 /******************* Destructor functions ******************/
 270
 271 /* Call all of the top level destructors.  */
 272
 273 void
 274 gfc_done_1 (void)
 275 {
 276   gfc_scanner_done_1 ();
 277   gfc_intrinsic_done_1 ();
 278   gfc_arith_done_1 ();
 279 }
 280
 281
 282 /* Per program unit destructors.  */
 283
 284 void
 285 gfc_done_2 (void)
 286 {
 287   gfc_symbol_done_2 ();
 288   gfc_module_done_2 ();
 289 }
 290
 291
 292 /* Returns the index into the table of C interoperable kinds where the
 293    kind with the given name (c_kind_name) was found.  */
 294
 295 int
 296 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 297 {
 298   int index = 0;
 299
 300   for (index = 0; index < ISOCBINDING_LAST; index++)
 301     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 302       return index;
 303
 304   return ISOCBINDING_INVALID;
 305 }