| /* src.c -- Implementation File |
| Copyright (C) 1995, 2003 Free Software Foundation, Inc. |
| Contributed by James Craig Burley. |
| |
| This file is part of GNU Fortran. |
| |
| GNU Fortran is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 2, or (at your option) |
| any later version. |
| |
| GNU Fortran is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GNU Fortran; see the file COPYING. If not, write to |
| the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA |
| 02111-1307, USA. |
| |
| Related Modules: |
| |
| Description: |
| Source-file functions to handle various combinations of case sensitivity |
| and insensitivity at run time. |
| |
| Modifications: |
| */ |
| |
| #include "proj.h" |
| #include "src.h" |
| #include "top.h" |
| |
| /* This array is set up so that, given a source-mapped character, the result |
| of indexing into this array will match an upper-cased character depending |
| on the source-mapped character's case and the established ffe_case_match() |
| setting. So the uppercase cells contain identies (e.g. ['A'] == 'A') |
| as long as uppercase matching is permitted (!FFE_caseLOWER) and the |
| lowercase cells contain uppercased identities (e.g. ['a'] == 'A') as long |
| as lowercase matching is permitted (!FFE_caseUPPER). Else the case |
| cells contain -1. _init_ is for the first character of a keyword, |
| and _noninit_ is for other characters. */ |
| |
| char ffesrc_char_match_init_[256]; |
| char ffesrc_char_match_noninit_[256]; |
| |
| /* This array is used to map input source according to the established |
| ffe_case_source() setting: for FFE_caseNONE, the array is all |
| identities; for FFE_caseUPPER, the lowercase cells contain |
| uppercased identities; and vice versa for FFE_caseLOWER. */ |
| |
| char ffesrc_char_source_[256]; |
| |
| /* This array is used to map an internally generated character so that it |
| will be accepted as an initial character in a keyword. The assumption |
| is that the incoming character is uppercase. */ |
| |
| char ffesrc_char_internal_init_[256]; |
| |
| /* This array is used to determine if a particular character is valid in |
| a symbol name according to the established ffe_case_symbol() setting: |
| for FFE_caseNONE, the array is all FFEBAD; for FFE_caseUPPER, the |
| lowercase cells contain a non-FFEBAD error code (FFEBAD_SYMBOL_UPPER_CASE); |
| and vice versa for FFE_caseLOWER. _init_ and _noninit_ distinguish |
| between initial and subsequent characters for the caseINITCAP case, |
| and their error codes are different for appropriate messages -- |
| specifically, _noninit_ contains a non-FFEBAD error code for all |
| except lowercase characters for the caseINITCAP case. |
| |
| See ffesrc_check_symbol_, it must be TRUE if this array is not all |
| FFEBAD. */ |
| |
| ffebad ffesrc_bad_symbol_init_[256]; |
| ffebad ffesrc_bad_symbol_noninit_[256]; |
| |
| /* Set TRUE if any element in ffesrc_bad_symbol (with an index representing |
| a character that can also be in the text of a token passed to |
| ffename_find, strictly speaking) is not FFEBAD. I.e., TRUE if it is |
| necessary to check token characters against the ffesrc_bad_symbol_ |
| array. */ |
| |
| bool ffesrc_check_symbol_; |
| |
| /* These are set TRUE if the kind of character (upper/lower) is ok as a match |
| in the context (initial/noninitial character of keyword). */ |
| |
| bool ffesrc_ok_match_init_upper_; |
| bool ffesrc_ok_match_init_lower_; |
| bool ffesrc_ok_match_noninit_upper_; |
| bool ffesrc_ok_match_noninit_lower_; |
| |
| /* Initialize table of alphabetic matches. */ |
| |
| void |
| ffesrc_init_1 (void) |
| { |
| int i; |
| |
| for (i = 0; i < 256; ++i) |
| { |
| ffesrc_char_match_init_[i] = i; |
| ffesrc_char_match_noninit_[i] = i; |
| ffesrc_char_source_[i] = i; |
| ffesrc_char_internal_init_[i] = i; |
| ffesrc_bad_symbol_init_[i] = FFEBAD; |
| ffesrc_bad_symbol_noninit_[i] = FFEBAD; |
| } |
| |
| ffesrc_check_symbol_ = (ffe_case_symbol () != FFE_caseNONE); |
| |
| ffesrc_ok_match_init_upper_ = (ffe_case_match () != FFE_caseLOWER); |
| ffesrc_ok_match_init_lower_ = (ffe_case_match () != FFE_caseUPPER) |
| && (ffe_case_match () != FFE_caseINITCAP); |
| ffesrc_ok_match_noninit_upper_ = (ffe_case_match () != FFE_caseLOWER) |
| && (ffe_case_match () != FFE_caseINITCAP); |
| ffesrc_ok_match_noninit_lower_ = (ffe_case_match () != FFE_caseUPPER); |
| |
| /* Note that '-' is used to flag an invalid match character. '-' is |
| somewhat arbitrary, actually. -1 was used, but that's not wise on a |
| system with unsigned chars as default -- it'd turn into 255 or some such |
| large positive number, which would sort higher than the alphabetics and |
| thus possibly cause problems. So '-' is picked just because it's never |
| likely to be a symbol character in Fortran and because it's "less than" |
| any alphabetic character. EBCDIC might see things differently, I don't |
| remember it well enough, but that's just tough -- lots of other things |
| might have to change to support EBCDIC -- anyway, some other character |
| could easily be picked. */ |
| |
| #define FFESRC_INVALID_SYMBOL_CHAR_ '-' |
| |
| if (!ffesrc_ok_match_init_upper_) |
| for (i = 'A'; i <= 'Z'; ++i) |
| ffesrc_char_match_init_[i] = FFESRC_INVALID_SYMBOL_CHAR_; |
| |
| if (ffesrc_ok_match_init_lower_) |
| for (i = 'a'; i <= 'z'; ++i) |
| ffesrc_char_match_init_[i] = TOUPPER (i); |
| else |
| for (i = 'a'; i <= 'z'; ++i) |
| ffesrc_char_match_init_[i] = FFESRC_INVALID_SYMBOL_CHAR_; |
| |
| if (!ffesrc_ok_match_noninit_upper_) |
| for (i = 'A'; i <= 'Z'; ++i) |
| ffesrc_char_match_noninit_[i] = FFESRC_INVALID_SYMBOL_CHAR_; |
| |
| if (ffesrc_ok_match_noninit_lower_) |
| for (i = 'a'; i <= 'z'; ++i) |
| ffesrc_char_match_noninit_[i] = TOUPPER (i); |
| else |
| for (i = 'a'; i <= 'z'; ++i) |
| ffesrc_char_match_noninit_[i] = FFESRC_INVALID_SYMBOL_CHAR_; |
| |
| if (ffe_case_source () == FFE_caseLOWER) |
| for (i = 'A'; i <= 'Z'; ++i) |
| ffesrc_char_source_[i] = TOLOWER (i); |
| else if (ffe_case_source () == FFE_caseUPPER) |
| for (i = 'a'; i <= 'z'; ++i) |
| ffesrc_char_source_[i] = TOUPPER (i); |
| |
| if (ffe_case_match () == FFE_caseLOWER) |
| for (i = 'A'; i <= 'Z'; ++i) |
| ffesrc_char_internal_init_[i] = TOLOWER (i); |
| |
| switch (ffe_case_symbol ()) |
| { |
| case FFE_caseLOWER: |
| for (i = 'A'; i <= 'Z'; ++i) |
| { |
| ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_UPPER_CASE; |
| ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_UPPER_CASE; |
| } |
| break; |
| |
| case FFE_caseUPPER: |
| for (i = 'a'; i <= 'z'; ++i) |
| { |
| ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_LOWER_CASE; |
| ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_LOWER_CASE; |
| } |
| break; |
| |
| case FFE_caseINITCAP: |
| for (i = 0; i < 256; ++i) |
| ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_NOLOWER_INITCAP; |
| for (i = 'a'; i <= 'z'; ++i) |
| { |
| ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_LOWER_INITCAP; |
| ffesrc_bad_symbol_noninit_[i] = FFEBAD; |
| } |
| break; |
| |
| default: |
| break; |
| } |
| } |
| |
| /* Compare two strings a la strcmp, the first being a source string with its |
| length passed, and the second being a constant string passed |
| in InitialCaps form. Also, the return value is always -1, 0, or 1. */ |
| |
| int |
| ffesrc_strcmp_1ns2i (ffeCase mcase, const char *var, int len, |
| const char *str_ic) |
| { |
| char c; |
| char d; |
| |
| switch (mcase) |
| { |
| case FFE_caseNONE: |
| for (; len > 0; --len, ++var, ++str_ic) |
| { |
| c = ffesrc_char_source (*var); /* Transform source. */ |
| c = TOUPPER (c); /* Upcase source. */ |
| d = TOUPPER (*str_ic); /* Upcase InitialCaps char. */ |
| if (c != d) |
| { |
| if ((d != '\0') && (c < d)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| break; |
| |
| case FFE_caseUPPER: |
| for (; len > 0; --len, ++var, ++str_ic) |
| { |
| c = ffesrc_char_source (*var); /* Transform source. */ |
| d = TOUPPER (*str_ic); /* Transform InitialCaps char. */ |
| if (c != d) |
| { |
| if ((d != '\0') && (c < d)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| break; |
| |
| case FFE_caseLOWER: |
| for (; len > 0; --len, ++var, ++str_ic) |
| { |
| c = ffesrc_char_source (*var); /* Transform source. */ |
| d = TOLOWER (*str_ic); /* Transform InitialCaps char. */ |
| if (c != d) |
| { |
| if ((d != '\0') && (c < d)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| break; |
| |
| case FFE_caseINITCAP: |
| for (; len > 0; --len, ++var, ++str_ic) |
| { |
| c = ffesrc_char_source (*var); /* Transform source. */ |
| d = *str_ic; /* No transform of InitialCaps char. */ |
| if (c != d) |
| { |
| c = TOUPPER (c); |
| d = TOUPPER (d); |
| while ((len > 0) && (c == d)) |
| { /* Skip past equivalent (case-ins) chars. */ |
| --len, ++var, ++str_ic; |
| if (len > 0) |
| c = TOUPPER (*var); |
| d = TOUPPER (*str_ic); |
| } |
| if ((d != '\0') && (c < d)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| break; |
| |
| default: |
| assert ("bad case value" == NULL); |
| return -1; |
| } |
| |
| if (*str_ic == '\0') |
| return 0; |
| return -1; |
| } |
| |
| /* Compare two strings a la strcmp, the second being a constant string passed |
| in both uppercase and lowercase form. If not equal, the uppercase string |
| is used to determine the sign of the return value. Also, the return |
| value is always -1, 0, or 1. */ |
| |
| int |
| ffesrc_strcmp_2c (ffeCase mcase, const char *var, const char *str_uc, |
| const char *str_lc, const char *str_ic) |
| { |
| int i; |
| char c; |
| |
| switch (mcase) |
| { |
| case FFE_caseNONE: |
| for (; *var != '\0'; ++var, ++str_uc) |
| { |
| c = TOUPPER (*var); /* Upcase source. */ |
| if (c != *str_uc) |
| { |
| if ((*str_uc != '\0') && (c < *str_uc)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| if (*str_uc == '\0') |
| return 0; |
| return -1; |
| |
| case FFE_caseUPPER: |
| i = strcmp (var, str_uc); |
| break; |
| |
| case FFE_caseLOWER: |
| i = strcmp (var, str_lc); |
| break; |
| |
| case FFE_caseINITCAP: |
| for (; *var != '\0'; ++var, ++str_ic, ++str_uc) |
| { |
| if (*var != *str_ic) |
| { |
| c = TOUPPER (*var); |
| while ((c != '\0') && (c == *str_uc)) |
| { /* Skip past equivalent (case-ins) chars. */ |
| ++var, ++str_uc; |
| c = TOUPPER (*var); |
| } |
| if ((*str_uc != '\0') && (c < *str_uc)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| if (*str_ic == '\0') |
| return 0; |
| return -1; |
| |
| default: |
| assert ("bad case value" == NULL); |
| return -1; |
| } |
| |
| if (i == 0) |
| return 0; |
| else if (i < 0) |
| return -1; |
| return 1; |
| } |
| |
| /* Compare two strings a la strncmp, the second being a constant string passed |
| in uppercase, lowercase, and InitialCaps form. If not equal, the |
| uppercase string is used to determine the sign of the return value. */ |
| |
| int |
| ffesrc_strncmp_2c (ffeCase mcase, const char *var, const char *str_uc, |
| const char *str_lc, const char *str_ic, int len) |
| { |
| int i; |
| char c; |
| |
| switch (mcase) |
| { |
| case FFE_caseNONE: |
| for (; len > 0; ++var, ++str_uc, --len) |
| { |
| c = TOUPPER (*var); /* Upcase source. */ |
| if (c != *str_uc) |
| { |
| if (c < *str_uc) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| return 0; |
| |
| case FFE_caseUPPER: |
| i = strncmp (var, str_uc, len); |
| break; |
| |
| case FFE_caseLOWER: |
| i = strncmp (var, str_lc, len); |
| break; |
| |
| case FFE_caseINITCAP: |
| for (; len > 0; ++var, ++str_ic, ++str_uc, --len) |
| { |
| if (*var != *str_ic) |
| { |
| c = TOUPPER (*var); |
| while ((len > 0) && (c == *str_uc)) |
| { /* Skip past equivalent (case-ins) chars. */ |
| --len, ++var, ++str_uc; |
| if (len > 0) |
| c = TOUPPER (*var); |
| } |
| if ((len > 0) && (c < *str_uc)) |
| return -1; |
| else |
| return 1; |
| } |
| } |
| return 0; |
| |
| default: |
| assert ("bad case value" == NULL); |
| return -1; |
| } |
| |
| if (i == 0) |
| return 0; |
| else if (i < 0) |
| return -1; |
| return 1; |
| } |