gcc/fortran/misc.c

   1 /* Miscellaneous stuff that doesn't fit anywhere else.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  21
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "gfortran.h"
  26
  27
  28 /* Get a block of memory.  Many callers assume that the memory we
  29    return is zeroed.  */
  30
  31 void *
  32 gfc_getmem (size_t n)
  33 {
  34   void *p;
  35
  36   if (n == 0)
  37     return NULL;
  38
  39   p = xmalloc (n);
  40   if (p == NULL)
  41     gfc_fatal_error ("Out of memory-- malloc() failed");
  42   memset (p, 0, n);
  43   return p;
  44 }
  45
  46
  47 /* gfortran.h defines free to something that triggers a syntax error,
  48    but we need free() here.  */
  49
  50 #define temp free
  51 #undef free
  52
  53 void
  54 gfc_free (void *p)
  55 {
  56
  57   if (p != NULL)
  58     free (p);
  59 }
  60
  61 #define free temp
  62 #undef temp
  63
  64
  65 /* Get terminal width */
  66
  67 int
  68 gfc_terminal_width(void)
  69 {
  70   return 80;
  71 }
  72
  73
  74 /* Initialize a typespec to unknown.  */
  75
  76 void
  77 gfc_clear_ts (gfc_typespec * ts)
  78 {
  79
  80   ts->type = BT_UNKNOWN;
  81   ts->kind = 0;
  82   ts->derived = NULL;
  83   ts->cl = NULL;
  84 }
  85
  86
  87 /* Open a file for reading.  */
  88
  89 FILE *
  90 gfc_open_file (const char *name)
  91 {
  92   struct stat statbuf;
  93
  94   if (!*name)
  95     return stdin;
  96
  97   if (stat (name, &statbuf) < 0)
  98     return NULL;
  99
 100   if (!S_ISREG (statbuf.st_mode))
 101     return NULL;
 102
 103   return fopen (name, "r");
 104 }
 105
 106
 107 /* Given a word, return the correct article.  */
 108
 109 const char *
 110 gfc_article (const char *word)
 111 {
 112   const char *p;
 113
 114   switch (*word)
 115     {
 116     case 'a':
 117     case 'A':
 118     case 'e':
 119     case 'E':
 120     case 'i':
 121     case 'I':
 122     case 'o':
 123     case 'O':
 124     case 'u':
 125     case 'U':
 126       p = "an";
 127       break;
 128
 129     default:
 130       p = "a";
 131     }
 132
 133   return p;
 134 }
 135
 136
 137 /* Return a string for each type.  */
 138
 139 const char *
 140 gfc_basic_typename (bt type)
 141 {
 142   const char *p;
 143
 144   switch (type)
 145     {
 146     case BT_INTEGER:
 147       p = "INTEGER";
 148       break;
 149     case BT_REAL:
 150       p = "REAL";
 151       break;
 152     case BT_COMPLEX:
 153       p = "COMPLEX";
 154       break;
 155     case BT_LOGICAL:
 156       p = "LOGICAL";
 157       break;
 158     case BT_CHARACTER:
 159       p = "CHARACTER";
 160       break;
 161     case BT_DERIVED:
 162       p = "DERIVED";
 163       break;
 164     case BT_PROCEDURE:
 165       p = "PROCEDURE";
 166       break;
 167     case BT_UNKNOWN:
 168       p = "UNKNOWN";
 169       break;
 170     default:
 171       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 172     }
 173
 174   return p;
 175 }
 176
 177
 178 /* Return a string describing the type and kind of a typespec.  Because
 179    we return alternating buffers, this subroutine can appear twice in
 180    the argument list of a single statement.  */
 181
 182 const char *
 183 gfc_typename (gfc_typespec * ts)
 184 {
 185   static char buffer1[60], buffer2[60];
 186   static int flag = 0;
 187   char *buffer;
 188
 189   buffer = flag ? buffer1 : buffer2;
 190   flag = !flag;
 191
 192   switch (ts->type)
 193     {
 194     case BT_INTEGER:
 195       sprintf (buffer, "INTEGER(%d)", ts->kind);
 196       break;
 197     case BT_REAL:
 198       sprintf (buffer, "REAL(%d)", ts->kind);
 199       break;
 200     case BT_COMPLEX:
 201       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 202       break;
 203     case BT_LOGICAL:
 204       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 205       break;
 206     case BT_CHARACTER:
 207       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 208       break;
 209     case BT_DERIVED:
 210       sprintf (buffer, "TYPE(%s)", ts->derived->name);
 211       break;
 212     case BT_PROCEDURE:
 213       strcpy (buffer, "PROCEDURE");
 214       break;
 215     case BT_UNKNOWN:
 216       strcpy (buffer, "UNKNOWN");
 217       break;
 218     default:
 219       gfc_internal_error ("gfc_typespec(): Undefined type");
 220     }
 221
 222   return buffer;
 223 }
 224
 225
 226 /* Given an mstring array and a code, locate the code in the table,
 227    returning a pointer to the string.  */
 228
 229 const char *
 230 gfc_code2string (const mstring * m, int code)
 231 {
 232
 233   while (m->string != NULL)
 234     {
 235       if (m->tag == code)
 236         return m->string;
 237       m++;
 238     }
 239
 240   gfc_internal_error ("gfc_code2string(): Bad code");
 241   /* Not reached */
 242 }
 243
 244
 245 /* Given an mstring array and a string, returns the value of the tag
 246    field.  Returns the final tag if no matches to the string are
 247    found.  */
 248
 249 int
 250 gfc_string2code (const mstring * m, const char *string)
 251 {
 252
 253   for (; m->string != NULL; m++)
 254     if (strcmp (m->string, string) == 0)
 255       return m->tag;
 256
 257   return m->tag;
 258 }
 259
 260
 261 /* Convert an intent code to a string.  */
 262 /* TODO: move to gfortran.h as define.  */
 263 const char *
 264 gfc_intent_string (sym_intent i)
 265 {
 266
 267   return gfc_code2string (intents, i);
 268 }
 269
 270
 271 /***************** Initialization functions ****************/
 272
 273 /* Top level initialization.  */
 274
 275 void
 276 gfc_init_1 (void)
 277 {
 278   gfc_error_init_1 ();
 279   gfc_scanner_init_1 ();
 280   gfc_arith_init_1 ();
 281   gfc_intrinsic_init_1 ();
 282   gfc_simplify_init_1 ();
 283 }
 284
 285
 286 /* Per program unit initialization.  */
 287
 288 void
 289 gfc_init_2 (void)
 290 {
 291
 292   gfc_symbol_init_2 ();
 293   gfc_module_init_2 ();
 294 }
 295
 296
 297 /******************* Destructor functions ******************/
 298
 299 /* Call all of the top level destructors.  */
 300
 301 void
 302 gfc_done_1 (void)
 303 {
 304   gfc_scanner_done_1 ();
 305   gfc_intrinsic_done_1 ();
 306   gfc_arith_done_1 ();
 307 }
 308
 309
 310 /* Per program unit destructors.  */
 311
 312 void
 313 gfc_done_2 (void)
 314 {
 315
 316   gfc_symbol_done_2 ();
 317   gfc_module_done_2 ();
 318 }
 319