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