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, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, 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 /* Given a word, return the correct article.  */
 109
 110 const char *
 111 gfc_article (const char *word)
 112 {
 113   const char *p;
 114
 115   switch (*word)
 116     {
 117     case 'a':
 118     case 'A':
 119     case 'e':
 120     case 'E':
 121     case 'i':
 122     case 'I':
 123     case 'o':
 124     case 'O':
 125     case 'u':
 126     case 'U':
 127       p = "an";
 128       break;
 129
 130     default:
 131       p = "a";
 132     }
 133
 134   return p;
 135 }
 136
 137
 138 /* Return a string for each type.  */
 139
 140 const char *
 141 gfc_basic_typename (bt type)
 142 {
 143   const char *p;
 144
 145   switch (type)
 146     {
 147     case BT_INTEGER:
 148       p = "INTEGER";
 149       break;
 150     case BT_REAL:
 151       p = "REAL";
 152       break;
 153     case BT_COMPLEX:
 154       p = "COMPLEX";
 155       break;
 156     case BT_LOGICAL:
 157       p = "LOGICAL";
 158       break;
 159     case BT_CHARACTER:
 160       p = "CHARACTER";
 161       break;
 162     case BT_DERIVED:
 163       p = "DERIVED";
 164       break;
 165     case BT_PROCEDURE:
 166       p = "PROCEDURE";
 167       break;
 168     case BT_UNKNOWN:
 169       p = "UNKNOWN";
 170       break;
 171     default:
 172       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 173     }
 174
 175   return p;
 176 }
 177
 178
 179 /* Return a string describing the type and kind of a typespec.  Because
 180    we return alternating buffers, this subroutine can appear twice in
 181    the argument list of a single statement.  */
 182
 183 const char *
 184 gfc_typename (gfc_typespec * ts)
 185 {
 186   static char buffer1[60], buffer2[60];
 187   static int flag = 0;
 188   char *buffer;
 189
 190   buffer = flag ? buffer1 : buffer2;
 191   flag = !flag;
 192
 193   switch (ts->type)
 194     {
 195     case BT_INTEGER:
 196       sprintf (buffer, "INTEGER(%d)", ts->kind);
 197       break;
 198     case BT_REAL:
 199       sprintf (buffer, "REAL(%d)", ts->kind);
 200       break;
 201     case BT_COMPLEX:
 202       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 203       break;
 204     case BT_LOGICAL:
 205       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 206       break;
 207     case BT_CHARACTER:
 208       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 209       break;
 210     case BT_DERIVED:
 211       sprintf (buffer, "TYPE(%s)", ts->derived->name);
 212       break;
 213     case BT_PROCEDURE:
 214       strcpy (buffer, "PROCEDURE");
 215       break;
 216     case BT_UNKNOWN:
 217       strcpy (buffer, "UNKNOWN");
 218       break;
 219     default:
 220       gfc_internal_error ("gfc_typespec(): Undefined type");
 221     }
 222
 223   return buffer;
 224 }
 225
 226
 227 /* Given an mstring array and a code, locate the code in the table,
 228    returning a pointer to the string.  */
 229
 230 const char *
 231 gfc_code2string (const mstring * m, int code)
 232 {
 233
 234   while (m->string != NULL)
 235     {
 236       if (m->tag == code)
 237         return m->string;
 238       m++;
 239     }
 240
 241   gfc_internal_error ("gfc_code2string(): Bad code");
 242   /* Not reached */
 243 }
 244
 245
 246 /* Given an mstring array and a string, returns the value of the tag
 247    field.  Returns the final tag if no matches to the string are
 248    found.  */
 249
 250 int
 251 gfc_string2code (const mstring * m, const char *string)
 252 {
 253
 254   for (; m->string != NULL; m++)
 255     if (strcmp (m->string, string) == 0)
 256       return m->tag;
 257
 258   return m->tag;
 259 }
 260
 261
 262 /* Convert an intent code to a string.  */
 263 /* TODO: move to gfortran.h as define.  */
 264 const char *
 265 gfc_intent_string (sym_intent i)
 266 {
 267
 268   return gfc_code2string (intents, i);
 269 }
 270
 271
 272 /***************** Initialization functions ****************/
 273
 274 /* Top level initialization.  */
 275
 276 void
 277 gfc_init_1 (void)
 278 {
 279   gfc_error_init_1 ();
 280   gfc_scanner_init_1 ();
 281   gfc_arith_init_1 ();
 282   gfc_intrinsic_init_1 ();
 283   gfc_simplify_init_1 ();
 284 }
 285
 286
 287 /* Per program unit initialization.  */
 288
 289 void
 290 gfc_init_2 (void)
 291 {
 292
 293   gfc_symbol_init_2 ();
 294   gfc_module_init_2 ();
 295 }
 296
 297
 298 /******************* Destructor functions ******************/
 299
 300 /* Call all of the top level destructors.  */
 301
 302 void
 303 gfc_done_1 (void)
 304 {
 305   gfc_scanner_done_1 ();
 306   gfc_intrinsic_done_1 ();
 307   gfc_arith_done_1 ();
 308 }
 309
 310
 311 /* Per program unit destructors.  */
 312
 313 void
 314 gfc_done_2 (void)
 315 {
 316
 317   gfc_symbol_done_2 ();
 318   gfc_module_done_2 ();
 319 }
 320