gcc/f/implic.c

   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 \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 (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 }