contrib/gcc/f/implic.c

   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
   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 \f
  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 (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
 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       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
 221 void
 222 ffeimplic_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
 313 void
 314 ffeimplic_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
 350 ffeinfoBasictype
 351 ffeimplic_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
 379 void
 380 ffeimplic_terminate_2 ()
 381 {
 382 }