1/* implic.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5This file is part of GNU Fortran. 6 7GNU Fortran is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU Fortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU Fortran; see the file COPYING. If not, write to 19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 2002111-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 45typedef enum 46 { 47 FFEIMPLIC_stateINITIAL_, 48 FFEIMPLIC_stateASSUMED_, 49 FFEIMPLIC_stateESTABLISHED_, 50 FFEIMPLIC_state 51 } ffeimplicState_; 52 53/* Internal typedefs. */ 54 55typedef struct _ffeimplic_ *ffeimplic_; 56 57/* Private include files. */ 58 59 60/* Internal structure definitions. */ 61 62struct _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 72static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1]; 73 74/* Static functions (internal). */ 75 76static 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 91static ffeimplic_ 92ffeimplic_lookup_ (unsigned char c) 93{ 94 /* NOTE: This is definitely ASCII-specific!! */ 95 if (ISALPHA (c) || (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 109bool 110ffeimplic_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 168bool 169ffeimplic_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 ffebad_start_msg ("Implicit declaration of `%A' at %0", 203 FFEBAD_severityWARNING); 204 ffebad_here (0, ffesymbol_where_line (s), 205 ffesymbol_where_column (s)); 206 ffebad_string (ffesymbol_text (s)); 207 ffebad_finish (); 208 } 209 210 return TRUE; 211} 212 213/* ffeimplic_init_2 -- Initialize table 214 215 ffeimplic_init_2(); 216 217 Assigns initial type information to all initial letters. 218 219 Allows for holes in the sequence of letters (i.e. EBCDIC). */ 220 221void 222ffeimplic_init_2 () 223{ 224 ffeimplic_ imp; 225 char c; 226 227 for (c = 'A'; c <= 'z'; ++c) 228 { 229 imp = &ffeimplic_table_[c - 'A']; 230 imp->state = FFEIMPLIC_stateINITIAL_; 231 switch (c) 232 { 233 case 'A': 234 case 'B': 235 case 'C': 236 case 'D': 237 case 'E': 238 case 'F': 239 case 'G': 240 case 'H': 241 case 'O': 242 case 'P': 243 case 'Q': 244 case 'R': 245 case 'S': 246 case 'T': 247 case 'U': 248 case 'V': 249 case 'W': 250 case 'X': 251 case 'Y': 252 case 'Z': 253 case '_': 254 case 'a': 255 case 'b': 256 case 'c': 257 case 'd': 258 case 'e': 259 case 'f': 260 case 'g': 261 case 'h': 262 case 'o': 263 case 'p': 264 case 'q': 265 case 'r': 266 case 's': 267 case 't': 268 case 'u': 269 case 'v': 270 case 'w': 271 case 'x': 272 case 'y': 273 case 'z': 274 imp->info = ffeinfo_new (FFEINFO_basictypeREAL, 275 FFEINFO_kindtypeREALDEFAULT, 276 0, 277 FFEINFO_kindNONE, 278 FFEINFO_whereNONE, 279 FFETARGET_charactersizeNONE); 280 break; 281 282 case 'I': 283 case 'J': 284 case 'K': 285 case 'L': 286 case 'M': 287 case 'N': 288 case 'i': 289 case 'j': 290 case 'k': 291 case 'l': 292 case 'm': 293 case 'n': 294 imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER, 295 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE, 296 FFETARGET_charactersizeNONE); 297 break; 298 299 default: 300 imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, 301 FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE); 302 break; 303 } 304 } 305} 306 307/* ffeimplic_none -- Implement IMPLICIT NONE statement 308 309 ffeimplic_none(); 310 311 Assigns null type information to all initial letters. */ 312 313void 314ffeimplic_none () 315{ 316 ffeimplic_ imp; 317 318 for (imp = &ffeimplic_table_[0]; 319 imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)]; 320 imp++) 321 { 322 imp->info = ffeinfo_new (FFEINFO_basictypeNONE, 323 FFEINFO_kindtypeNONE, 324 0, 325 FFEINFO_kindNONE, 326 FFEINFO_whereNONE, 327 FFETARGET_charactersizeNONE); 328 } 329} 330 331/* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol 332 333 ffesymbol s; 334 const char *name; // name for s in case it is NULL, or NULL if s never NULL 335 if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER) 336 // is or will be a CHARACTER-typed name 337 338 Like establish_symbol, but doesn't change anything. 339 340 If symbol is non-NULL and already has a type, return it. 341 Get first character of symbol's name or from name arg if symbol is NULL. 342 Get ffeimplic_ object for it (return FALSE if NULL returned). 343 Return NONE if object has no assigned type (IMPLICIT NONE). 344 Return the data type indicated in the object. 345 346 24-Oct-91 JCB 2.0 347 Take a char * instead of ffelexToken, since the latter isn't always 348 needed anyway (as when ffecom calls it). */ 349 350ffeinfoBasictype 351ffeimplic_peek_symbol_type (ffesymbol s, const char *name) 352{ 353 char c; 354 ffeimplic_ imp; 355 356 if (s == NULL) 357 c = *name; 358 else 359 { 360 if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) 361 return ffesymbol_basictype (s); 362 363 c = *(ffesymbol_text (s)); 364 } 365 366 imp = ffeimplic_lookup_ (c); 367 if (imp == NULL) 368 return FFEINFO_basictypeNONE; /* First character not A-Z or 369 something. */ 370 return ffeinfo_basictype (imp->info); 371} 372 373/* ffeimplic_terminate_2 -- Terminate table 374 375 ffeimplic_terminate_2(); 376 377 Kills info object for each entry in table. */ 378 379void 380ffeimplic_terminate_2 () 381{ 382} 383