| /* implic.c -- Implementation File (module.c template V1.0) |
| Copyright (C) 1995 Free Software Foundation, Inc. |
| Contributed by James Craig Burley. |
| |
| This file is part of GNU Fortran. |
| |
| GNU Fortran is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 2, or (at your option) |
| any later version. |
| |
| GNU Fortran is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GNU Fortran; see the file COPYING. If not, write to |
| the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA |
| 02111-1307, USA. |
| |
| Related Modules: |
| None. |
| |
| Description: |
| The GNU Fortran Front End. |
| |
| Modifications: |
| */ |
| |
| /* Include files. */ |
| |
| #include "proj.h" |
| #include "implic.h" |
| #include "info.h" |
| #include "src.h" |
| #include "symbol.h" |
| #include "target.h" |
| |
| /* Externals defined here. */ |
| |
| |
| /* Simple definitions and enumerations. */ |
| |
| typedef enum |
| { |
| FFEIMPLIC_stateINITIAL_, |
| FFEIMPLIC_stateASSUMED_, |
| FFEIMPLIC_stateESTABLISHED_, |
| FFEIMPLIC_state |
| } ffeimplicState_; |
| |
| /* Internal typedefs. */ |
| |
| typedef struct _ffeimplic_ *ffeimplic_; |
| |
| /* Private include files. */ |
| |
| |
| /* Internal structure definitions. */ |
| |
| struct _ffeimplic_ |
| { |
| ffeimplicState_ state; |
| ffeinfo info; |
| }; |
| |
| /* Static objects accessed by functions in this module. */ |
| |
| /* NOTE: This is definitely ASCII-specific!! */ |
| |
| static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1]; |
| |
| /* Static functions (internal). */ |
| |
| static ffeimplic_ ffeimplic_lookup_ (unsigned char c); |
| |
| /* Internal macros. */ |
| |
| |
| /* ffeimplic_lookup_ -- Look up implicit descriptor for initial character |
| |
| ffeimplic_ imp; |
| if ((imp = ffeimplic_lookup_('A')) == NULL) |
| // error |
| |
| Returns a pointer to an implicit descriptor block based on the character |
| passed, or NULL if it is not a valid initial character for an implicit |
| data type. */ |
| |
| static ffeimplic_ |
| ffeimplic_lookup_ (unsigned char c) |
| { |
| /* NOTE: This is definitely ASCII-specific!! */ |
| if (ISALPHA (c) || (c == '_')) |
| return &ffeimplic_table_[c - 'A']; |
| return NULL; |
| } |
| |
| /* ffeimplic_establish_initial -- Establish type of implicit initial letter |
| |
| ffesymbol s; |
| if (!ffeimplic_establish_initial(s)) |
| // error |
| |
| Assigns implicit type information to the symbol based on the first |
| character of the symbol's name. */ |
| |
| bool |
| ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type, |
| ffeinfoKindtype kind_type, ffetargetCharacterSize size) |
| { |
| ffeimplic_ imp; |
| |
| imp = ffeimplic_lookup_ (c); |
| if (imp == NULL) |
| return FALSE; /* Character not A-Z or some such thing. */ |
| if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE) |
| return FALSE; /* IMPLICIT NONE in effect here. */ |
| |
| switch (imp->state) |
| { |
| case FFEIMPLIC_stateINITIAL_: |
| imp->info = ffeinfo_new (basic_type, |
| kind_type, |
| 0, |
| FFEINFO_kindNONE, |
| FFEINFO_whereNONE, |
| size); |
| imp->state = FFEIMPLIC_stateESTABLISHED_; |
| return TRUE; |
| |
| case FFEIMPLIC_stateASSUMED_: |
| if ((ffeinfo_basictype (imp->info) != basic_type) |
| || (ffeinfo_kindtype (imp->info) != kind_type) |
| || (ffeinfo_size (imp->info) != size)) |
| return FALSE; |
| imp->state = FFEIMPLIC_stateESTABLISHED_; |
| return TRUE; |
| |
| case FFEIMPLIC_stateESTABLISHED_: |
| return FALSE; |
| |
| default: |
| assert ("Weird state for implicit object" == NULL); |
| return FALSE; |
| } |
| } |
| |
| /* ffeimplic_establish_symbol -- Establish implicit type of a symbol |
| |
| ffesymbol s; |
| if (!ffeimplic_establish_symbol(s)) |
| // error |
| |
| Assigns implicit type information to the symbol based on the first |
| character of the symbol's name. |
| |
| If symbol already has a type, return TRUE. |
| Get first character of symbol's name. |
| Get ffeimplic_ object for it (return FALSE if NULL returned). |
| Return FALSE if object has no assigned type (IMPLICIT NONE). |
| Copy the type information from the object to the symbol. |
| If the object is state "INITIAL", set to state "ASSUMED" so no |
| subsequent IMPLICIT statement may change the state. |
| Return TRUE. */ |
| |
| bool |
| ffeimplic_establish_symbol (ffesymbol s) |
| { |
| char c; |
| ffeimplic_ imp; |
| |
| if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) |
| return TRUE; |
| |
| c = *(ffesymbol_text (s)); |
| imp = ffeimplic_lookup_ (c); |
| if (imp == NULL) |
| return FALSE; /* First character not A-Z or some such |
| thing. */ |
| if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE) |
| return FALSE; /* IMPLICIT NONE in effect here. */ |
| |
| ffesymbol_signal_change (s); /* Gonna change, save existing? */ |
| |
| /* Establish basictype, kindtype, size; preserve rank, kind, where. */ |
| |
| ffesymbol_set_info (s, |
| ffeinfo_new (ffeinfo_basictype (imp->info), |
| ffeinfo_kindtype (imp->info), |
| ffesymbol_rank (s), |
| ffesymbol_kind (s), |
| ffesymbol_where (s), |
| ffeinfo_size (imp->info))); |
| |
| if (imp->state == FFEIMPLIC_stateINITIAL_) |
| imp->state = FFEIMPLIC_stateASSUMED_; |
| |
| if (ffe_is_warn_implicit ()) |
| { |
| ffebad_start_msg ("Implicit declaration of `%A' at %0", |
| FFEBAD_severityWARNING); |
| ffebad_here (0, ffesymbol_where_line (s), |
| ffesymbol_where_column (s)); |
| ffebad_string (ffesymbol_text (s)); |
| ffebad_finish (); |
| } |
| |
| return TRUE; |
| } |
| |
| /* ffeimplic_init_2 -- Initialize table |
| |
| ffeimplic_init_2(); |
| |
| Assigns initial type information to all initial letters. |
| |
| Allows for holes in the sequence of letters (i.e. EBCDIC). */ |
| |
| void |
| ffeimplic_init_2 () |
| { |
| ffeimplic_ imp; |
| char c; |
| |
| for (c = 'A'; c <= 'z'; ++c) |
| { |
| imp = &ffeimplic_table_[c - 'A']; |
| imp->state = FFEIMPLIC_stateINITIAL_; |
| switch (c) |
| { |
| case 'A': |
| case 'B': |
| case 'C': |
| case 'D': |
| case 'E': |
| case 'F': |
| case 'G': |
| case 'H': |
| case 'O': |
| case 'P': |
| case 'Q': |
| case 'R': |
| case 'S': |
| case 'T': |
| case 'U': |
| case 'V': |
| case 'W': |
| case 'X': |
| case 'Y': |
| case 'Z': |
| case '_': |
| case 'a': |
| case 'b': |
| case 'c': |
| case 'd': |
| case 'e': |
| case 'f': |
| case 'g': |
| case 'h': |
| case 'o': |
| case 'p': |
| case 'q': |
| case 'r': |
| case 's': |
| case 't': |
| case 'u': |
| case 'v': |
| case 'w': |
| case 'x': |
| case 'y': |
| case 'z': |
| imp->info = ffeinfo_new (FFEINFO_basictypeREAL, |
| FFEINFO_kindtypeREALDEFAULT, |
| 0, |
| FFEINFO_kindNONE, |
| FFEINFO_whereNONE, |
| FFETARGET_charactersizeNONE); |
| break; |
| |
| case 'I': |
| case 'J': |
| case 'K': |
| case 'L': |
| case 'M': |
| case 'N': |
| case 'i': |
| case 'j': |
| case 'k': |
| case 'l': |
| case 'm': |
| case 'n': |
| imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER, |
| FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE, |
| FFETARGET_charactersizeNONE); |
| break; |
| |
| default: |
| imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, |
| FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE); |
| break; |
| } |
| } |
| } |
| |
| /* ffeimplic_none -- Implement IMPLICIT NONE statement |
| |
| ffeimplic_none(); |
| |
| Assigns null type information to all initial letters. */ |
| |
| void |
| ffeimplic_none () |
| { |
| ffeimplic_ imp; |
| |
| for (imp = &ffeimplic_table_[0]; |
| imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)]; |
| imp++) |
| { |
| imp->info = ffeinfo_new (FFEINFO_basictypeNONE, |
| FFEINFO_kindtypeNONE, |
| 0, |
| FFEINFO_kindNONE, |
| FFEINFO_whereNONE, |
| FFETARGET_charactersizeNONE); |
| } |
| } |
| |
| /* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol |
| |
| ffesymbol s; |
| const char *name; // name for s in case it is NULL, or NULL if s never NULL |
| if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER) |
| // is or will be a CHARACTER-typed name |
| |
| Like establish_symbol, but doesn't change anything. |
| |
| If symbol is non-NULL and already has a type, return it. |
| Get first character of symbol's name or from name arg if symbol is NULL. |
| Get ffeimplic_ object for it (return FALSE if NULL returned). |
| Return NONE if object has no assigned type (IMPLICIT NONE). |
| Return the data type indicated in the object. |
| |
| 24-Oct-91 JCB 2.0 |
| Take a char * instead of ffelexToken, since the latter isn't always |
| needed anyway (as when ffecom calls it). */ |
| |
| ffeinfoBasictype |
| ffeimplic_peek_symbol_type (ffesymbol s, const char *name) |
| { |
| char c; |
| ffeimplic_ imp; |
| |
| if (s == NULL) |
| c = *name; |
| else |
| { |
| if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) |
| return ffesymbol_basictype (s); |
| |
| c = *(ffesymbol_text (s)); |
| } |
| |
| imp = ffeimplic_lookup_ (c); |
| if (imp == NULL) |
| return FFEINFO_basictypeNONE; /* First character not A-Z or |
| something. */ |
| return ffeinfo_basictype (imp->info); |
| } |
| |
| /* ffeimplic_terminate_2 -- Terminate table |
| |
| ffeimplic_terminate_2(); |
| |
| Kills info object for each entry in table. */ |
| |
| void |
| ffeimplic_terminate_2 () |
| { |
| } |