1/* Miscellaneous stuff that doesn't fit anywhere else. 2 Copyright (C) 2000-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along 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 29void 30gfc_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 49FILE * 50gfc_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 61const char * 62gfc_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_DERIVED: 87 p = "DERIVED"; 88 break; 89 case BT_CLASS: 90 p = "CLASS"; 91 break; 92 case BT_PROCEDURE: 93 p = "PROCEDURE"; 94 break; 95 case BT_VOID: 96 p = "VOID"; 97 break; 98 case BT_UNKNOWN: 99 p = "UNKNOWN"; 100 break; 101 case BT_ASSUMED: 102 p = "TYPE(*)"; 103 break; 104 default: 105 gfc_internal_error ("gfc_basic_typename(): Undefined type"); 106 } 107 108 return p; 109} 110 111 112/* Return a string describing the type and kind of a typespec. Because 113 we return alternating buffers, this subroutine can appear twice in 114 the argument list of a single statement. */ 115 116const char * 117gfc_typename (gfc_typespec *ts) 118{ 119 static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */ 120 static char buffer2[GFC_MAX_SYMBOL_LEN + 7]; 121 static int flag = 0; 122 char *buffer; 123 124 buffer = flag ? buffer1 : buffer2; 125 flag = !flag; 126 127 switch (ts->type) 128 { 129 case BT_INTEGER: 130 sprintf (buffer, "INTEGER(%d)", ts->kind); 131 break; 132 case BT_REAL: 133 sprintf (buffer, "REAL(%d)", ts->kind); 134 break; 135 case BT_COMPLEX: 136 sprintf (buffer, "COMPLEX(%d)", ts->kind); 137 break; 138 case BT_LOGICAL: 139 sprintf (buffer, "LOGICAL(%d)", ts->kind); 140 break; 141 case BT_CHARACTER: 142 sprintf (buffer, "CHARACTER(%d)", ts->kind); 143 break; 144 case BT_HOLLERITH: 145 sprintf (buffer, "HOLLERITH"); 146 break; 147 case BT_DERIVED: 148 sprintf (buffer, "TYPE(%s)", ts->u.derived->name); 149 break; 150 case BT_CLASS: 151 ts = &ts->u.derived->components->ts; 152 if (ts->u.derived->attr.unlimited_polymorphic) 153 sprintf (buffer, "CLASS(*)"); 154 else 155 sprintf (buffer, "CLASS(%s)", ts->u.derived->name); 156 break; 157 case BT_ASSUMED: 158 sprintf (buffer, "TYPE(*)"); 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 177const char * 178gfc_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 195int 196gfc_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 209const char * 210gfc_intent_string (sym_intent i) 211{ 212 return gfc_code2string (intents, i); 213} 214 215 216/***************** Initialization functions ****************/ 217 218/* Top level initialization. */ 219 220void 221gfc_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 232void 233gfc_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 244void 245gfc_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 255void 256gfc_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 266int 267get_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} 277