gcc/fortran/misc.c

   1 /* Miscellaneous stuff that doesn't fit anywhere else.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2010, 2011
   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 3, 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 COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "gfortran.h"
  25
  26
  27 /* Get terminal width.  */
  28
  29 int
  30 gfc_terminal_width (void)
  31 {
  32   return 80;
  33 }
  34
  35
  36 /* Initialize a typespec to unknown.  */
  37
  38 void
  39 gfc_clear_ts (gfc_typespec *ts)
  40 {
  41   ts->type = BT_UNKNOWN;
  42   ts->u.derived = NULL;
  43   ts->kind = 0;
  44   ts->u.cl = NULL;
  45   ts->interface = NULL;
  46   /* flag that says if the type is C interoperable */
  47   ts->is_c_interop = 0;
  48   /* says what f90 type the C kind interops with */
  49   ts->f90_type = BT_UNKNOWN;
  50   /* flag that says whether it's from iso_c_binding or not */
  51   ts->is_iso_c = 0;
  52   ts->deferred = false;
  53 }
  54
  55
  56 /* Open a file for reading.  */
  57
  58 FILE *
  59 gfc_open_file (const char *name)
  60 {
  61   struct stat statbuf;
  62
  63   if (!*name)
  64     return stdin;
  65
  66   if (stat (name, &statbuf) < 0)
  67     return NULL;
  68
  69   if (!S_ISREG (statbuf.st_mode))
  70     return NULL;
  71
  72   return fopen (name, "r");
  73 }
  74
  75
  76 /* Return a string for each type.  */
  77
  78 const char *
  79 gfc_basic_typename (bt type)
  80 {
  81   const char *p;
  82
  83   switch (type)
  84     {
  85     case BT_INTEGER:
  86       p = "INTEGER";
  87       break;
  88     case BT_REAL:
  89       p = "REAL";
  90       break;
  91     case BT_COMPLEX:
  92       p = "COMPLEX";
  93       break;
  94     case BT_LOGICAL:
  95       p = "LOGICAL";
  96       break;
  97     case BT_CHARACTER:
  98       p = "CHARACTER";
  99       break;
 100     case BT_HOLLERITH:
 101       p = "HOLLERITH";
 102       break;
 103     case BT_DERIVED:
 104       p = "DERIVED";
 105       break;
 106     case BT_CLASS:
 107       p = "CLASS";
 108       break;
 109     case BT_PROCEDURE:
 110       p = "PROCEDURE";
 111       break;
 112     case BT_VOID:
 113       p = "VOID";
 114       break;
 115     case BT_UNKNOWN:
 116       p = "UNKNOWN";
 117       break;
 118     default:
 119       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 120     }
 121
 122   return p;
 123 }
 124
 125
 126 /* Return a string describing the type and kind of a typespec.  Because
 127    we return alternating buffers, this subroutine can appear twice in
 128    the argument list of a single statement.  */
 129
 130 const char *
 131 gfc_typename (gfc_typespec *ts)
 132 {
 133   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
 134   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
 135   static int flag = 0;
 136   char *buffer;
 137
 138   buffer = flag ? buffer1 : buffer2;
 139   flag = !flag;
 140
 141   switch (ts->type)
 142     {
 143     case BT_INTEGER:
 144       sprintf (buffer, "INTEGER(%d)", ts->kind);
 145       break;
 146     case BT_REAL:
 147       sprintf (buffer, "REAL(%d)", ts->kind);
 148       break;
 149     case BT_COMPLEX:
 150       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 151       break;
 152     case BT_LOGICAL:
 153       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 154       break;
 155     case BT_CHARACTER:
 156       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 157       break;
 158     case BT_HOLLERITH:
 159       sprintf (buffer, "HOLLERITH");
 160       break;
 161     case BT_DERIVED:
 162       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
 163       break;
 164     case BT_CLASS:
 165       sprintf (buffer, "CLASS(%s)",
 166                ts->u.derived->components->ts.u.derived->name);
 167       break;
 168     case BT_PROCEDURE:
 169       strcpy (buffer, "PROCEDURE");
 170       break;
 171     case BT_UNKNOWN:
 172       strcpy (buffer, "UNKNOWN");
 173       break;
 174     default:
 175       gfc_internal_error ("gfc_typename(): Undefined type");
 176     }
 177
 178   return buffer;
 179 }
 180
 181
 182 /* Given an mstring array and a code, locate the code in the table,
 183    returning a pointer to the string.  */
 184
 185 const char *
 186 gfc_code2string (const mstring *m, int code)
 187 {
 188   while (m->string != NULL)
 189     {
 190       if (m->tag == code)
 191         return m->string;
 192       m++;
 193     }
 194
 195   gfc_internal_error ("gfc_code2string(): Bad code");
 196   /* Not reached */
 197 }
 198
 199
 200 /* Given an mstring array and a string, returns the value of the tag
 201    field.  Returns the final tag if no matches to the string are found.  */
 202
 203 int
 204 gfc_string2code (const mstring *m, const char *string)
 205 {
 206   for (; m->string != NULL; m++)
 207     if (strcmp (m->string, string) == 0)
 208       return m->tag;
 209
 210   return m->tag;
 211 }
 212
 213
 214 /* Convert an intent code to a string.  */
 215 /* TODO: move to gfortran.h as define.  */
 216
 217 const char *
 218 gfc_intent_string (sym_intent i)
 219 {
 220   return gfc_code2string (intents, i);
 221 }
 222
 223
 224 /***************** Initialization functions ****************/
 225
 226 /* Top level initialization.  */
 227
 228 void
 229 gfc_init_1 (void)
 230 {
 231   gfc_error_init_1 ();
 232   gfc_scanner_init_1 ();
 233   gfc_arith_init_1 ();
 234   gfc_intrinsic_init_1 ();
 235 }
 236
 237
 238 /* Per program unit initialization.  */
 239
 240 void
 241 gfc_init_2 (void)
 242 {
 243   gfc_symbol_init_2 ();
 244   gfc_module_init_2 ();
 245 }
 246
 247
 248 /******************* Destructor functions ******************/
 249
 250 /* Call all of the top level destructors.  */
 251
 252 void
 253 gfc_done_1 (void)
 254 {
 255   gfc_scanner_done_1 ();
 256   gfc_intrinsic_done_1 ();
 257   gfc_arith_done_1 ();
 258 }
 259
 260
 261 /* Per program unit destructors.  */
 262
 263 void
 264 gfc_done_2 (void)
 265 {
 266   gfc_symbol_done_2 ();
 267   gfc_module_done_2 ();
 268 }
 269
 270
 271 /* Returns the index into the table of C interoperable kinds where the
 272    kind with the given name (c_kind_name) was found.  */
 273
 274 int
 275 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 276 {
 277   int index = 0;
 278
 279   for (index = 0; index < ISOCBINDING_LAST; index++)
 280     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 281       return index;
 282
 283   return ISOCBINDING_INVALID;
 284 }