Open64: osprey/kgccfe/gnu/f/implic.c Source File

00001 /* implic.c -- Implementation File (module.c template V1.0)
00002    Copyright (C) 1995, 2002 Free Software Foundation, Inc.
00003    Contributed by James Craig Burley.
00004 
00005 This file is part of GNU Fortran.
00006 
00007 GNU Fortran is free software; you can redistribute it and/or modify
00008 it under the terms of the GNU General Public License as published by
00009 the Free Software Foundation; either version 2, or (at your option)
00010 any later version.
00011 
00012 GNU Fortran is distributed in the hope that it will be useful,
00013 but WITHOUT ANY WARRANTY; without even the implied warranty of
00014 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00015 GNU General Public License for more details.
00016 
00017 You should have received a copy of the GNU General Public License
00018 along with GNU Fortran; see the file COPYING.  If not, write to
00019 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
00020 02111-1307, USA.
00021 
00022    Related Modules:
00023       None.
00024 
00025    Description:
00026       The GNU Fortran Front End.
00027 
00028    Modifications:
00029 */
00030 
00031 /* Include files. */
00032 
00033 #include "proj.h"
00034 #include "implic.h"
00035 #include "info.h"
00036 #include "src.h"
00037 #include "symbol.h"
00038 #include "target.h"
00039 
00040 /* Externals defined here. */
00041 
00042 
00043 /* Simple definitions and enumerations. */
00044 
00045 typedef enum
00046   {
00047     FFEIMPLIC_stateINITIAL_,
00048     FFEIMPLIC_stateASSUMED_,
00049     FFEIMPLIC_stateESTABLISHED_,
00050     FFEIMPLIC_state
00051   } ffeimplicState_;
00052 
00053 /* Internal typedefs. */
00054 
00055 typedef struct _ffeimplic_ *ffeimplic_;
00056 
00057 /* Private include files. */
00058 
00059 
00060 /* Internal structure definitions. */
00061 
00062 struct _ffeimplic_
00063   {
00064     ffeimplicState_ state;
00065     ffeinfo info;
00066   };
00067 
00068 /* Static objects accessed by functions in this module. */
00069 
00070 /* NOTE: This is definitely ASCII-specific!!  */
00071 
00072 static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1];
00073 
00074 /* Static functions (internal). */
00075 
00076 static ffeimplic_ ffeimplic_lookup_ (unsigned char c);
00077 
00078 /* Internal macros. */
00079 
00080 
00081 /* ffeimplic_lookup_ -- Look up implicit descriptor for initial character
00082 
00083    ffeimplic_ imp;
00084    if ((imp = ffeimplic_lookup_('A')) == NULL)
00085        // error
00086 
00087    Returns a pointer to an implicit descriptor block based on the character
00088    passed, or NULL if it is not a valid initial character for an implicit
00089    data type.  */
00090 
00091 static ffeimplic_
00092 ffeimplic_lookup_ (unsigned char c)
00093 {
00094   /* NOTE: This is definitely ASCII-specific!!  */
00095   if (ISIDST (c))
00096     return &ffeimplic_table_[c - 'A'];
00097   return NULL;
00098 }
00099 
00100 /* ffeimplic_establish_initial -- Establish type of implicit initial letter
00101 
00102    ffesymbol s;
00103    if (!ffeimplic_establish_initial(s))
00104        // error
00105 
00106    Assigns implicit type information to the symbol based on the first
00107    character of the symbol's name.  */
00108 
00109 bool
00110 ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
00111          ffeinfoKindtype kind_type, ffetargetCharacterSize size)
00112 {
00113   ffeimplic_ imp;
00114 
00115   imp = ffeimplic_lookup_ (c);
00116   if (imp == NULL)
00117     return FALSE;   /* Character not A-Z or some such thing. */
00118   if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
00119     return FALSE;   /* IMPLICIT NONE in effect here. */
00120 
00121   switch (imp->state)
00122     {
00123     case FFEIMPLIC_stateINITIAL_:
00124       imp->info = ffeinfo_new (basic_type,
00125              kind_type,
00126              0,
00127              FFEINFO_kindNONE,
00128              FFEINFO_whereNONE,
00129              size);
00130       imp->state = FFEIMPLIC_stateESTABLISHED_;
00131       return TRUE;
00132 
00133     case FFEIMPLIC_stateASSUMED_:
00134       if ((ffeinfo_basictype (imp->info) != basic_type)
00135     || (ffeinfo_kindtype (imp->info) != kind_type)
00136     || (ffeinfo_size (imp->info) != size))
00137   return FALSE;
00138       imp->state = FFEIMPLIC_stateESTABLISHED_;
00139       return TRUE;
00140 
00141     case FFEIMPLIC_stateESTABLISHED_:
00142       return FALSE;
00143 
00144     default:
00145       assert ("Weird state for implicit object" == NULL);
00146       return FALSE;
00147     }
00148 }
00149 
00150 /* ffeimplic_establish_symbol -- Establish implicit type of a symbol
00151 
00152    ffesymbol s;
00153    if (!ffeimplic_establish_symbol(s))
00154        // error
00155 
00156    Assigns implicit type information to the symbol based on the first
00157    character of the symbol's name.
00158 
00159    If symbol already has a type, return TRUE.
00160    Get first character of symbol's name.
00161    Get ffeimplic_ object for it (return FALSE if NULL returned).
00162    Return FALSE if object has no assigned type (IMPLICIT NONE).
00163    Copy the type information from the object to the symbol.
00164    If the object is state "INITIAL", set to state "ASSUMED" so no
00165        subsequent IMPLICIT statement may change the state.
00166    Return TRUE.  */
00167 
00168 bool
00169 ffeimplic_establish_symbol (ffesymbol s)
00170 {
00171   char c;
00172   ffeimplic_ imp;
00173 
00174   if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
00175     return TRUE;
00176 
00177   c = *(ffesymbol_text (s));
00178   imp = ffeimplic_lookup_ (c);
00179   if (imp == NULL)
00180     return FALSE;   /* First character not A-Z or some such
00181            thing. */
00182   if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
00183     return FALSE;   /* IMPLICIT NONE in effect here. */
00184 
00185   ffesymbol_signal_change (s);  /* Gonna change, save existing? */
00186 
00187   /* Establish basictype, kindtype, size; preserve rank, kind, where. */
00188 
00189   ffesymbol_set_info (s,
00190           ffeinfo_new (ffeinfo_basictype (imp->info),
00191            ffeinfo_kindtype (imp->info),
00192            ffesymbol_rank (s),
00193            ffesymbol_kind (s),
00194            ffesymbol_where (s),
00195            ffeinfo_size (imp->info)));
00196 
00197   if (imp->state == FFEIMPLIC_stateINITIAL_)
00198     imp->state = FFEIMPLIC_stateASSUMED_;
00199 
00200   if (ffe_is_warn_implicit ())
00201     {
00202       /* xgettext:no-c-format */
00203       ffebad_start_msg ("Implicit declaration of `%A' at %0",
00204       FFEBAD_severityWARNING);
00205       ffebad_here (0, ffesymbol_where_line (s),
00206        ffesymbol_where_column (s));
00207       ffebad_string (ffesymbol_text (s));
00208       ffebad_finish ();
00209     }
00210 
00211   return TRUE;
00212 }
00213 
00214 /* ffeimplic_init_2 -- Initialize table
00215 
00216    ffeimplic_init_2();
00217 
00218    Assigns initial type information to all initial letters.
00219 
00220    Allows for holes in the sequence of letters (i.e. EBCDIC).  */
00221 
00222 void
00223 ffeimplic_init_2 ()
00224 {
00225   ffeimplic_ imp;
00226   char c;
00227 
00228   for (c = 'A'; c <= 'z'; ++c)
00229     {
00230       imp = &ffeimplic_table_[c - 'A'];
00231       imp->state = FFEIMPLIC_stateINITIAL_;
00232       switch (c)
00233   {
00234   case 'A':
00235   case 'B':
00236   case 'C':
00237   case 'D':
00238   case 'E':
00239   case 'F':
00240   case 'G':
00241   case 'H':
00242   case 'O':
00243   case 'P':
00244   case 'Q':
00245   case 'R':
00246   case 'S':
00247   case 'T':
00248   case 'U':
00249   case 'V':
00250   case 'W':
00251   case 'X':
00252   case 'Y':
00253   case 'Z':
00254   case '_':
00255   case 'a':
00256   case 'b':
00257   case 'c':
00258   case 'd':
00259   case 'e':
00260   case 'f':
00261   case 'g':
00262   case 'h':
00263   case 'o':
00264   case 'p':
00265   case 'q':
00266   case 'r':
00267   case 's':
00268   case 't':
00269   case 'u':
00270   case 'v':
00271   case 'w':
00272   case 'x':
00273   case 'y':
00274   case 'z':
00275     imp->info = ffeinfo_new (FFEINFO_basictypeREAL,
00276            FFEINFO_kindtypeREALDEFAULT,
00277            0,
00278            FFEINFO_kindNONE,
00279            FFEINFO_whereNONE,
00280            FFETARGET_charactersizeNONE);
00281     break;
00282 
00283   case 'I':
00284   case 'J':
00285   case 'K':
00286   case 'L':
00287   case 'M':
00288   case 'N':
00289   case 'i':
00290   case 'j':
00291   case 'k':
00292   case 'l':
00293   case 'm':
00294   case 'n':
00295     imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER,
00296            FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE,
00297            FFETARGET_charactersizeNONE);
00298     break;
00299 
00300   default:
00301     imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0,
00302     FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE);
00303     break;
00304   }
00305     }
00306 }
00307 
00308 /* ffeimplic_none -- Implement IMPLICIT NONE statement
00309 
00310    ffeimplic_none();
00311 
00312    Assigns null type information to all initial letters.  */
00313 
00314 void
00315 ffeimplic_none ()
00316 {
00317   ffeimplic_ imp;
00318 
00319   for (imp = &ffeimplic_table_[0];
00320        imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)];
00321        imp++)
00322     {
00323       imp->info = ffeinfo_new (FFEINFO_basictypeNONE,
00324              FFEINFO_kindtypeNONE,
00325              0,
00326              FFEINFO_kindNONE,
00327              FFEINFO_whereNONE,
00328              FFETARGET_charactersizeNONE);
00329     }
00330 }
00331 
00332 /* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol
00333 
00334    ffesymbol s;
00335    const char *name; // name for s in case it is NULL, or NULL if s never NULL
00336    if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER)
00337        // is or will be a CHARACTER-typed name
00338 
00339    Like establish_symbol, but doesn't change anything.
00340 
00341    If symbol is non-NULL and already has a type, return it.
00342    Get first character of symbol's name or from name arg if symbol is NULL.
00343    Get ffeimplic_ object for it (return FALSE if NULL returned).
00344    Return NONE if object has no assigned type (IMPLICIT NONE).
00345    Return the data type indicated in the object.
00346 
00347    24-Oct-91  JCB  2.0
00348       Take a char * instead of ffelexToken, since the latter isn't always
00349       needed anyway (as when ffecom calls it).  */
00350 
00351 ffeinfoBasictype
00352 ffeimplic_peek_symbol_type (ffesymbol s, const char *name)
00353 {
00354   char c;
00355   ffeimplic_ imp;
00356 
00357   if (s == NULL)
00358     c = *name;
00359   else
00360     {
00361       if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
00362   return ffesymbol_basictype (s);
00363 
00364       c = *(ffesymbol_text (s));
00365     }
00366 
00367   imp = ffeimplic_lookup_ (c);
00368   if (imp == NULL)
00369     return FFEINFO_basictypeNONE; /* First character not A-Z or
00370              something. */
00371   return ffeinfo_basictype (imp->info);
00372 }
00373 
00374 /* ffeimplic_terminate_2 -- Terminate table
00375 
00376    ffeimplic_terminate_2();
00377 
00378    Kills info object for each entry in table.  */
00379 
00380 void
00381 ffeimplic_terminate_2 ()
00382 {
00383 }