gcc/fortran/misc.c

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