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