gcc/f/src.c

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