gcc/fortran/misc.c

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