]>
Commit | Line | Data |
---|---|---|
5ff904cd | 1 | /* Implementation of Fortran lexer |
400500c4 | 2 | Copyright (C) 1995, 1996, 1997, 1998, 2001 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 | #include "proj.h" | |
5ff904cd JL |
23 | #include "top.h" |
24 | #include "bad.h" | |
25 | #include "com.h" | |
26 | #include "lex.h" | |
27 | #include "malloc.h" | |
28 | #include "src.h" | |
29 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
15a40ced ZW |
30 | #include "flags.h" |
31 | #include "input.h" | |
32 | #include "toplev.h" | |
33 | #include "output.h" | |
34 | #include "ggc.h" | |
5ff904cd JL |
35 | #endif |
36 | ||
37 | #ifdef DWARF_DEBUGGING_INFO | |
3b304f5b ZW |
38 | #include "dwarfout.h" |
39 | #endif | |
5ff904cd JL |
40 | |
41 | static void ffelex_append_to_token_ (char c); | |
42 | static int ffelex_backslash_ (int c, ffewhereColumnNumber col); | |
43 | static void ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, | |
44 | ffewhereColumnNumber cn0); | |
45 | static void ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, | |
46 | ffewhereColumnNumber cn0, ffewhereLineNumber ln1, | |
47 | ffewhereColumnNumber cn1); | |
48 | static void ffelex_bad_here_ (int num, ffewhereLineNumber ln0, | |
49 | ffewhereColumnNumber cn0); | |
50 | static void ffelex_finish_statement_ (void); | |
51 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
52 | static int ffelex_get_directive_line_ (char **text, FILE *finput); | |
53 | static int ffelex_hash_ (FILE *f); | |
54 | #endif | |
55 | static ffewhereColumnNumber ffelex_image_char_ (int c, | |
56 | ffewhereColumnNumber col); | |
57 | static void ffelex_include_ (void); | |
58 | static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col); | |
59 | static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col); | |
60 | static void ffelex_next_line_ (void); | |
61 | static void ffelex_prepare_eos_ (void); | |
62 | static void ffelex_send_token_ (void); | |
63 | static ffelexHandler ffelex_swallow_tokens_ (ffelexToken t); | |
64 | static ffelexToken ffelex_token_new_ (void); | |
65 | ||
66 | /* Pertaining to the geometry of the input file. */ | |
67 | ||
68 | /* Initial size for card image to be allocated. */ | |
69 | #define FFELEX_columnINITIAL_SIZE_ 255 | |
70 | ||
71 | /* The card image itself, which grows as source lines get longer. It | |
72 | has room for ffelex_card_size_ + 8 characters, and the length of the | |
73 | current image is ffelex_card_length_. (The + 8 characters are made | |
74 | available for easy handling of tabs and such.) */ | |
75 | static char *ffelex_card_image_; | |
76 | static ffewhereColumnNumber ffelex_card_size_; | |
77 | static ffewhereColumnNumber ffelex_card_length_; | |
78 | ||
79 | /* Max width for free-form lines (ISO F90). */ | |
80 | #define FFELEX_FREE_MAX_COLUMNS_ 132 | |
81 | ||
82 | /* True if we saw a tab on the current line, as this (currently) means | |
83 | the line is therefore treated as though final_nontab_column_ were | |
84 | infinite. */ | |
85 | static bool ffelex_saw_tab_; | |
86 | ||
87 | /* TRUE if current line is known to be erroneous, so don't bother | |
88 | expanding room for it just to display it. */ | |
89 | static bool ffelex_bad_line_ = FALSE; | |
90 | ||
91 | /* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */ | |
92 | static ffewhereColumnNumber ffelex_final_nontab_column_; | |
93 | ||
94 | /* Array for quickly deciding what kind of line the current card has, | |
95 | based on its first character. */ | |
96 | static ffelexType ffelex_first_char_[256]; | |
97 | ||
98 | /* Pertaining to file management. */ | |
99 | ||
100 | /* The wf argument of the most recent active ffelex_file_(fixed,free) | |
101 | function. */ | |
102 | static ffewhereFile ffelex_current_wf_; | |
103 | ||
104 | /* TRUE if an INCLUDE statement can be processed (ffelex_set_include | |
105 | can be called). */ | |
106 | static bool ffelex_permit_include_; | |
107 | ||
108 | /* TRUE if an INCLUDE statement is pending (ffelex_set_include has been | |
109 | called). */ | |
110 | static bool ffelex_set_include_; | |
111 | ||
112 | /* Information on the pending INCLUDE file. */ | |
113 | static FILE *ffelex_include_file_; | |
114 | static bool ffelex_include_free_form_; | |
115 | static ffewhereFile ffelex_include_wherefile_; | |
116 | ||
117 | /* Current master line count. */ | |
118 | static ffewhereLineNumber ffelex_linecount_current_; | |
119 | /* Next master line count. */ | |
120 | static ffewhereLineNumber ffelex_linecount_next_; | |
121 | ||
122 | /* ffewhere info on the latest (currently active) line read from the | |
123 | active source file. */ | |
124 | static ffewhereLine ffelex_current_wl_; | |
125 | static ffewhereColumn ffelex_current_wc_; | |
126 | ||
127 | /* Pertaining to tokens in general. */ | |
128 | ||
129 | /* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER | |
130 | token. */ | |
131 | #define FFELEX_columnTOKEN_SIZE_ 63 | |
132 | #if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX | |
133 | #error "token size too small!" | |
134 | #endif | |
135 | ||
136 | /* Current token being lexed. */ | |
137 | static ffelexToken ffelex_token_; | |
138 | ||
139 | /* Handler for current token. */ | |
140 | static ffelexHandler ffelex_handler_; | |
141 | ||
142 | /* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */ | |
143 | static bool ffelex_names_; | |
144 | ||
145 | /* TRUE if both lexers are to generate NAMES instead of NAME tokens. */ | |
146 | static bool ffelex_names_pure_; | |
147 | ||
148 | /* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex | |
149 | numbers. */ | |
150 | static bool ffelex_hexnum_; | |
151 | ||
152 | /* For ffelex_swallow_tokens(). */ | |
153 | static ffelexHandler ffelex_eos_handler_; | |
154 | ||
155 | /* Number of tokens sent since last EOS or beginning of input file | |
156 | (include INCLUDEd files). */ | |
157 | static unsigned long int ffelex_number_of_tokens_; | |
158 | ||
159 | /* Number of labels sent (as NUMBER tokens) since last reset of | |
160 | ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases. | |
161 | (Fixed-form source only.) */ | |
162 | static unsigned long int ffelex_label_tokens_; | |
163 | ||
164 | /* Metering for token management, to catch token-memory leaks. */ | |
165 | static long int ffelex_total_tokens_ = 0; | |
166 | static long int ffelex_old_total_tokens_ = 1; | |
167 | static long int ffelex_token_nextid_ = 0; | |
168 | ||
169 | /* Pertaining to lexing CHARACTER and HOLLERITH tokens. */ | |
170 | ||
171 | /* >0 if a Hollerith constant of that length might be in mid-lex, used | |
172 | when the next character seen is 'H' or 'h' to enter HOLLERITH lexing | |
173 | mode (see ffelex_raw_mode_). */ | |
174 | static long int ffelex_expecting_hollerith_; | |
175 | ||
176 | /* -3: Backslash (escape) sequence being lexed in CHARACTER. | |
177 | -2: Possible closing apostrophe/quote seen in CHARACTER. | |
178 | -1: Lexing CHARACTER. | |
179 | 0: Not lexing CHARACTER or HOLLERITH. | |
180 | >0: Lexing HOLLERITH, value is # chars remaining to expect. */ | |
181 | static long int ffelex_raw_mode_; | |
182 | ||
183 | /* When lexing CHARACTER, open quote/apostrophe (either ' or "). */ | |
184 | static char ffelex_raw_char_; | |
185 | ||
186 | /* TRUE when backslash processing had to use most recent character | |
187 | to finish its state engine, but that character is not part of | |
188 | the backslash sequence, so must be reconsidered as a "normal" | |
189 | character in CHARACTER/HOLLERITH lexing. */ | |
190 | static bool ffelex_backslash_reconsider_ = FALSE; | |
191 | ||
192 | /* Characters preread before lexing happened (might include EOF). */ | |
193 | static int *ffelex_kludge_chars_ = NULL; | |
194 | ||
195 | /* Doing the kludge processing, so not initialized yet. */ | |
196 | static bool ffelex_kludge_flag_ = FALSE; | |
197 | ||
198 | /* The beginning of a (possible) CHARACTER/HOLLERITH token. */ | |
199 | static ffewhereLine ffelex_raw_where_line_; | |
200 | static ffewhereColumn ffelex_raw_where_col_; | |
201 | \f | |
202 | ||
203 | /* Call this to append another character to the current token. If it isn't | |
204 | currently big enough for it, it will be enlarged. The current token | |
205 | must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER. */ | |
206 | ||
207 | static void | |
208 | ffelex_append_to_token_ (char c) | |
209 | { | |
210 | if (ffelex_token_->text == NULL) | |
211 | { | |
212 | ffelex_token_->text | |
213 | = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
214 | FFELEX_columnTOKEN_SIZE_ + 1); | |
215 | ffelex_token_->size = FFELEX_columnTOKEN_SIZE_; | |
216 | ffelex_token_->length = 0; | |
217 | } | |
218 | else if (ffelex_token_->length >= ffelex_token_->size) | |
219 | { | |
220 | ffelex_token_->text | |
221 | = malloc_resize_ksr (malloc_pool_image (), | |
222 | ffelex_token_->text, | |
223 | (ffelex_token_->size << 1) + 1, | |
224 | ffelex_token_->size + 1); | |
225 | ffelex_token_->size <<= 1; | |
226 | assert (ffelex_token_->length < ffelex_token_->size); | |
227 | } | |
228 | #ifdef MAP_CHARACTER | |
229 | Sorry, MAP_CHARACTER is not going to work as expected in GNU Fortran, | |
f2d76545 | 230 | please contact fortran@gnu.org if you wish to fund work to |
5ff904cd JL |
231 | port g77 to non-ASCII machines. |
232 | #endif | |
233 | ffelex_token_->text[ffelex_token_->length++] = c; | |
234 | } | |
235 | ||
236 | /* Do backslash (escape) processing for a CHARACTER/HOLLERITH token | |
237 | being lexed. */ | |
238 | ||
239 | static int | |
240 | ffelex_backslash_ (int c, ffewhereColumnNumber col) | |
241 | { | |
242 | static int state = 0; | |
243 | static unsigned int count; | |
244 | static int code; | |
245 | static unsigned int firstdig = 0; | |
246 | static int nonnull; | |
247 | static ffewhereLineNumber line; | |
248 | static ffewhereColumnNumber column; | |
249 | ||
250 | /* See gcc/c-lex.c readescape() for a straightforward version | |
251 | of this state engine for handling backslashes in character/ | |
252 | hollerith constants. */ | |
253 | ||
254 | #define wide_flag 0 | |
255 | #define warn_traditional 0 | |
256 | #define flag_traditional 0 | |
257 | ||
258 | switch (state) | |
259 | { | |
260 | case 0: | |
261 | if ((c == '\\') | |
262 | && (ffelex_raw_mode_ != 0) | |
263 | && ffe_is_backslash ()) | |
264 | { | |
265 | state = 1; | |
266 | column = col + 1; | |
267 | line = ffelex_linecount_current_; | |
268 | return EOF; | |
269 | } | |
270 | return c; | |
271 | ||
272 | case 1: | |
273 | state = 0; /* Assume simple case. */ | |
274 | switch (c) | |
275 | { | |
276 | case 'x': | |
277 | if (warn_traditional) | |
278 | { | |
279 | ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional", | |
280 | FFEBAD_severityWARNING); | |
281 | ffelex_bad_here_ (0, line, column); | |
282 | ffebad_finish (); | |
283 | } | |
284 | ||
285 | if (flag_traditional) | |
286 | return c; | |
287 | ||
288 | code = 0; | |
289 | count = 0; | |
290 | nonnull = 0; | |
291 | state = 2; | |
292 | return EOF; | |
293 | ||
294 | case '0': case '1': case '2': case '3': case '4': | |
295 | case '5': case '6': case '7': | |
296 | code = c - '0'; | |
297 | count = 1; | |
298 | state = 3; | |
299 | return EOF; | |
300 | ||
301 | case '\\': case '\'': case '"': | |
302 | return c; | |
303 | ||
304 | #if 0 /* Inappropriate for Fortran. */ | |
305 | case '\n': | |
306 | ffelex_next_line_ (); | |
307 | *ignore_ptr = 1; | |
308 | return 0; | |
309 | #endif | |
310 | ||
311 | case 'n': | |
312 | return TARGET_NEWLINE; | |
313 | ||
314 | case 't': | |
315 | return TARGET_TAB; | |
316 | ||
317 | case 'r': | |
318 | return TARGET_CR; | |
319 | ||
320 | case 'f': | |
321 | return TARGET_FF; | |
322 | ||
323 | case 'b': | |
324 | return TARGET_BS; | |
325 | ||
326 | case 'a': | |
327 | if (warn_traditional) | |
328 | { | |
329 | ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional", | |
330 | FFEBAD_severityWARNING); | |
331 | ffelex_bad_here_ (0, line, column); | |
332 | ffebad_finish (); | |
333 | } | |
334 | ||
335 | if (flag_traditional) | |
336 | return c; | |
337 | return TARGET_BELL; | |
338 | ||
339 | case 'v': | |
340 | #if 0 /* Vertical tab is present in common usage compilers. */ | |
341 | if (flag_traditional) | |
342 | return c; | |
343 | #endif | |
344 | return TARGET_VT; | |
345 | ||
346 | case 'e': | |
347 | case 'E': | |
348 | case '(': | |
349 | case '{': | |
350 | case '[': | |
351 | case '%': | |
352 | if (pedantic) | |
353 | { | |
354 | char m[2]; | |
355 | ||
356 | m[0] = c; | |
357 | m[1] = '\0'; | |
358 | ffebad_start_msg_lex ("Non-ANSI-C-standard escape sequence `\\%A' at %0", | |
359 | FFEBAD_severityPEDANTIC); | |
360 | ffelex_bad_here_ (0, line, column); | |
361 | ffebad_string (m); | |
362 | ffebad_finish (); | |
363 | } | |
364 | return (c == 'E' || c == 'e') ? 033 : c; | |
365 | ||
366 | case '?': | |
367 | return c; | |
368 | ||
369 | default: | |
370 | if (c >= 040 && c < 0177) | |
371 | { | |
372 | char m[2]; | |
373 | ||
374 | m[0] = c; | |
375 | m[1] = '\0'; | |
376 | ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0", | |
377 | FFEBAD_severityPEDANTIC); | |
378 | ffelex_bad_here_ (0, line, column); | |
379 | ffebad_string (m); | |
380 | ffebad_finish (); | |
381 | } | |
382 | else if (c == EOF) | |
383 | { | |
384 | ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0", | |
385 | FFEBAD_severityPEDANTIC); | |
386 | ffelex_bad_here_ (0, line, column); | |
387 | ffebad_finish (); | |
388 | } | |
389 | else | |
390 | { | |
391 | char m[20]; | |
392 | ||
393 | sprintf (&m[0], "%x", c); | |
394 | ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0", | |
395 | FFEBAD_severityPEDANTIC); | |
396 | ffelex_bad_here_ (0, line, column); | |
397 | ffebad_string (m); | |
398 | ffebad_finish (); | |
399 | } | |
400 | } | |
401 | return c; | |
402 | ||
403 | case 2: | |
404 | if ((c >= 'a' && c <= 'f') | |
405 | || (c >= 'A' && c <= 'F') | |
406 | || (c >= '0' && c <= '9')) | |
407 | { | |
408 | code *= 16; | |
409 | if (c >= 'a' && c <= 'f') | |
410 | code += c - 'a' + 10; | |
411 | if (c >= 'A' && c <= 'F') | |
412 | code += c - 'A' + 10; | |
413 | if (c >= '0' && c <= '9') | |
414 | code += c - '0'; | |
415 | if (code != 0 || count != 0) | |
416 | { | |
417 | if (count == 0) | |
418 | firstdig = code; | |
419 | count++; | |
420 | } | |
421 | nonnull = 1; | |
422 | return EOF; | |
423 | } | |
424 | ||
425 | state = 0; | |
426 | ||
427 | if (! nonnull) | |
428 | { | |
429 | ffebad_start_msg_lex ("\\x used at %0 with no following hex digits", | |
430 | FFEBAD_severityFATAL); | |
431 | ffelex_bad_here_ (0, line, column); | |
432 | ffebad_finish (); | |
433 | } | |
434 | else if (count == 0) | |
435 | /* Digits are all 0's. Ok. */ | |
436 | ; | |
437 | else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node) | |
438 | || (count > 1 | |
439 | && ((1 << (TYPE_PRECISION (integer_type_node) - (count - 1) * 4)) | |
440 | <= (int) firstdig))) | |
441 | { | |
442 | ffebad_start_msg_lex ("Hex escape at %0 out of range", | |
443 | FFEBAD_severityPEDANTIC); | |
444 | ffelex_bad_here_ (0, line, column); | |
445 | ffebad_finish (); | |
446 | } | |
447 | break; | |
448 | ||
449 | case 3: | |
450 | if ((c <= '7') && (c >= '0') && (count++ < 3)) | |
451 | { | |
452 | code = (code * 8) + (c - '0'); | |
453 | return EOF; | |
454 | } | |
455 | state = 0; | |
456 | break; | |
457 | ||
458 | default: | |
459 | assert ("bad backslash state" == NULL); | |
460 | abort (); | |
461 | } | |
462 | ||
463 | /* Come here when code has a built character, and c is the next | |
464 | character that might (or might not) be the next one in the constant. */ | |
465 | ||
466 | /* Don't bother doing this check for each character going into | |
467 | CHARACTER or HOLLERITH constants, just the escaped-value ones. | |
468 | gcc apparently checks every single character, which seems | |
469 | like it'd be kinda slow and not worth doing anyway. */ | |
470 | ||
471 | if (!wide_flag | |
472 | && TYPE_PRECISION (char_type_node) < HOST_BITS_PER_INT | |
473 | && code >= (1 << TYPE_PRECISION (char_type_node))) | |
474 | { | |
475 | ffebad_start_msg_lex ("Escape sequence at %0 out of range for character", | |
476 | FFEBAD_severityFATAL); | |
477 | ffelex_bad_here_ (0, line, column); | |
478 | ffebad_finish (); | |
479 | } | |
480 | ||
481 | if (c == EOF) | |
482 | { | |
483 | /* Known end of constant, just append this character. */ | |
484 | ffelex_append_to_token_ (code); | |
485 | if (ffelex_raw_mode_ > 0) | |
486 | --ffelex_raw_mode_; | |
487 | return EOF; | |
488 | } | |
489 | ||
490 | /* Have two characters to handle. Do the first, then leave it to the | |
491 | caller to detect anything special about the second. */ | |
492 | ||
493 | ffelex_append_to_token_ (code); | |
494 | if (ffelex_raw_mode_ > 0) | |
495 | --ffelex_raw_mode_; | |
496 | ffelex_backslash_reconsider_ = TRUE; | |
497 | return c; | |
498 | } | |
499 | ||
500 | /* ffelex_bad_1_ -- Issue diagnostic with one source point | |
501 | ||
502 | ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1); | |
503 | ||
504 | Creates ffewhere line and column objects for the source point, sends them | |
505 | along with the error code to ffebad, then kills the line and column | |
506 | objects before returning. */ | |
507 | ||
508 | static void | |
509 | ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0) | |
510 | { | |
511 | ffewhereLine wl0; | |
512 | ffewhereColumn wc0; | |
513 | ||
514 | wl0 = ffewhere_line_new (ln0); | |
515 | wc0 = ffewhere_column_new (cn0); | |
516 | ffebad_start_lex (errnum); | |
517 | ffebad_here (0, wl0, wc0); | |
518 | ffebad_finish (); | |
519 | ffewhere_line_kill (wl0); | |
520 | ffewhere_column_kill (wc0); | |
521 | } | |
522 | ||
523 | /* ffelex_bad_2_ -- Issue diagnostic with two source points | |
524 | ||
525 | ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1, | |
526 | otherline,othercolumn); | |
527 | ||
528 | Creates ffewhere line and column objects for the source points, sends them | |
529 | along with the error code to ffebad, then kills the line and column | |
530 | objects before returning. */ | |
531 | ||
532 | static void | |
533 | ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0, | |
534 | ffewhereLineNumber ln1, ffewhereColumnNumber cn1) | |
535 | { | |
536 | ffewhereLine wl0, wl1; | |
537 | ffewhereColumn wc0, wc1; | |
538 | ||
539 | wl0 = ffewhere_line_new (ln0); | |
540 | wc0 = ffewhere_column_new (cn0); | |
541 | wl1 = ffewhere_line_new (ln1); | |
542 | wc1 = ffewhere_column_new (cn1); | |
543 | ffebad_start_lex (errnum); | |
544 | ffebad_here (0, wl0, wc0); | |
545 | ffebad_here (1, wl1, wc1); | |
546 | ffebad_finish (); | |
547 | ffewhere_line_kill (wl0); | |
548 | ffewhere_column_kill (wc0); | |
549 | ffewhere_line_kill (wl1); | |
550 | ffewhere_column_kill (wc1); | |
551 | } | |
552 | ||
553 | static void | |
554 | ffelex_bad_here_ (int n, ffewhereLineNumber ln0, | |
555 | ffewhereColumnNumber cn0) | |
556 | { | |
557 | ffewhereLine wl0; | |
558 | ffewhereColumn wc0; | |
559 | ||
560 | wl0 = ffewhere_line_new (ln0); | |
561 | wc0 = ffewhere_column_new (cn0); | |
562 | ffebad_here (n, wl0, wc0); | |
563 | ffewhere_line_kill (wl0); | |
564 | ffewhere_column_kill (wc0); | |
565 | } | |
566 | ||
567 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
568 | static int | |
569 | ffelex_getc_ (FILE *finput) | |
570 | { | |
571 | int c; | |
572 | ||
573 | if (ffelex_kludge_chars_ == NULL) | |
574 | return getc (finput); | |
575 | ||
576 | c = *ffelex_kludge_chars_++; | |
577 | if (c != 0) | |
578 | return c; | |
579 | ||
580 | ffelex_kludge_chars_ = NULL; | |
581 | return getc (finput); | |
582 | } | |
583 | ||
584 | #endif | |
585 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
586 | static int | |
587 | ffelex_cfebackslash_ (int *use_d, int *d, FILE *finput) | |
588 | { | |
589 | register int c = getc (finput); | |
590 | register int code; | |
591 | register unsigned count; | |
592 | unsigned firstdig = 0; | |
593 | int nonnull; | |
594 | ||
595 | *use_d = 0; | |
596 | ||
597 | switch (c) | |
598 | { | |
599 | case 'x': | |
600 | if (warn_traditional) | |
601 | warning ("the meaning of `\\x' varies with -traditional"); | |
602 | ||
603 | if (flag_traditional) | |
604 | return c; | |
605 | ||
606 | code = 0; | |
607 | count = 0; | |
608 | nonnull = 0; | |
609 | while (1) | |
610 | { | |
611 | c = getc (finput); | |
612 | if (!(c >= 'a' && c <= 'f') | |
613 | && !(c >= 'A' && c <= 'F') | |
614 | && !(c >= '0' && c <= '9')) | |
615 | { | |
616 | *use_d = 1; | |
617 | *d = c; | |
618 | break; | |
619 | } | |
620 | code *= 16; | |
621 | if (c >= 'a' && c <= 'f') | |
622 | code += c - 'a' + 10; | |
623 | if (c >= 'A' && c <= 'F') | |
624 | code += c - 'A' + 10; | |
625 | if (c >= '0' && c <= '9') | |
626 | code += c - '0'; | |
627 | if (code != 0 || count != 0) | |
628 | { | |
629 | if (count == 0) | |
630 | firstdig = code; | |
631 | count++; | |
632 | } | |
633 | nonnull = 1; | |
634 | } | |
635 | if (! nonnull) | |
636 | error ("\\x used with no following hex digits"); | |
637 | else if (count == 0) | |
638 | /* Digits are all 0's. Ok. */ | |
639 | ; | |
640 | else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node) | |
641 | || (count > 1 | |
642 | && (((unsigned) 1 | |
643 | << (TYPE_PRECISION (integer_type_node) - (count - 1) | |
644 | * 4)) | |
645 | <= firstdig))) | |
646 | pedwarn ("hex escape out of range"); | |
647 | return code; | |
648 | ||
649 | case '0': case '1': case '2': case '3': case '4': | |
650 | case '5': case '6': case '7': | |
651 | code = 0; | |
652 | count = 0; | |
653 | while ((c <= '7') && (c >= '0') && (count++ < 3)) | |
654 | { | |
655 | code = (code * 8) + (c - '0'); | |
656 | c = getc (finput); | |
657 | } | |
658 | *use_d = 1; | |
659 | *d = c; | |
660 | return code; | |
661 | ||
662 | case '\\': case '\'': case '"': | |
663 | return c; | |
664 | ||
665 | case '\n': | |
666 | ffelex_next_line_ (); | |
667 | *use_d = 2; | |
668 | return 0; | |
669 | ||
670 | case EOF: | |
671 | *use_d = 1; | |
672 | *d = EOF; | |
673 | return EOF; | |
674 | ||
675 | case 'n': | |
676 | return TARGET_NEWLINE; | |
677 | ||
678 | case 't': | |
679 | return TARGET_TAB; | |
680 | ||
681 | case 'r': | |
682 | return TARGET_CR; | |
683 | ||
684 | case 'f': | |
685 | return TARGET_FF; | |
686 | ||
687 | case 'b': | |
688 | return TARGET_BS; | |
689 | ||
690 | case 'a': | |
691 | if (warn_traditional) | |
692 | warning ("the meaning of `\\a' varies with -traditional"); | |
693 | ||
694 | if (flag_traditional) | |
695 | return c; | |
696 | return TARGET_BELL; | |
697 | ||
698 | case 'v': | |
699 | #if 0 /* Vertical tab is present in common usage compilers. */ | |
700 | if (flag_traditional) | |
701 | return c; | |
702 | #endif | |
703 | return TARGET_VT; | |
704 | ||
705 | case 'e': | |
706 | case 'E': | |
707 | if (pedantic) | |
708 | pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c); | |
709 | return 033; | |
710 | ||
711 | case '?': | |
712 | return c; | |
713 | ||
714 | /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */ | |
715 | case '(': | |
716 | case '{': | |
717 | case '[': | |
718 | /* `\%' is used to prevent SCCS from getting confused. */ | |
719 | case '%': | |
720 | if (pedantic) | |
721 | pedwarn ("non-ANSI escape sequence `\\%c'", c); | |
722 | return c; | |
723 | } | |
724 | if (c >= 040 && c < 0177) | |
725 | pedwarn ("unknown escape sequence `\\%c'", c); | |
726 | else | |
727 | pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c); | |
728 | return c; | |
729 | } | |
730 | ||
731 | #endif | |
732 | /* A miniature version of the C front-end lexer. */ | |
733 | ||
734 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
735 | static int | |
736 | ffelex_cfelex_ (ffelexToken *xtoken, FILE *finput, int c) | |
737 | { | |
738 | ffelexToken token; | |
739 | char buff[129]; | |
740 | char *p; | |
741 | char *q; | |
742 | char *r; | |
743 | register unsigned buffer_length; | |
744 | ||
745 | if ((*xtoken != NULL) && !ffelex_kludge_flag_) | |
746 | ffelex_token_kill (*xtoken); | |
747 | ||
748 | switch (c) | |
749 | { | |
750 | case '0': case '1': case '2': case '3': case '4': | |
751 | case '5': case '6': case '7': case '8': case '9': | |
752 | buffer_length = ARRAY_SIZE (buff); | |
753 | p = &buff[0]; | |
754 | q = p; | |
755 | r = &buff[buffer_length]; | |
756 | for (;;) | |
757 | { | |
758 | *p++ = c; | |
759 | if (p >= r) | |
760 | { | |
761 | register unsigned bytes_used = (p - q); | |
762 | ||
763 | buffer_length *= 2; | |
764 | q = (char *)xrealloc (q, buffer_length); | |
765 | p = &q[bytes_used]; | |
766 | r = &q[buffer_length]; | |
767 | } | |
768 | c = ffelex_getc_ (finput); | |
8b45da67 | 769 | if (! ISDIGIT (c)) |
5ff904cd JL |
770 | break; |
771 | } | |
772 | *p = '\0'; | |
773 | token = ffelex_token_new_number (q, ffewhere_line_unknown (), | |
774 | ffewhere_column_unknown ()); | |
775 | ||
776 | if (q != &buff[0]) | |
777 | free (q); | |
778 | ||
779 | break; | |
780 | ||
781 | case '\"': | |
782 | buffer_length = ARRAY_SIZE (buff); | |
783 | p = &buff[0]; | |
784 | q = p; | |
785 | r = &buff[buffer_length]; | |
786 | c = ffelex_getc_ (finput); | |
787 | for (;;) | |
788 | { | |
789 | bool done = FALSE; | |
790 | int use_d = 0; | |
791 | int d; | |
792 | ||
793 | switch (c) | |
794 | { | |
795 | case '\"': | |
796 | c = getc (finput); | |
797 | done = TRUE; | |
798 | break; | |
799 | ||
800 | case '\\': /* ~~~~~ */ | |
801 | c = ffelex_cfebackslash_ (&use_d, &d, finput); | |
802 | break; | |
803 | ||
804 | case EOF: | |
805 | case '\n': | |
400500c4 | 806 | error ("Badly formed directive -- no closing quote"); |
5ff904cd JL |
807 | done = TRUE; |
808 | break; | |
809 | ||
810 | default: | |
811 | break; | |
812 | } | |
813 | if (done) | |
814 | break; | |
815 | ||
816 | if (use_d != 2) /* 0=>c, 1=>cd, 2=>nil. */ | |
817 | { | |
818 | *p++ = c; | |
819 | if (p >= r) | |
820 | { | |
821 | register unsigned bytes_used = (p - q); | |
822 | ||
823 | buffer_length = bytes_used * 2; | |
824 | q = (char *)xrealloc (q, buffer_length); | |
825 | p = &q[bytes_used]; | |
826 | r = &q[buffer_length]; | |
827 | } | |
828 | } | |
829 | if (use_d == 1) | |
830 | c = d; | |
831 | else | |
832 | c = getc (finput); | |
833 | } | |
834 | *p = '\0'; | |
835 | token = ffelex_token_new_character (q, ffewhere_line_unknown (), | |
836 | ffewhere_column_unknown ()); | |
837 | ||
838 | if (q != &buff[0]) | |
839 | free (q); | |
840 | ||
841 | break; | |
842 | ||
843 | default: | |
844 | token = NULL; | |
845 | break; | |
846 | } | |
847 | ||
848 | *xtoken = token; | |
849 | return c; | |
850 | } | |
851 | #endif | |
852 | ||
853 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
854 | static void | |
3b304f5b | 855 | ffelex_file_pop_ (const char *input_filename) |
5ff904cd JL |
856 | { |
857 | if (input_file_stack->next) | |
858 | { | |
859 | struct file_stack *p = input_file_stack; | |
860 | input_file_stack = p->next; | |
861 | free (p); | |
862 | input_file_stack_tick++; | |
863 | #ifdef DWARF_DEBUGGING_INFO | |
864 | if (debug_info_level == DINFO_LEVEL_VERBOSE | |
865 | && write_symbols == DWARF_DEBUG) | |
866 | dwarfout_resume_previous_source_file (input_file_stack->line); | |
867 | #endif /* DWARF_DEBUGGING_INFO */ | |
868 | } | |
869 | else | |
870 | error ("#-lines for entering and leaving files don't match"); | |
871 | ||
872 | /* Now that we've pushed or popped the input stack, | |
873 | update the name in the top element. */ | |
874 | if (input_file_stack) | |
875 | input_file_stack->name = input_filename; | |
876 | } | |
877 | ||
878 | #endif | |
879 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
880 | static void | |
3b304f5b | 881 | ffelex_file_push_ (int old_lineno, const char *input_filename) |
5ff904cd JL |
882 | { |
883 | struct file_stack *p | |
884 | = (struct file_stack *) xmalloc (sizeof (struct file_stack)); | |
885 | ||
886 | input_file_stack->line = old_lineno; | |
887 | p->next = input_file_stack; | |
888 | p->name = input_filename; | |
889 | input_file_stack = p; | |
890 | input_file_stack_tick++; | |
891 | #ifdef DWARF_DEBUGGING_INFO | |
892 | if (debug_info_level == DINFO_LEVEL_VERBOSE | |
893 | && write_symbols == DWARF_DEBUG) | |
894 | dwarfout_start_new_source_file (input_filename); | |
895 | #endif /* DWARF_DEBUGGING_INFO */ | |
896 | ||
897 | /* Now that we've pushed or popped the input stack, | |
898 | update the name in the top element. */ | |
899 | if (input_file_stack) | |
900 | input_file_stack->name = input_filename; | |
901 | } | |
902 | #endif | |
903 | ||
904 | /* Prepare to finish a statement-in-progress by sending the current | |
905 | token, if any, then setting up EOS as the current token with the | |
906 | appropriate current pointer. The caller can then move the current | |
907 | pointer before actually sending EOS, if desired, as it is in | |
908 | typical fixed-form cases. */ | |
909 | ||
910 | static void | |
911 | ffelex_prepare_eos_ () | |
912 | { | |
913 | if (ffelex_token_->type != FFELEX_typeNONE) | |
914 | { | |
915 | ffelex_backslash_ (EOF, 0); | |
916 | ||
917 | switch (ffelex_raw_mode_) | |
918 | { | |
919 | case -2: | |
920 | break; | |
921 | ||
922 | case -1: | |
923 | ffebad_start_lex ((ffelex_raw_char_ == '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE | |
924 | : FFEBAD_NO_CLOSING_QUOTE); | |
925 | ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col); | |
926 | ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_); | |
927 | ffebad_finish (); | |
928 | break; | |
929 | ||
930 | case 0: | |
931 | break; | |
932 | ||
933 | default: | |
934 | { | |
935 | char num[20]; | |
936 | ||
937 | ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS); | |
938 | ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col); | |
939 | ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_); | |
940 | sprintf (num, "%lu", (unsigned long) ffelex_raw_mode_); | |
941 | ffebad_string (num); | |
942 | ffebad_finish (); | |
943 | /* Make sure the token has some text, might as well fill up with spaces. */ | |
944 | do | |
945 | { | |
946 | ffelex_append_to_token_ (' '); | |
947 | } while (--ffelex_raw_mode_ > 0); | |
948 | break; | |
949 | } | |
950 | } | |
951 | ffelex_raw_mode_ = 0; | |
952 | ffelex_send_token_ (); | |
953 | } | |
954 | ffelex_token_->type = FFELEX_typeEOS; | |
955 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
956 | ffelex_token_->where_col = ffewhere_column_use (ffelex_current_wc_); | |
957 | } | |
958 | ||
959 | static void | |
960 | ffelex_finish_statement_ () | |
961 | { | |
962 | if ((ffelex_number_of_tokens_ == 0) | |
963 | && (ffelex_token_->type == FFELEX_typeNONE)) | |
964 | return; /* Don't have a statement pending. */ | |
965 | ||
966 | if (ffelex_token_->type != FFELEX_typeEOS) | |
967 | ffelex_prepare_eos_ (); | |
968 | ||
969 | ffelex_permit_include_ = TRUE; | |
970 | ffelex_send_token_ (); | |
971 | ffelex_permit_include_ = FALSE; | |
972 | ffelex_number_of_tokens_ = 0; | |
973 | ffelex_label_tokens_ = 0; | |
974 | ffelex_names_ = TRUE; | |
975 | ffelex_names_pure_ = FALSE; /* Probably not necessary. */ | |
976 | ffelex_hexnum_ = FALSE; | |
977 | ||
978 | if (!ffe_is_ffedebug ()) | |
979 | return; | |
980 | ||
981 | /* For debugging purposes only. */ | |
982 | ||
983 | if (ffelex_total_tokens_ != ffelex_old_total_tokens_) | |
984 | { | |
985 | fprintf (dmpout, "; token_track had %ld tokens, now have %ld.\n", | |
986 | ffelex_old_total_tokens_, ffelex_total_tokens_); | |
987 | ffelex_old_total_tokens_ = ffelex_total_tokens_; | |
988 | } | |
989 | } | |
990 | ||
991 | /* Copied from gcc/c-common.c get_directive_line. */ | |
992 | ||
993 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
994 | static int | |
995 | ffelex_get_directive_line_ (char **text, FILE *finput) | |
996 | { | |
997 | static char *directive_buffer = NULL; | |
998 | static unsigned buffer_length = 0; | |
999 | register char *p; | |
1000 | register char *buffer_limit; | |
1001 | register int looking_for = 0; | |
1002 | register int char_escaped = 0; | |
1003 | ||
1004 | if (buffer_length == 0) | |
1005 | { | |
1006 | directive_buffer = (char *)xmalloc (128); | |
1007 | buffer_length = 128; | |
1008 | } | |
1009 | ||
1010 | buffer_limit = &directive_buffer[buffer_length]; | |
1011 | ||
1012 | for (p = directive_buffer; ; ) | |
1013 | { | |
1014 | int c; | |
1015 | ||
1016 | /* Make buffer bigger if it is full. */ | |
1017 | if (p >= buffer_limit) | |
1018 | { | |
1019 | register unsigned bytes_used = (p - directive_buffer); | |
1020 | ||
1021 | buffer_length *= 2; | |
1022 | directive_buffer | |
1023 | = (char *)xrealloc (directive_buffer, buffer_length); | |
1024 | p = &directive_buffer[bytes_used]; | |
1025 | buffer_limit = &directive_buffer[buffer_length]; | |
1026 | } | |
1027 | ||
1028 | c = getc (finput); | |
1029 | ||
1030 | /* Discard initial whitespace. */ | |
1031 | if ((c == ' ' || c == '\t') && p == directive_buffer) | |
1032 | continue; | |
1033 | ||
1034 | /* Detect the end of the directive. */ | |
1035 | if ((c == '\n' && looking_for == 0) | |
1036 | || c == EOF) | |
1037 | { | |
1038 | if (looking_for != 0) | |
400500c4 | 1039 | error ("Bad directive -- missing close-quote"); |
5ff904cd JL |
1040 | |
1041 | *p++ = '\0'; | |
1042 | *text = directive_buffer; | |
1043 | return c; | |
1044 | } | |
1045 | ||
1046 | *p++ = c; | |
1047 | if (c == '\n') | |
1048 | ffelex_next_line_ (); | |
1049 | ||
1050 | /* Handle string and character constant syntax. */ | |
1051 | if (looking_for) | |
1052 | { | |
1053 | if (looking_for == c && !char_escaped) | |
1054 | looking_for = 0; /* Found terminator... stop looking. */ | |
1055 | } | |
1056 | else | |
1057 | if (c == '\'' || c == '"') | |
1058 | looking_for = c; /* Don't stop buffering until we see another | |
38e01259 | 1059 | one of these (or an EOF). */ |
5ff904cd JL |
1060 | |
1061 | /* Handle backslash. */ | |
1062 | char_escaped = (c == '\\' && ! char_escaped); | |
1063 | } | |
1064 | } | |
1065 | #endif | |
1066 | ||
1067 | /* Handle # directives that make it through (or are generated by) the | |
1068 | preprocessor. As much as reasonably possible, emulate the behavior | |
1069 | of the gcc compiler phase cc1, though interactions between #include | |
1070 | and INCLUDE might possibly produce bizarre results in terms of | |
1071 | error reporting and the generation of debugging info vis-a-vis the | |
1072 | locations of some things. | |
1073 | ||
1074 | Returns the next character unhandled, which is always newline or EOF. */ | |
1075 | ||
1076 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
ae4d12ca NC |
1077 | |
1078 | #if defined HANDLE_PRAGMA | |
1079 | /* Local versions of these macros, that can be passed as function pointers. */ | |
1080 | static int | |
1081 | pragma_getc () | |
1082 | { | |
1083 | return getc (finput); | |
1084 | } | |
1085 | ||
1086 | static void | |
1087 | pragma_ungetc (arg) | |
1088 | int arg; | |
1089 | { | |
1090 | ungetc (arg, finput); | |
1091 | } | |
1092 | #endif /* HANDLE_PRAGMA */ | |
1093 | ||
5ff904cd JL |
1094 | static int |
1095 | ffelex_hash_ (FILE *finput) | |
1096 | { | |
1097 | register int c; | |
1098 | ffelexToken token = NULL; | |
1099 | ||
1100 | /* Read first nonwhite char after the `#'. */ | |
1101 | ||
1102 | c = ffelex_getc_ (finput); | |
1103 | while (c == ' ' || c == '\t') | |
1104 | c = ffelex_getc_ (finput); | |
1105 | ||
1106 | /* If a letter follows, then if the word here is `line', skip | |
1107 | it and ignore it; otherwise, ignore the line, with an error | |
1108 | if the word isn't `pragma', `ident', `define', or `undef'. */ | |
1109 | ||
1110 | if ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) | |
1111 | { | |
1112 | if (c == 'p') | |
1113 | { | |
1114 | if (getc (finput) == 'r' | |
1115 | && getc (finput) == 'a' | |
1116 | && getc (finput) == 'g' | |
1117 | && getc (finput) == 'm' | |
1118 | && getc (finput) == 'a' | |
1119 | && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' | |
1120 | || c == EOF)) | |
1121 | { | |
5ff904cd | 1122 | #if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */ |
ae4d12ca NC |
1123 | static char buffer [128]; |
1124 | char * buff = buffer; | |
1125 | ||
92a438d1 KG |
1126 | /* Read the pragma name into a buffer. |
1127 | ISSPACE() may evaluate its argument more than once! */ | |
1128 | while (((c = getc (finput)), ISSPACE(c))) | |
ae4d12ca NC |
1129 | continue; |
1130 | ||
1131 | do | |
1132 | { | |
1133 | * buff ++ = c; | |
1134 | c = getc (finput); | |
1135 | } | |
92a438d1 | 1136 | while (c != EOF && ! ISSPACE (c) && c != '\n' |
ae4d12ca NC |
1137 | && buff < buffer + 128); |
1138 | ||
1139 | pragma_ungetc (c); | |
1140 | ||
1141 | * -- buff = 0; | |
5ff904cd | 1142 | #ifdef HANDLE_PRAGMA |
ae4d12ca NC |
1143 | if (HANDLE_PRAGMA (pragma_getc, pragma_ungetc, buffer)) |
1144 | goto skipline; | |
5ff904cd | 1145 | #endif /* HANDLE_PRAGMA */ |
a09a009c NC |
1146 | #ifdef HANDLE_GENERIC_PRAGMAS |
1147 | if (handle_generic_pragma (buffer)) | |
ae4d12ca | 1148 | goto skipline; |
a09a009c | 1149 | #endif /* !HANDLE_GENERIC_PRAGMAS */ |
ae4d12ca NC |
1150 | |
1151 | /* Issue a warning message if we have been asked to do so. | |
1152 | Ignoring unknown pragmas in system header file unless | |
1153 | an explcit -Wunknown-pragmas has been given. */ | |
1154 | if (warn_unknown_pragmas > 1 | |
1155 | || (warn_unknown_pragmas && ! in_system_header)) | |
1156 | warning ("ignoring pragma: %s", token_buffer); | |
5ff904cd | 1157 | #endif /* 0 */ |
ae4d12ca | 1158 | goto skipline; |
5ff904cd JL |
1159 | } |
1160 | } | |
1161 | ||
1162 | else if (c == 'd') | |
1163 | { | |
1164 | if (getc (finput) == 'e' | |
1165 | && getc (finput) == 'f' | |
1166 | && getc (finput) == 'i' | |
1167 | && getc (finput) == 'n' | |
1168 | && getc (finput) == 'e' | |
1169 | && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' | |
1170 | || c == EOF)) | |
1171 | { | |
1172 | char *text; | |
1173 | ||
1174 | c = ffelex_get_directive_line_ (&text, finput); | |
1175 | ||
1176 | #ifdef DWARF_DEBUGGING_INFO | |
1177 | if ((debug_info_level == DINFO_LEVEL_VERBOSE) | |
1178 | && (write_symbols == DWARF_DEBUG)) | |
1179 | dwarfout_define (lineno, text); | |
1180 | #endif /* DWARF_DEBUGGING_INFO */ | |
1181 | ||
1182 | goto skipline; | |
1183 | } | |
1184 | } | |
1185 | else if (c == 'u') | |
1186 | { | |
1187 | if (getc (finput) == 'n' | |
1188 | && getc (finput) == 'd' | |
1189 | && getc (finput) == 'e' | |
1190 | && getc (finput) == 'f' | |
1191 | && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' | |
1192 | || c == EOF)) | |
1193 | { | |
1194 | char *text; | |
1195 | ||
1196 | c = ffelex_get_directive_line_ (&text, finput); | |
1197 | ||
1198 | #ifdef DWARF_DEBUGGING_INFO | |
1199 | if ((debug_info_level == DINFO_LEVEL_VERBOSE) | |
1200 | && (write_symbols == DWARF_DEBUG)) | |
1201 | dwarfout_undef (lineno, text); | |
1202 | #endif /* DWARF_DEBUGGING_INFO */ | |
1203 | ||
1204 | goto skipline; | |
1205 | } | |
1206 | } | |
1207 | else if (c == 'l') | |
1208 | { | |
1209 | if (getc (finput) == 'i' | |
1210 | && getc (finput) == 'n' | |
1211 | && getc (finput) == 'e' | |
1212 | && ((c = getc (finput)) == ' ' || c == '\t')) | |
1213 | goto linenum; | |
1214 | } | |
1215 | else if (c == 'i') | |
1216 | { | |
1217 | if (getc (finput) == 'd' | |
1218 | && getc (finput) == 'e' | |
1219 | && getc (finput) == 'n' | |
1220 | && getc (finput) == 't' | |
1221 | && ((c = getc (finput)) == ' ' || c == '\t')) | |
1222 | { | |
86702e31 | 1223 | /* #ident. The pedantic warning is now in cpp. */ |
5ff904cd JL |
1224 | |
1225 | /* Here we have just seen `#ident '. | |
1226 | A string constant should follow. */ | |
1227 | ||
1228 | while (c == ' ' || c == '\t') | |
1229 | c = getc (finput); | |
1230 | ||
1231 | /* If no argument, ignore the line. */ | |
1232 | if (c == '\n' || c == EOF) | |
1233 | return c; | |
1234 | ||
1235 | c = ffelex_cfelex_ (&token, finput, c); | |
1236 | ||
1237 | if ((token == NULL) | |
1238 | || (ffelex_token_type (token) != FFELEX_typeCHARACTER)) | |
1239 | { | |
1240 | error ("invalid #ident"); | |
1241 | goto skipline; | |
1242 | } | |
1243 | ||
1328d92f | 1244 | if (! flag_no_ident) |
5ff904cd JL |
1245 | { |
1246 | #ifdef ASM_OUTPUT_IDENT | |
1247 | ASM_OUTPUT_IDENT (asm_out_file, | |
1248 | ffelex_token_text (token)); | |
1249 | #endif | |
1250 | } | |
1251 | ||
1252 | /* Skip the rest of this line. */ | |
1253 | goto skipline; | |
1254 | } | |
1255 | } | |
1256 | ||
1257 | error ("undefined or invalid # directive"); | |
1258 | goto skipline; | |
1259 | } | |
1260 | ||
1261 | linenum: | |
1262 | /* Here we have either `#line' or `# <nonletter>'. | |
1263 | In either case, it should be a line number; a digit should follow. */ | |
1264 | ||
1265 | while (c == ' ' || c == '\t') | |
1266 | c = ffelex_getc_ (finput); | |
1267 | ||
1268 | /* If the # is the only nonwhite char on the line, | |
1269 | just ignore it. Check the new newline. */ | |
1270 | if (c == '\n' || c == EOF) | |
1271 | return c; | |
1272 | ||
1273 | /* Something follows the #; read a token. */ | |
1274 | ||
1275 | c = ffelex_cfelex_ (&token, finput, c); | |
1276 | ||
1277 | if ((token != NULL) | |
1278 | && (ffelex_token_type (token) == FFELEX_typeNUMBER)) | |
1279 | { | |
1280 | int old_lineno = lineno; | |
3b304f5b | 1281 | const char *old_input_filename = input_filename; |
5ff904cd JL |
1282 | ffewhereFile wf; |
1283 | ||
1284 | /* subtract one, because it is the following line that | |
1285 | gets the specified number */ | |
1286 | int l = atoi (ffelex_token_text (token)) - 1; | |
1287 | ||
1288 | /* Is this the last nonwhite stuff on the line? */ | |
1289 | while (c == ' ' || c == '\t') | |
1290 | c = ffelex_getc_ (finput); | |
1291 | if (c == '\n' || c == EOF) | |
1292 | { | |
1293 | /* No more: store the line number and check following line. */ | |
1294 | lineno = l; | |
1295 | if (!ffelex_kludge_flag_) | |
1296 | { | |
1297 | ffewhere_file_set (NULL, TRUE, (ffewhereLineNumber) l); | |
1298 | ||
1299 | if (token != NULL) | |
1300 | ffelex_token_kill (token); | |
1301 | } | |
1302 | return c; | |
1303 | } | |
1304 | ||
1305 | /* More follows: it must be a string constant (filename). */ | |
1306 | ||
1307 | /* Read the string constant. */ | |
1308 | c = ffelex_cfelex_ (&token, finput, c); | |
1309 | ||
1310 | if ((token == NULL) | |
1311 | || (ffelex_token_type (token) != FFELEX_typeCHARACTER)) | |
1312 | { | |
1313 | error ("invalid #line"); | |
1314 | goto skipline; | |
1315 | } | |
1316 | ||
1317 | lineno = l; | |
1318 | ||
1319 | if (ffelex_kludge_flag_) | |
a8a05998 | 1320 | input_filename = ggc_strdup (ffelex_token_text (token)); |
5ff904cd JL |
1321 | else |
1322 | { | |
1323 | wf = ffewhere_file_new (ffelex_token_text (token), | |
1324 | ffelex_token_length (token)); | |
1325 | input_filename = ffewhere_file_name (wf); | |
1326 | ffewhere_file_set (wf, TRUE, (ffewhereLineNumber) l); | |
1327 | } | |
1328 | ||
1329 | #if 0 /* Not sure what g77 should do with this yet. */ | |
1330 | /* Each change of file name | |
1331 | reinitializes whether we are now in a system header. */ | |
1332 | in_system_header = 0; | |
1333 | #endif | |
1334 | ||
1335 | if (main_input_filename == 0) | |
1336 | main_input_filename = input_filename; | |
1337 | ||
1338 | /* Is this the last nonwhite stuff on the line? */ | |
1339 | while (c == ' ' || c == '\t') | |
1340 | c = getc (finput); | |
1341 | if (c == '\n' || c == EOF) | |
1342 | { | |
1343 | if (!ffelex_kludge_flag_) | |
1344 | { | |
1345 | /* Update the name in the top element of input_file_stack. */ | |
1346 | if (input_file_stack) | |
1347 | input_file_stack->name = input_filename; | |
1348 | ||
1349 | if (token != NULL) | |
1350 | ffelex_token_kill (token); | |
1351 | } | |
1352 | return c; | |
1353 | } | |
1354 | ||
1355 | c = ffelex_cfelex_ (&token, finput, c); | |
1356 | ||
1357 | /* `1' after file name means entering new file. | |
1358 | `2' after file name means just left a file. */ | |
1359 | ||
1360 | if ((token != NULL) | |
1361 | && (ffelex_token_type (token) == FFELEX_typeNUMBER)) | |
1362 | { | |
1363 | int num = atoi (ffelex_token_text (token)); | |
1364 | ||
1365 | if (ffelex_kludge_flag_) | |
1366 | { | |
1367 | lineno = 1; | |
1368 | input_filename = old_input_filename; | |
400500c4 | 1369 | error ("Use `#line ...' instead of `# ...' in first line"); |
5ff904cd JL |
1370 | } |
1371 | ||
1372 | if (num == 1) | |
1373 | { | |
1374 | /* Pushing to a new file. */ | |
1375 | ffelex_file_push_ (old_lineno, input_filename); | |
1376 | } | |
1377 | else if (num == 2) | |
1378 | { | |
1379 | /* Popping out of a file. */ | |
1380 | ffelex_file_pop_ (input_filename); | |
1381 | } | |
1382 | ||
1383 | /* Is this the last nonwhite stuff on the line? */ | |
1384 | while (c == ' ' || c == '\t') | |
1385 | c = getc (finput); | |
1386 | if (c == '\n' || c == EOF) | |
1387 | { | |
1388 | if (token != NULL) | |
1389 | ffelex_token_kill (token); | |
1390 | return c; | |
1391 | } | |
1392 | ||
1393 | c = ffelex_cfelex_ (&token, finput, c); | |
1394 | } | |
1395 | ||
1396 | /* `3' after file name means this is a system header file. */ | |
1397 | ||
1398 | #if 0 /* Not sure what g77 should do with this yet. */ | |
1399 | if ((token != NULL) | |
1400 | && (ffelex_token_type (token) == FFELEX_typeNUMBER) | |
1401 | && (atoi (ffelex_token_text (token)) == 3)) | |
1402 | in_system_header = 1; | |
1403 | #endif | |
1404 | ||
1405 | while (c == ' ' || c == '\t') | |
1406 | c = getc (finput); | |
1407 | if (((token != NULL) | |
1408 | || (c != '\n' && c != EOF)) | |
1409 | && ffelex_kludge_flag_) | |
1410 | { | |
1411 | lineno = 1; | |
1412 | input_filename = old_input_filename; | |
400500c4 | 1413 | error ("Use `#line ...' instead of `# ...' in first line"); |
5ff904cd JL |
1414 | } |
1415 | } | |
1416 | else | |
1417 | error ("invalid #-line"); | |
1418 | ||
1419 | /* skip the rest of this line. */ | |
1420 | skipline: | |
1421 | if ((token != NULL) && !ffelex_kludge_flag_) | |
1422 | ffelex_token_kill (token); | |
1423 | while ((c = getc (finput)) != EOF && c != '\n') | |
1424 | ; | |
1425 | return c; | |
1426 | } | |
1427 | #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ | |
1428 | ||
1429 | /* "Image" a character onto the card image, return incremented column number. | |
1430 | ||
1431 | Normally invoking this function as in | |
1432 | column = ffelex_image_char_ (c, column); | |
1433 | is the same as doing: | |
1434 | ffelex_card_image_[column++] = c; | |
1435 | ||
1436 | However, tabs and carriage returns are handled specially, to preserve | |
1437 | the visual "image" of the input line (in most editors) in the card | |
1438 | image. | |
1439 | ||
1440 | Carriage returns are ignored, as they are assumed to be followed | |
1441 | by newlines. | |
1442 | ||
1443 | A tab is handled by first doing: | |
1444 | ffelex_card_image_[column++] = ' '; | |
1445 | That is, it translates to at least one space. Then, as many spaces | |
1446 | are imaged as necessary to bring the column number to the next tab | |
1447 | position, where tab positions start in the ninth column and each | |
1448 | eighth column afterwards. ALSO, a static var named ffelex_saw_tab_ | |
1449 | is set to TRUE to notify the lexer that a tab was seen. | |
1450 | ||
1451 | Columns are numbered and tab stops set as illustrated below: | |
1452 | ||
1453 | 012345670123456701234567... | |
1454 | x y z | |
1455 | xx yy zz | |
1456 | ... | |
1457 | xxxxxxx yyyyyyy zzzzzzz | |
1458 | xxxxxxxx yyyyyyyy... */ | |
1459 | ||
1460 | static ffewhereColumnNumber | |
1461 | ffelex_image_char_ (int c, ffewhereColumnNumber column) | |
1462 | { | |
1463 | ffewhereColumnNumber old_column = column; | |
1464 | ||
1465 | if (column >= ffelex_card_size_) | |
1466 | { | |
1467 | ffewhereColumnNumber newmax = ffelex_card_size_ << 1; | |
1468 | ||
1469 | if (ffelex_bad_line_) | |
1470 | return column; | |
1471 | ||
1472 | if ((newmax >> 1) != ffelex_card_size_) | |
1473 | { /* Overflowed column number. */ | |
1474 | overflow: /* :::::::::::::::::::: */ | |
1475 | ||
1476 | ffelex_bad_line_ = TRUE; | |
1477 | strcpy (&ffelex_card_image_[column - 3], "..."); | |
1478 | ffelex_card_length_ = column; | |
1479 | ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG, | |
1480 | ffelex_linecount_current_, column + 1); | |
1481 | return column; | |
1482 | } | |
1483 | ||
1484 | ffelex_card_image_ | |
1485 | = malloc_resize_ksr (malloc_pool_image (), | |
1486 | ffelex_card_image_, | |
1487 | newmax + 9, | |
1488 | ffelex_card_size_ + 9); | |
1489 | ffelex_card_size_ = newmax; | |
1490 | } | |
1491 | ||
1492 | switch (c) | |
1493 | { | |
1494 | case '\r': | |
1495 | break; | |
1496 | ||
1497 | case '\t': | |
1498 | ffelex_saw_tab_ = TRUE; | |
1499 | ffelex_card_image_[column++] = ' '; | |
1500 | while ((column & 7) != 0) | |
1501 | ffelex_card_image_[column++] = ' '; | |
1502 | break; | |
1503 | ||
1504 | case '\0': | |
1505 | if (!ffelex_bad_line_) | |
1506 | { | |
1507 | ffelex_bad_line_ = TRUE; | |
1508 | strcpy (&ffelex_card_image_[column], "[\\0]"); | |
1509 | ffelex_card_length_ = column + 4; | |
1510 | ffebad_start_msg_lex ("Null character at %0 -- line ignored", | |
1511 | FFEBAD_severityFATAL); | |
1512 | ffelex_bad_here_ (0, ffelex_linecount_current_, column + 1); | |
1513 | ffebad_finish (); | |
1514 | column += 4; | |
1515 | } | |
1516 | break; | |
1517 | ||
1518 | default: | |
1519 | ffelex_card_image_[column++] = c; | |
1520 | break; | |
1521 | } | |
1522 | ||
1523 | if (column < old_column) | |
1524 | { | |
1525 | column = old_column; | |
1526 | goto overflow; /* :::::::::::::::::::: */ | |
1527 | } | |
1528 | ||
1529 | return column; | |
1530 | } | |
1531 | ||
1532 | static void | |
1533 | ffelex_include_ () | |
1534 | { | |
1535 | ffewhereFile include_wherefile = ffelex_include_wherefile_; | |
1536 | FILE *include_file = ffelex_include_file_; | |
1537 | /* The rest of this is to push, and after the INCLUDE file is processed, | |
1538 | pop, the static lexer state info that pertains to each particular | |
1539 | input file. */ | |
1540 | char *card_image; | |
1541 | ffewhereColumnNumber card_size = ffelex_card_size_; | |
1542 | ffewhereColumnNumber card_length = ffelex_card_length_; | |
1543 | ffewhereLine current_wl = ffelex_current_wl_; | |
1544 | ffewhereColumn current_wc = ffelex_current_wc_; | |
1545 | bool saw_tab = ffelex_saw_tab_; | |
1546 | ffewhereColumnNumber final_nontab_column = ffelex_final_nontab_column_; | |
1547 | ffewhereFile current_wf = ffelex_current_wf_; | |
1548 | ffewhereLineNumber linecount_current = ffelex_linecount_current_; | |
1549 | ffewhereLineNumber linecount_offset | |
1550 | = ffewhere_line_filelinenum (current_wl); | |
1551 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1552 | int old_lineno = lineno; | |
3b304f5b | 1553 | const char *old_input_filename = input_filename; |
5ff904cd JL |
1554 | #endif |
1555 | ||
1556 | if (card_length != 0) | |
1557 | { | |
1558 | card_image = malloc_new_ks (malloc_pool_image (), | |
1559 | "FFELEX saved card image", | |
1560 | card_length); | |
1561 | memcpy (card_image, ffelex_card_image_, card_length); | |
1562 | } | |
1563 | else | |
1564 | card_image = NULL; | |
1565 | ||
1566 | ffelex_set_include_ = FALSE; | |
1567 | ||
1568 | ffelex_next_line_ (); | |
1569 | ||
1570 | ffewhere_file_set (include_wherefile, TRUE, 0); | |
1571 | ||
1572 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1573 | ffelex_file_push_ (old_lineno, ffewhere_file_name (include_wherefile)); | |
1574 | #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ | |
1575 | ||
1576 | if (ffelex_include_free_form_) | |
1577 | ffelex_file_free (include_wherefile, include_file); | |
1578 | else | |
1579 | ffelex_file_fixed (include_wherefile, include_file); | |
1580 | ||
1581 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1582 | ffelex_file_pop_ (ffewhere_file_name (current_wf)); | |
1583 | #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ | |
1584 | ||
1585 | ffewhere_file_set (current_wf, TRUE, linecount_offset); | |
1586 | ||
1587 | ffecom_close_include (include_file); | |
1588 | ||
1589 | if (card_length != 0) | |
1590 | { | |
1591 | #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */ | |
1592 | #error "need to handle possible reduction of card size here!!" | |
1593 | #endif | |
1594 | assert (ffelex_card_size_ >= card_length); /* It shrunk?? */ | |
1595 | memcpy (ffelex_card_image_, card_image, card_length); | |
1596 | } | |
1597 | ffelex_card_image_[card_length] = '\0'; | |
1598 | ||
1599 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1600 | input_filename = old_input_filename; | |
1601 | lineno = old_lineno; | |
1602 | #endif | |
1603 | ffelex_linecount_current_ = linecount_current; | |
1604 | ffelex_current_wf_ = current_wf; | |
1605 | ffelex_final_nontab_column_ = final_nontab_column; | |
1606 | ffelex_saw_tab_ = saw_tab; | |
1607 | ffelex_current_wc_ = current_wc; | |
1608 | ffelex_current_wl_ = current_wl; | |
1609 | ffelex_card_length_ = card_length; | |
1610 | ffelex_card_size_ = card_size; | |
1611 | } | |
1612 | ||
1613 | /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation? | |
1614 | ||
1615 | ffewhereColumnNumber col; | |
1616 | int c; // Char at col. | |
1617 | if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1)) | |
1618 | // We have a continuation indicator. | |
1619 | ||
1620 | If there are <n> spaces starting at ffelex_card_image_[col] up through | |
1621 | the null character, where <n> is 0 or greater, returns TRUE. */ | |
1622 | ||
1623 | static bool | |
1624 | ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col) | |
1625 | { | |
1626 | while (ffelex_card_image_[col] != '\0') | |
1627 | { | |
1628 | if (ffelex_card_image_[col++] != ' ') | |
1629 | return FALSE; | |
1630 | } | |
1631 | return TRUE; | |
1632 | } | |
1633 | ||
1634 | /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation? | |
1635 | ||
1636 | ffewhereColumnNumber col; | |
1637 | int c; // Char at col. | |
1638 | if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1)) | |
1639 | // We have a continuation indicator. | |
1640 | ||
1641 | If there are <n> spaces starting at ffelex_card_image_[col] up through | |
1642 | the null character or '!', where <n> is 0 or greater, returns TRUE. */ | |
1643 | ||
1644 | static bool | |
1645 | ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col) | |
1646 | { | |
1647 | while ((ffelex_card_image_[col] != '\0') && (ffelex_card_image_[col] != '!')) | |
1648 | { | |
1649 | if (ffelex_card_image_[col++] != ' ') | |
1650 | return FALSE; | |
1651 | } | |
1652 | return TRUE; | |
1653 | } | |
1654 | ||
1655 | static void | |
1656 | ffelex_next_line_ () | |
1657 | { | |
1658 | ffelex_linecount_current_ = ffelex_linecount_next_; | |
1659 | ++ffelex_linecount_next_; | |
1660 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1661 | ++lineno; | |
1662 | #endif | |
1663 | } | |
1664 | ||
1665 | static void | |
1666 | ffelex_send_token_ () | |
1667 | { | |
1668 | ++ffelex_number_of_tokens_; | |
1669 | ||
1670 | ffelex_backslash_ (EOF, 0); | |
1671 | ||
1672 | if (ffelex_token_->text == NULL) | |
1673 | { | |
1674 | if (ffelex_token_->type == FFELEX_typeCHARACTER) | |
1675 | { | |
1676 | ffelex_append_to_token_ ('\0'); | |
1677 | ffelex_token_->length = 0; | |
1678 | } | |
1679 | } | |
1680 | else | |
1681 | ffelex_token_->text[ffelex_token_->length] = '\0'; | |
1682 | ||
1683 | assert (ffelex_raw_mode_ == 0); | |
1684 | ||
1685 | if (ffelex_token_->type == FFELEX_typeNAMES) | |
1686 | { | |
1687 | ffewhere_line_kill (ffelex_token_->currentnames_line); | |
1688 | ffewhere_column_kill (ffelex_token_->currentnames_col); | |
1689 | } | |
1690 | ||
1691 | assert (ffelex_handler_ != NULL); | |
1692 | ffelex_handler_ = (ffelexHandler) (*ffelex_handler_) (ffelex_token_); | |
1693 | assert (ffelex_handler_ != NULL); | |
1694 | ||
1695 | ffelex_token_kill (ffelex_token_); | |
1696 | ||
1697 | ffelex_token_ = ffelex_token_new_ (); | |
1698 | ffelex_token_->uses = 1; | |
1699 | ffelex_token_->text = NULL; | |
1700 | if (ffelex_raw_mode_ < 0) | |
1701 | { | |
1702 | ffelex_token_->type = FFELEX_typeCHARACTER; | |
1703 | ffelex_token_->where_line = ffelex_raw_where_line_; | |
1704 | ffelex_token_->where_col = ffelex_raw_where_col_; | |
1705 | ffelex_raw_where_line_ = ffewhere_line_unknown (); | |
1706 | ffelex_raw_where_col_ = ffewhere_column_unknown (); | |
1707 | } | |
1708 | else | |
1709 | { | |
1710 | ffelex_token_->type = FFELEX_typeNONE; | |
1711 | ffelex_token_->where_line = ffewhere_line_unknown (); | |
1712 | ffelex_token_->where_col = ffewhere_column_unknown (); | |
1713 | } | |
1714 | ||
1715 | if (ffelex_set_include_) | |
1716 | ffelex_include_ (); | |
1717 | } | |
1718 | ||
1719 | /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me | |
1720 | ||
1721 | return ffelex_swallow_tokens_; | |
1722 | ||
1723 | Return this handler when you don't want to look at any more tokens in the | |
1724 | statement because you've encountered an unrecoverable error in the | |
1725 | statement. */ | |
1726 | ||
1727 | static ffelexHandler | |
1728 | ffelex_swallow_tokens_ (ffelexToken t) | |
1729 | { | |
1730 | assert (ffelex_eos_handler_ != NULL); | |
1731 | ||
1732 | if ((ffelex_token_type (t) == FFELEX_typeEOS) | |
1733 | || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)) | |
1734 | return (ffelexHandler) (*ffelex_eos_handler_) (t); | |
1735 | ||
1736 | return (ffelexHandler) ffelex_swallow_tokens_; | |
1737 | } | |
1738 | ||
1739 | static ffelexToken | |
1740 | ffelex_token_new_ () | |
1741 | { | |
1742 | ffelexToken t; | |
1743 | ||
1744 | ++ffelex_total_tokens_; | |
1745 | ||
1746 | t = (ffelexToken) malloc_new_ks (malloc_pool_image (), | |
1747 | "FFELEX token", sizeof (*t)); | |
1748 | t->id_ = ffelex_token_nextid_++; | |
1749 | return t; | |
1750 | } | |
1751 | ||
26f096f9 | 1752 | static const char * |
5ff904cd JL |
1753 | ffelex_type_string_ (ffelexType type) |
1754 | { | |
26f096f9 | 1755 | static const char *types[] = { |
5ff904cd JL |
1756 | "FFELEX_typeNONE", |
1757 | "FFELEX_typeCOMMENT", | |
1758 | "FFELEX_typeEOS", | |
1759 | "FFELEX_typeEOF", | |
1760 | "FFELEX_typeERROR", | |
1761 | "FFELEX_typeRAW", | |
1762 | "FFELEX_typeQUOTE", | |
1763 | "FFELEX_typeDOLLAR", | |
1764 | "FFELEX_typeHASH", | |
1765 | "FFELEX_typePERCENT", | |
1766 | "FFELEX_typeAMPERSAND", | |
1767 | "FFELEX_typeAPOSTROPHE", | |
1768 | "FFELEX_typeOPEN_PAREN", | |
1769 | "FFELEX_typeCLOSE_PAREN", | |
1770 | "FFELEX_typeASTERISK", | |
1771 | "FFELEX_typePLUS", | |
1772 | "FFELEX_typeMINUS", | |
1773 | "FFELEX_typePERIOD", | |
1774 | "FFELEX_typeSLASH", | |
1775 | "FFELEX_typeNUMBER", | |
1776 | "FFELEX_typeOPEN_ANGLE", | |
1777 | "FFELEX_typeEQUALS", | |
1778 | "FFELEX_typeCLOSE_ANGLE", | |
1779 | "FFELEX_typeNAME", | |
1780 | "FFELEX_typeCOMMA", | |
1781 | "FFELEX_typePOWER", | |
1782 | "FFELEX_typeCONCAT", | |
1783 | "FFELEX_typeDEBUG", | |
1784 | "FFELEX_typeNAMES", | |
1785 | "FFELEX_typeHOLLERITH", | |
1786 | "FFELEX_typeCHARACTER", | |
1787 | "FFELEX_typeCOLON", | |
1788 | "FFELEX_typeSEMICOLON", | |
1789 | "FFELEX_typeUNDERSCORE", | |
1790 | "FFELEX_typeQUESTION", | |
1791 | "FFELEX_typeOPEN_ARRAY", | |
1792 | "FFELEX_typeCLOSE_ARRAY", | |
1793 | "FFELEX_typeCOLONCOLON", | |
1794 | "FFELEX_typeREL_LE", | |
1795 | "FFELEX_typeREL_NE", | |
1796 | "FFELEX_typeREL_EQ", | |
1797 | "FFELEX_typePOINTS", | |
1798 | "FFELEX_typeREL_GE" | |
1799 | }; | |
1800 | ||
1801 | if (type >= ARRAY_SIZE (types)) | |
1802 | return "???"; | |
1803 | return types[type]; | |
1804 | } | |
1805 | ||
1806 | void | |
1807 | ffelex_display_token (ffelexToken t) | |
1808 | { | |
1809 | if (t == NULL) | |
1810 | t = ffelex_token_; | |
1811 | ||
1812 | fprintf (dmpout, "; Token #%lu is %s (line %" ffewhereLineNumber_f "u, col %" | |
1813 | ffewhereColumnNumber_f "u)", | |
1814 | t->id_, | |
1815 | ffelex_type_string_ (t->type), | |
1816 | ffewhere_line_number (t->where_line), | |
1817 | ffewhere_column_number (t->where_col)); | |
1818 | ||
1819 | if (t->text != NULL) | |
1820 | fprintf (dmpout, ": \"%.*s\"\n", | |
1821 | (int) t->length, | |
1822 | t->text); | |
1823 | else | |
1824 | fprintf (dmpout, ".\n"); | |
1825 | } | |
1826 | ||
1827 | /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER | |
1828 | ||
1829 | if (ffelex_expecting_character()) | |
1830 | // next token delivered by lexer will be CHARACTER. | |
1831 | ||
1832 | If the most recent call to ffelex_set_expecting_hollerith since the last | |
1833 | token was delivered by the lexer passed a length of -1, then we return | |
1834 | TRUE, because the next token we deliver will be typeCHARACTER, else we | |
1835 | return FALSE. */ | |
1836 | ||
1837 | bool | |
1838 | ffelex_expecting_character () | |
1839 | { | |
1840 | return (ffelex_raw_mode_ != 0); | |
1841 | } | |
1842 | ||
1843 | /* ffelex_file_fixed -- Lex a given file in fixed source form | |
1844 | ||
1845 | ffewhere wf; | |
1846 | FILE *f; | |
1847 | ffelex_file_fixed(wf,f); | |
1848 | ||
1849 | Lexes the file according to Fortran 90 ANSI + VXT specifications. */ | |
1850 | ||
1851 | ffelexHandler | |
1852 | ffelex_file_fixed (ffewhereFile wf, FILE *f) | |
1853 | { | |
8b45da67 CB |
1854 | register int c = 0; /* Character currently under consideration. */ |
1855 | register ffewhereColumnNumber column = 0; /* Not really; 0 means column 1... */ | |
5ff904cd | 1856 | bool disallow_continuation_line; |
8b45da67 | 1857 | bool ignore_disallowed_continuation = FALSE; |
5ff904cd JL |
1858 | int latest_char_in_file = 0; /* For getting back into comment-skipping |
1859 | code. */ | |
1860 | ffelexType lextype; | |
1861 | ffewhereColumnNumber first_label_char; /* First char of label -- | |
1862 | column number. */ | |
1863 | char label_string[6]; /* Text of label. */ | |
1864 | int labi; /* Length of label text. */ | |
1865 | bool finish_statement; /* Previous statement finished? */ | |
1866 | bool have_content; /* This line have content? */ | |
1867 | bool just_do_label; /* Nothing but label (and continuation?) on | |
1868 | line. */ | |
1869 | ||
1870 | /* Lex is called for a particular file, not for a particular program unit. | |
1871 | Yet the two events do share common characteristics. The first line in a | |
1872 | file or in a program unit cannot be a continuation line. No token can | |
1873 | be in mid-formation. No current label for the statement exists, since | |
1874 | there is no current statement. */ | |
1875 | ||
1876 | assert (ffelex_handler_ != NULL); | |
1877 | ||
1878 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1879 | lineno = 0; | |
1880 | input_filename = ffewhere_file_name (wf); | |
1881 | #endif | |
1882 | ffelex_current_wf_ = wf; | |
1883 | disallow_continuation_line = TRUE; | |
1884 | ignore_disallowed_continuation = FALSE; | |
1885 | ffelex_token_->type = FFELEX_typeNONE; | |
1886 | ffelex_number_of_tokens_ = 0; | |
1887 | ffelex_label_tokens_ = 0; | |
1888 | ffelex_current_wl_ = ffewhere_line_unknown (); | |
1889 | ffelex_current_wc_ = ffewhere_column_unknown (); | |
1890 | latest_char_in_file = '\n'; | |
95a1b676 CB |
1891 | |
1892 | if (ffe_is_null_version ()) | |
1893 | { | |
1894 | /* Just substitute a "program" directly here. */ | |
1895 | ||
1896 | char line[] = " call g77__fvers;call g77__ivers;call g77__uvers;end"; | |
1897 | char *p; | |
1898 | ||
1899 | column = 0; | |
1900 | for (p = &line[0]; *p != '\0'; ++p) | |
1901 | column = ffelex_image_char_ (*p, column); | |
1902 | ||
1903 | c = EOF; | |
1904 | ||
1905 | goto have_line; /* :::::::::::::::::::: */ | |
1906 | } | |
1907 | ||
5ff904cd JL |
1908 | goto first_line; /* :::::::::::::::::::: */ |
1909 | ||
1910 | /* Come here to get a new line. */ | |
1911 | ||
1912 | beginning_of_line: /* :::::::::::::::::::: */ | |
1913 | ||
1914 | disallow_continuation_line = FALSE; | |
1915 | ||
1916 | /* Come here directly when last line didn't clarify the continuation issue. */ | |
1917 | ||
1918 | beginning_of_line_again: /* :::::::::::::::::::: */ | |
1919 | ||
1920 | #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */ | |
1921 | if (ffelex_card_size_ != FFELEX_columnINITIAL_SIZE_) | |
1922 | { | |
1923 | ffelex_card_image_ | |
1924 | = malloc_resize_ks (malloc_pool_image (), | |
1925 | ffelex_card_image_, | |
1926 | FFELEX_columnINITIAL_SIZE_ + 9, | |
1927 | ffelex_card_size_ + 9); | |
1928 | ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_; | |
1929 | } | |
1930 | #endif | |
1931 | ||
1932 | first_line: /* :::::::::::::::::::: */ | |
1933 | ||
1934 | c = latest_char_in_file; | |
1935 | if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF)) | |
1936 | { | |
1937 | ||
1938 | end_of_file: /* :::::::::::::::::::: */ | |
1939 | ||
1940 | /* Line ending in EOF instead of \n still counts as a whole line. */ | |
1941 | ||
1942 | ffelex_finish_statement_ (); | |
1943 | ffewhere_line_kill (ffelex_current_wl_); | |
1944 | ffewhere_column_kill (ffelex_current_wc_); | |
1945 | return (ffelexHandler) ffelex_handler_; | |
1946 | } | |
1947 | ||
1948 | ffelex_next_line_ (); | |
1949 | ||
1950 | ffelex_bad_line_ = FALSE; | |
1951 | ||
1952 | /* Skip over comment (and otherwise ignored) lines as quickly as possible! */ | |
1953 | ||
1954 | while (((lextype = ffelex_first_char_[c]) == FFELEX_typeCOMMENT) | |
1955 | || (lextype == FFELEX_typeERROR) | |
1956 | || (lextype == FFELEX_typeSLASH) | |
1957 | || (lextype == FFELEX_typeHASH)) | |
1958 | { | |
1959 | /* Test most frequent type of line first, etc. */ | |
1960 | if ((lextype == FFELEX_typeCOMMENT) | |
1961 | || ((lextype == FFELEX_typeSLASH) | |
1962 | && ((c = getc (f)) == '*'))) /* NOTE SIDE-EFFECT. */ | |
1963 | { | |
1964 | /* Typical case (straight comment), just ignore rest of line. */ | |
1965 | comment_line: /* :::::::::::::::::::: */ | |
1966 | ||
1967 | while ((c != '\n') && (c != EOF)) | |
1968 | c = getc (f); | |
1969 | } | |
1970 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
1971 | else if (lextype == FFELEX_typeHASH) | |
1972 | c = ffelex_hash_ (f); | |
1973 | #endif | |
1974 | else if (lextype == FFELEX_typeSLASH) | |
1975 | { | |
1976 | /* SIDE-EFFECT ABOVE HAS HAPPENED. */ | |
1977 | ffelex_card_image_[0] = '/'; | |
1978 | ffelex_card_image_[1] = c; | |
1979 | column = 2; | |
1980 | goto bad_first_character; /* :::::::::::::::::::: */ | |
1981 | } | |
1982 | else | |
1983 | /* typeERROR or unsupported typeHASH. */ | |
1984 | { /* Bad first character, get line and display | |
1985 | it with message. */ | |
1986 | column = ffelex_image_char_ (c, 0); | |
1987 | ||
1988 | bad_first_character: /* :::::::::::::::::::: */ | |
1989 | ||
1990 | ffelex_bad_line_ = TRUE; | |
1991 | while (((c = getc (f)) != '\n') && (c != EOF)) | |
1992 | column = ffelex_image_char_ (c, column); | |
1993 | ffelex_card_image_[column] = '\0'; | |
1994 | ffelex_card_length_ = column; | |
1995 | ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID, | |
1996 | ffelex_linecount_current_, 1); | |
1997 | } | |
1998 | ||
1999 | /* Read past last char in line. */ | |
2000 | ||
2001 | if (c == EOF) | |
2002 | { | |
2003 | ffelex_next_line_ (); | |
2004 | goto end_of_file; /* :::::::::::::::::::: */ | |
2005 | } | |
2006 | ||
2007 | c = getc (f); | |
2008 | ||
2009 | ffelex_next_line_ (); | |
2010 | ||
2011 | if (c == EOF) | |
2012 | goto end_of_file; /* :::::::::::::::::::: */ | |
2013 | ||
2014 | ffelex_bad_line_ = FALSE; | |
2015 | } /* while [c, first char, means comment] */ | |
2016 | ||
2017 | ffelex_saw_tab_ | |
2018 | = (c == '&') | |
2019 | || (ffelex_final_nontab_column_ == 0); | |
2020 | ||
2021 | if (lextype == FFELEX_typeDEBUG) | |
2022 | c = ' '; /* A 'D' or 'd' in column 1 with the | |
2023 | debug-lines option on. */ | |
2024 | ||
2025 | column = ffelex_image_char_ (c, 0); | |
2026 | ||
2027 | /* Read the entire line in as is (with whitespace processing). */ | |
2028 | ||
2029 | while (((c = getc (f)) != '\n') && (c != EOF)) | |
2030 | column = ffelex_image_char_ (c, column); | |
2031 | ||
2032 | if (ffelex_bad_line_) | |
2033 | { | |
2034 | ffelex_card_image_[column] = '\0'; | |
2035 | ffelex_card_length_ = column; | |
2036 | goto comment_line; /* :::::::::::::::::::: */ | |
2037 | } | |
2038 | ||
2039 | /* If no tab, cut off line after column 72/132. */ | |
2040 | ||
2041 | if (!ffelex_saw_tab_ && (column > ffelex_final_nontab_column_)) | |
2042 | { | |
2043 | /* Technically, we should now fill ffelex_card_image_ up thru column | |
2044 | 72/132 with spaces, since character/hollerith constants must count | |
2045 | them in that manner. To save CPU time in several ways (avoid a loop | |
2046 | here that would be used only when we actually end a line in | |
2047 | character-constant mode; avoid writing memory unnecessarily; avoid a | |
2048 | loop later checking spaces when not scanning for character-constant | |
2049 | characters), we don't do this, and we do the appropriate thing when | |
2050 | we encounter end-of-line while actually processing a character | |
2051 | constant. */ | |
2052 | ||
2053 | column = ffelex_final_nontab_column_; | |
2054 | } | |
95a1b676 CB |
2055 | |
2056 | have_line: /* :::::::::::::::::::: */ | |
2057 | ||
5ff904cd JL |
2058 | ffelex_card_image_[column] = '\0'; |
2059 | ffelex_card_length_ = column; | |
2060 | ||
2061 | /* Save next char in file so we can use register-based c while analyzing | |
2062 | line we just read. */ | |
2063 | ||
2064 | latest_char_in_file = c; /* Should be either '\n' or EOF. */ | |
2065 | ||
2066 | have_content = FALSE; | |
2067 | ||
2068 | /* Handle label, if any. */ | |
2069 | ||
2070 | labi = 0; | |
2071 | first_label_char = FFEWHERE_columnUNKNOWN; | |
2072 | for (column = 0; column < 5; ++column) | |
2073 | { | |
2074 | switch (c = ffelex_card_image_[column]) | |
2075 | { | |
2076 | case '\0': | |
2077 | case '!': | |
2078 | goto stop_looking; /* :::::::::::::::::::: */ | |
2079 | ||
2080 | case ' ': | |
2081 | break; | |
2082 | ||
2083 | case '0': | |
2084 | case '1': | |
2085 | case '2': | |
2086 | case '3': | |
2087 | case '4': | |
2088 | case '5': | |
2089 | case '6': | |
2090 | case '7': | |
2091 | case '8': | |
2092 | case '9': | |
2093 | label_string[labi++] = c; | |
2094 | if (first_label_char == FFEWHERE_columnUNKNOWN) | |
2095 | first_label_char = column + 1; | |
2096 | break; | |
2097 | ||
2098 | case '&': | |
2099 | if (column != 0) | |
2100 | { | |
2101 | ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC, | |
2102 | ffelex_linecount_current_, | |
2103 | column + 1); | |
2104 | goto beginning_of_line_again; /* :::::::::::::::::::: */ | |
2105 | } | |
2106 | if (ffe_is_pedantic ()) | |
2107 | ffelex_bad_1_ (FFEBAD_AMPERSAND, | |
2108 | ffelex_linecount_current_, 1); | |
2109 | finish_statement = FALSE; | |
2110 | just_do_label = FALSE; | |
2111 | goto got_a_continuation; /* :::::::::::::::::::: */ | |
2112 | ||
2113 | case '/': | |
2114 | if (ffelex_card_image_[column + 1] == '*') | |
2115 | goto stop_looking; /* :::::::::::::::::::: */ | |
2116 | /* Fall through. */ | |
2117 | default: | |
2118 | ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC, | |
2119 | ffelex_linecount_current_, column + 1); | |
2120 | goto beginning_of_line_again; /* :::::::::::::::::::: */ | |
2121 | } | |
2122 | } | |
2123 | ||
2124 | stop_looking: /* :::::::::::::::::::: */ | |
2125 | ||
2126 | label_string[labi] = '\0'; | |
2127 | ||
2128 | /* Find first nonblank char starting with continuation column. */ | |
2129 | ||
2130 | if (column == 5) /* In which case we didn't see end of line in | |
2131 | label field. */ | |
2132 | while ((c = ffelex_card_image_[column]) == ' ') | |
2133 | ++column; | |
2134 | ||
2135 | /* Now we're trying to figure out whether this is a continuation line and | |
2136 | whether there's anything else of substance on the line. The cases are | |
2137 | as follows: | |
2138 | ||
2139 | 1. If a line has an explicit continuation character (other than the digit | |
2140 | zero), then if it also has a label, the label is ignored and an error | |
2141 | message is printed. Any remaining text on the line is passed to the | |
2142 | parser tasks, thus even an all-blank line (possibly with an ignored | |
2143 | label) aside from a positive continuation character might have meaning | |
2144 | in the midst of a character or hollerith constant. | |
2145 | ||
2146 | 2. If a line has no explicit continuation character (that is, it has a | |
2147 | space in column 6 and the first non-space character past column 6 is | |
2148 | not a digit 0-9), then there are two possibilities: | |
2149 | ||
2150 | A. A label is present and/or a non-space (and non-comment) character | |
2151 | appears somewhere after column 6. Terminate processing of the previous | |
2152 | statement, if any, send the new label for the next statement, if any, | |
2153 | and start processing a new statement with this non-blank character, if | |
2154 | any. | |
2155 | ||
2156 | B. The line is essentially blank, except for a possible comment character. | |
2157 | Don't terminate processing of the previous statement and don't pass any | |
2158 | characters to the parser tasks, since the line is not flagged as a | |
2159 | continuation line. We treat it just like a completely blank line. | |
2160 | ||
2161 | 3. If a line has a continuation character of zero (0), then we terminate | |
2162 | processing of the previous statement, if any, send the new label for the | |
2163 | next statement, if any, and start processing a new statement, if any | |
2164 | non-blank characters are present. | |
2165 | ||
2166 | If, when checking to see if we should terminate the previous statement, it | |
2167 | is found that there is no previous statement but that there is an | |
2168 | outstanding label, substitute CONTINUE as the statement for the label | |
2169 | and display an error message. */ | |
2170 | ||
2171 | finish_statement = FALSE; | |
2172 | just_do_label = FALSE; | |
2173 | ||
2174 | switch (c) | |
2175 | { | |
2176 | case '!': /* ANSI Fortran 90 says ! in column 6 is | |
2177 | continuation. */ | |
2178 | /* VXT Fortran says ! anywhere is comment, even column 6. */ | |
2179 | if (ffe_is_vxt () || (column != 5)) | |
2180 | goto no_tokens_on_line; /* :::::::::::::::::::: */ | |
2181 | goto got_a_continuation; /* :::::::::::::::::::: */ | |
2182 | ||
2183 | case '/': | |
2184 | if (ffelex_card_image_[column + 1] != '*') | |
2185 | goto some_other_character; /* :::::::::::::::::::: */ | |
2186 | /* Fall through. */ | |
2187 | if (column == 5) | |
2188 | { | |
2189 | /* This seems right to do. But it is close to call, since / * starting | |
2190 | in column 6 will thus be interpreted as a continuation line | |
2191 | beginning with '*'. */ | |
2192 | ||
2193 | goto got_a_continuation;/* :::::::::::::::::::: */ | |
2194 | } | |
2195 | /* Fall through. */ | |
2196 | case '\0': | |
2197 | /* End of line. Therefore may be continued-through line, so handle | |
2198 | pending label as possible to-be-continued and drive end-of-statement | |
2199 | for any previous statement, else treat as blank line. */ | |
2200 | ||
2201 | no_tokens_on_line: /* :::::::::::::::::::: */ | |
2202 | ||
2203 | if (ffe_is_pedantic () && (c == '/')) | |
2204 | ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT, | |
2205 | ffelex_linecount_current_, column + 1); | |
2206 | if (first_label_char != FFEWHERE_columnUNKNOWN) | |
2207 | { /* Can't be a continued-through line if it | |
2208 | has a label. */ | |
2209 | finish_statement = TRUE; | |
2210 | have_content = TRUE; | |
2211 | just_do_label = TRUE; | |
2212 | break; | |
2213 | } | |
2214 | goto beginning_of_line_again; /* :::::::::::::::::::: */ | |
2215 | ||
2216 | case '0': | |
2217 | if (ffe_is_pedantic () && (column != 5)) | |
2218 | ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, | |
2219 | ffelex_linecount_current_, column + 1); | |
2220 | finish_statement = TRUE; | |
2221 | goto check_for_content; /* :::::::::::::::::::: */ | |
2222 | ||
2223 | case '1': | |
2224 | case '2': | |
2225 | case '3': | |
2226 | case '4': | |
2227 | case '5': | |
2228 | case '6': | |
2229 | case '7': | |
2230 | case '8': | |
2231 | case '9': | |
2232 | ||
2233 | /* NOTE: This label can be reached directly from the code | |
2234 | that lexes the label field in columns 1-5. */ | |
2235 | got_a_continuation: /* :::::::::::::::::::: */ | |
2236 | ||
2237 | if (first_label_char != FFEWHERE_columnUNKNOWN) | |
2238 | { | |
2239 | ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION, | |
2240 | ffelex_linecount_current_, | |
2241 | first_label_char, | |
2242 | ffelex_linecount_current_, | |
2243 | column + 1); | |
2244 | first_label_char = FFEWHERE_columnUNKNOWN; | |
2245 | } | |
2246 | if (disallow_continuation_line) | |
2247 | { | |
2248 | if (!ignore_disallowed_continuation) | |
2249 | ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION, | |
2250 | ffelex_linecount_current_, column + 1); | |
2251 | goto beginning_of_line_again; /* :::::::::::::::::::: */ | |
2252 | } | |
2253 | if (ffe_is_pedantic () && (column != 5)) | |
2254 | ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, | |
2255 | ffelex_linecount_current_, column + 1); | |
2256 | if ((ffelex_raw_mode_ != 0) | |
2257 | && (((c = ffelex_card_image_[column + 1]) != '\0') | |
2258 | || !ffelex_saw_tab_)) | |
2259 | { | |
2260 | ++column; | |
2261 | have_content = TRUE; | |
2262 | break; | |
2263 | } | |
2264 | ||
2265 | check_for_content: /* :::::::::::::::::::: */ | |
2266 | ||
2267 | while ((c = ffelex_card_image_[++column]) == ' ') | |
2268 | ; | |
2269 | if ((c == '\0') | |
2270 | || (c == '!') | |
2271 | || ((c == '/') | |
2272 | && (ffelex_card_image_[column + 1] == '*'))) | |
2273 | { | |
2274 | if (ffe_is_pedantic () && (c == '/')) | |
2275 | ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT, | |
2276 | ffelex_linecount_current_, column + 1); | |
2277 | just_do_label = TRUE; | |
2278 | } | |
2279 | else | |
2280 | have_content = TRUE; | |
2281 | break; | |
2282 | ||
2283 | default: | |
2284 | ||
2285 | some_other_character: /* :::::::::::::::::::: */ | |
2286 | ||
2287 | if (column == 5) | |
2288 | goto got_a_continuation;/* :::::::::::::::::::: */ | |
2289 | ||
2290 | /* Here is the very normal case of a regular character starting in | |
2291 | column 7 or beyond with a blank in column 6. */ | |
2292 | ||
2293 | finish_statement = TRUE; | |
2294 | have_content = TRUE; | |
2295 | break; | |
2296 | } | |
2297 | ||
2298 | if (have_content | |
2299 | || (first_label_char != FFEWHERE_columnUNKNOWN)) | |
2300 | { | |
2301 | /* The line has content of some kind, install new end-statement | |
2302 | point for error messages. Note that "content" includes cases | |
2303 | where there's little apparent content but enough to finish | |
2304 | a statement. That's because finishing a statement can trigger | |
2305 | an impending INCLUDE, and that requires accurate line info being | |
2306 | maintained by the lexer. */ | |
2307 | ||
2308 | if (finish_statement) | |
2309 | ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */ | |
2310 | ||
2311 | ffewhere_line_kill (ffelex_current_wl_); | |
2312 | ffewhere_column_kill (ffelex_current_wc_); | |
2313 | ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_); | |
2314 | ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1); | |
2315 | } | |
2316 | ||
2317 | /* We delay this for a combination of reasons. Mainly, it can start | |
2318 | INCLUDE processing, and we want to delay that until the lexer's | |
2319 | info on the line is coherent. And we want to delay that until we're | |
2320 | sure there's a reason to make that info coherent, to avoid saving | |
2321 | lots of useless lines. */ | |
2322 | ||
2323 | if (finish_statement) | |
2324 | ffelex_finish_statement_ (); | |
2325 | ||
2326 | /* If label is present, enclose it in a NUMBER token and send it along. */ | |
2327 | ||
2328 | if (first_label_char != FFEWHERE_columnUNKNOWN) | |
2329 | { | |
2330 | assert (ffelex_token_->type == FFELEX_typeNONE); | |
2331 | ffelex_token_->type = FFELEX_typeNUMBER; | |
2332 | ffelex_append_to_token_ ('\0'); /* Make room for label text. */ | |
2333 | strcpy (ffelex_token_->text, label_string); | |
2334 | ffelex_token_->where_line | |
2335 | = ffewhere_line_use (ffelex_current_wl_); | |
2336 | ffelex_token_->where_col = ffewhere_column_new (first_label_char); | |
2337 | ffelex_token_->length = labi; | |
2338 | ffelex_send_token_ (); | |
2339 | ++ffelex_label_tokens_; | |
2340 | } | |
2341 | ||
2342 | if (just_do_label) | |
2343 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
2344 | ||
2345 | /* Here is the main engine for parsing. c holds the character at column. | |
2346 | It is already known that c is not a blank, end of line, or shriek, | |
2347 | unless ffelex_raw_mode_ is not 0 (indicating we are in a | |
2348 | character/hollerith constant). A partially filled token may already | |
2349 | exist in ffelex_token_. One special case: if, when the end of the line | |
2350 | is reached, continuation_line is FALSE and the only token on the line is | |
2351 | END, then it is indeed the last statement. We don't look for | |
2352 | continuation lines during this program unit in that case. This is | |
2353 | according to ANSI. */ | |
2354 | ||
2355 | if (ffelex_raw_mode_ != 0) | |
2356 | { | |
2357 | ||
2358 | parse_raw_character: /* :::::::::::::::::::: */ | |
2359 | ||
2360 | if (c == '\0') | |
2361 | { | |
2362 | ffewhereColumnNumber i; | |
2363 | ||
2364 | if (ffelex_saw_tab_ || (column >= ffelex_final_nontab_column_)) | |
2365 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
2366 | ||
2367 | /* Pad out line with "virtual" spaces. */ | |
2368 | ||
2369 | for (i = column; i < ffelex_final_nontab_column_; ++i) | |
2370 | ffelex_card_image_[i] = ' '; | |
2371 | ffelex_card_image_[i] = '\0'; | |
2372 | ffelex_card_length_ = i; | |
2373 | c = ' '; | |
2374 | } | |
2375 | ||
2376 | switch (ffelex_raw_mode_) | |
2377 | { | |
2378 | case -3: | |
2379 | c = ffelex_backslash_ (c, column); | |
2380 | if (c == EOF) | |
2381 | break; | |
2382 | ||
2383 | if (!ffelex_backslash_reconsider_) | |
2384 | ffelex_append_to_token_ (c); | |
2385 | ffelex_raw_mode_ = -1; | |
2386 | break; | |
2387 | ||
2388 | case -2: | |
2389 | if (c == ffelex_raw_char_) | |
2390 | { | |
2391 | ffelex_raw_mode_ = -1; | |
2392 | ffelex_append_to_token_ (c); | |
2393 | } | |
2394 | else | |
2395 | { | |
2396 | ffelex_raw_mode_ = 0; | |
2397 | ffelex_backslash_reconsider_ = TRUE; | |
2398 | } | |
2399 | break; | |
2400 | ||
2401 | case -1: | |
2402 | if (c == ffelex_raw_char_) | |
2403 | ffelex_raw_mode_ = -2; | |
2404 | else | |
2405 | { | |
2406 | c = ffelex_backslash_ (c, column); | |
2407 | if (c == EOF) | |
2408 | { | |
2409 | ffelex_raw_mode_ = -3; | |
2410 | break; | |
2411 | } | |
2412 | ||
2413 | ffelex_append_to_token_ (c); | |
2414 | } | |
2415 | break; | |
2416 | ||
2417 | default: | |
2418 | c = ffelex_backslash_ (c, column); | |
2419 | if (c == EOF) | |
2420 | break; | |
2421 | ||
2422 | if (!ffelex_backslash_reconsider_) | |
2423 | { | |
2424 | ffelex_append_to_token_ (c); | |
2425 | --ffelex_raw_mode_; | |
2426 | } | |
2427 | break; | |
2428 | } | |
2429 | ||
2430 | if (ffelex_backslash_reconsider_) | |
2431 | ffelex_backslash_reconsider_ = FALSE; | |
2432 | else | |
2433 | c = ffelex_card_image_[++column]; | |
2434 | ||
2435 | if (ffelex_raw_mode_ == 0) | |
2436 | { | |
2437 | ffelex_send_token_ (); | |
2438 | assert (ffelex_raw_mode_ == 0); | |
2439 | while (c == ' ') | |
2440 | c = ffelex_card_image_[++column]; | |
2441 | if ((c == '\0') | |
2442 | || (c == '!') | |
2443 | || ((c == '/') | |
2444 | && (ffelex_card_image_[column + 1] == '*'))) | |
2445 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
2446 | goto parse_nonraw_character; /* :::::::::::::::::::: */ | |
2447 | } | |
2448 | goto parse_raw_character; /* :::::::::::::::::::: */ | |
2449 | } | |
2450 | ||
2451 | parse_nonraw_character: /* :::::::::::::::::::: */ | |
2452 | ||
2453 | switch (ffelex_token_->type) | |
2454 | { | |
2455 | case FFELEX_typeNONE: | |
2456 | switch (c) | |
2457 | { | |
2458 | case '\"': | |
2459 | ffelex_token_->type = FFELEX_typeQUOTE; | |
2460 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2461 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2462 | ffelex_send_token_ (); | |
2463 | break; | |
2464 | ||
2465 | case '$': | |
2466 | ffelex_token_->type = FFELEX_typeDOLLAR; | |
2467 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2468 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2469 | ffelex_send_token_ (); | |
2470 | break; | |
2471 | ||
2472 | case '%': | |
2473 | ffelex_token_->type = FFELEX_typePERCENT; | |
2474 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2475 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2476 | ffelex_send_token_ (); | |
2477 | break; | |
2478 | ||
2479 | case '&': | |
2480 | ffelex_token_->type = FFELEX_typeAMPERSAND; | |
2481 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2482 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2483 | ffelex_send_token_ (); | |
2484 | break; | |
2485 | ||
2486 | case '\'': | |
2487 | ffelex_token_->type = FFELEX_typeAPOSTROPHE; | |
2488 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2489 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2490 | ffelex_send_token_ (); | |
2491 | break; | |
2492 | ||
2493 | case '(': | |
2494 | ffelex_token_->type = FFELEX_typeOPEN_PAREN; | |
2495 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2496 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2497 | break; | |
2498 | ||
2499 | case ')': | |
2500 | ffelex_token_->type = FFELEX_typeCLOSE_PAREN; | |
2501 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2502 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2503 | ffelex_send_token_ (); | |
2504 | break; | |
2505 | ||
2506 | case '*': | |
2507 | ffelex_token_->type = FFELEX_typeASTERISK; | |
2508 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2509 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2510 | break; | |
2511 | ||
2512 | case '+': | |
2513 | ffelex_token_->type = FFELEX_typePLUS; | |
2514 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2515 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2516 | ffelex_send_token_ (); | |
2517 | break; | |
2518 | ||
2519 | case ',': | |
2520 | ffelex_token_->type = FFELEX_typeCOMMA; | |
2521 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2522 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2523 | ffelex_send_token_ (); | |
2524 | break; | |
2525 | ||
2526 | case '-': | |
2527 | ffelex_token_->type = FFELEX_typeMINUS; | |
2528 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2529 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2530 | ffelex_send_token_ (); | |
2531 | break; | |
2532 | ||
2533 | case '.': | |
2534 | ffelex_token_->type = FFELEX_typePERIOD; | |
2535 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2536 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2537 | ffelex_send_token_ (); | |
2538 | break; | |
2539 | ||
2540 | case '/': | |
2541 | ffelex_token_->type = FFELEX_typeSLASH; | |
2542 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2543 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2544 | break; | |
2545 | ||
2546 | case '0': | |
2547 | case '1': | |
2548 | case '2': | |
2549 | case '3': | |
2550 | case '4': | |
2551 | case '5': | |
2552 | case '6': | |
2553 | case '7': | |
2554 | case '8': | |
2555 | case '9': | |
2556 | ffelex_token_->type | |
2557 | = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER; | |
2558 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2559 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2560 | ffelex_append_to_token_ (c); | |
2561 | break; | |
2562 | ||
2563 | case ':': | |
2564 | ffelex_token_->type = FFELEX_typeCOLON; | |
2565 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2566 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2567 | break; | |
2568 | ||
2569 | case ';': | |
2570 | ffelex_token_->type = FFELEX_typeSEMICOLON; | |
2571 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2572 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2573 | ffelex_permit_include_ = TRUE; | |
2574 | ffelex_send_token_ (); | |
2575 | ffelex_permit_include_ = FALSE; | |
2576 | break; | |
2577 | ||
2578 | case '<': | |
2579 | ffelex_token_->type = FFELEX_typeOPEN_ANGLE; | |
2580 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2581 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2582 | break; | |
2583 | ||
2584 | case '=': | |
2585 | ffelex_token_->type = FFELEX_typeEQUALS; | |
2586 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2587 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2588 | break; | |
2589 | ||
2590 | case '>': | |
2591 | ffelex_token_->type = FFELEX_typeCLOSE_ANGLE; | |
2592 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2593 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2594 | break; | |
2595 | ||
2596 | case '?': | |
2597 | ffelex_token_->type = FFELEX_typeQUESTION; | |
2598 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
2599 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2600 | ffelex_send_token_ (); | |
2601 | break; | |
2602 | ||
2603 | case '_': | |
2604 | if (1 || ffe_is_90 ()) | |
2605 | { | |
2606 | ffelex_token_->type = FFELEX_typeUNDERSCORE; | |
2607 | ffelex_token_->where_line | |
2608 | = ffewhere_line_use (ffelex_current_wl_); | |
2609 | ffelex_token_->where_col | |
2610 | = ffewhere_column_new (column + 1); | |
2611 | ffelex_send_token_ (); | |
2612 | break; | |
2613 | } | |
2614 | /* Fall through. */ | |
2615 | case 'A': | |
2616 | case 'B': | |
2617 | case 'C': | |
2618 | case 'D': | |
2619 | case 'E': | |
2620 | case 'F': | |
2621 | case 'G': | |
2622 | case 'H': | |
2623 | case 'I': | |
2624 | case 'J': | |
2625 | case 'K': | |
2626 | case 'L': | |
2627 | case 'M': | |
2628 | case 'N': | |
2629 | case 'O': | |
2630 | case 'P': | |
2631 | case 'Q': | |
2632 | case 'R': | |
2633 | case 'S': | |
2634 | case 'T': | |
2635 | case 'U': | |
2636 | case 'V': | |
2637 | case 'W': | |
2638 | case 'X': | |
2639 | case 'Y': | |
2640 | case 'Z': | |
2641 | case 'a': | |
2642 | case 'b': | |
2643 | case 'c': | |
2644 | case 'd': | |
2645 | case 'e': | |
2646 | case 'f': | |
2647 | case 'g': | |
2648 | case 'h': | |
2649 | case 'i': | |
2650 | case 'j': | |
2651 | case 'k': | |
2652 | case 'l': | |
2653 | case 'm': | |
2654 | case 'n': | |
2655 | case 'o': | |
2656 | case 'p': | |
2657 | case 'q': | |
2658 | case 'r': | |
2659 | case 's': | |
2660 | case 't': | |
2661 | case 'u': | |
2662 | case 'v': | |
2663 | case 'w': | |
2664 | case 'x': | |
2665 | case 'y': | |
2666 | case 'z': | |
2667 | c = ffesrc_char_source (c); | |
2668 | ||
2669 | if (ffesrc_char_match_init (c, 'H', 'h') | |
2670 | && ffelex_expecting_hollerith_ != 0) | |
2671 | { | |
2672 | ffelex_raw_mode_ = ffelex_expecting_hollerith_; | |
2673 | ffelex_token_->type = FFELEX_typeHOLLERITH; | |
2674 | ffelex_token_->where_line = ffelex_raw_where_line_; | |
2675 | ffelex_token_->where_col = ffelex_raw_where_col_; | |
2676 | ffelex_raw_where_line_ = ffewhere_line_unknown (); | |
2677 | ffelex_raw_where_col_ = ffewhere_column_unknown (); | |
2678 | c = ffelex_card_image_[++column]; | |
2679 | goto parse_raw_character; /* :::::::::::::::::::: */ | |
2680 | } | |
2681 | ||
2682 | if (ffelex_names_) | |
2683 | { | |
2684 | ffelex_token_->where_line | |
2685 | = ffewhere_line_use (ffelex_token_->currentnames_line | |
2686 | = ffewhere_line_use (ffelex_current_wl_)); | |
2687 | ffelex_token_->where_col | |
2688 | = ffewhere_column_use (ffelex_token_->currentnames_col | |
2689 | = ffewhere_column_new (column + 1)); | |
2690 | ffelex_token_->type = FFELEX_typeNAMES; | |
2691 | } | |
2692 | else | |
2693 | { | |
2694 | ffelex_token_->where_line | |
2695 | = ffewhere_line_use (ffelex_current_wl_); | |
2696 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
2697 | ffelex_token_->type = FFELEX_typeNAME; | |
2698 | } | |
2699 | ffelex_append_to_token_ (c); | |
2700 | break; | |
2701 | ||
2702 | default: | |
2703 | ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER, | |
2704 | ffelex_linecount_current_, column + 1); | |
2705 | ffelex_finish_statement_ (); | |
2706 | disallow_continuation_line = TRUE; | |
2707 | ignore_disallowed_continuation = TRUE; | |
2708 | goto beginning_of_line_again; /* :::::::::::::::::::: */ | |
2709 | } | |
2710 | break; | |
2711 | ||
2712 | case FFELEX_typeNAME: | |
2713 | switch (c) | |
2714 | { | |
2715 | case 'A': | |
2716 | case 'B': | |
2717 | case 'C': | |
2718 | case 'D': | |
2719 | case 'E': | |
2720 | case 'F': | |
2721 | case 'G': | |
2722 | case 'H': | |
2723 | case 'I': | |
2724 | case 'J': | |
2725 | case 'K': | |
2726 | case 'L': | |
2727 | case 'M': | |
2728 | case 'N': | |
2729 | case 'O': | |
2730 | case 'P': | |
2731 | case 'Q': | |
2732 | case 'R': | |
2733 | case 'S': | |
2734 | case 'T': | |
2735 | case 'U': | |
2736 | case 'V': | |
2737 | case 'W': | |
2738 | case 'X': | |
2739 | case 'Y': | |
2740 | case 'Z': | |
2741 | case 'a': | |
2742 | case 'b': | |
2743 | case 'c': | |
2744 | case 'd': | |
2745 | case 'e': | |
2746 | case 'f': | |
2747 | case 'g': | |
2748 | case 'h': | |
2749 | case 'i': | |
2750 | case 'j': | |
2751 | case 'k': | |
2752 | case 'l': | |
2753 | case 'm': | |
2754 | case 'n': | |
2755 | case 'o': | |
2756 | case 'p': | |
2757 | case 'q': | |
2758 | case 'r': | |
2759 | case 's': | |
2760 | case 't': | |
2761 | case 'u': | |
2762 | case 'v': | |
2763 | case 'w': | |
2764 | case 'x': | |
2765 | case 'y': | |
2766 | case 'z': | |
2767 | c = ffesrc_char_source (c); | |
2768 | /* Fall through. */ | |
2769 | case '0': | |
2770 | case '1': | |
2771 | case '2': | |
2772 | case '3': | |
2773 | case '4': | |
2774 | case '5': | |
2775 | case '6': | |
2776 | case '7': | |
2777 | case '8': | |
2778 | case '9': | |
2779 | case '_': | |
2780 | case '$': | |
2781 | if ((c == '$') | |
2782 | && !ffe_is_dollar_ok ()) | |
2783 | { | |
2784 | ffelex_send_token_ (); | |
2785 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2786 | } | |
2787 | ffelex_append_to_token_ (c); | |
2788 | break; | |
2789 | ||
2790 | default: | |
2791 | ffelex_send_token_ (); | |
2792 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2793 | } | |
2794 | break; | |
2795 | ||
2796 | case FFELEX_typeNAMES: | |
2797 | switch (c) | |
2798 | { | |
2799 | case 'A': | |
2800 | case 'B': | |
2801 | case 'C': | |
2802 | case 'D': | |
2803 | case 'E': | |
2804 | case 'F': | |
2805 | case 'G': | |
2806 | case 'H': | |
2807 | case 'I': | |
2808 | case 'J': | |
2809 | case 'K': | |
2810 | case 'L': | |
2811 | case 'M': | |
2812 | case 'N': | |
2813 | case 'O': | |
2814 | case 'P': | |
2815 | case 'Q': | |
2816 | case 'R': | |
2817 | case 'S': | |
2818 | case 'T': | |
2819 | case 'U': | |
2820 | case 'V': | |
2821 | case 'W': | |
2822 | case 'X': | |
2823 | case 'Y': | |
2824 | case 'Z': | |
2825 | case 'a': | |
2826 | case 'b': | |
2827 | case 'c': | |
2828 | case 'd': | |
2829 | case 'e': | |
2830 | case 'f': | |
2831 | case 'g': | |
2832 | case 'h': | |
2833 | case 'i': | |
2834 | case 'j': | |
2835 | case 'k': | |
2836 | case 'l': | |
2837 | case 'm': | |
2838 | case 'n': | |
2839 | case 'o': | |
2840 | case 'p': | |
2841 | case 'q': | |
2842 | case 'r': | |
2843 | case 's': | |
2844 | case 't': | |
2845 | case 'u': | |
2846 | case 'v': | |
2847 | case 'w': | |
2848 | case 'x': | |
2849 | case 'y': | |
2850 | case 'z': | |
2851 | c = ffesrc_char_source (c); | |
2852 | /* Fall through. */ | |
2853 | case '0': | |
2854 | case '1': | |
2855 | case '2': | |
2856 | case '3': | |
2857 | case '4': | |
2858 | case '5': | |
2859 | case '6': | |
2860 | case '7': | |
2861 | case '8': | |
2862 | case '9': | |
2863 | case '_': | |
2864 | case '$': | |
2865 | if ((c == '$') | |
2866 | && !ffe_is_dollar_ok ()) | |
2867 | { | |
2868 | ffelex_send_token_ (); | |
2869 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2870 | } | |
2871 | if (ffelex_token_->length < FFEWHERE_indexMAX) | |
2872 | { | |
2873 | ffewhere_track (&ffelex_token_->currentnames_line, | |
2874 | &ffelex_token_->currentnames_col, | |
2875 | ffelex_token_->wheretrack, | |
2876 | ffelex_token_->length, | |
2877 | ffelex_linecount_current_, | |
2878 | column + 1); | |
2879 | } | |
2880 | ffelex_append_to_token_ (c); | |
2881 | break; | |
2882 | ||
2883 | default: | |
2884 | ffelex_send_token_ (); | |
2885 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2886 | } | |
2887 | break; | |
2888 | ||
2889 | case FFELEX_typeNUMBER: | |
2890 | switch (c) | |
2891 | { | |
2892 | case '0': | |
2893 | case '1': | |
2894 | case '2': | |
2895 | case '3': | |
2896 | case '4': | |
2897 | case '5': | |
2898 | case '6': | |
2899 | case '7': | |
2900 | case '8': | |
2901 | case '9': | |
2902 | ffelex_append_to_token_ (c); | |
2903 | break; | |
2904 | ||
2905 | default: | |
2906 | ffelex_send_token_ (); | |
2907 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2908 | } | |
2909 | break; | |
2910 | ||
2911 | case FFELEX_typeASTERISK: | |
2912 | switch (c) | |
2913 | { | |
2914 | case '*': /* ** */ | |
2915 | ffelex_token_->type = FFELEX_typePOWER; | |
2916 | ffelex_send_token_ (); | |
2917 | break; | |
2918 | ||
2919 | default: /* * not followed by another *. */ | |
2920 | ffelex_send_token_ (); | |
2921 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2922 | } | |
2923 | break; | |
2924 | ||
2925 | case FFELEX_typeCOLON: | |
2926 | switch (c) | |
2927 | { | |
2928 | case ':': /* :: */ | |
2929 | ffelex_token_->type = FFELEX_typeCOLONCOLON; | |
2930 | ffelex_send_token_ (); | |
2931 | break; | |
2932 | ||
2933 | default: /* : not followed by another :. */ | |
2934 | ffelex_send_token_ (); | |
2935 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2936 | } | |
2937 | break; | |
2938 | ||
2939 | case FFELEX_typeSLASH: | |
2940 | switch (c) | |
2941 | { | |
2942 | case '/': /* // */ | |
2943 | ffelex_token_->type = FFELEX_typeCONCAT; | |
2944 | ffelex_send_token_ (); | |
2945 | break; | |
2946 | ||
2947 | case ')': /* /) */ | |
2948 | ffelex_token_->type = FFELEX_typeCLOSE_ARRAY; | |
2949 | ffelex_send_token_ (); | |
2950 | break; | |
2951 | ||
2952 | case '=': /* /= */ | |
2953 | ffelex_token_->type = FFELEX_typeREL_NE; | |
2954 | ffelex_send_token_ (); | |
2955 | break; | |
2956 | ||
2957 | default: | |
2958 | ffelex_send_token_ (); | |
2959 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2960 | } | |
2961 | break; | |
2962 | ||
2963 | case FFELEX_typeOPEN_PAREN: | |
2964 | switch (c) | |
2965 | { | |
2966 | case '/': /* (/ */ | |
2967 | ffelex_token_->type = FFELEX_typeOPEN_ARRAY; | |
2968 | ffelex_send_token_ (); | |
2969 | break; | |
2970 | ||
2971 | default: | |
2972 | ffelex_send_token_ (); | |
2973 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2974 | } | |
2975 | break; | |
2976 | ||
2977 | case FFELEX_typeOPEN_ANGLE: | |
2978 | switch (c) | |
2979 | { | |
2980 | case '=': /* <= */ | |
2981 | ffelex_token_->type = FFELEX_typeREL_LE; | |
2982 | ffelex_send_token_ (); | |
2983 | break; | |
2984 | ||
2985 | default: | |
2986 | ffelex_send_token_ (); | |
2987 | goto parse_next_character; /* :::::::::::::::::::: */ | |
2988 | } | |
2989 | break; | |
2990 | ||
2991 | case FFELEX_typeEQUALS: | |
2992 | switch (c) | |
2993 | { | |
2994 | case '=': /* == */ | |
2995 | ffelex_token_->type = FFELEX_typeREL_EQ; | |
2996 | ffelex_send_token_ (); | |
2997 | break; | |
2998 | ||
2999 | case '>': /* => */ | |
3000 | ffelex_token_->type = FFELEX_typePOINTS; | |
3001 | ffelex_send_token_ (); | |
3002 | break; | |
3003 | ||
3004 | default: | |
3005 | ffelex_send_token_ (); | |
3006 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3007 | } | |
3008 | break; | |
3009 | ||
3010 | case FFELEX_typeCLOSE_ANGLE: | |
3011 | switch (c) | |
3012 | { | |
3013 | case '=': /* >= */ | |
3014 | ffelex_token_->type = FFELEX_typeREL_GE; | |
3015 | ffelex_send_token_ (); | |
3016 | break; | |
3017 | ||
3018 | default: | |
3019 | ffelex_send_token_ (); | |
3020 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3021 | } | |
3022 | break; | |
3023 | ||
3024 | default: | |
3025 | assert ("Serious error!!" == NULL); | |
3026 | abort (); | |
3027 | break; | |
3028 | } | |
3029 | ||
3030 | c = ffelex_card_image_[++column]; | |
3031 | ||
3032 | parse_next_character: /* :::::::::::::::::::: */ | |
3033 | ||
3034 | if (ffelex_raw_mode_ != 0) | |
3035 | goto parse_raw_character; /* :::::::::::::::::::: */ | |
3036 | ||
3037 | while (c == ' ') | |
3038 | c = ffelex_card_image_[++column]; | |
3039 | ||
3040 | if ((c == '\0') | |
3041 | || (c == '!') | |
3042 | || ((c == '/') | |
3043 | && (ffelex_card_image_[column + 1] == '*'))) | |
3044 | { | |
3045 | if ((ffelex_number_of_tokens_ == ffelex_label_tokens_) | |
3046 | && (ffelex_token_->type == FFELEX_typeNAMES) | |
3047 | && (ffelex_token_->length == 3) | |
3048 | && (ffesrc_strncmp_2c (ffe_case_match (), | |
3049 | ffelex_token_->text, | |
3050 | "END", "end", "End", | |
3051 | 3) | |
3052 | == 0)) | |
3053 | { | |
3054 | ffelex_finish_statement_ (); | |
3055 | disallow_continuation_line = TRUE; | |
3056 | ignore_disallowed_continuation = FALSE; | |
3057 | goto beginning_of_line_again; /* :::::::::::::::::::: */ | |
3058 | } | |
3059 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3060 | } | |
3061 | goto parse_nonraw_character; /* :::::::::::::::::::: */ | |
3062 | } | |
3063 | ||
3064 | /* ffelex_file_free -- Lex a given file in free source form | |
3065 | ||
3066 | ffewhere wf; | |
3067 | FILE *f; | |
3068 | ffelex_file_free(wf,f); | |
3069 | ||
3070 | Lexes the file according to Fortran 90 ANSI + VXT specifications. */ | |
3071 | ||
3072 | ffelexHandler | |
3073 | ffelex_file_free (ffewhereFile wf, FILE *f) | |
3074 | { | |
8b45da67 CB |
3075 | register int c = 0; /* Character currently under consideration. */ |
3076 | register ffewhereColumnNumber column = 0; /* Not really; 0 means column 1... */ | |
3077 | bool continuation_line = FALSE; | |
5ff904cd | 3078 | ffewhereColumnNumber continuation_column; |
8b45da67 | 3079 | int latest_char_in_file = 0; /* For getting back into comment-skipping |
5ff904cd JL |
3080 | code. */ |
3081 | ||
3082 | /* Lex is called for a particular file, not for a particular program unit. | |
3083 | Yet the two events do share common characteristics. The first line in a | |
3084 | file or in a program unit cannot be a continuation line. No token can | |
3085 | be in mid-formation. No current label for the statement exists, since | |
3086 | there is no current statement. */ | |
3087 | ||
3088 | assert (ffelex_handler_ != NULL); | |
3089 | ||
3090 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
3091 | lineno = 0; | |
3092 | input_filename = ffewhere_file_name (wf); | |
3093 | #endif | |
3094 | ffelex_current_wf_ = wf; | |
3095 | continuation_line = FALSE; | |
3096 | ffelex_token_->type = FFELEX_typeNONE; | |
3097 | ffelex_number_of_tokens_ = 0; | |
3098 | ffelex_current_wl_ = ffewhere_line_unknown (); | |
3099 | ffelex_current_wc_ = ffewhere_column_unknown (); | |
3100 | latest_char_in_file = '\n'; | |
3101 | ||
3102 | /* Come here to get a new line. */ | |
3103 | ||
3104 | beginning_of_line: /* :::::::::::::::::::: */ | |
3105 | ||
3106 | c = latest_char_in_file; | |
3107 | if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF)) | |
3108 | { | |
3109 | ||
3110 | end_of_file: /* :::::::::::::::::::: */ | |
3111 | ||
3112 | /* Line ending in EOF instead of \n still counts as a whole line. */ | |
3113 | ||
3114 | ffelex_finish_statement_ (); | |
3115 | ffewhere_line_kill (ffelex_current_wl_); | |
3116 | ffewhere_column_kill (ffelex_current_wc_); | |
3117 | return (ffelexHandler) ffelex_handler_; | |
3118 | } | |
3119 | ||
3120 | ffelex_next_line_ (); | |
3121 | ||
3122 | ffelex_bad_line_ = FALSE; | |
3123 | ||
3124 | /* Skip over initial-comment and empty lines as quickly as possible! */ | |
3125 | ||
3126 | while ((c == '\n') | |
3127 | || (c == '!') | |
3128 | || (c == '#')) | |
3129 | { | |
3130 | if (c == '#') | |
3131 | { | |
3132 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
3133 | c = ffelex_hash_ (f); | |
3134 | #else | |
3135 | /* Don't skip over # line after all. */ | |
3136 | break; | |
3137 | #endif | |
3138 | } | |
3139 | ||
3140 | comment_line: /* :::::::::::::::::::: */ | |
3141 | ||
3142 | while ((c != '\n') && (c != EOF)) | |
3143 | c = getc (f); | |
3144 | ||
3145 | if (c == EOF) | |
3146 | { | |
3147 | ffelex_next_line_ (); | |
3148 | goto end_of_file; /* :::::::::::::::::::: */ | |
3149 | } | |
3150 | ||
3151 | c = getc (f); | |
3152 | ||
3153 | ffelex_next_line_ (); | |
3154 | ||
3155 | if (c == EOF) | |
3156 | goto end_of_file; /* :::::::::::::::::::: */ | |
3157 | } | |
3158 | ||
3159 | ffelex_saw_tab_ = FALSE; | |
3160 | ||
3161 | column = ffelex_image_char_ (c, 0); | |
3162 | ||
3163 | /* Read the entire line in as is (with whitespace processing). */ | |
3164 | ||
3165 | while (((c = getc (f)) != '\n') && (c != EOF)) | |
3166 | column = ffelex_image_char_ (c, column); | |
3167 | ||
3168 | if (ffelex_bad_line_) | |
3169 | { | |
3170 | ffelex_card_image_[column] = '\0'; | |
3171 | ffelex_card_length_ = column; | |
3172 | goto comment_line; /* :::::::::::::::::::: */ | |
3173 | } | |
3174 | ||
3175 | /* If no tab, cut off line after column 132. */ | |
3176 | ||
3177 | if (!ffelex_saw_tab_ && (column > FFELEX_FREE_MAX_COLUMNS_)) | |
3178 | column = FFELEX_FREE_MAX_COLUMNS_; | |
3179 | ||
3180 | ffelex_card_image_[column] = '\0'; | |
3181 | ffelex_card_length_ = column; | |
3182 | ||
3183 | /* Save next char in file so we can use register-based c while analyzing | |
3184 | line we just read. */ | |
3185 | ||
3186 | latest_char_in_file = c; /* Should be either '\n' or EOF. */ | |
3187 | ||
3188 | column = 0; | |
3189 | continuation_column = 0; | |
3190 | ||
3191 | /* Skip over initial spaces to see if the first nonblank character | |
3192 | is exclamation point, newline, or EOF (line is therefore a comment) or | |
3193 | ampersand (line is therefore a continuation line). */ | |
3194 | ||
3195 | while ((c = ffelex_card_image_[column]) == ' ') | |
3196 | ++column; | |
3197 | ||
3198 | switch (c) | |
3199 | { | |
3200 | case '!': | |
3201 | case '\0': | |
3202 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3203 | ||
3204 | case '&': | |
3205 | continuation_column = column + 1; | |
3206 | break; | |
3207 | ||
3208 | default: | |
3209 | break; | |
3210 | } | |
3211 | ||
3212 | /* The line definitely has content of some kind, install new end-statement | |
3213 | point for error messages. */ | |
3214 | ||
3215 | ffewhere_line_kill (ffelex_current_wl_); | |
3216 | ffewhere_column_kill (ffelex_current_wc_); | |
3217 | ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_); | |
3218 | ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1); | |
3219 | ||
3220 | /* Figure out which column to start parsing at. */ | |
3221 | ||
3222 | if (continuation_line) | |
3223 | { | |
3224 | if (continuation_column == 0) | |
3225 | { | |
3226 | if (ffelex_raw_mode_ != 0) | |
3227 | { | |
3228 | ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE, | |
3229 | ffelex_linecount_current_, column + 1); | |
3230 | } | |
3231 | else if (ffelex_token_->type != FFELEX_typeNONE) | |
3232 | { | |
3233 | ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE, | |
3234 | ffelex_linecount_current_, column + 1); | |
3235 | } | |
3236 | } | |
3237 | else if (ffelex_is_free_char_ctx_contin_ (continuation_column)) | |
3238 | { /* Line contains only a single "&" as only | |
3239 | nonblank character. */ | |
3240 | ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE, | |
3241 | ffelex_linecount_current_, continuation_column); | |
3242 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3243 | } | |
3244 | column = continuation_column; | |
3245 | } | |
3246 | else | |
3247 | column = 0; | |
3248 | ||
3249 | c = ffelex_card_image_[column]; | |
3250 | continuation_line = FALSE; | |
3251 | ||
3252 | /* Here is the main engine for parsing. c holds the character at column. | |
3253 | It is already known that c is not a blank, end of line, or shriek, | |
3254 | unless ffelex_raw_mode_ is not 0 (indicating we are in a | |
3255 | character/hollerith constant). A partially filled token may already | |
3256 | exist in ffelex_token_. */ | |
3257 | ||
3258 | if (ffelex_raw_mode_ != 0) | |
3259 | { | |
3260 | ||
3261 | parse_raw_character: /* :::::::::::::::::::: */ | |
3262 | ||
3263 | switch (c) | |
3264 | { | |
3265 | case '&': | |
3266 | if (ffelex_is_free_char_ctx_contin_ (column + 1)) | |
3267 | { | |
3268 | continuation_line = TRUE; | |
3269 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3270 | } | |
3271 | break; | |
3272 | ||
3273 | case '\0': | |
3274 | ffelex_finish_statement_ (); | |
3275 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3276 | ||
3277 | default: | |
3278 | break; | |
3279 | } | |
3280 | ||
3281 | switch (ffelex_raw_mode_) | |
3282 | { | |
3283 | case -3: | |
3284 | c = ffelex_backslash_ (c, column); | |
3285 | if (c == EOF) | |
3286 | break; | |
3287 | ||
3288 | if (!ffelex_backslash_reconsider_) | |
3289 | ffelex_append_to_token_ (c); | |
3290 | ffelex_raw_mode_ = -1; | |
3291 | break; | |
3292 | ||
3293 | case -2: | |
3294 | if (c == ffelex_raw_char_) | |
3295 | { | |
3296 | ffelex_raw_mode_ = -1; | |
3297 | ffelex_append_to_token_ (c); | |
3298 | } | |
3299 | else | |
3300 | { | |
3301 | ffelex_raw_mode_ = 0; | |
3302 | ffelex_backslash_reconsider_ = TRUE; | |
3303 | } | |
3304 | break; | |
3305 | ||
3306 | case -1: | |
3307 | if (c == ffelex_raw_char_) | |
3308 | ffelex_raw_mode_ = -2; | |
3309 | else | |
3310 | { | |
3311 | c = ffelex_backslash_ (c, column); | |
3312 | if (c == EOF) | |
3313 | { | |
3314 | ffelex_raw_mode_ = -3; | |
3315 | break; | |
3316 | } | |
3317 | ||
3318 | ffelex_append_to_token_ (c); | |
3319 | } | |
3320 | break; | |
3321 | ||
3322 | default: | |
3323 | c = ffelex_backslash_ (c, column); | |
3324 | if (c == EOF) | |
3325 | break; | |
3326 | ||
3327 | if (!ffelex_backslash_reconsider_) | |
3328 | { | |
3329 | ffelex_append_to_token_ (c); | |
3330 | --ffelex_raw_mode_; | |
3331 | } | |
3332 | break; | |
3333 | } | |
3334 | ||
3335 | if (ffelex_backslash_reconsider_) | |
3336 | ffelex_backslash_reconsider_ = FALSE; | |
3337 | else | |
3338 | c = ffelex_card_image_[++column]; | |
3339 | ||
3340 | if (ffelex_raw_mode_ == 0) | |
3341 | { | |
3342 | ffelex_send_token_ (); | |
3343 | assert (ffelex_raw_mode_ == 0); | |
3344 | while (c == ' ') | |
3345 | c = ffelex_card_image_[++column]; | |
3346 | if ((c == '\0') || (c == '!')) | |
3347 | { | |
3348 | ffelex_finish_statement_ (); | |
3349 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3350 | } | |
3351 | if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) | |
3352 | { | |
3353 | continuation_line = TRUE; | |
3354 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3355 | } | |
3356 | goto parse_nonraw_character_noncontin; /* :::::::::::::::::::: */ | |
3357 | } | |
3358 | goto parse_raw_character; /* :::::::::::::::::::: */ | |
3359 | } | |
3360 | ||
3361 | parse_nonraw_character: /* :::::::::::::::::::: */ | |
3362 | ||
3363 | if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) | |
3364 | { | |
3365 | continuation_line = TRUE; | |
3366 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3367 | } | |
3368 | ||
3369 | parse_nonraw_character_noncontin: /* :::::::::::::::::::: */ | |
3370 | ||
3371 | switch (ffelex_token_->type) | |
3372 | { | |
3373 | case FFELEX_typeNONE: | |
3374 | if (c == ' ') | |
3375 | { /* Otherwise | |
3376 | finish-statement/continue-statement | |
3377 | already checked. */ | |
3378 | while (c == ' ') | |
3379 | c = ffelex_card_image_[++column]; | |
3380 | if ((c == '\0') || (c == '!')) | |
3381 | { | |
3382 | ffelex_finish_statement_ (); | |
3383 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3384 | } | |
3385 | if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) | |
3386 | { | |
3387 | continuation_line = TRUE; | |
3388 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3389 | } | |
3390 | } | |
3391 | ||
3392 | switch (c) | |
3393 | { | |
3394 | case '\"': | |
3395 | ffelex_token_->type = FFELEX_typeQUOTE; | |
3396 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3397 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3398 | ffelex_send_token_ (); | |
3399 | break; | |
3400 | ||
3401 | case '$': | |
3402 | ffelex_token_->type = FFELEX_typeDOLLAR; | |
3403 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3404 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3405 | ffelex_send_token_ (); | |
3406 | break; | |
3407 | ||
3408 | case '%': | |
3409 | ffelex_token_->type = FFELEX_typePERCENT; | |
3410 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3411 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3412 | ffelex_send_token_ (); | |
3413 | break; | |
3414 | ||
3415 | case '&': | |
3416 | ffelex_token_->type = FFELEX_typeAMPERSAND; | |
3417 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3418 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3419 | ffelex_send_token_ (); | |
3420 | break; | |
3421 | ||
3422 | case '\'': | |
3423 | ffelex_token_->type = FFELEX_typeAPOSTROPHE; | |
3424 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3425 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3426 | ffelex_send_token_ (); | |
3427 | break; | |
3428 | ||
3429 | case '(': | |
3430 | ffelex_token_->type = FFELEX_typeOPEN_PAREN; | |
3431 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3432 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3433 | break; | |
3434 | ||
3435 | case ')': | |
3436 | ffelex_token_->type = FFELEX_typeCLOSE_PAREN; | |
3437 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3438 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3439 | ffelex_send_token_ (); | |
3440 | break; | |
3441 | ||
3442 | case '*': | |
3443 | ffelex_token_->type = FFELEX_typeASTERISK; | |
3444 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3445 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3446 | break; | |
3447 | ||
3448 | case '+': | |
3449 | ffelex_token_->type = FFELEX_typePLUS; | |
3450 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3451 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3452 | ffelex_send_token_ (); | |
3453 | break; | |
3454 | ||
3455 | case ',': | |
3456 | ffelex_token_->type = FFELEX_typeCOMMA; | |
3457 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3458 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3459 | ffelex_send_token_ (); | |
3460 | break; | |
3461 | ||
3462 | case '-': | |
3463 | ffelex_token_->type = FFELEX_typeMINUS; | |
3464 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3465 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3466 | ffelex_send_token_ (); | |
3467 | break; | |
3468 | ||
3469 | case '.': | |
3470 | ffelex_token_->type = FFELEX_typePERIOD; | |
3471 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3472 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3473 | ffelex_send_token_ (); | |
3474 | break; | |
3475 | ||
3476 | case '/': | |
3477 | ffelex_token_->type = FFELEX_typeSLASH; | |
3478 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3479 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3480 | break; | |
3481 | ||
3482 | case '0': | |
3483 | case '1': | |
3484 | case '2': | |
3485 | case '3': | |
3486 | case '4': | |
3487 | case '5': | |
3488 | case '6': | |
3489 | case '7': | |
3490 | case '8': | |
3491 | case '9': | |
3492 | ffelex_token_->type | |
3493 | = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER; | |
3494 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3495 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3496 | ffelex_append_to_token_ (c); | |
3497 | break; | |
3498 | ||
3499 | case ':': | |
3500 | ffelex_token_->type = FFELEX_typeCOLON; | |
3501 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3502 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3503 | break; | |
3504 | ||
3505 | case ';': | |
3506 | ffelex_token_->type = FFELEX_typeSEMICOLON; | |
3507 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3508 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3509 | ffelex_permit_include_ = TRUE; | |
3510 | ffelex_send_token_ (); | |
3511 | ffelex_permit_include_ = FALSE; | |
3512 | break; | |
3513 | ||
3514 | case '<': | |
3515 | ffelex_token_->type = FFELEX_typeOPEN_ANGLE; | |
3516 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3517 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3518 | break; | |
3519 | ||
3520 | case '=': | |
3521 | ffelex_token_->type = FFELEX_typeEQUALS; | |
3522 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3523 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3524 | break; | |
3525 | ||
3526 | case '>': | |
3527 | ffelex_token_->type = FFELEX_typeCLOSE_ANGLE; | |
3528 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3529 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3530 | break; | |
3531 | ||
3532 | case '?': | |
3533 | ffelex_token_->type = FFELEX_typeQUESTION; | |
3534 | ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); | |
3535 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3536 | ffelex_send_token_ (); | |
3537 | break; | |
3538 | ||
3539 | case '_': | |
3540 | if (1 || ffe_is_90 ()) | |
3541 | { | |
3542 | ffelex_token_->type = FFELEX_typeUNDERSCORE; | |
3543 | ffelex_token_->where_line | |
3544 | = ffewhere_line_use (ffelex_current_wl_); | |
3545 | ffelex_token_->where_col | |
3546 | = ffewhere_column_new (column + 1); | |
3547 | ffelex_send_token_ (); | |
3548 | break; | |
3549 | } | |
3550 | /* Fall through. */ | |
3551 | case 'A': | |
3552 | case 'B': | |
3553 | case 'C': | |
3554 | case 'D': | |
3555 | case 'E': | |
3556 | case 'F': | |
3557 | case 'G': | |
3558 | case 'H': | |
3559 | case 'I': | |
3560 | case 'J': | |
3561 | case 'K': | |
3562 | case 'L': | |
3563 | case 'M': | |
3564 | case 'N': | |
3565 | case 'O': | |
3566 | case 'P': | |
3567 | case 'Q': | |
3568 | case 'R': | |
3569 | case 'S': | |
3570 | case 'T': | |
3571 | case 'U': | |
3572 | case 'V': | |
3573 | case 'W': | |
3574 | case 'X': | |
3575 | case 'Y': | |
3576 | case 'Z': | |
3577 | case 'a': | |
3578 | case 'b': | |
3579 | case 'c': | |
3580 | case 'd': | |
3581 | case 'e': | |
3582 | case 'f': | |
3583 | case 'g': | |
3584 | case 'h': | |
3585 | case 'i': | |
3586 | case 'j': | |
3587 | case 'k': | |
3588 | case 'l': | |
3589 | case 'm': | |
3590 | case 'n': | |
3591 | case 'o': | |
3592 | case 'p': | |
3593 | case 'q': | |
3594 | case 'r': | |
3595 | case 's': | |
3596 | case 't': | |
3597 | case 'u': | |
3598 | case 'v': | |
3599 | case 'w': | |
3600 | case 'x': | |
3601 | case 'y': | |
3602 | case 'z': | |
3603 | c = ffesrc_char_source (c); | |
3604 | ||
3605 | if (ffesrc_char_match_init (c, 'H', 'h') | |
3606 | && ffelex_expecting_hollerith_ != 0) | |
3607 | { | |
3608 | ffelex_raw_mode_ = ffelex_expecting_hollerith_; | |
3609 | ffelex_token_->type = FFELEX_typeHOLLERITH; | |
3610 | ffelex_token_->where_line = ffelex_raw_where_line_; | |
3611 | ffelex_token_->where_col = ffelex_raw_where_col_; | |
3612 | ffelex_raw_where_line_ = ffewhere_line_unknown (); | |
3613 | ffelex_raw_where_col_ = ffewhere_column_unknown (); | |
3614 | c = ffelex_card_image_[++column]; | |
3615 | goto parse_raw_character; /* :::::::::::::::::::: */ | |
3616 | } | |
3617 | ||
3618 | if (ffelex_names_pure_) | |
3619 | { | |
3620 | ffelex_token_->where_line | |
3621 | = ffewhere_line_use (ffelex_token_->currentnames_line | |
3622 | = ffewhere_line_use (ffelex_current_wl_)); | |
3623 | ffelex_token_->where_col | |
3624 | = ffewhere_column_use (ffelex_token_->currentnames_col | |
3625 | = ffewhere_column_new (column + 1)); | |
3626 | ffelex_token_->type = FFELEX_typeNAMES; | |
3627 | } | |
3628 | else | |
3629 | { | |
3630 | ffelex_token_->where_line | |
3631 | = ffewhere_line_use (ffelex_current_wl_); | |
3632 | ffelex_token_->where_col = ffewhere_column_new (column + 1); | |
3633 | ffelex_token_->type = FFELEX_typeNAME; | |
3634 | } | |
3635 | ffelex_append_to_token_ (c); | |
3636 | break; | |
3637 | ||
3638 | default: | |
3639 | ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER, | |
3640 | ffelex_linecount_current_, column + 1); | |
3641 | ffelex_finish_statement_ (); | |
3642 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3643 | } | |
3644 | break; | |
3645 | ||
3646 | case FFELEX_typeNAME: | |
3647 | switch (c) | |
3648 | { | |
3649 | case 'A': | |
3650 | case 'B': | |
3651 | case 'C': | |
3652 | case 'D': | |
3653 | case 'E': | |
3654 | case 'F': | |
3655 | case 'G': | |
3656 | case 'H': | |
3657 | case 'I': | |
3658 | case 'J': | |
3659 | case 'K': | |
3660 | case 'L': | |
3661 | case 'M': | |
3662 | case 'N': | |
3663 | case 'O': | |
3664 | case 'P': | |
3665 | case 'Q': | |
3666 | case 'R': | |
3667 | case 'S': | |
3668 | case 'T': | |
3669 | case 'U': | |
3670 | case 'V': | |
3671 | case 'W': | |
3672 | case 'X': | |
3673 | case 'Y': | |
3674 | case 'Z': | |
3675 | case 'a': | |
3676 | case 'b': | |
3677 | case 'c': | |
3678 | case 'd': | |
3679 | case 'e': | |
3680 | case 'f': | |
3681 | case 'g': | |
3682 | case 'h': | |
3683 | case 'i': | |
3684 | case 'j': | |
3685 | case 'k': | |
3686 | case 'l': | |
3687 | case 'm': | |
3688 | case 'n': | |
3689 | case 'o': | |
3690 | case 'p': | |
3691 | case 'q': | |
3692 | case 'r': | |
3693 | case 's': | |
3694 | case 't': | |
3695 | case 'u': | |
3696 | case 'v': | |
3697 | case 'w': | |
3698 | case 'x': | |
3699 | case 'y': | |
3700 | case 'z': | |
3701 | c = ffesrc_char_source (c); | |
3702 | /* Fall through. */ | |
3703 | case '0': | |
3704 | case '1': | |
3705 | case '2': | |
3706 | case '3': | |
3707 | case '4': | |
3708 | case '5': | |
3709 | case '6': | |
3710 | case '7': | |
3711 | case '8': | |
3712 | case '9': | |
3713 | case '_': | |
3714 | case '$': | |
3715 | if ((c == '$') | |
3716 | && !ffe_is_dollar_ok ()) | |
3717 | { | |
3718 | ffelex_send_token_ (); | |
3719 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3720 | } | |
3721 | ffelex_append_to_token_ (c); | |
3722 | break; | |
3723 | ||
3724 | default: | |
3725 | ffelex_send_token_ (); | |
3726 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3727 | } | |
3728 | break; | |
3729 | ||
3730 | case FFELEX_typeNAMES: | |
3731 | switch (c) | |
3732 | { | |
3733 | case 'A': | |
3734 | case 'B': | |
3735 | case 'C': | |
3736 | case 'D': | |
3737 | case 'E': | |
3738 | case 'F': | |
3739 | case 'G': | |
3740 | case 'H': | |
3741 | case 'I': | |
3742 | case 'J': | |
3743 | case 'K': | |
3744 | case 'L': | |
3745 | case 'M': | |
3746 | case 'N': | |
3747 | case 'O': | |
3748 | case 'P': | |
3749 | case 'Q': | |
3750 | case 'R': | |
3751 | case 'S': | |
3752 | case 'T': | |
3753 | case 'U': | |
3754 | case 'V': | |
3755 | case 'W': | |
3756 | case 'X': | |
3757 | case 'Y': | |
3758 | case 'Z': | |
3759 | case 'a': | |
3760 | case 'b': | |
3761 | case 'c': | |
3762 | case 'd': | |
3763 | case 'e': | |
3764 | case 'f': | |
3765 | case 'g': | |
3766 | case 'h': | |
3767 | case 'i': | |
3768 | case 'j': | |
3769 | case 'k': | |
3770 | case 'l': | |
3771 | case 'm': | |
3772 | case 'n': | |
3773 | case 'o': | |
3774 | case 'p': | |
3775 | case 'q': | |
3776 | case 'r': | |
3777 | case 's': | |
3778 | case 't': | |
3779 | case 'u': | |
3780 | case 'v': | |
3781 | case 'w': | |
3782 | case 'x': | |
3783 | case 'y': | |
3784 | case 'z': | |
3785 | c = ffesrc_char_source (c); | |
3786 | /* Fall through. */ | |
3787 | case '0': | |
3788 | case '1': | |
3789 | case '2': | |
3790 | case '3': | |
3791 | case '4': | |
3792 | case '5': | |
3793 | case '6': | |
3794 | case '7': | |
3795 | case '8': | |
3796 | case '9': | |
3797 | case '_': | |
3798 | case '$': | |
3799 | if ((c == '$') | |
3800 | && !ffe_is_dollar_ok ()) | |
3801 | { | |
3802 | ffelex_send_token_ (); | |
3803 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3804 | } | |
3805 | if (ffelex_token_->length < FFEWHERE_indexMAX) | |
3806 | { | |
3807 | ffewhere_track (&ffelex_token_->currentnames_line, | |
3808 | &ffelex_token_->currentnames_col, | |
3809 | ffelex_token_->wheretrack, | |
3810 | ffelex_token_->length, | |
3811 | ffelex_linecount_current_, | |
3812 | column + 1); | |
3813 | } | |
3814 | ffelex_append_to_token_ (c); | |
3815 | break; | |
3816 | ||
3817 | default: | |
3818 | ffelex_send_token_ (); | |
3819 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3820 | } | |
3821 | break; | |
3822 | ||
3823 | case FFELEX_typeNUMBER: | |
3824 | switch (c) | |
3825 | { | |
3826 | case '0': | |
3827 | case '1': | |
3828 | case '2': | |
3829 | case '3': | |
3830 | case '4': | |
3831 | case '5': | |
3832 | case '6': | |
3833 | case '7': | |
3834 | case '8': | |
3835 | case '9': | |
3836 | ffelex_append_to_token_ (c); | |
3837 | break; | |
3838 | ||
3839 | default: | |
3840 | ffelex_send_token_ (); | |
3841 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3842 | } | |
3843 | break; | |
3844 | ||
3845 | case FFELEX_typeASTERISK: | |
3846 | switch (c) | |
3847 | { | |
3848 | case '*': /* ** */ | |
3849 | ffelex_token_->type = FFELEX_typePOWER; | |
3850 | ffelex_send_token_ (); | |
3851 | break; | |
3852 | ||
3853 | default: /* * not followed by another *. */ | |
3854 | ffelex_send_token_ (); | |
3855 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3856 | } | |
3857 | break; | |
3858 | ||
3859 | case FFELEX_typeCOLON: | |
3860 | switch (c) | |
3861 | { | |
3862 | case ':': /* :: */ | |
3863 | ffelex_token_->type = FFELEX_typeCOLONCOLON; | |
3864 | ffelex_send_token_ (); | |
3865 | break; | |
3866 | ||
3867 | default: /* : not followed by another :. */ | |
3868 | ffelex_send_token_ (); | |
3869 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3870 | } | |
3871 | break; | |
3872 | ||
3873 | case FFELEX_typeSLASH: | |
3874 | switch (c) | |
3875 | { | |
3876 | case '/': /* // */ | |
3877 | ffelex_token_->type = FFELEX_typeCONCAT; | |
3878 | ffelex_send_token_ (); | |
3879 | break; | |
3880 | ||
3881 | case ')': /* /) */ | |
3882 | ffelex_token_->type = FFELEX_typeCLOSE_ARRAY; | |
3883 | ffelex_send_token_ (); | |
3884 | break; | |
3885 | ||
3886 | case '=': /* /= */ | |
3887 | ffelex_token_->type = FFELEX_typeREL_NE; | |
3888 | ffelex_send_token_ (); | |
3889 | break; | |
3890 | ||
3891 | default: | |
3892 | ffelex_send_token_ (); | |
3893 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3894 | } | |
3895 | break; | |
3896 | ||
3897 | case FFELEX_typeOPEN_PAREN: | |
3898 | switch (c) | |
3899 | { | |
3900 | case '/': /* (/ */ | |
3901 | ffelex_token_->type = FFELEX_typeOPEN_ARRAY; | |
3902 | ffelex_send_token_ (); | |
3903 | break; | |
3904 | ||
3905 | default: | |
3906 | ffelex_send_token_ (); | |
3907 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3908 | } | |
3909 | break; | |
3910 | ||
3911 | case FFELEX_typeOPEN_ANGLE: | |
3912 | switch (c) | |
3913 | { | |
3914 | case '=': /* <= */ | |
3915 | ffelex_token_->type = FFELEX_typeREL_LE; | |
3916 | ffelex_send_token_ (); | |
3917 | break; | |
3918 | ||
3919 | default: | |
3920 | ffelex_send_token_ (); | |
3921 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3922 | } | |
3923 | break; | |
3924 | ||
3925 | case FFELEX_typeEQUALS: | |
3926 | switch (c) | |
3927 | { | |
3928 | case '=': /* == */ | |
3929 | ffelex_token_->type = FFELEX_typeREL_EQ; | |
3930 | ffelex_send_token_ (); | |
3931 | break; | |
3932 | ||
3933 | case '>': /* => */ | |
3934 | ffelex_token_->type = FFELEX_typePOINTS; | |
3935 | ffelex_send_token_ (); | |
3936 | break; | |
3937 | ||
3938 | default: | |
3939 | ffelex_send_token_ (); | |
3940 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3941 | } | |
3942 | break; | |
3943 | ||
3944 | case FFELEX_typeCLOSE_ANGLE: | |
3945 | switch (c) | |
3946 | { | |
3947 | case '=': /* >= */ | |
3948 | ffelex_token_->type = FFELEX_typeREL_GE; | |
3949 | ffelex_send_token_ (); | |
3950 | break; | |
3951 | ||
3952 | default: | |
3953 | ffelex_send_token_ (); | |
3954 | goto parse_next_character; /* :::::::::::::::::::: */ | |
3955 | } | |
3956 | break; | |
3957 | ||
3958 | default: | |
3959 | assert ("Serious error!" == NULL); | |
3960 | abort (); | |
3961 | break; | |
3962 | } | |
3963 | ||
3964 | c = ffelex_card_image_[++column]; | |
3965 | ||
3966 | parse_next_character: /* :::::::::::::::::::: */ | |
3967 | ||
3968 | if (ffelex_raw_mode_ != 0) | |
3969 | goto parse_raw_character; /* :::::::::::::::::::: */ | |
3970 | ||
3971 | if ((c == '\0') || (c == '!')) | |
3972 | { | |
3973 | ffelex_finish_statement_ (); | |
3974 | goto beginning_of_line; /* :::::::::::::::::::: */ | |
3975 | } | |
3976 | goto parse_nonraw_character; /* :::::::::::::::::::: */ | |
3977 | } | |
3978 | ||
3979 | /* See the code in com.c that calls this to understand why. */ | |
3980 | ||
3981 | #if FFECOM_targetCURRENT == FFECOM_targetGCC | |
3982 | void | |
3983 | ffelex_hash_kludge (FILE *finput) | |
3984 | { | |
3985 | /* If you change this constant string, you have to change whatever | |
3986 | code might thus be affected by it in terms of having to use | |
3987 | ffelex_getc_() instead of getc() in the lexers and _hash_. */ | |
3988 | static char match[] = "# 1 \""; | |
3989 | static int kludge[ARRAY_SIZE (match) + 1]; | |
3990 | int c; | |
3991 | char *p; | |
3992 | int *q; | |
3993 | ||
3994 | /* Read chars as long as they match the target string. | |
3995 | Copy them into an array that will serve as a record | |
3996 | of what we read (essentially a multi-char ungetc(), | |
3997 | for code that uses ffelex_getc_ instead of getc() elsewhere | |
3998 | in the lexer. */ | |
3999 | for (p = &match[0], q = &kludge[0], c = getc (finput); | |
4000 | (c == *p) && (*p != '\0') && (c != EOF); | |
4001 | ++p, ++q, c = getc (finput)) | |
4002 | *q = c; | |
4003 | ||
4004 | *q = c; /* Might be EOF, which requires int. */ | |
4005 | *++q = 0; | |
4006 | ||
4007 | ffelex_kludge_chars_ = &kludge[0]; | |
4008 | ||
4009 | if (*p == 0) | |
4010 | { | |
4011 | ffelex_kludge_flag_ = TRUE; | |
4012 | ++ffelex_kludge_chars_; | |
4013 | ffelex_hash_ (finput); /* Handle it NOW rather than later. */ | |
4014 | ffelex_kludge_flag_ = FALSE; | |
4015 | } | |
4016 | } | |
4017 | ||
4018 | #endif | |
4019 | void | |
4020 | ffelex_init_1 () | |
4021 | { | |
4022 | unsigned int i; | |
4023 | ||
4024 | ffelex_final_nontab_column_ = ffe_fixed_line_length (); | |
4025 | ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_; | |
4026 | ffelex_card_image_ = malloc_new_ksr (malloc_pool_image (), | |
4027 | "FFELEX card image", | |
4028 | FFELEX_columnINITIAL_SIZE_ + 9); | |
4029 | ffelex_card_image_[0] = '\0'; | |
4030 | ||
4031 | for (i = 0; i < 256; ++i) | |
4032 | ffelex_first_char_[i] = FFELEX_typeERROR; | |
4033 | ||
4034 | ffelex_first_char_['\t'] = FFELEX_typeRAW; | |
4035 | ffelex_first_char_['\n'] = FFELEX_typeCOMMENT; | |
4036 | ffelex_first_char_['\v'] = FFELEX_typeCOMMENT; | |
4037 | ffelex_first_char_['\f'] = FFELEX_typeCOMMENT; | |
4038 | ffelex_first_char_['\r'] = FFELEX_typeRAW; | |
4039 | ffelex_first_char_[' '] = FFELEX_typeRAW; | |
4040 | ffelex_first_char_['!'] = FFELEX_typeCOMMENT; | |
4041 | ffelex_first_char_['*'] = FFELEX_typeCOMMENT; | |
4042 | ffelex_first_char_['/'] = FFELEX_typeSLASH; | |
4043 | ffelex_first_char_['&'] = FFELEX_typeRAW; | |
4044 | ffelex_first_char_['#'] = FFELEX_typeHASH; | |
4045 | ||
4046 | for (i = '0'; i <= '9'; ++i) | |
4047 | ffelex_first_char_[i] = FFELEX_typeRAW; | |
4048 | ||
4049 | if ((ffe_case_match () == FFE_caseNONE) | |
4050 | || ((ffe_case_match () == FFE_caseUPPER) | |
4051 | && (ffe_case_source () != FFE_caseLOWER)) /* Idiot! :-) */ | |
4052 | || ((ffe_case_match () == FFE_caseLOWER) | |
4053 | && (ffe_case_source () == FFE_caseLOWER))) | |
4054 | { | |
4055 | ffelex_first_char_['C'] = FFELEX_typeCOMMENT; | |
4056 | ffelex_first_char_['D'] = FFELEX_typeCOMMENT; | |
4057 | } | |
4058 | if ((ffe_case_match () == FFE_caseNONE) | |
4059 | || ((ffe_case_match () == FFE_caseLOWER) | |
4060 | && (ffe_case_source () != FFE_caseUPPER)) /* Idiot! :-) */ | |
4061 | || ((ffe_case_match () == FFE_caseUPPER) | |
4062 | && (ffe_case_source () == FFE_caseUPPER))) | |
4063 | { | |
4064 | ffelex_first_char_['c'] = FFELEX_typeCOMMENT; | |
4065 | ffelex_first_char_['d'] = FFELEX_typeCOMMENT; | |
4066 | } | |
4067 | ||
4068 | ffelex_linecount_current_ = 0; | |
4069 | ffelex_linecount_next_ = 1; | |
4070 | ffelex_raw_mode_ = 0; | |
4071 | ffelex_set_include_ = FALSE; | |
4072 | ffelex_permit_include_ = FALSE; | |
4073 | ffelex_names_ = TRUE; /* First token in program is a names. */ | |
4074 | ffelex_names_pure_ = FALSE; /* Free-form lexer does NAMES only for | |
4075 | FORMAT. */ | |
4076 | ffelex_hexnum_ = FALSE; | |
4077 | ffelex_expecting_hollerith_ = 0; | |
4078 | ffelex_raw_where_line_ = ffewhere_line_unknown (); | |
4079 | ffelex_raw_where_col_ = ffewhere_column_unknown (); | |
4080 | ||
4081 | ffelex_token_ = ffelex_token_new_ (); | |
4082 | ffelex_token_->type = FFELEX_typeNONE; | |
4083 | ffelex_token_->uses = 1; | |
4084 | ffelex_token_->where_line = ffewhere_line_unknown (); | |
4085 | ffelex_token_->where_col = ffewhere_column_unknown (); | |
4086 | ffelex_token_->text = NULL; | |
4087 | ||
4088 | ffelex_handler_ = NULL; | |
4089 | } | |
4090 | ||
4091 | /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME? | |
4092 | ||
4093 | if (ffelex_is_names_expected()) | |
4094 | // Deliver NAMES token | |
4095 | else | |
4096 | // Deliver NAME token | |
4097 | ||
4098 | Must be called while lexer is active, obviously. */ | |
4099 | ||
4100 | bool | |
4101 | ffelex_is_names_expected () | |
4102 | { | |
4103 | return ffelex_names_; | |
4104 | } | |
4105 | ||
4106 | /* Current card image, which has the master linecount number | |
4107 | ffelex_linecount_current_. */ | |
4108 | ||
4109 | char * | |
4110 | ffelex_line () | |
4111 | { | |
4112 | return ffelex_card_image_; | |
4113 | } | |
4114 | ||
4115 | /* ffelex_line_length -- Return length of current lexer line | |
4116 | ||
4117 | printf("Length is %lu\n",ffelex_line_length()); | |
4118 | ||
4119 | Must be called while lexer is active, obviously. */ | |
4120 | ||
4121 | ffewhereColumnNumber | |
4122 | ffelex_line_length () | |
4123 | { | |
4124 | return ffelex_card_length_; | |
4125 | } | |
4126 | ||
4127 | /* Master line count of current card image, or 0 if no card image | |
4128 | is current. */ | |
4129 | ||
4130 | ffewhereLineNumber | |
4131 | ffelex_line_number () | |
4132 | { | |
4133 | return ffelex_linecount_current_; | |
4134 | } | |
4135 | ||
4136 | /* ffelex_set_expecting_hollerith -- Set hollerith expectation status | |
4137 | ||
4138 | ffelex_set_expecting_hollerith(0); | |
4139 | ||
4140 | Lex initially assumes no hollerith constant is about to show up. If | |
4141 | syntactic analysis expects one, it should call this function with the | |
4142 | number of characters expected in the constant immediately after recognizing | |
4143 | the decimal number preceding the "H" and the constant itself. Then, if | |
4144 | the next character is indeed H, the lexer will interpret it as beginning | |
4145 | a hollerith constant and ship the token formed by reading the specified | |
4146 | number of characters (interpreting blanks and otherwise-comments too) | |
4147 | from the input file. It is up to syntactic analysis to call this routine | |
4148 | again with 0 to turn hollerith detection off immediately upon receiving | |
4149 | the token that might or might not be HOLLERITH. | |
4150 | ||
4151 | Also call this after seeing an APOSTROPHE or QUOTE token that begins a | |
4152 | character constant. Pass the expected termination character (apostrophe | |
4153 | or quote). | |
4154 | ||
4155 | Pass for length either the length of the hollerith (must be > 0), -1 | |
4156 | meaning expecting a character constant, or 0 to cancel expectation of | |
4157 | a hollerith only after calling it with a length of > 0 and receiving the | |
4158 | next token (which may or may not have been a HOLLERITH token). | |
4159 | ||
4160 | Pass for which either an apostrophe or quote when passing length of -1. | |
4161 | Else which is a don't-care. | |
4162 | ||
4163 | Pass for line and column the line/column info for the token beginning the | |
4164 | character or hollerith constant, for use in error messages, when passing | |
4165 | a length of -1 -- this function will invoke ffewhere_line/column_use to | |
4166 | make its own copies. Else line and column are don't-cares (when length | |
4167 | is 0) and the outstanding copies of the previous line/column info, if | |
4168 | still around, are killed. | |
4169 | ||
4170 | 21-Feb-90 JCB 3.1 | |
4171 | When called with length of 0, also zero ffelex_raw_mode_. This is | |
4172 | so ffest_save_ can undo the effects of replaying tokens like | |
4173 | APOSTROPHE and QUOTE. | |
4174 | 25-Jan-90 JCB 3.0 | |
4175 | New line, column arguments allow error messages to point to the true | |
4176 | beginning of a character/hollerith constant, rather than the beginning | |
4177 | of the content part, which makes them more consistent and helpful. | |
4178 | 05-Nov-89 JCB 2.0 | |
4179 | New "which" argument allows caller to specify termination character, | |
4180 | which should be apostrophe or double-quote, to support Fortran 90. */ | |
4181 | ||
4182 | void | |
4183 | ffelex_set_expecting_hollerith (long length, char which, | |
4184 | ffewhereLine line, ffewhereColumn column) | |
4185 | { | |
4186 | ||
4187 | /* First kill the pending line/col info, if any (should only be pending | |
4188 | when this call has length==0, the previous call had length>0, and a | |
4189 | non-HOLLERITH token was sent in between the calls, but play it safe). */ | |
4190 | ||
4191 | ffewhere_line_kill (ffelex_raw_where_line_); | |
4192 | ffewhere_column_kill (ffelex_raw_where_col_); | |
4193 | ||
4194 | /* Now handle the length function. */ | |
4195 | switch (length) | |
4196 | { | |
4197 | case 0: | |
4198 | ffelex_expecting_hollerith_ = 0; | |
4199 | ffelex_raw_mode_ = 0; | |
4200 | ffelex_raw_where_line_ = ffewhere_line_unknown (); | |
4201 | ffelex_raw_where_col_ = ffewhere_column_unknown (); | |
4202 | return; /* Don't set new line/column info from args. */ | |
4203 | ||
4204 | case -1: | |
4205 | ffelex_raw_mode_ = -1; | |
4206 | ffelex_raw_char_ = which; | |
4207 | break; | |
4208 | ||
4209 | default: /* length > 0 */ | |
4210 | ffelex_expecting_hollerith_ = length; | |
4211 | break; | |
4212 | } | |
4213 | ||
4214 | /* Now set new line/column information from passed args. */ | |
4215 | ||
4216 | ffelex_raw_where_line_ = ffewhere_line_use (line); | |
4217 | ffelex_raw_where_col_ = ffewhere_column_use (column); | |
4218 | } | |
4219 | ||
4220 | /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free | |
4221 | ||
4222 | ffelex_set_handler((ffelexHandler) my_first_handler); | |
4223 | ||
4224 | Must be called before calling ffelex_file_fixed or ffelex_file_free or | |
4225 | after they return, but not while they are active. */ | |
4226 | ||
4227 | void | |
4228 | ffelex_set_handler (ffelexHandler first) | |
4229 | { | |
4230 | ffelex_handler_ = first; | |
4231 | } | |
4232 | ||
4233 | /* ffelex_set_hexnum -- Set hexnum flag | |
4234 | ||
4235 | ffelex_set_hexnum(TRUE); | |
4236 | ||
4237 | Lex normally interprets a token starting with [0-9] as a NUMBER token, | |
4238 | so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves | |
4239 | the character as the first of the next token. But when parsing a | |
4240 | hexadecimal number, by calling this function with TRUE before starting | |
4241 | the parse of the token itself, lex will interpret [0-9] as the start | |
4242 | of a NAME token. */ | |
4243 | ||
4244 | void | |
4245 | ffelex_set_hexnum (bool f) | |
4246 | { | |
4247 | ffelex_hexnum_ = f; | |
4248 | } | |
4249 | ||
4250 | /* ffelex_set_include -- Set INCLUDE file to be processed next | |
4251 | ||
4252 | ffewhereFile wf; // The ffewhereFile object for the file. | |
4253 | bool free_form; // TRUE means read free-form file, FALSE fixed-form. | |
4254 | FILE *fi; // The file to INCLUDE. | |
4255 | ffelex_set_include(wf,free_form,fi); | |
4256 | ||
4257 | Must be called only after receiving the EOS token following a valid | |
4258 | INCLUDE statement specifying a file that has already been successfully | |
4259 | opened. */ | |
4260 | ||
4261 | void | |
4262 | ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi) | |
4263 | { | |
4264 | assert (ffelex_permit_include_); | |
4265 | assert (!ffelex_set_include_); | |
4266 | ffelex_set_include_ = TRUE; | |
4267 | ffelex_include_free_form_ = free_form; | |
4268 | ffelex_include_file_ = fi; | |
4269 | ffelex_include_wherefile_ = wf; | |
4270 | } | |
4271 | ||
4272 | /* ffelex_set_names -- Set names/name flag, names = TRUE | |
4273 | ||
4274 | ffelex_set_names(FALSE); | |
4275 | ||
4276 | Lex initially assumes multiple names should be formed. If this function is | |
4277 | called with FALSE, then single names are formed instead. The differences | |
4278 | are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME) | |
4279 | and in whether full source-location tracking is performed (it is for | |
4280 | multiple names, not for single names), which is more expensive in terms of | |
4281 | CPU time. */ | |
4282 | ||
4283 | void | |
4284 | ffelex_set_names (bool f) | |
4285 | { | |
4286 | ffelex_names_ = f; | |
4287 | if (!f) | |
4288 | ffelex_names_pure_ = FALSE; | |
4289 | } | |
4290 | ||
4291 | /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE | |
4292 | ||
4293 | ffelex_set_names_pure(FALSE); | |
4294 | ||
4295 | Like ffelex_set_names, except affects both lexers. Normally, the | |
4296 | free-form lexer need not generate NAMES tokens because adjacent NAME | |
4297 | tokens must be separated by spaces which causes the lexer to generate | |
4298 | separate tokens for analysis (whereas in fixed-form the spaces are | |
4299 | ignored resulting in one long token). But in FORMAT statements, for | |
4300 | some reason, the Fortran 90 standard specifies that spaces can occur | |
4301 | anywhere within a format-item-list with no effect on the format spec | |
4302 | (except of course within character string edit descriptors), which means | |
4303 | that "1PE14.2" and "1 P E 1 4 . 2" are equivalent. For the FORMAT | |
4304 | statement handling, the existence of spaces makes it hard to deal with, | |
4305 | because each token is seen distinctly (i.e. seven tokens in the latter | |
4306 | example). But when no spaces are provided, as in the former example, | |
4307 | then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD, | |
4308 | NUMBER ("2"). By generating a NAMES instead of NAME, three things happen: | |
4309 | One, ffest_kw_format_ does a substring rather than full-string match, | |
4310 | and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions | |
4311 | may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token; | |
4312 | and three, error reporting can point to the actual character rather than | |
4313 | at or prior to it. The first two things could be resolved by providing | |
4314 | alternate functions fairly easy, thus allowing FORMAT handling to expect | |
4315 | both lexers to generate NAME tokens instead of NAMES (with otherwise minor | |
4316 | changes to FORMAT parsing), but the third, error reporting, would suffer, | |
4317 | and when one makes mistakes in a FORMAT, believe me, one wants a pointer | |
4318 | to exactly where the compilers thinks the problem is, to even begin to get | |
4319 | a handle on it. So there. */ | |
4320 | ||
4321 | void | |
4322 | ffelex_set_names_pure (bool f) | |
4323 | { | |
4324 | ffelex_names_pure_ = f; | |
4325 | ffelex_names_ = f; | |
4326 | } | |
4327 | ||
4328 | /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES | |
4329 | ||
4330 | return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token, | |
4331 | start_char_index); | |
4332 | ||
4333 | Returns first_handler if start_char_index chars into master_token (which | |
4334 | must be a NAMES token) is '\0'. Else, creates a subtoken from that | |
4335 | char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar), | |
4336 | an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign) | |
4337 | and sends it to first_handler. If anything other than NAME is sent, the | |
4338 | character at the end of it in the master token is examined to see if it | |
4339 | begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so, | |
4340 | the handler returned by first_handler is invoked with that token, and | |
4341 | this process is repeated until the end of the master token or a NAME | |
4342 | token is reached. */ | |
4343 | ||
4344 | ffelexHandler | |
4345 | ffelex_splice_tokens (ffelexHandler first, ffelexToken master, | |
4346 | ffeTokenLength start) | |
4347 | { | |
0816ebdd | 4348 | unsigned char *p; |
5ff904cd JL |
4349 | ffeTokenLength i; |
4350 | ffelexToken t; | |
4351 | ||
4352 | p = ffelex_token_text (master) + (i = start); | |
4353 | ||
4354 | while (*p != '\0') | |
4355 | { | |
8b45da67 | 4356 | if (ISDIGIT (*p)) |
5ff904cd JL |
4357 | { |
4358 | t = ffelex_token_number_from_names (master, i); | |
4359 | p += ffelex_token_length (t); | |
4360 | i += ffelex_token_length (t); | |
4361 | } | |
4362 | else if (ffesrc_is_name_init (*p)) | |
4363 | { | |
4364 | t = ffelex_token_name_from_names (master, i, 0); | |
4365 | p += ffelex_token_length (t); | |
4366 | i += ffelex_token_length (t); | |
4367 | } | |
4368 | else if (*p == '$') | |
4369 | { | |
4370 | t = ffelex_token_dollar_from_names (master, i); | |
4371 | ++p; | |
4372 | ++i; | |
4373 | } | |
4374 | else if (*p == '_') | |
4375 | { | |
4376 | t = ffelex_token_uscore_from_names (master, i); | |
4377 | ++p; | |
4378 | ++i; | |
4379 | } | |
4380 | else | |
4381 | { | |
4382 | assert ("not a valid NAMES character" == NULL); | |
4383 | t = NULL; | |
4384 | } | |
4385 | assert (first != NULL); | |
4386 | first = (ffelexHandler) (*first) (t); | |
4387 | ffelex_token_kill (t); | |
4388 | } | |
4389 | ||
4390 | return first; | |
4391 | } | |
4392 | ||
4393 | /* ffelex_swallow_tokens -- Eat all tokens delivered to me | |
4394 | ||
4395 | return ffelex_swallow_tokens; | |
4396 | ||
4397 | Return this handler when you don't want to look at any more tokens in the | |
4398 | statement because you've encountered an unrecoverable error in the | |
4399 | statement. */ | |
4400 | ||
4401 | ffelexHandler | |
4402 | ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler) | |
4403 | { | |
4404 | assert (handler != NULL); | |
4405 | ||
4406 | if ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeEOS) | |
4407 | || (ffelex_token_type (t) == FFELEX_typeSEMICOLON))) | |
4408 | return (ffelexHandler) (*handler) (t); | |
4409 | ||
4410 | ffelex_eos_handler_ = handler; | |
4411 | return (ffelexHandler) ffelex_swallow_tokens_; | |
4412 | } | |
4413 | ||
4414 | /* ffelex_token_dollar_from_names -- Return a dollar from within a names token | |
4415 | ||
4416 | ffelexToken t; | |
4417 | t = ffelex_token_dollar_from_names(t,6); | |
4418 | ||
4419 | It's as if you made a new token of dollar type having the dollar | |
4420 | at, in the example above, the sixth character of the NAMES token. */ | |
4421 | ||
4422 | ffelexToken | |
4423 | ffelex_token_dollar_from_names (ffelexToken t, ffeTokenLength start) | |
4424 | { | |
4425 | ffelexToken nt; | |
4426 | ||
4427 | assert (t != NULL); | |
4428 | assert (ffelex_token_type (t) == FFELEX_typeNAMES); | |
4429 | assert (start < t->length); | |
4430 | assert (t->text[start] == '$'); | |
4431 | ||
4432 | /* Now make the token. */ | |
4433 | ||
4434 | nt = ffelex_token_new_ (); | |
4435 | nt->type = FFELEX_typeDOLLAR; | |
4436 | nt->length = 0; | |
4437 | nt->uses = 1; | |
4438 | ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, | |
4439 | t->where_col, t->wheretrack, start); | |
4440 | nt->text = NULL; | |
4441 | return nt; | |
4442 | } | |
4443 | ||
4444 | /* ffelex_token_kill -- Decrement use count for token, kill if no uses left | |
4445 | ||
4446 | ffelexToken t; | |
4447 | ffelex_token_kill(t); | |
4448 | ||
4449 | Complements a call to ffelex_token_use or ffelex_token_new_.... */ | |
4450 | ||
4451 | void | |
4452 | ffelex_token_kill (ffelexToken t) | |
4453 | { | |
4454 | assert (t != NULL); | |
4455 | ||
4456 | assert (t->uses > 0); | |
4457 | ||
4458 | if (--t->uses != 0) | |
4459 | return; | |
4460 | ||
4461 | --ffelex_total_tokens_; | |
4462 | ||
4463 | if (t->type == FFELEX_typeNAMES) | |
4464 | ffewhere_track_kill (t->where_line, t->where_col, | |
4465 | t->wheretrack, t->length); | |
4466 | ffewhere_line_kill (t->where_line); | |
4467 | ffewhere_column_kill (t->where_col); | |
4468 | if (t->text != NULL) | |
4469 | malloc_kill_ksr (malloc_pool_image (), t->text, t->size + 1); | |
4470 | malloc_kill_ks (malloc_pool_image (), t, sizeof (*t)); | |
4471 | } | |
4472 | ||
4473 | /* Make a new NAME token that is a substring of a NAMES token. */ | |
4474 | ||
4475 | ffelexToken | |
4476 | ffelex_token_name_from_names (ffelexToken t, ffeTokenLength start, | |
4477 | ffeTokenLength len) | |
4478 | { | |
4479 | ffelexToken nt; | |
4480 | ||
4481 | assert (t != NULL); | |
4482 | assert (ffelex_token_type (t) == FFELEX_typeNAMES); | |
4483 | assert (start < t->length); | |
4484 | if (len == 0) | |
4485 | len = t->length - start; | |
4486 | else | |
4487 | { | |
4488 | assert (len > 0); | |
4489 | assert ((start + len) <= t->length); | |
4490 | } | |
0816ebdd | 4491 | assert (ffelex_is_firstnamechar ((unsigned char)(t->text[start]))); |
5ff904cd JL |
4492 | |
4493 | nt = ffelex_token_new_ (); | |
4494 | nt->type = FFELEX_typeNAME; | |
4495 | nt->size = len; /* Assume nobody's gonna fiddle with token | |
4496 | text. */ | |
4497 | nt->length = len; | |
4498 | nt->uses = 1; | |
4499 | ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, | |
4500 | t->where_col, t->wheretrack, start); | |
4501 | nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4502 | len + 1); | |
4503 | strncpy (nt->text, t->text + start, len); | |
4504 | nt->text[len] = '\0'; | |
4505 | return nt; | |
4506 | } | |
4507 | ||
4508 | /* Make a new NAMES token that is a substring of another NAMES token. */ | |
4509 | ||
4510 | ffelexToken | |
4511 | ffelex_token_names_from_names (ffelexToken t, ffeTokenLength start, | |
4512 | ffeTokenLength len) | |
4513 | { | |
4514 | ffelexToken nt; | |
4515 | ||
4516 | assert (t != NULL); | |
4517 | assert (ffelex_token_type (t) == FFELEX_typeNAMES); | |
4518 | assert (start < t->length); | |
4519 | if (len == 0) | |
4520 | len = t->length - start; | |
4521 | else | |
4522 | { | |
4523 | assert (len > 0); | |
4524 | assert ((start + len) <= t->length); | |
4525 | } | |
0816ebdd | 4526 | assert (ffelex_is_firstnamechar ((unsigned char)(t->text[start]))); |
5ff904cd JL |
4527 | |
4528 | nt = ffelex_token_new_ (); | |
4529 | nt->type = FFELEX_typeNAMES; | |
4530 | nt->size = len; /* Assume nobody's gonna fiddle with token | |
4531 | text. */ | |
4532 | nt->length = len; | |
4533 | nt->uses = 1; | |
4534 | ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, | |
4535 | t->where_col, t->wheretrack, start); | |
4536 | ffewhere_track_copy (nt->wheretrack, t->wheretrack, start, len); | |
4537 | nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4538 | len + 1); | |
4539 | strncpy (nt->text, t->text + start, len); | |
4540 | nt->text[len] = '\0'; | |
4541 | return nt; | |
4542 | } | |
4543 | ||
4544 | /* Make a new CHARACTER token. */ | |
4545 | ||
4546 | ffelexToken | |
26f096f9 | 4547 | ffelex_token_new_character (const char *s, ffewhereLine l, ffewhereColumn c) |
5ff904cd JL |
4548 | { |
4549 | ffelexToken t; | |
4550 | ||
4551 | t = ffelex_token_new_ (); | |
4552 | t->type = FFELEX_typeCHARACTER; | |
4553 | t->length = t->size = strlen (s); /* Assume it won't get bigger. */ | |
4554 | t->uses = 1; | |
4555 | t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4556 | t->size + 1); | |
4557 | strcpy (t->text, s); | |
4558 | t->where_line = ffewhere_line_use (l); | |
4559 | t->where_col = ffewhere_column_new (c); | |
4560 | return t; | |
4561 | } | |
4562 | ||
4563 | /* Make a new EOF token right after end of file. */ | |
4564 | ||
4565 | ffelexToken | |
4566 | ffelex_token_new_eof () | |
4567 | { | |
4568 | ffelexToken t; | |
4569 | ||
4570 | t = ffelex_token_new_ (); | |
4571 | t->type = FFELEX_typeEOF; | |
4572 | t->uses = 1; | |
4573 | t->text = NULL; | |
4574 | t->where_line = ffewhere_line_new (ffelex_linecount_current_); | |
4575 | t->where_col = ffewhere_column_new (1); | |
4576 | return t; | |
4577 | } | |
4578 | ||
4579 | /* Make a new NAME token. */ | |
4580 | ||
4581 | ffelexToken | |
26f096f9 | 4582 | ffelex_token_new_name (const char *s, ffewhereLine l, ffewhereColumn c) |
5ff904cd JL |
4583 | { |
4584 | ffelexToken t; | |
4585 | ||
0816ebdd | 4586 | assert (ffelex_is_firstnamechar ((unsigned char)*s)); |
5ff904cd JL |
4587 | |
4588 | t = ffelex_token_new_ (); | |
4589 | t->type = FFELEX_typeNAME; | |
4590 | t->length = t->size = strlen (s); /* Assume it won't get bigger. */ | |
4591 | t->uses = 1; | |
4592 | t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4593 | t->size + 1); | |
4594 | strcpy (t->text, s); | |
4595 | t->where_line = ffewhere_line_use (l); | |
4596 | t->where_col = ffewhere_column_new (c); | |
4597 | return t; | |
4598 | } | |
4599 | ||
4600 | /* Make a new NAMES token. */ | |
4601 | ||
4602 | ffelexToken | |
26f096f9 | 4603 | ffelex_token_new_names (const char *s, ffewhereLine l, ffewhereColumn c) |
5ff904cd JL |
4604 | { |
4605 | ffelexToken t; | |
4606 | ||
0816ebdd | 4607 | assert (ffelex_is_firstnamechar ((unsigned char)*s)); |
5ff904cd JL |
4608 | |
4609 | t = ffelex_token_new_ (); | |
4610 | t->type = FFELEX_typeNAMES; | |
4611 | t->length = t->size = strlen (s); /* Assume it won't get bigger. */ | |
4612 | t->uses = 1; | |
4613 | t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4614 | t->size + 1); | |
4615 | strcpy (t->text, s); | |
4616 | t->where_line = ffewhere_line_use (l); | |
4617 | t->where_col = ffewhere_column_new (c); | |
4618 | ffewhere_track_clear (t->wheretrack, t->length); /* Assume contiguous | |
4619 | names. */ | |
4620 | return t; | |
4621 | } | |
4622 | ||
4623 | /* Make a new NUMBER token. | |
4624 | ||
4625 | The first character of the string must be a digit, and only the digits | |
4626 | are copied into the new number. So this may be used to easily extract | |
4627 | a NUMBER token from within any text string. Then the length of the | |
4628 | resulting token may be used to calculate where the digits stopped | |
4629 | in the original string. */ | |
4630 | ||
4631 | ffelexToken | |
26f096f9 | 4632 | ffelex_token_new_number (const char *s, ffewhereLine l, ffewhereColumn c) |
5ff904cd JL |
4633 | { |
4634 | ffelexToken t; | |
4635 | ffeTokenLength len; | |
4636 | ||
4637 | /* How long is the string of decimal digits at s? */ | |
4638 | ||
4639 | len = strspn (s, "0123456789"); | |
4640 | ||
4641 | /* Make sure there is at least one digit. */ | |
4642 | ||
4643 | assert (len != 0); | |
4644 | ||
4645 | /* Now make the token. */ | |
4646 | ||
4647 | t = ffelex_token_new_ (); | |
4648 | t->type = FFELEX_typeNUMBER; | |
4649 | t->length = t->size = len; /* Assume it won't get bigger. */ | |
4650 | t->uses = 1; | |
4651 | t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4652 | len + 1); | |
4653 | strncpy (t->text, s, len); | |
4654 | t->text[len] = '\0'; | |
4655 | t->where_line = ffewhere_line_use (l); | |
4656 | t->where_col = ffewhere_column_new (c); | |
4657 | return t; | |
4658 | } | |
4659 | ||
4660 | /* Make a new token of any type that doesn't contain text. A private | |
4661 | function that is used by public macros in the interface file. */ | |
4662 | ||
4663 | ffelexToken | |
4664 | ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, ffewhereColumn c) | |
4665 | { | |
4666 | ffelexToken t; | |
4667 | ||
4668 | t = ffelex_token_new_ (); | |
4669 | t->type = type; | |
4670 | t->uses = 1; | |
4671 | t->text = NULL; | |
4672 | t->where_line = ffewhere_line_use (l); | |
4673 | t->where_col = ffewhere_column_new (c); | |
4674 | return t; | |
4675 | } | |
4676 | ||
4677 | /* Make a new NUMBER token from an existing NAMES token. | |
4678 | ||
4679 | Like ffelex_token_new_number, this function calculates the length | |
4680 | of the digit string itself. */ | |
4681 | ||
4682 | ffelexToken | |
4683 | ffelex_token_number_from_names (ffelexToken t, ffeTokenLength start) | |
4684 | { | |
4685 | ffelexToken nt; | |
4686 | ffeTokenLength len; | |
4687 | ||
4688 | assert (t != NULL); | |
4689 | assert (ffelex_token_type (t) == FFELEX_typeNAMES); | |
4690 | assert (start < t->length); | |
4691 | ||
4692 | /* How long is the string of decimal digits at s? */ | |
4693 | ||
4694 | len = strspn (t->text + start, "0123456789"); | |
4695 | ||
4696 | /* Make sure there is at least one digit. */ | |
4697 | ||
4698 | assert (len != 0); | |
4699 | ||
4700 | /* Now make the token. */ | |
4701 | ||
4702 | nt = ffelex_token_new_ (); | |
4703 | nt->type = FFELEX_typeNUMBER; | |
4704 | nt->size = len; /* Assume nobody's gonna fiddle with token | |
4705 | text. */ | |
4706 | nt->length = len; | |
4707 | nt->uses = 1; | |
4708 | ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, | |
4709 | t->where_col, t->wheretrack, start); | |
4710 | nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", | |
4711 | len + 1); | |
4712 | strncpy (nt->text, t->text + start, len); | |
4713 | nt->text[len] = '\0'; | |
4714 | return nt; | |
4715 | } | |
4716 | ||
4717 | /* Make a new UNDERSCORE token from a NAMES token. */ | |
4718 | ||
4719 | ffelexToken | |
4720 | ffelex_token_uscore_from_names (ffelexToken t, ffeTokenLength start) | |
4721 | { | |
4722 | ffelexToken nt; | |
4723 | ||
4724 | assert (t != NULL); | |
4725 | assert (ffelex_token_type (t) == FFELEX_typeNAMES); | |
4726 | assert (start < t->length); | |
4727 | assert (t->text[start] == '_'); | |
4728 | ||
4729 | /* Now make the token. */ | |
4730 | ||
4731 | nt = ffelex_token_new_ (); | |
4732 | nt->type = FFELEX_typeUNDERSCORE; | |
4733 | nt->uses = 1; | |
4734 | ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, | |
4735 | t->where_col, t->wheretrack, start); | |
4736 | nt->text = NULL; | |
4737 | return nt; | |
4738 | } | |
4739 | ||
4740 | /* ffelex_token_use -- Return another instance of a token | |
4741 | ||
4742 | ffelexToken t; | |
4743 | t = ffelex_token_use(t); | |
4744 | ||
4745 | In a sense, the new token is a copy of the old, though it might be the | |
4746 | same with just a new use count. | |
4747 | ||
4748 | We use the use count method (easy). */ | |
4749 | ||
4750 | ffelexToken | |
4751 | ffelex_token_use (ffelexToken t) | |
4752 | { | |
4753 | if (t == NULL) | |
4754 | assert ("_token_use: null token" == NULL); | |
4755 | t->uses++; | |
4756 | return t; | |
4757 | } |