gcc/fortran/misc.c

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