gcc/f/src.c

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