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 /* 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_HOLLERITH:
 163       p = "HOLLERITH";
 164       break;
 165     case BT_DERIVED:
 166       p = "DERIVED";
 167       break;
 168     case BT_PROCEDURE:
 169       p = "PROCEDURE";
 170       break;
 171     case BT_UNKNOWN:
 172       p = "UNKNOWN";
 173       break;
 174     default:
 175       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 176     }
 177
 178   return p;
 179 }
 180
 181
 182 /* Return a string describing the type and kind of a typespec.  Because
 183    we return alternating buffers, this subroutine can appear twice in
 184    the argument list of a single statement.  */
 185
 186 const char *
 187 gfc_typename (gfc_typespec * ts)
 188 {
 189   static char buffer1[60], buffer2[60];
 190   static int flag = 0;
 191   char *buffer;
 192
 193   buffer = flag ? buffer1 : buffer2;
 194   flag = !flag;
 195
 196   switch (ts->type)
 197     {
 198     case BT_INTEGER:
 199       sprintf (buffer, "INTEGER(%d)", ts->kind);
 200       break;
 201     case BT_REAL:
 202       sprintf (buffer, "REAL(%d)", ts->kind);
 203       break;
 204     case BT_COMPLEX:
 205       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 206       break;
 207     case BT_LOGICAL:
 208       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 209       break;
 210     case BT_CHARACTER:
 211       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 212       break;
 213     case BT_HOLLERITH:
 214       sprintf (buffer, "HOLLERITH");
 215       break;
 216     case BT_DERIVED:
 217       sprintf (buffer, "TYPE(%s)", ts->derived->name);
 218       break;
 219     case BT_PROCEDURE:
 220       strcpy (buffer, "PROCEDURE");
 221       break;
 222     case BT_UNKNOWN:
 223       strcpy (buffer, "UNKNOWN");
 224       break;
 225     default:
 226       gfc_internal_error ("gfc_typespec(): Undefined type");
 227     }
 228
 229   return buffer;
 230 }
 231
 232
 233 /* Given an mstring array and a code, locate the code in the table,
 234    returning a pointer to the string.  */
 235
 236 const char *
 237 gfc_code2string (const mstring * m, int code)
 238 {
 239
 240   while (m->string != NULL)
 241     {
 242       if (m->tag == code)
 243         return m->string;
 244       m++;
 245     }
 246
 247   gfc_internal_error ("gfc_code2string(): Bad code");
 248   /* Not reached */
 249 }
 250
 251
 252 /* Given an mstring array and a string, returns the value of the tag
 253    field.  Returns the final tag if no matches to the string are
 254    found.  */
 255
 256 int
 257 gfc_string2code (const mstring * m, const char *string)
 258 {
 259
 260   for (; m->string != NULL; m++)
 261     if (strcmp (m->string, string) == 0)
 262       return m->tag;
 263
 264   return m->tag;
 265 }
 266
 267
 268 /* Convert an intent code to a string.  */
 269 /* TODO: move to gfortran.h as define.  */
 270 const char *
 271 gfc_intent_string (sym_intent i)
 272 {
 273
 274   return gfc_code2string (intents, i);
 275 }
 276
 277
 278 /***************** Initialization functions ****************/
 279
 280 /* Top level initialization.  */
 281
 282 void
 283 gfc_init_1 (void)
 284 {
 285   gfc_error_init_1 ();
 286   gfc_scanner_init_1 ();
 287   gfc_arith_init_1 ();
 288   gfc_intrinsic_init_1 ();
 289   gfc_simplify_init_1 ();
 290 }
 291
 292
 293 /* Per program unit initialization.  */
 294
 295 void
 296 gfc_init_2 (void)
 297 {
 298
 299   gfc_symbol_init_2 ();
 300   gfc_module_init_2 ();
 301 }
 302
 303
 304 /******************* Destructor functions ******************/
 305
 306 /* Call all of the top level destructors.  */
 307
 308 void
 309 gfc_done_1 (void)
 310 {
 311   gfc_scanner_done_1 ();
 312   gfc_intrinsic_done_1 ();
 313   gfc_arith_done_1 ();
 314 }
 315
 316
 317 /* Per program unit destructors.  */
 318
 319 void
 320 gfc_done_2 (void)
 321 {
 322
 323   gfc_symbol_done_2 ();
 324   gfc_module_done_2 ();
 325 }
 326