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   if (!*name)
  62     return stdin;
  63
  64   return fopen (name, "r");
  65 }
  66
  67
  68 /* Return a string for each type.  */
  69
  70 const char *
  71 gfc_basic_typename (bt type)
  72 {
  73   const char *p;
  74
  75   switch (type)
  76     {
  77     case BT_INTEGER:
  78       p = "INTEGER";
  79       break;
  80     case BT_REAL:
  81       p = "REAL";
  82       break;
  83     case BT_COMPLEX:
  84       p = "COMPLEX";
  85       break;
  86     case BT_LOGICAL:
  87       p = "LOGICAL";
  88       break;
  89     case BT_CHARACTER:
  90       p = "CHARACTER";
  91       break;
  92     case BT_HOLLERITH:
  93       p = "HOLLERITH";
  94       break;
  95     case BT_DERIVED:
  96       p = "DERIVED";
  97       break;
  98     case BT_CLASS:
  99       p = "CLASS";
 100       break;
 101     case BT_PROCEDURE:
 102       p = "PROCEDURE";
 103       break;
 104     case BT_VOID:
 105       p = "VOID";
 106       break;
 107     case BT_UNKNOWN:
 108       p = "UNKNOWN";
 109       break;
 110     default:
 111       gfc_internal_error ("gfc_basic_typename(): Undefined type");
 112     }
 113
 114   return p;
 115 }
 116
 117
 118 /* Return a string describing the type and kind of a typespec.  Because
 119    we return alternating buffers, this subroutine can appear twice in
 120    the argument list of a single statement.  */
 121
 122 const char *
 123 gfc_typename (gfc_typespec *ts)
 124 {
 125   static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
 126   static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
 127   static int flag = 0;
 128   char *buffer;
 129
 130   buffer = flag ? buffer1 : buffer2;
 131   flag = !flag;
 132
 133   switch (ts->type)
 134     {
 135     case BT_INTEGER:
 136       sprintf (buffer, "INTEGER(%d)", ts->kind);
 137       break;
 138     case BT_REAL:
 139       sprintf (buffer, "REAL(%d)", ts->kind);
 140       break;
 141     case BT_COMPLEX:
 142       sprintf (buffer, "COMPLEX(%d)", ts->kind);
 143       break;
 144     case BT_LOGICAL:
 145       sprintf (buffer, "LOGICAL(%d)", ts->kind);
 146       break;
 147     case BT_CHARACTER:
 148       sprintf (buffer, "CHARACTER(%d)", ts->kind);
 149       break;
 150     case BT_HOLLERITH:
 151       sprintf (buffer, "HOLLERITH");
 152       break;
 153     case BT_DERIVED:
 154       sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
 155       break;
 156     case BT_CLASS:
 157       sprintf (buffer, "CLASS(%s)",
 158                ts->u.derived->components->ts.u.derived->name);
 159       break;
 160     case BT_PROCEDURE:
 161       strcpy (buffer, "PROCEDURE");
 162       break;
 163     case BT_UNKNOWN:
 164       strcpy (buffer, "UNKNOWN");
 165       break;
 166     default:
 167       gfc_internal_error ("gfc_typename(): Undefined type");
 168     }
 169
 170   return buffer;
 171 }
 172
 173
 174 /* Given an mstring array and a code, locate the code in the table,
 175    returning a pointer to the string.  */
 176
 177 const char *
 178 gfc_code2string (const mstring *m, int code)
 179 {
 180   while (m->string != NULL)
 181     {
 182       if (m->tag == code)
 183         return m->string;
 184       m++;
 185     }
 186
 187   gfc_internal_error ("gfc_code2string(): Bad code");
 188   /* Not reached */
 189 }
 190
 191
 192 /* Given an mstring array and a string, returns the value of the tag
 193    field.  Returns the final tag if no matches to the string are found.  */
 194
 195 int
 196 gfc_string2code (const mstring *m, const char *string)
 197 {
 198   for (; m->string != NULL; m++)
 199     if (strcmp (m->string, string) == 0)
 200       return m->tag;
 201
 202   return m->tag;
 203 }
 204
 205
 206 /* Convert an intent code to a string.  */
 207 /* TODO: move to gfortran.h as define.  */
 208
 209 const char *
 210 gfc_intent_string (sym_intent i)
 211 {
 212   return gfc_code2string (intents, i);
 213 }
 214
 215
 216 /***************** Initialization functions ****************/
 217
 218 /* Top level initialization.  */
 219
 220 void
 221 gfc_init_1 (void)
 222 {
 223   gfc_error_init_1 ();
 224   gfc_scanner_init_1 ();
 225   gfc_arith_init_1 ();
 226   gfc_intrinsic_init_1 ();
 227 }
 228
 229
 230 /* Per program unit initialization.  */
 231
 232 void
 233 gfc_init_2 (void)
 234 {
 235   gfc_symbol_init_2 ();
 236   gfc_module_init_2 ();
 237 }
 238
 239
 240 /******************* Destructor functions ******************/
 241
 242 /* Call all of the top level destructors.  */
 243
 244 void
 245 gfc_done_1 (void)
 246 {
 247   gfc_scanner_done_1 ();
 248   gfc_intrinsic_done_1 ();
 249   gfc_arith_done_1 ();
 250 }
 251
 252
 253 /* Per program unit destructors.  */
 254
 255 void
 256 gfc_done_2 (void)
 257 {
 258   gfc_symbol_done_2 ();
 259   gfc_module_done_2 ();
 260 }
 261
 262
 263 /* Returns the index into the table of C interoperable kinds where the
 264    kind with the given name (c_kind_name) was found.  */
 265
 266 int
 267 get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
 268 {
 269   int index = 0;
 270
 271   for (index = 0; index < ISOCBINDING_LAST; index++)
 272     if (strcmp (kinds_table[index].name, c_kind_name) == 0)
 273       return index;
 274
 275   return ISOCBINDING_INVALID;
 276 }