1 /* implic.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995, 2002 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5 This file is part of GNU Fortran. 6 7 GNU Fortran is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 2, or (at your option) 10 any later version. 11 12 GNU Fortran is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 You should have received a copy of the GNU General Public License 18 along with GNU Fortran; see the file COPYING. If not, write to 19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 20 02111-1307, USA. 21 22 Related Modules: 23 None. 24 25 Description: 26 The GNU Fortran Front End. 27 28 Modifications: 29 */ 30 31 /* Include files. */ 32 33 #include "proj.h" 34 #include "implic.h" 35 #include "info.h" 36 #include "src.h" 37 #include "symbol.h" 38 #include "target.h" 39 40 /* Externals defined here. */ 41 42 43 /* Simple definitions and enumerations. */ 44 45 typedef enum 46 { 47 FFEIMPLIC_stateINITIAL_, 48 FFEIMPLIC_stateASSUMED_, 49 FFEIMPLIC_stateESTABLISHED_, 50 FFEIMPLIC_state 51 } ffeimplicState_; 52 53 /* Internal typedefs. */ 54 55 typedef struct _ffeimplic_ *ffeimplic_; 56 57 /* Private include files. */ 58 59 60 /* Internal structure definitions. */ 61 62 struct _ffeimplic_ 63 { 64 ffeimplicState_ state; 65 ffeinfo info; 66 }; 67 68 /* Static objects accessed by functions in this module. */ 69 70 /* NOTE: This is definitely ASCII-specific!! */ 71 72 static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1]; 73 74 /* Static functions (internal). */ 75 76 static ffeimplic_ ffeimplic_lookup_ (unsigned char c); 77 78 /* Internal macros. */ 79 80 81 /* ffeimplic_lookup_ -- Look up implicit descriptor for initial character 82 83 ffeimplic_ imp; 84 if ((imp = ffeimplic_lookup_('A')) == NULL) 85 // error 86 87 Returns a pointer to an implicit descriptor block based on the character 88 passed, or NULL if it is not a valid initial character for an implicit 89 data type. */ 90 91 static ffeimplic_ 92 ffeimplic_lookup_ (unsigned char c) 93 { 94 /* NOTE: This is definitely ASCII-specific!! */ 95 if (ISIDST (c)) 96 return &ffeimplic_table_[c - 'A']; 97 return NULL; 98 } 99 100 /* ffeimplic_establish_initial -- Establish type of implicit initial letter 101 102 ffesymbol s; 103 if (!ffeimplic_establish_initial(s)) 104 // error 105 106 Assigns implicit type information to the symbol based on the first 107 character of the symbol's name. */ 108 109 bool 110 ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type, 111 ffeinfoKindtype kind_type, ffetargetCharacterSize size) 112 { 113 ffeimplic_ imp; 114 115 imp = ffeimplic_lookup_ (c); 116 if (imp == NULL) 117 return FALSE; /* Character not A-Z or some such thing. */ 118 if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE) 119 return FALSE; /* IMPLICIT NONE in effect here. */ 120 121 switch (imp->state) 122 { 123 case FFEIMPLIC_stateINITIAL_: 124 imp->info = ffeinfo_new (basic_type, 125 kind_type, 126 0, 127 FFEINFO_kindNONE, 128 FFEINFO_whereNONE, 129 size); 130 imp->state = FFEIMPLIC_stateESTABLISHED_; 131 return TRUE; 132 133 case FFEIMPLIC_stateASSUMED_: 134 if ((ffeinfo_basictype (imp->info) != basic_type) 135 || (ffeinfo_kindtype (imp->info) != kind_type) 136 || (ffeinfo_size (imp->info) != size)) 137 return FALSE; 138 imp->state = FFEIMPLIC_stateESTABLISHED_; 139 return TRUE; 140 141 case FFEIMPLIC_stateESTABLISHED_: 142 return FALSE; 143 144 default: 145 assert ("Weird state for implicit object" == NULL); 146 return FALSE; 147 } 148 } 149 150 /* ffeimplic_establish_symbol -- Establish implicit type of a symbol 151 152 ffesymbol s; 153 if (!ffeimplic_establish_symbol(s)) 154 // error 155 156 Assigns implicit type information to the symbol based on the first 157 character of the symbol's name. 158 159 If symbol already has a type, return TRUE. 160 Get first character of symbol's name. 161 Get ffeimplic_ object for it (return FALSE if NULL returned). 162 Return FALSE if object has no assigned type (IMPLICIT NONE). 163 Copy the type information from the object to the symbol. 164 If the object is state "INITIAL", set to state "ASSUMED" so no 165 subsequent IMPLICIT statement may change the state. 166 Return TRUE. */ 167 168 bool 169 ffeimplic_establish_symbol (ffesymbol s) 170 { 171 char c; 172 ffeimplic_ imp; 173 174 if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) 175 return TRUE; 176 177 c = *(ffesymbol_text (s)); 178 imp = ffeimplic_lookup_ (c); 179 if (imp == NULL) 180 return FALSE; /* First character not A-Z or some such 181 thing. */ 182 if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE) 183 return FALSE; /* IMPLICIT NONE in effect here. */ 184 185 ffesymbol_signal_change (s); /* Gonna change, save existing? */ 186 187 /* Establish basictype, kindtype, size; preserve rank, kind, where. */ 188 189 ffesymbol_set_info (s, 190 ffeinfo_new (ffeinfo_basictype (imp->info), 191 ffeinfo_kindtype (imp->info), 192 ffesymbol_rank (s), 193 ffesymbol_kind (s), 194 ffesymbol_where (s), 195 ffeinfo_size (imp->info))); 196 197 if (imp->state == FFEIMPLIC_stateINITIAL_) 198 imp->state = FFEIMPLIC_stateASSUMED_; 199 200 if (ffe_is_warn_implicit ()) 201 { 202 /* xgettext:no-c-format */ 203 ffebad_start_msg ("Implicit declaration of `%A' at %0", 204 FFEBAD_severityWARNING); 205 ffebad_here (0, ffesymbol_where_line (s), 206 ffesymbol_where_column (s)); 207 ffebad_string (ffesymbol_text (s)); 208 ffebad_finish (); 209 } 210 211 return TRUE; 212 } 213 214 /* ffeimplic_init_2 -- Initialize table 215 216 ffeimplic_init_2(); 217 218 Assigns initial type information to all initial letters. 219 220 Allows for holes in the sequence of letters (i.e. EBCDIC). */ 221 222 void 223 ffeimplic_init_2 () 224 { 225 ffeimplic_ imp; 226 char c; 227 228 for (c = 'A'; c <= 'z'; ++c) 229 { 230 imp = &ffeimplic_table_[c - 'A']; 231 imp->state = FFEIMPLIC_stateINITIAL_; 232 switch (c) 233 { 234 case 'A': 235 case 'B': 236 case 'C': 237 case 'D': 238 case 'E': 239 case 'F': 240 case 'G': 241 case 'H': 242 case 'O': 243 case 'P': 244 case 'Q': 245 case 'R': 246 case 'S': 247 case 'T': 248 case 'U': 249 case 'V': 250 case 'W': 251 case 'X': 252 case 'Y': 253 case 'Z': 254 case '_': 255 case 'a': 256 case 'b': 257 case 'c': 258 case 'd': 259 case 'e': 260 case 'f': 261 case 'g': 262 case 'h': 263 case 'o': 264 case 'p': 265 case 'q': 266 case 'r': 267 case 's': 268 case 't': 269 case 'u': 270 case 'v': 271 case 'w': 272 case 'x': 273 case 'y': 274 case 'z': 275 imp->info = ffeinfo_new (FFEINFO_basictypeREAL, 276 FFEINFO_kindtypeREALDEFAULT, 277 0, 278 FFEINFO_kindNONE, 279 FFEINFO_whereNONE, 280 FFETARGET_charactersizeNONE); 281 break; 282 283 case 'I': 284 case 'J': 285 case 'K': 286 case 'L': 287 case 'M': 288 case 'N': 289 case 'i': 290 case 'j': 291 case 'k': 292 case 'l': 293 case 'm': 294 case 'n': 295 imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER, 296 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE, 297 FFETARGET_charactersizeNONE); 298 break; 299 300 default: 301 imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, 302 FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE); 303 break; 304 } 305 } 306 } 307 308 /* ffeimplic_none -- Implement IMPLICIT NONE statement 309 310 ffeimplic_none(); 311 312 Assigns null type information to all initial letters. */ 313 314 void 315 ffeimplic_none () 316 { 317 ffeimplic_ imp; 318 319 for (imp = &ffeimplic_table_[0]; 320 imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)]; 321 imp++) 322 { 323 imp->info = ffeinfo_new (FFEINFO_basictypeNONE, 324 FFEINFO_kindtypeNONE, 325 0, 326 FFEINFO_kindNONE, 327 FFEINFO_whereNONE, 328 FFETARGET_charactersizeNONE); 329 } 330 } 331 332 /* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol 333 334 ffesymbol s; 335 const char *name; // name for s in case it is NULL, or NULL if s never NULL 336 if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER) 337 // is or will be a CHARACTER-typed name 338 339 Like establish_symbol, but doesn't change anything. 340 341 If symbol is non-NULL and already has a type, return it. 342 Get first character of symbol's name or from name arg if symbol is NULL. 343 Get ffeimplic_ object for it (return FALSE if NULL returned). 344 Return NONE if object has no assigned type (IMPLICIT NONE). 345 Return the data type indicated in the object. 346 347 24-Oct-91 JCB 2.0 348 Take a char * instead of ffelexToken, since the latter isn't always 349 needed anyway (as when ffecom calls it). */ 350 351 ffeinfoBasictype 352 ffeimplic_peek_symbol_type (ffesymbol s, const char *name) 353 { 354 char c; 355 ffeimplic_ imp; 356 357 if (s == NULL) 358 c = *name; 359 else 360 { 361 if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) 362 return ffesymbol_basictype (s); 363 364 c = *(ffesymbol_text (s)); 365 } 366 367 imp = ffeimplic_lookup_ (c); 368 if (imp == NULL) 369 return FFEINFO_basictypeNONE; /* First character not A-Z or 370 something. */ 371 return ffeinfo_basictype (imp->info); 372 } 373 374 /* ffeimplic_terminate_2 -- Terminate table 375 376 ffeimplic_terminate_2(); 377 378 Kills info object for each entry in table. */ 379 380 void 381 ffeimplic_terminate_2 () 382 { 383 } 384