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 (burley@gnu.org).
   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 <ctype.h>
  35 #include "implic.h"
  36 #include "info.h"
  37 #include "src.h"
  38 #include "symbol.h"
  39 #include "target.h"
  40
  41 /* Externals defined here. */
  42
  43
  44 /* Simple definitions and enumerations. */
  45
  46 typedef enum
  47   {
  48     FFEIMPLIC_stateINITIAL_,
  49     FFEIMPLIC_stateASSUMED_,
  50     FFEIMPLIC_stateESTABLISHED_,
  51     FFEIMPLIC_state
  52   } ffeimplicState_;
  53
  54 /* Internal typedefs. */
  55
  56 typedef struct _ffeimplic_ *ffeimplic_;
  57
  58 /* Private include files. */
  59
  60
  61 /* Internal structure definitions. */
  62
  63 struct _ffeimplic_
  64   {
  65     ffeimplicState_ state;
  66     ffeinfo info;
  67   };
  68
  69 /* Static objects accessed by functions in this module. */
  70
  71 /* NOTE: This is definitely ASCII-specific!!  */
  72
  73 static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1];
  74
  75 /* Static functions (internal). */
  76
  77 static ffeimplic_ ffeimplic_lookup_ (char c);
  78
  79 /* Internal macros. */
  80 \f
  81
  82 /* ffeimplic_lookup_ -- Look up implicit descriptor for initial character
  83
  84    ffeimplic_ imp;
  85    if ((imp = ffeimplic_lookup_('A')) == NULL)
  86        // error
  87
  88    Returns a pointer to an implicit descriptor block based on the character
  89    passed, or NULL if it is not a valid initial character for an implicit
  90    data type.  */
  91
  92 static ffeimplic_
  93 ffeimplic_lookup_ (char c)
  94 {
  95   /* NOTE: This is definitely ASCII-specific!!  */
  96   if (isalpha (c) || (c == '_'))
  97     return &ffeimplic_table_[c - 'A'];
  98   return NULL;
  99 }
 100
 101 /* ffeimplic_establish_initial -- Establish type of implicit initial letter
 102
 103    ffesymbol s;
 104    if (!ffeimplic_establish_initial(s))
 105        // error
 106
 107    Assigns implicit type information to the symbol based on the first
 108    character of the symbol's name.  */
 109
 110 bool
 111 ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
 112                      ffeinfoKindtype kind_type, ffetargetCharacterSize size)
 113 {
 114   ffeimplic_ imp;
 115
 116   imp = ffeimplic_lookup_ (c);
 117   if (imp == NULL)
 118     return FALSE;               /* Character not A-Z or some such thing. */
 119   if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
 120     return FALSE;               /* IMPLICIT NONE in effect here. */
 121
 122   switch (imp->state)
 123     {
 124     case FFEIMPLIC_stateINITIAL_:
 125       imp->info = ffeinfo_new (basic_type,
 126                                kind_type,
 127                                0,
 128                                FFEINFO_kindNONE,
 129                                FFEINFO_whereNONE,
 130                                size);
 131       imp->state = FFEIMPLIC_stateESTABLISHED_;
 132       return TRUE;
 133
 134     case FFEIMPLIC_stateASSUMED_:
 135       if ((ffeinfo_basictype (imp->info) != basic_type)
 136           || (ffeinfo_kindtype (imp->info) != kind_type)
 137           || (ffeinfo_size (imp->info) != size))
 138         return FALSE;
 139       imp->state = FFEIMPLIC_stateESTABLISHED_;
 140       return TRUE;
 141
 142     case FFEIMPLIC_stateESTABLISHED_:
 143       return FALSE;
 144
 145     default:
 146       assert ("Weird state for implicit object" == NULL);
 147       return FALSE;
 148     }
 149 }
 150
 151 /* ffeimplic_establish_symbol -- Establish implicit type of a symbol
 152
 153    ffesymbol s;
 154    if (!ffeimplic_establish_symbol(s))
 155        // error
 156
 157    Assigns implicit type information to the symbol based on the first
 158    character of the symbol's name.
 159
 160    If symbol already has a type, return TRUE.
 161    Get first character of symbol's name.
 162    Get ffeimplic_ object for it (return FALSE if NULL returned).
 163    Return FALSE if object has no assigned type (IMPLICIT NONE).
 164    Copy the type information from the object to the symbol.
 165    If the object is state "INITIAL", set to state "ASSUMED" so no
 166        subsequent IMPLICIT statement may change the state.
 167    Return TRUE.  */
 168
 169 bool
 170 ffeimplic_establish_symbol (ffesymbol s)
 171 {
 172   char c;
 173   ffeimplic_ imp;
 174
 175   if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
 176     return TRUE;
 177
 178   c = *(ffesymbol_text (s));
 179   imp = ffeimplic_lookup_ (c);
 180   if (imp == NULL)
 181     return FALSE;               /* First character not A-Z or some such
 182                                    thing. */
 183   if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
 184     return FALSE;               /* IMPLICIT NONE in effect here. */
 185
 186   ffesymbol_signal_change (s);  /* Gonna change, save existing? */
 187
 188   /* Establish basictype, kindtype, size; preserve rank, kind, where. */
 189
 190   ffesymbol_set_info (s,
 191                       ffeinfo_new (ffeinfo_basictype (imp->info),
 192                                    ffeinfo_kindtype (imp->info),
 193                                    ffesymbol_rank (s),
 194                                    ffesymbol_kind (s),
 195                                    ffesymbol_where (s),
 196                                    ffeinfo_size (imp->info)));
 197
 198   if (imp->state == FFEIMPLIC_stateINITIAL_)
 199     imp->state = FFEIMPLIC_stateASSUMED_;
 200
 201   if (ffe_is_warn_implicit ())
 202     {
 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    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, 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 }