]>
Commit | Line | Data |
---|---|---|
5ff904cd | 1 | /* src.c -- Implementation File |
77f9b92c | 2 | Copyright (C) 1995, 2003 Free Software Foundation, Inc. |
25d7717e | 3 | Contributed by James Craig Burley. |
5ff904cd JL |
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" | |
5ff904cd JL |
32 | #include "src.h" |
33 | #include "top.h" | |
34 | ||
5ff904cd JL |
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 | |
77f9b92c | 96 | ffesrc_init_1 (void) |
5ff904cd JL |
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; | |
5ff904cd JL |
106 | ffesrc_bad_symbol_init_[i] = FFEBAD; |
107 | ffesrc_bad_symbol_noninit_[i] = FFEBAD; | |
108 | } | |
109 | ||
5ff904cd JL |
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) | |
92a438d1 | 138 | ffesrc_char_match_init_[i] = TOUPPER (i); |
5ff904cd JL |
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) | |
92a438d1 | 149 | ffesrc_char_match_noninit_[i] = TOUPPER (i); |
5ff904cd JL |
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) | |
92a438d1 | 156 | ffesrc_char_source_[i] = TOLOWER (i); |
5ff904cd JL |
157 | else if (ffe_case_source () == FFE_caseUPPER) |
158 | for (i = 'a'; i <= 'z'; ++i) | |
92a438d1 | 159 | ffesrc_char_source_[i] = TOUPPER (i); |
5ff904cd JL |
160 | |
161 | if (ffe_case_match () == FFE_caseLOWER) | |
162 | for (i = 'A'; i <= 'Z'; ++i) | |
92a438d1 | 163 | ffesrc_char_internal_init_[i] = TOLOWER (i); |
5ff904cd JL |
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. */ | |
f6bbde28 ZW |
215 | c = TOUPPER (c); /* Upcase source. */ |
216 | d = TOUPPER (*str_ic); /* Upcase InitialCaps char. */ | |
5ff904cd | 217 | if (c != d) |
567f3d36 KG |
218 | { |
219 | if ((d != '\0') && (c < d)) | |
220 | return -1; | |
221 | else | |
222 | return 1; | |
223 | } | |
5ff904cd JL |
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. */ | |
f6bbde28 | 231 | d = TOUPPER (*str_ic); /* Transform InitialCaps char. */ |
5ff904cd | 232 | if (c != d) |
567f3d36 KG |
233 | { |
234 | if ((d != '\0') && (c < d)) | |
235 | return -1; | |
236 | else | |
237 | return 1; | |
238 | } | |
5ff904cd JL |
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. */ | |
f6bbde28 | 246 | d = TOLOWER (*str_ic); /* Transform InitialCaps char. */ |
5ff904cd | 247 | if (c != d) |
567f3d36 KG |
248 | { |
249 | if ((d != '\0') && (c < d)) | |
250 | return -1; | |
251 | else | |
252 | return 1; | |
253 | } | |
5ff904cd JL |
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 | { | |
f6bbde28 ZW |
264 | c = TOUPPER (c); |
265 | d = TOUPPER (d); | |
5ff904cd JL |
266 | while ((len > 0) && (c == d)) |
267 | { /* Skip past equivalent (case-ins) chars. */ | |
268 | --len, ++var, ++str_ic; | |
269 | if (len > 0) | |
f6bbde28 ZW |
270 | c = TOUPPER (*var); |
271 | d = TOUPPER (*str_ic); | |
5ff904cd JL |
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 | { | |
f6bbde28 | 308 | c = TOUPPER (*var); /* Upcase source. */ |
5ff904cd | 309 | if (c != *str_uc) |
567f3d36 KG |
310 | { |
311 | if ((*str_uc != '\0') && (c < *str_uc)) | |
312 | return -1; | |
313 | else | |
314 | return 1; | |
315 | } | |
5ff904cd JL |
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 | { | |
f6bbde28 | 334 | c = TOUPPER (*var); |
5ff904cd JL |
335 | while ((c != '\0') && (c == *str_uc)) |
336 | { /* Skip past equivalent (case-ins) chars. */ | |
337 | ++var, ++str_uc; | |
f6bbde28 | 338 | c = TOUPPER (*var); |
5ff904cd JL |
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 | { | |
f6bbde28 | 378 | c = TOUPPER (*var); /* Upcase source. */ |
5ff904cd | 379 | if (c != *str_uc) |
567f3d36 KG |
380 | { |
381 | if (c < *str_uc) | |
382 | return -1; | |
383 | else | |
384 | return 1; | |
385 | } | |
5ff904cd JL |
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 | { | |
f6bbde28 | 402 | c = TOUPPER (*var); |
5ff904cd JL |
403 | while ((len > 0) && (c == *str_uc)) |
404 | { /* Skip past equivalent (case-ins) chars. */ | |
405 | --len, ++var, ++str_uc; | |
406 | if (len > 0) | |
f6bbde28 | 407 | c = TOUPPER (*var); |
5ff904cd JL |
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 | } |