gcc/fortran/misc.c

   1 /* Miscellaneous stuff that doesn't fit anywhere else.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005
   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 2, 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 COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "gfortran.h"
  27
  28
  29 /* Get a block of memory.  Many callers assume that the memory we
  30    return is zeroed.  */
  31
  32 void *
  33 gfc_getmem (size_t n)
  34 {
  35   void *p;
  36
  37   if (n == 0)
  38     return NULL;
  39
  40   p = xmalloc (n);
  41   if (p == NULL)
  42     gfc_fatal_error ("Out of memory-- malloc() failed");
  43   memset (p, 0, n);
  44   return p;
  45 }
  46
  47
  48 /* gfortran.h defines free to something that triggers a syntax error,
  49    but we need free() here.  */
  50
  51 #define temp free
  52 #undef free
  53
  54 void
  55 gfc_free (void *p)
  56 {
  57
  58   if (p != NULL)
  59     free (p);
  60 }
  61
  62 #define free temp
  63 #undef temp
  64
  65
  66 /* Get terminal width */
  67
  68 int
  69 gfc_terminal_width(void)
  70 {
  71   return 80;
  72 }
  73
  74
  75 /* Initialize a typespec to unknown.  */
  76
  77 void
  78 gfc_clear_ts (gfc_typespec * ts)
  79 {
  80
  81   ts->type = BT_UNKNOWN;
  82   ts->kind = 0;
  83   ts->derived = NULL;
  84   ts->cl = NULL;
  85 }
  86
  87
  88 /* Open a file for reading.  */
  89
  90 FILE *
  91 gfc_open_file (const char *name)
  92 {
  93   struct stat statbuf;
  94
  95   if (!*name)
  96     return stdin;
  97
  98   if (stat (name, &statbuf) < 0)
  99     return NULL;
 100
 101   if (!S_ISREG (statbuf.st_mode))
 102     return NULL;
 103
 104   return fopen (name, "r");
 105 }
 106
 107
 108 /* Return a string for each type.  */
 109
 110 const char *
 111 gfc_basic_typename (bt type)
 112 {
 113   const char *p;
 114
 115   switch (type)
 116     {
 117     case BT_INTEGER:
 118       p = "INTEGER";
 119       break;
 120     case BT_REAL:
 121       p = "REAL";
 122       break;
 123     case BT_COMPLEX:
 124       p = "COMPLEX";
 125       break;
 126     case BT_LOGICAL:
 127       p = "LOGICAL";
 128       break;
 129     case BT_CHARACTER:
 130       p = "CHARACTER";
 131       break;
 132     case BT_HOLLERITH:
 133       p = "HOLLERITH";
 134       break;
 135     case BT_DERIVED:
 136       p = "DERIVED";
 137       break;
 138     case BT_PROCEDURE:
 139       p = "PROCEDURE";
 140       break;
 141     case BT_UNKNOWN:
 142       p = "UNKNOWN";
 143       break;
 144     default:
 145       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 146     }
 147
 148   return p;
 149 }
 150
 151
 152 /* Return a string describing the type and kind of a typespec.  Because
 153    we return alternating buffers, this subroutine can appear twice in
 154    the argument list of a single statement.  */
 155
 156 const char *
 157 gfc_typename (gfc_typespec * ts)
 158 {
 159   static char buffer1[60], buffer2[60];
 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_typespec(): 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
 210   while (m->string != NULL)
 211     {
 212       if (m->tag == code)
 213         return m->string;
 214       m++;
 215     }
 216
 217   gfc_internal_error ("gfc_code2string(): Bad code");
 218   /* Not reached */
 219 }
 220
 221
 222 /* Given an mstring array and a string, returns the value of the tag
 223    field.  Returns the final tag if no matches to the string are
 224    found.  */
 225
 226 int
 227 gfc_string2code (const mstring * m, const char *string)
 228 {
 229
 230   for (; m->string != NULL; m++)
 231     if (strcmp (m->string, string) == 0)
 232       return m->tag;
 233
 234   return m->tag;
 235 }
 236
 237
 238 /* Convert an intent code to a string.  */
 239 /* TODO: move to gfortran.h as define.  */
 240 const char *
 241 gfc_intent_string (sym_intent i)
 242 {
 243
 244   return gfc_code2string (intents, i);
 245 }
 246
 247
 248 /***************** Initialization functions ****************/
 249
 250 /* Top level initialization.  */
 251
 252 void
 253 gfc_init_1 (void)
 254 {
 255   gfc_error_init_1 ();
 256   gfc_scanner_init_1 ();
 257   gfc_arith_init_1 ();
 258   gfc_intrinsic_init_1 ();
 259   gfc_simplify_init_1 ();
 260 }
 261
 262
 263 /* Per program unit initialization.  */
 264
 265 void
 266 gfc_init_2 (void)
 267 {
 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
 293   gfc_symbol_done_2 ();
 294   gfc_module_done_2 ();
 295 }
 296