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 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
93 /* Initialize table of alphabetic matches. */
94
95 void
ffesrc_init_1()96 ffesrc_init_1 ()
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
ffesrc_strcmp_1ns2i(ffeCase mcase,const char * var,int len,const char * str_ic)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
ffesrc_strcmp_2c(ffeCase mcase,const char * var,const char * str_uc,const char * str_lc,const char * str_ic)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
ffesrc_strncmp_2c(ffeCase mcase,const char * var,const char * str_uc,const char * str_lc,const char * str_ic,int len)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 }
428