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 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 #include "config.h"
  24 #include "system.h"
  25 #include "gfortran.h"
  26
  27 /* Get a block of memory.  Many callers assume that the memory we
  28    return is zeroed.  */
  29
  30 void *
  31 gfc_getmem (size_t n)
  32 {
  33   void *p;
  34
  35   if (n == 0)
  36     return NULL;
  37
  38   p = xmalloc (n);
  39   if (p == NULL)
  40     gfc_fatal_error ("Out of memory-- malloc() failed");
  41   memset (p, 0, n);
  42   return p;
  43 }
  44
  45
  46 /* gfortran.h defines free to something that triggers a syntax error,
  47    but we need free() here.  */
  48
  49 #define temp free
  50 #undef free
  51
  52 void
  53 gfc_free (void *p)
  54 {
  55   if (p != NULL)
  56     free (p);
  57 }
  58
  59 #define free temp
  60 #undef temp
  61
  62
  63 /* Get terminal width.  */
  64
  65 int
  66 gfc_terminal_width (void)
  67 {
  68   return 80;
  69 }
  70
  71
  72 /* Initialize a typespec to unknown.  */
  73
  74 void
  75 gfc_clear_ts (gfc_typespec *ts)
  76 {
  77   ts->type = BT_UNKNOWN;
  78   ts->kind = 0;
  79   ts->derived = NULL;
  80   ts->cl = NULL;
  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_UNKNOWN:
 138       p = "UNKNOWN";
 139       break;
 140     default:
 141       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 142     }
 143
 144   return p;
 145 }
 146
 147
 148 /* Return a string describing the type and kind of a typespec.  Because
 149    we return alternating buffers, this subroutine can appear twice in
 150    the argument list of a single statement.  */
 151
 152 const char *
 153 gfc_typename (gfc_typespec *ts)
 154 {
 155   static char buffer1[60], buffer2[60]; /* FIXME:  Buffer overflow.  */
 156   static int flag = 0;
 157   char *buffer;
 158
 159   buffer = flag ? buffer1 : buffer2;
 160   flag = !flag;
 161
 162   switch (ts->type)
 163     {
 164     case BT_INTEGER:
 165       sprintf (buffer, "INTEGER(%d)", ts->kind);
 166       break;
 167     case BT_REAL:
 168       sprintf (buffer, "REAL(%d)", ts->kind);
 169       break;
 170     case BT_COMPLEX:
 171       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 172       break;
 173     case BT_LOGICAL:
 174       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 175       break;
 176     case BT_CHARACTER:
 177       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 178       break;
 179     case BT_HOLLERITH:
 180       sprintf (buffer, "HOLLERITH");
 181       break;
 182     case BT_DERIVED:
 183       sprintf (buffer, "TYPE(%s)", ts->derived->name);
 184       break;
 185     case BT_PROCEDURE:
 186       strcpy (buffer, "PROCEDURE");
 187       break;
 188     case BT_UNKNOWN:
 189       strcpy (buffer, "UNKNOWN");
 190       break;
 191     default:
 192       gfc_internal_error ("gfc_typename(): Undefined type");
 193     }
 194
 195   return buffer;
 196 }
 197
 198
 199 /* Given an mstring array and a code, locate the code in the table,
 200    returning a pointer to the string.  */
 201
 202 const char *
 203 gfc_code2string (const mstring *m, int code)
 204 {
 205   while (m->string != NULL)
 206     {
 207       if (m->tag == code)
 208         return m->string;
 209       m++;
 210     }
 211
 212   gfc_internal_error ("gfc_code2string(): Bad code");
 213   /* Not reached */
 214 }
 215
 216
 217 /* Given an mstring array and a string, returns the value of the tag
 218    field.  Returns the final tag if no matches to the string are found.  */
 219
 220 int
 221 gfc_string2code (const mstring *m, const char *string)
 222 {
 223   for (; m->string != NULL; m++)
 224     if (strcmp (m->string, string) == 0)
 225       return m->tag;
 226
 227   return m->tag;
 228 }
 229
 230
 231 /* Convert an intent code to a string.  */
 232 /* TODO: move to gfortran.h as define.  */
 233
 234 const char *
 235 gfc_intent_string (sym_intent i)
 236 {
 237   return gfc_code2string (intents, i);
 238 }
 239
 240
 241 /***************** Initialization functions ****************/
 242
 243 /* Top level initialization.  */
 244
 245 void
 246 gfc_init_1 (void)
 247 {
 248   gfc_error_init_1 ();
 249   gfc_scanner_init_1 ();
 250   gfc_arith_init_1 ();
 251   gfc_intrinsic_init_1 ();
 252 }
 253
 254
 255 /* Per program unit initialization.  */
 256
 257 void
 258 gfc_init_2 (void)
 259 {
 260   gfc_symbol_init_2 ();
 261   gfc_module_init_2 ();
 262 }
 263
 264
 265 /******************* Destructor functions ******************/
 266
 267 /* Call all of the top level destructors.  */
 268
 269 void
 270 gfc_done_1 (void)
 271 {
 272   gfc_scanner_done_1 ();
 273   gfc_intrinsic_done_1 ();
 274   gfc_arith_done_1 ();
 275 }
 276
 277
 278 /* Per program unit destructors.  */
 279
 280 void
 281 gfc_done_2 (void)
 282 {
 283   gfc_symbol_done_2 ();
 284   gfc_module_done_2 ();
 285 }
 286