gcc/f/src.c

   1 /* src.c -- Implementation File
   2    Copyright (C) 1995, 2003 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
  24    Description:
  25       Source-file functions to handle various combinations of case sensitivity
  26       and insensitivity at run time.
  27
  28    Modifications:
  29 */
  30
  31 #include "proj.h"
  32 #include "src.h"
  33 #include "top.h"
  34
  35 /* This array is set up so that, given a source-mapped character, the result
  36    of indexing into this array will match an upper-cased character depending
  37    on the source-mapped character's case and the established ffe_case_match()
  38    setting.  So the uppercase cells contain identies (e.g. ['A'] == 'A')
  39    as long as uppercase matching is permitted (!FFE_caseLOWER) and the
  40    lowercase cells contain uppercased identities (e.g. ['a'] == 'A') as long
  41    as lowercase matching is permitted (!FFE_caseUPPER).  Else the case
  42    cells contain -1.  _init_ is for the first character of a keyword,
  43    and _noninit_ is for other characters.  */
  44
  45 char ffesrc_char_match_init_[256];
  46 char ffesrc_char_match_noninit_[256];
  47
  48 /* This array is used to map input source according to the established
  49    ffe_case_source() setting: for FFE_caseNONE, the array is all
  50    identities; for FFE_caseUPPER, the lowercase cells contain
  51    uppercased identities; and vice versa for FFE_caseLOWER.  */
  52
  53 char ffesrc_char_source_[256];
  54
  55 /* This array is used to map an internally generated character so that it
  56    will be accepted as an initial character in a keyword.  The assumption
  57    is that the incoming character is uppercase.  */
  58
  59 char ffesrc_char_internal_init_[256];
  60
  61 /* This array is used to determine if a particular character is valid in
  62    a symbol name according to the established ffe_case_symbol() setting:
  63    for FFE_caseNONE, the array is all FFEBAD; for FFE_caseUPPER, the
  64    lowercase cells contain a non-FFEBAD error code (FFEBAD_SYMBOL_UPPER_CASE);
  65    and vice versa for FFE_caseLOWER.  _init_ and _noninit_ distinguish
  66    between initial and subsequent characters for the caseINITCAP case,
  67    and their error codes are different for appropriate messages --
  68    specifically, _noninit_ contains a non-FFEBAD error code for all
  69    except lowercase characters for the caseINITCAP case.
  70
  71    See ffesrc_check_symbol_, it must be TRUE if this array is not all
  72    FFEBAD.  */
  73
  74 ffebad ffesrc_bad_symbol_init_[256];
  75 ffebad ffesrc_bad_symbol_noninit_[256];
  76
  77 /* Set TRUE if any element in ffesrc_bad_symbol (with an index representing
  78    a character that can also be in the text of a token passed to
  79    ffename_find, strictly speaking) is not FFEBAD.  I.e., TRUE if it is
  80    necessary to check token characters against the ffesrc_bad_symbol_
  81    array.  */
  82
  83 bool ffesrc_check_symbol_;
  84
  85 /* These are set TRUE if the kind of character (upper/lower) is ok as a match
  86    in the context (initial/noninitial character of keyword).  */
  87
  88 bool ffesrc_ok_match_init_upper_;
  89 bool ffesrc_ok_match_init_lower_;
  90 bool ffesrc_ok_match_noninit_upper_;
  91 bool ffesrc_ok_match_noninit_lower_;
  92 \f
  93 /* Initialize table of alphabetic matches. */
  94
  95 void
  96 ffesrc_init_1 (void)
  97 {
  98   int i;
  99
 100   for (i = 0; i < 256; ++i)
 101     {
 102       ffesrc_char_match_init_[i] = i;
 103       ffesrc_char_match_noninit_[i] = i;
 104       ffesrc_char_source_[i] = i;
 105       ffesrc_char_internal_init_[i] = i;
 106       ffesrc_bad_symbol_init_[i] = FFEBAD;
 107       ffesrc_bad_symbol_noninit_[i] = FFEBAD;
 108     }
 109
 110   ffesrc_check_symbol_ = (ffe_case_symbol () != FFE_caseNONE);
 111
 112   ffesrc_ok_match_init_upper_ = (ffe_case_match () != FFE_caseLOWER);
 113   ffesrc_ok_match_init_lower_ = (ffe_case_match () != FFE_caseUPPER)
 114     && (ffe_case_match () != FFE_caseINITCAP);
 115   ffesrc_ok_match_noninit_upper_ = (ffe_case_match () != FFE_caseLOWER)
 116     && (ffe_case_match () != FFE_caseINITCAP);
 117   ffesrc_ok_match_noninit_lower_ = (ffe_case_match () != FFE_caseUPPER);
 118
 119   /* Note that '-' is used to flag an invalid match character.  '-' is
 120      somewhat arbitrary, actually.  -1 was used, but that's not wise on a
 121      system with unsigned chars as default -- it'd turn into 255 or some such
 122      large positive number, which would sort higher than the alphabetics and
 123      thus possibly cause problems.  So '-' is picked just because it's never
 124      likely to be a symbol character in Fortran and because it's "less than"
 125      any alphabetic character.  EBCDIC might see things differently, I don't
 126      remember it well enough, but that's just tough -- lots of other things
 127      might have to change to support EBCDIC -- anyway, some other character
 128      could easily be picked.  */
 129
 130 #define FFESRC_INVALID_SYMBOL_CHAR_ '-'
 131
 132   if (!ffesrc_ok_match_init_upper_)
 133     for (i = 'A'; i <= 'Z'; ++i)
 134       ffesrc_char_match_init_[i] = FFESRC_INVALID_SYMBOL_CHAR_;
 135
 136   if (ffesrc_ok_match_init_lower_)
 137     for (i = 'a'; i <= 'z'; ++i)
 138       ffesrc_char_match_init_[i] = TOUPPER (i);
 139   else
 140     for (i = 'a'; i <= 'z'; ++i)
 141       ffesrc_char_match_init_[i] = FFESRC_INVALID_SYMBOL_CHAR_;
 142
 143   if (!ffesrc_ok_match_noninit_upper_)
 144     for (i = 'A'; i <= 'Z'; ++i)
 145       ffesrc_char_match_noninit_[i] = FFESRC_INVALID_SYMBOL_CHAR_;
 146
 147   if (ffesrc_ok_match_noninit_lower_)
 148     for (i = 'a'; i <= 'z'; ++i)
 149       ffesrc_char_match_noninit_[i] = TOUPPER (i);
 150   else
 151     for (i = 'a'; i <= 'z'; ++i)
 152       ffesrc_char_match_noninit_[i] = FFESRC_INVALID_SYMBOL_CHAR_;
 153
 154   if (ffe_case_source () == FFE_caseLOWER)
 155     for (i = 'A'; i <= 'Z'; ++i)
 156       ffesrc_char_source_[i] = TOLOWER (i);
 157   else if (ffe_case_source () == FFE_caseUPPER)
 158     for (i = 'a'; i <= 'z'; ++i)
 159       ffesrc_char_source_[i] = TOUPPER (i);
 160
 161   if (ffe_case_match () == FFE_caseLOWER)
 162     for (i = 'A'; i <= 'Z'; ++i)
 163       ffesrc_char_internal_init_[i] = TOLOWER (i);
 164
 165   switch (ffe_case_symbol ())
 166     {
 167     case FFE_caseLOWER:
 168       for (i = 'A'; i <= 'Z'; ++i)
 169         {
 170           ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_UPPER_CASE;
 171           ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_UPPER_CASE;
 172         }
 173       break;
 174
 175     case FFE_caseUPPER:
 176       for (i = 'a'; i <= 'z'; ++i)
 177         {
 178           ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_LOWER_CASE;
 179           ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_LOWER_CASE;
 180         }
 181       break;
 182
 183     case FFE_caseINITCAP:
 184       for (i = 0; i < 256; ++i)
 185         ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_NOLOWER_INITCAP;
 186       for (i = 'a'; i <= 'z'; ++i)
 187         {
 188           ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_LOWER_INITCAP;
 189           ffesrc_bad_symbol_noninit_[i] = FFEBAD;
 190         }
 191       break;
 192
 193     default:
 194       break;
 195     }
 196 }
 197
 198 /* Compare two strings a la strcmp, the first being a source string with its
 199    length passed, and the second being a constant string passed
 200    in InitialCaps form.  Also, the return value is always -1, 0, or 1. */
 201
 202 int
 203 ffesrc_strcmp_1ns2i (ffeCase mcase, const char *var, int len,
 204                      const char *str_ic)
 205 {
 206   char c;
 207   char d;
 208
 209   switch (mcase)
 210     {
 211     case FFE_caseNONE:
 212       for (; len > 0; --len, ++var, ++str_ic)
 213         {
 214           c = ffesrc_char_source (*var);        /* Transform source. */
 215           c = TOUPPER (c);                      /* Upcase source. */
 216           d = TOUPPER (*str_ic);                /* Upcase InitialCaps char. */
 217           if (c != d)
 218             {
 219               if ((d != '\0') && (c < d))
 220                 return -1;
 221               else
 222                 return 1;
 223             }
 224         }
 225       break;
 226
 227     case FFE_caseUPPER:
 228       for (; len > 0; --len, ++var, ++str_ic)
 229         {
 230           c = ffesrc_char_source (*var);        /* Transform source. */
 231           d = TOUPPER (*str_ic);        /* Transform InitialCaps char. */
 232           if (c != d)
 233             {
 234               if ((d != '\0') && (c < d))
 235                 return -1;
 236               else
 237                 return 1;
 238             }
 239         }
 240       break;
 241
 242     case FFE_caseLOWER:
 243       for (; len > 0; --len, ++var, ++str_ic)
 244         {
 245           c = ffesrc_char_source (*var);        /* Transform source. */
 246           d = TOLOWER (*str_ic);        /* Transform InitialCaps char. */
 247           if (c != d)
 248             {
 249               if ((d != '\0') && (c < d))
 250                 return -1;
 251               else
 252                 return 1;
 253             }
 254         }
 255       break;
 256
 257     case FFE_caseINITCAP:
 258       for (; len > 0; --len, ++var, ++str_ic)
 259         {
 260           c = ffesrc_char_source (*var);        /* Transform source. */
 261           d = *str_ic;          /* No transform of InitialCaps char. */
 262           if (c != d)
 263             {
 264               c = TOUPPER (c);
 265               d = TOUPPER (d);
 266               while ((len > 0) && (c == d))
 267                 {               /* Skip past equivalent (case-ins) chars. */
 268                   --len, ++var, ++str_ic;
 269                   if (len > 0)
 270                     c = TOUPPER (*var);
 271                   d = TOUPPER (*str_ic);
 272                 }
 273               if ((d != '\0') && (c < d))
 274                 return -1;
 275               else
 276                 return 1;
 277             }
 278         }
 279       break;
 280
 281     default:
 282       assert ("bad case value" == NULL);
 283       return -1;
 284     }
 285
 286   if (*str_ic == '\0')
 287     return 0;
 288   return -1;
 289 }
 290
 291 /* Compare two strings a la strcmp, the second being a constant string passed
 292    in both uppercase and lowercase form.  If not equal, the uppercase string
 293    is used to determine the sign of the return value.  Also, the return
 294    value is always -1, 0, or 1. */
 295
 296 int
 297 ffesrc_strcmp_2c (ffeCase mcase, const char *var, const char *str_uc,
 298                   const char *str_lc, const char *str_ic)
 299 {
 300   int i;
 301   char c;
 302
 303   switch (mcase)
 304     {
 305     case FFE_caseNONE:
 306       for (; *var != '\0'; ++var, ++str_uc)
 307         {
 308           c = TOUPPER (*var);   /* Upcase source. */
 309           if (c != *str_uc)
 310             {
 311               if ((*str_uc != '\0') && (c < *str_uc))
 312                 return -1;
 313               else
 314                 return 1;
 315             }
 316         }
 317       if (*str_uc == '\0')
 318         return 0;
 319       return -1;
 320
 321     case FFE_caseUPPER:
 322       i = strcmp (var, str_uc);
 323       break;
 324
 325     case FFE_caseLOWER:
 326       i = strcmp (var, str_lc);
 327       break;
 328
 329     case FFE_caseINITCAP:
 330       for (; *var != '\0'; ++var, ++str_ic, ++str_uc)
 331         {
 332           if (*var != *str_ic)
 333             {
 334               c = TOUPPER (*var);
 335               while ((c != '\0') && (c == *str_uc))
 336                 {               /* Skip past equivalent (case-ins) chars. */
 337                   ++var, ++str_uc;
 338                   c = TOUPPER (*var);
 339                 }
 340               if ((*str_uc != '\0') && (c < *str_uc))
 341                 return -1;
 342               else
 343                 return 1;
 344             }
 345         }
 346       if (*str_ic == '\0')
 347         return 0;
 348       return -1;
 349
 350     default:
 351       assert ("bad case value" == NULL);
 352       return -1;
 353     }
 354
 355   if (i == 0)
 356     return 0;
 357   else if (i < 0)
 358     return -1;
 359   return 1;
 360 }
 361
 362 /* Compare two strings a la strncmp, the second being a constant string passed
 363    in uppercase, lowercase, and InitialCaps form.  If not equal, the
 364    uppercase string is used to determine the sign of the return value.  */
 365
 366 int
 367 ffesrc_strncmp_2c (ffeCase mcase, const char *var, const char *str_uc,
 368                    const char *str_lc, const char *str_ic, int len)
 369 {
 370   int i;
 371   char c;
 372
 373   switch (mcase)
 374     {
 375     case FFE_caseNONE:
 376       for (; len > 0; ++var, ++str_uc, --len)
 377         {
 378           c = TOUPPER (*var);   /* Upcase source. */
 379           if (c != *str_uc)
 380             {
 381               if (c < *str_uc)
 382                 return -1;
 383               else
 384                 return 1;
 385             }
 386         }
 387       return 0;
 388
 389     case FFE_caseUPPER:
 390       i = strncmp (var, str_uc, len);
 391       break;
 392
 393     case FFE_caseLOWER:
 394       i = strncmp (var, str_lc, len);
 395       break;
 396
 397     case FFE_caseINITCAP:
 398       for (; len > 0; ++var, ++str_ic, ++str_uc, --len)
 399         {
 400           if (*var != *str_ic)
 401             {
 402               c = TOUPPER (*var);
 403               while ((len > 0) && (c == *str_uc))
 404                 {               /* Skip past equivalent (case-ins) chars. */
 405                   --len, ++var, ++str_uc;
 406                   if (len > 0)
 407                     c = TOUPPER (*var);
 408                 }
 409               if ((len > 0) && (c < *str_uc))
 410                 return -1;
 411               else
 412                 return 1;
 413             }
 414         }
 415       return 0;
 416
 417     default:
 418       assert ("bad case value" == NULL);
 419       return -1;
 420     }
 421
 422   if (i == 0)
 423     return 0;
 424   else if (i < 0)
 425     return -1;
 426   return 1;
 427 }