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.
6 This file is part of GNU Fortran.
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)
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.
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
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);
60 /* Pertaining to the geometry of the input file. */
62 /* Initial size for card image to be allocated. */
63 #define FFELEX_columnINITIAL_SIZE_ 255
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_
;
73 /* Max width for free-form lines (ISO F90). */
74 #define FFELEX_FREE_MAX_COLUMNS_ 132
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
79 static bool ffelex_saw_tab_
;
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
;
85 /* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */
86 static ffewhereColumnNumber ffelex_final_nontab_column_
;
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];
92 /* Pertaining to file management. */
94 /* The wf argument of the most recent active ffelex_file_(fixed,free)
96 static GTY (()) ffewhereFile ffelex_current_wf_
;
98 /* TRUE if an INCLUDE statement can be processed (ffelex_set_include
100 static bool ffelex_permit_include_
;
102 /* TRUE if an INCLUDE statement is pending (ffelex_set_include has been
104 static bool ffelex_set_include_
;
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_
;
111 /* Current master line count. */
112 static ffewhereLineNumber ffelex_linecount_current_
;
113 /* Next master line count. */
114 static ffewhereLineNumber ffelex_linecount_next_
;
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_
;
121 /* Pertaining to tokens in general. */
123 /* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER
125 #define FFELEX_columnTOKEN_SIZE_ 63
126 #if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX
127 #error "token size too small!"
130 /* Current token being lexed. */
131 static ffelexToken ffelex_token_
;
133 /* Handler for current token. */
134 static ffelexHandler ffelex_handler_
;
136 /* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */
137 static bool ffelex_names_
;
139 /* TRUE if both lexers are to generate NAMES instead of NAME tokens. */
140 static bool ffelex_names_pure_
;
142 /* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex
144 static bool ffelex_hexnum_
;
146 /* For ffelex_swallow_tokens(). */
147 static ffelexHandler ffelex_eos_handler_
;
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_
;
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_
;
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;
163 /* Pertaining to lexing CHARACTER and HOLLERITH tokens. */
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_
;
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_
;
177 /* When lexing CHARACTER, open quote/apostrophe (either ' or "). */
178 static char ffelex_raw_char_
;
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
;
186 /* Characters preread before lexing happened (might include EOF). */
187 static int *ffelex_kludge_chars_
= NULL
;
189 /* Doing the kludge processing, so not initialized yet. */
190 static bool ffelex_kludge_flag_
= FALSE
;
192 /* The beginning of a (possible) CHARACTER/HOLLERITH token. */
193 static ffewhereLine ffelex_raw_where_line_
;
194 static ffewhereColumn ffelex_raw_where_col_
;
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. */
202 ffelex_append_to_token_ (char c
)
204 if (ffelex_token_
->text
== NULL
)
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;
212 else if (ffelex_token_
->length
>= ffelex_token_
->size
)
215 = malloc_resize_ksr (malloc_pool_image (),
217 (ffelex_token_
->size
<< 1) + 1,
218 ffelex_token_
->size
+ 1);
219 ffelex_token_
->size
<<= 1;
220 assert (ffelex_token_
->length
< ffelex_token_
->size
);
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
.
227 ffelex_token_
->text
[ffelex_token_
->length
++] = c
;
230 /* Do backslash (escape) processing for a CHARACTER/HOLLERITH token
234 ffelex_backslash_ (int c
, ffewhereColumnNumber col
)
236 static int state
= 0;
237 static unsigned int count
;
239 static unsigned int firstdig
= 0;
241 static ffewhereLineNumber line
;
242 static ffewhereColumnNumber column
;
244 /* See gcc/c-lex.c readescape() for a straightforward version
245 of this state engine for handling backslashes in character/
246 hollerith constants. */
254 && (ffelex_raw_mode_
!= 0)
255 && ffe_is_backslash ())
259 line
= ffelex_linecount_current_
;
265 state
= 0; /* Assume simple case. */
275 case '0': case '1': case '2': case '3': case '4':
276 case '5': case '6': case '7':
282 case '\\': case '\'': case '"':
285 #if 0 /* Inappropriate for Fortran. */
287 ffelex_next_line_ ();
293 return TARGET_NEWLINE
;
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
);
332 return (c
== 'E' || c
== 'e') ? 033 : c
;
338 if (c
>= 040 && c
< 0177)
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
);
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
);
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
);
377 code
= (code
* 16) + hex_value (c
);
378 if (code
!= 0 || count
!= 0)
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
);
399 /* Digits are all 0's. Ok. */
401 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
403 && ((1 << (TYPE_PRECISION (integer_type_node
) - (count
- 1) * 4))
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
);
415 if ((c
<= '7') && (c
>= '0') && (count
++ < 3))
417 code
= (code
* 8) + (c
- '0');
424 assert ("bad backslash state" == NULL
);
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. */
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. */
437 && TYPE_PRECISION (char_type_node
) < HOST_BITS_PER_INT
438 && code
>= (1 << TYPE_PRECISION (char_type_node
)))
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
);
449 /* Known end of constant, just append this character. */
450 ffelex_append_to_token_ (code
);
451 if (ffelex_raw_mode_
> 0)
456 /* Have two characters to handle. Do the first, then leave it to the
457 caller to detect anything special about the second. */
459 ffelex_append_to_token_ (code
);
460 if (ffelex_raw_mode_
> 0)
462 ffelex_backslash_reconsider_
= TRUE
;
466 /* ffelex_bad_1_ -- Issue diagnostic with one source point
468 ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1);
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. */
475 ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
)
480 wl0
= ffewhere_line_new (ln0
);
481 wc0
= ffewhere_column_new (cn0
);
482 ffebad_start_lex (errnum
);
483 ffebad_here (0, wl0
, wc0
);
485 ffewhere_line_kill (wl0
);
486 ffewhere_column_kill (wc0
);
489 /* ffelex_bad_2_ -- Issue diagnostic with two source points
491 ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1,
492 otherline,othercolumn);
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. */
499 ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
,
500 ffewhereLineNumber ln1
, ffewhereColumnNumber cn1
)
502 ffewhereLine wl0
, wl1
;
503 ffewhereColumn wc0
, wc1
;
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
);
513 ffewhere_line_kill (wl0
);
514 ffewhere_column_kill (wc0
);
515 ffewhere_line_kill (wl1
);
516 ffewhere_column_kill (wc1
);
520 ffelex_bad_here_ (int n
, ffewhereLineNumber ln0
,
521 ffewhereColumnNumber cn0
)
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
);
534 ffelex_getc_ (FILE *finput
)
538 if (ffelex_kludge_chars_
== NULL
)
539 return getc (finput
);
541 c
= *ffelex_kludge_chars_
++;
545 ffelex_kludge_chars_
= NULL
;
546 return getc (finput
);
550 ffelex_cfebackslash_ (int *use_d
, int *d
, FILE *finput
)
552 register int c
= getc (finput
);
554 register unsigned count
;
555 unsigned firstdig
= 0;
575 code
= (code
* 16) + hex_value (c
);
576 if (code
!= 0 || count
!= 0)
585 error ("\\x used with no following hex digits");
587 /* Digits are all 0's. Ok. */
589 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
592 << (TYPE_PRECISION (integer_type_node
) - (count
- 1)
595 pedwarn ("hex escape out of range");
598 case '0': case '1': case '2': case '3': case '4':
599 case '5': case '6': case '7':
602 while ((c
<= '7') && (c
>= '0') && (count
++ < 3))
604 code
= (code
* 8) + (c
- '0');
611 case '\\': case '\'': case '"':
615 ffelex_next_line_ ();
625 return TARGET_NEWLINE
;
648 pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c
);
654 /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */
658 /* `\%' is used to prevent SCCS from getting confused. */
661 pedwarn ("non-ISO escape sequence `\\%c'", c
);
664 if (c
>= 040 && c
< 0177)
665 pedwarn ("unknown escape sequence `\\%c'", c
);
667 pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c
);
671 /* A miniature version of the C front-end lexer. */
674 ffelex_cfelex_ (ffelexToken
*xtoken
, FILE *finput
, int c
)
681 register unsigned buffer_length
;
683 if ((*xtoken
!= NULL
) && !ffelex_kludge_flag_
)
684 ffelex_token_kill (*xtoken
);
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
);
693 r
= &buff
[buffer_length
];
699 register unsigned bytes_used
= (p
- q
);
702 q
= (char *)xrealloc (q
, buffer_length
);
704 r
= &q
[buffer_length
];
706 c
= ffelex_getc_ (finput
);
711 token
= ffelex_token_new_number (q
, ffewhere_line_unknown (),
712 ffewhere_column_unknown ());
720 buffer_length
= ARRAY_SIZE (buff
);
723 r
= &buff
[buffer_length
];
724 c
= ffelex_getc_ (finput
);
738 case '\\': /* ~~~~~ */
739 c
= ffelex_cfebackslash_ (&use_d
, &d
, finput
);
744 error ("badly formed directive -- no closing quote");
754 if (use_d
!= 2) /* 0=>c, 1=>cd, 2=>nil. */
759 register unsigned bytes_used
= (p
- q
);
761 buffer_length
= bytes_used
* 2;
762 q
= (char *)xrealloc (q
, buffer_length
);
764 r
= &q
[buffer_length
];
773 token
= ffelex_token_new_character (q
, ffewhere_line_unknown (),
774 ffewhere_column_unknown ());
791 ffelex_file_pop_ (const char *input_filename
)
793 if (input_file_stack
->next
)
795 struct file_stack
*p
= input_file_stack
;
796 input_file_stack
= p
->next
;
798 input_file_stack_tick
++;
799 (*debug_hooks
->end_source_file
) (input_file_stack
->line
);
802 error ("#-lines for entering and leaving files don't match");
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
;
811 ffelex_file_push_ (int old_lineno
, const char *input_filename
)
814 = (struct file_stack
*) xmalloc (sizeof (struct file_stack
));
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
++;
822 (*debug_hooks
->start_source_file
) (0, input_filename
);
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
;
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. */
837 ffelex_prepare_eos_ ()
839 if (ffelex_token_
->type
!= FFELEX_typeNONE
)
841 ffelex_backslash_ (EOF
, 0);
843 switch (ffelex_raw_mode_
)
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_
);
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_
);
869 /* Make sure the token has some text, might as well fill up with spaces. */
872 ffelex_append_to_token_ (' ');
873 } while (--ffelex_raw_mode_
> 0);
877 ffelex_raw_mode_
= 0;
878 ffelex_send_token_ ();
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_
);
886 ffelex_finish_statement_ ()
888 if ((ffelex_number_of_tokens_
== 0)
889 && (ffelex_token_
->type
== FFELEX_typeNONE
))
890 return; /* Don't have a statement pending. */
892 if (ffelex_token_
->type
!= FFELEX_typeEOS
)
893 ffelex_prepare_eos_ ();
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
;
904 if (!ffe_is_ffedebug ())
907 /* For debugging purposes only. */
909 if (ffelex_total_tokens_
!= ffelex_old_total_tokens_
)
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_
;
917 /* Copied from gcc/c-common.c get_directive_line. */
920 ffelex_get_directive_line_ (char **text
, FILE *finput
)
922 static char *directive_buffer
= NULL
;
923 static unsigned buffer_length
= 0;
925 register char *buffer_limit
;
926 register int looking_for
= 0;
927 register int char_escaped
= 0;
929 if (buffer_length
== 0)
931 directive_buffer
= (char *)xmalloc (128);
935 buffer_limit
= &directive_buffer
[buffer_length
];
937 for (p
= directive_buffer
; ; )
941 /* Make buffer bigger if it is full. */
942 if (p
>= buffer_limit
)
944 register unsigned bytes_used
= (p
- directive_buffer
);
948 = (char *)xrealloc (directive_buffer
, buffer_length
);
949 p
= &directive_buffer
[bytes_used
];
950 buffer_limit
= &directive_buffer
[buffer_length
];
955 /* Discard initial whitespace. */
956 if ((c
== ' ' || c
== '\t') && p
== directive_buffer
)
959 /* Detect the end of the directive. */
960 if ((c
== '\n' && looking_for
== 0)
963 if (looking_for
!= 0)
964 error ("bad directive -- missing close-quote");
967 *text
= directive_buffer
;
973 ffelex_next_line_ ();
975 /* Handle string and character constant syntax. */
978 if (looking_for
== c
&& !char_escaped
)
979 looking_for
= 0; /* Found terminator... stop looking. */
982 if (c
== '\'' || c
== '"')
983 looking_for
= c
; /* Don't stop buffering until we see another
984 one of these (or an EOF). */
986 /* Handle backslash. */
987 char_escaped
= (c
== '\\' && ! char_escaped
);
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.
998 Returns the next character unhandled, which is always newline or EOF. */
1000 #if defined HANDLE_PRAGMA
1001 /* Local versions of these macros, that can be passed as function pointers. */
1005 return getc (finput
);
1012 ungetc (arg
, finput
);
1014 #endif /* HANDLE_PRAGMA */
1017 ffelex_hash_ (FILE *finput
)
1020 ffelexToken token
= NULL
;
1022 /* Read first nonwhite char after the `#'. */
1024 c
= ffelex_getc_ (finput
);
1025 while (c
== ' ' || c
== '\t')
1026 c
= ffelex_getc_ (finput
);
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'. */
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'
1044 #if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */
1045 static char buffer
[128];
1046 char * buff
= buffer
;
1048 /* Read the pragma name into a buffer.
1049 ISSPACE() may evaluate its argument more than once! */
1050 while (((c
= getc (finput
)), ISSPACE(c
)))
1058 while (c
!= EOF
&& ! ISSPACE (c
) && c
!= '\n'
1059 && buff
< buffer
+ 128);
1064 #ifdef HANDLE_PRAGMA
1065 if (HANDLE_PRAGMA (pragma_getc
, pragma_ungetc
, buffer
))
1067 #endif /* HANDLE_PRAGMA */
1068 #ifdef HANDLE_GENERIC_PRAGMAS
1069 if (handle_generic_pragma (buffer
))
1071 #endif /* !HANDLE_GENERIC_PRAGMAS */
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
);
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'
1096 c
= ffelex_get_directive_line_ (&text
, finput
);
1098 if (debug_info_level
== DINFO_LEVEL_VERBOSE
)
1099 (*debug_hooks
->define
) (lineno
, text
);
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'
1115 c
= ffelex_get_directive_line_ (&text
, finput
);
1117 if (debug_info_level
== DINFO_LEVEL_VERBOSE
)
1118 (*debug_hooks
->undef
) (lineno
, text
);
1125 if (getc (finput
) == 'i'
1126 && getc (finput
) == 'n'
1127 && getc (finput
) == 'e'
1128 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1133 if (getc (finput
) == 'd'
1134 && getc (finput
) == 'e'
1135 && getc (finput
) == 'n'
1136 && getc (finput
) == 't'
1137 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1139 /* #ident. The pedantic warning is now in cpp. */
1141 /* Here we have just seen `#ident '.
1142 A string constant should follow. */
1144 while (c
== ' ' || c
== '\t')
1147 /* If no argument, ignore the line. */
1148 if (c
== '\n' || c
== EOF
)
1151 c
= ffelex_cfelex_ (&token
, finput
, c
);
1154 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1156 error ("invalid #ident");
1160 if (! flag_no_ident
)
1162 #ifdef ASM_OUTPUT_IDENT
1163 ASM_OUTPUT_IDENT (asm_out_file
,
1164 ffelex_token_text (token
));
1168 /* Skip the rest of this line. */
1173 error ("undefined or invalid # directive");
1178 /* Here we have either `#line' or `# <nonletter>'.
1179 In either case, it should be a line number; a digit should follow. */
1181 while (c
== ' ' || c
== '\t')
1182 c
= ffelex_getc_ (finput
);
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
)
1189 /* Something follows the #; read a token. */
1191 c
= ffelex_cfelex_ (&token
, finput
, c
);
1194 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1196 int old_lineno
= lineno
;
1197 const char *old_input_filename
= input_filename
;
1200 /* subtract one, because it is the following line that
1201 gets the specified number */
1202 int l
= atoi (ffelex_token_text (token
)) - 1;
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
)
1209 /* No more: store the line number and check following line. */
1211 if (!ffelex_kludge_flag_
)
1213 ffewhere_file_set (NULL
, TRUE
, (ffewhereLineNumber
) l
);
1216 ffelex_token_kill (token
);
1221 /* More follows: it must be a string constant (filename). */
1223 /* Read the string constant. */
1224 c
= ffelex_cfelex_ (&token
, finput
, c
);
1227 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1229 error ("invalid #line");
1235 if (ffelex_kludge_flag_
)
1236 input_filename
= ggc_strdup (ffelex_token_text (token
));
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
);
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;
1251 if (main_input_filename
== 0)
1252 main_input_filename
= input_filename
;
1254 /* Is this the last nonwhite stuff on the line? */
1255 while (c
== ' ' || c
== '\t')
1257 if (c
== '\n' || c
== EOF
)
1259 if (!ffelex_kludge_flag_
)
1261 /* Update the name in the top element of input_file_stack. */
1262 if (input_file_stack
)
1263 input_file_stack
->name
= input_filename
;
1266 ffelex_token_kill (token
);
1271 c
= ffelex_cfelex_ (&token
, finput
, c
);
1273 /* `1' after file name means entering new file.
1274 `2' after file name means just left a file. */
1277 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1279 int num
= atoi (ffelex_token_text (token
));
1281 if (ffelex_kludge_flag_
)
1284 input_filename
= old_input_filename
;
1285 error ("use `#line ...' instead of `# ...' in first line");
1290 /* Pushing to a new file. */
1291 ffelex_file_push_ (old_lineno
, input_filename
);
1295 /* Popping out of a file. */
1296 ffelex_file_pop_ (input_filename
);
1299 /* Is this the last nonwhite stuff on the line? */
1300 while (c
== ' ' || c
== '\t')
1302 if (c
== '\n' || c
== EOF
)
1305 ffelex_token_kill (token
);
1309 c
= ffelex_cfelex_ (&token
, finput
, c
);
1312 /* `3' after file name means this is a system header file. */
1314 #if 0 /* Not sure what g77 should do with this yet. */
1316 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
)
1317 && (atoi (ffelex_token_text (token
)) == 3))
1318 in_system_header
= 1;
1321 while (c
== ' ' || c
== '\t')
1323 if (((token
!= NULL
)
1324 || (c
!= '\n' && c
!= EOF
))
1325 && ffelex_kludge_flag_
)
1328 input_filename
= old_input_filename
;
1329 error ("use `#line ...' instead of `# ...' in first line");
1331 if (c
== '\n' || c
== EOF
)
1333 if (token
!= NULL
&& !ffelex_kludge_flag_
)
1334 ffelex_token_kill (token
);
1339 error ("invalid #-line");
1341 /* skip the rest of this line. */
1343 if ((token
!= NULL
) && !ffelex_kludge_flag_
)
1344 ffelex_token_kill (token
);
1345 while ((c
= getc (finput
)) != EOF
&& c
!= '\n')
1350 /* "Image" a character onto the card image, return incremented column number.
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;
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
1361 Carriage returns are ignored, as they are assumed to be followed
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.
1372 Columns are numbered and tab stops set as illustrated below:
1374 012345670123456701234567...
1378 xxxxxxx yyyyyyy zzzzzzz
1379 xxxxxxxx yyyyyyyy... */
1381 static ffewhereColumnNumber
1382 ffelex_image_char_ (int c
, ffewhereColumnNumber column
)
1384 ffewhereColumnNumber old_column
= column
;
1386 if (column
>= ffelex_card_size_
)
1388 ffewhereColumnNumber newmax
= ffelex_card_size_
<< 1;
1390 if (ffelex_bad_line_
)
1393 if ((newmax
>> 1) != ffelex_card_size_
)
1394 { /* Overflowed column number. */
1395 overflow
: /* :::::::::::::::::::: */
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);
1406 = malloc_resize_ksr (malloc_pool_image (),
1409 ffelex_card_size_
+ 9);
1410 ffelex_card_size_
= newmax
;
1419 ffelex_saw_tab_
= TRUE
;
1420 ffelex_card_image_
[column
++] = ' ';
1421 while ((column
& 7) != 0)
1422 ffelex_card_image_
[column
++] = ' ';
1426 if (!ffelex_bad_line_
)
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);
1441 ffelex_card_image_
[column
++] = c
;
1445 if (column
< old_column
)
1447 column
= old_column
;
1448 goto overflow
; /* :::::::::::::::::::: */
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
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
;
1476 if (card_length
!= 0)
1478 card_image
= malloc_new_ks (malloc_pool_image (),
1479 "FFELEX saved card image",
1481 memcpy (card_image
, ffelex_card_image_
, card_length
);
1486 ffelex_set_include_
= FALSE
;
1488 ffelex_next_line_ ();
1490 ffewhere_file_set (include_wherefile
, TRUE
, 0);
1492 ffelex_file_push_ (old_lineno
, ffewhere_file_name (include_wherefile
));
1494 if (ffelex_include_free_form_
)
1495 ffelex_file_free (include_wherefile
, include_file
);
1497 ffelex_file_fixed (include_wherefile
, include_file
);
1499 ffelex_file_pop_ (ffewhere_file_name (current_wf
));
1501 ffewhere_file_set (current_wf
, TRUE
, linecount_offset
);
1503 ffecom_close_include (include_file
);
1505 if (card_length
!= 0)
1507 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1508 #error "need to handle possible reduction of card size here!!"
1510 assert (ffelex_card_size_
>= card_length
); /* It shrunk?? */
1511 memcpy (ffelex_card_image_
, card_image
, card_length
);
1513 ffelex_card_image_
[card_length
] = '\0';
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
;
1527 /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation?
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.
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. */
1538 ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
)
1540 while (ffelex_card_image_
[col
] != '\0')
1542 if (ffelex_card_image_
[col
++] != ' ')
1548 /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation?
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.
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. */
1559 ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
)
1561 while ((ffelex_card_image_
[col
] != '\0') && (ffelex_card_image_
[col
] != '!'))
1563 if (ffelex_card_image_
[col
++] != ' ')
1570 ffelex_next_line_ ()
1572 ffelex_linecount_current_
= ffelex_linecount_next_
;
1573 ++ffelex_linecount_next_
;
1578 ffelex_send_token_ ()
1580 ++ffelex_number_of_tokens_
;
1582 ffelex_backslash_ (EOF
, 0);
1584 if (ffelex_token_
->text
== NULL
)
1586 if (ffelex_token_
->type
== FFELEX_typeCHARACTER
)
1588 ffelex_append_to_token_ ('\0');
1589 ffelex_token_
->length
= 0;
1593 ffelex_token_
->text
[ffelex_token_
->length
] = '\0';
1595 assert (ffelex_raw_mode_
== 0);
1597 if (ffelex_token_
->type
== FFELEX_typeNAMES
)
1599 ffewhere_line_kill (ffelex_token_
->currentnames_line
);
1600 ffewhere_column_kill (ffelex_token_
->currentnames_col
);
1603 assert (ffelex_handler_
!= NULL
);
1604 ffelex_handler_
= (ffelexHandler
) (*ffelex_handler_
) (ffelex_token_
);
1605 assert (ffelex_handler_
!= NULL
);
1607 ffelex_token_kill (ffelex_token_
);
1609 ffelex_token_
= ffelex_token_new_ ();
1610 ffelex_token_
->uses
= 1;
1611 ffelex_token_
->text
= NULL
;
1612 if (ffelex_raw_mode_
< 0)
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 ();
1622 ffelex_token_
->type
= FFELEX_typeNONE
;
1623 ffelex_token_
->where_line
= ffewhere_line_unknown ();
1624 ffelex_token_
->where_col
= ffewhere_column_unknown ();
1627 if (ffelex_set_include_
)
1631 /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me
1633 return ffelex_swallow_tokens_;
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
1639 static ffelexHandler
1640 ffelex_swallow_tokens_ (ffelexToken t
)
1642 assert (ffelex_eos_handler_
!= NULL
);
1644 if ((ffelex_token_type (t
) == FFELEX_typeEOS
)
1645 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
))
1646 return (ffelexHandler
) (*ffelex_eos_handler_
) (t
);
1648 return (ffelexHandler
) ffelex_swallow_tokens_
;
1652 ffelex_token_new_ ()
1656 ++ffelex_total_tokens_
;
1658 t
= (ffelexToken
) malloc_new_ks (malloc_pool_image (),
1659 "FFELEX token", sizeof (*t
));
1660 t
->id_
= ffelex_token_nextid_
++;
1665 ffelex_type_string_ (ffelexType type
)
1667 static const char *const types
[] = {
1669 "FFELEX_typeCOMMENT",
1675 "FFELEX_typeDOLLAR",
1677 "FFELEX_typePERCENT",
1678 "FFELEX_typeAMPERSAND",
1679 "FFELEX_typeAPOSTROPHE",
1680 "FFELEX_typeOPEN_PAREN",
1681 "FFELEX_typeCLOSE_PAREN",
1682 "FFELEX_typeASTERISK",
1685 "FFELEX_typePERIOD",
1687 "FFELEX_typeNUMBER",
1688 "FFELEX_typeOPEN_ANGLE",
1689 "FFELEX_typeEQUALS",
1690 "FFELEX_typeCLOSE_ANGLE",
1694 "FFELEX_typeCONCAT",
1697 "FFELEX_typeHOLLERITH",
1698 "FFELEX_typeCHARACTER",
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",
1713 if (type
>= ARRAY_SIZE (types
))
1719 ffelex_display_token (ffelexToken t
)
1724 fprintf (dmpout
, "; Token #%lu is %s (line %" ffewhereLineNumber_f
"u, col %"
1725 ffewhereColumnNumber_f
"u)",
1727 ffelex_type_string_ (t
->type
),
1728 ffewhere_line_number (t
->where_line
),
1729 ffewhere_column_number (t
->where_col
));
1731 if (t
->text
!= NULL
)
1732 fprintf (dmpout
, ": \"%.*s\"\n",
1736 fprintf (dmpout
, ".\n");
1739 /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER
1741 if (ffelex_expecting_character())
1742 // next token delivered by lexer will be CHARACTER.
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
1750 ffelex_expecting_character ()
1752 return (ffelex_raw_mode_
!= 0);
1755 /* ffelex_file_fixed -- Lex a given file in fixed source form
1759 ffelex_file_fixed(wf,f);
1761 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
1764 ffelex_file_fixed (ffewhereFile wf
, FILE *f
)
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
1773 ffewhereColumnNumber first_label_char
; /* First char of label --
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
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. */
1788 assert (ffelex_handler_
!= NULL
);
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';
1802 goto first_line
; /* :::::::::::::::::::: */
1804 /* Come here to get a new line. */
1806 beginning_of_line
: /* :::::::::::::::::::: */
1808 disallow_continuation_line
= FALSE
;
1810 /* Come here directly when last line didn't clarify the continuation issue. */
1812 beginning_of_line_again
: /* :::::::::::::::::::: */
1814 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1815 if (ffelex_card_size_
!= FFELEX_columnINITIAL_SIZE_
)
1818 = malloc_resize_ks (malloc_pool_image (),
1820 FFELEX_columnINITIAL_SIZE_
+ 9,
1821 ffelex_card_size_
+ 9);
1822 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
1826 first_line
: /* :::::::::::::::::::: */
1828 c
= latest_char_in_file
;
1829 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
1832 end_of_file
: /* :::::::::::::::::::: */
1834 /* Line ending in EOF instead of \n still counts as a whole line. */
1836 ffelex_finish_statement_ ();
1837 ffewhere_line_kill (ffelex_current_wl_
);
1838 ffewhere_column_kill (ffelex_current_wc_
);
1839 return (ffelexHandler
) ffelex_handler_
;
1842 ffelex_next_line_ ();
1844 ffelex_bad_line_
= FALSE
;
1846 /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1848 while (((lextype
= ffelex_first_char_
[c
]) == FFELEX_typeCOMMENT
)
1849 || (lextype
== FFELEX_typeERROR
)
1850 || (lextype
== FFELEX_typeSLASH
)
1851 || (lextype
== FFELEX_typeHASH
))
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. */
1858 /* Typical case (straight comment), just ignore rest of line. */
1859 comment_line
: /* :::::::::::::::::::: */
1861 while ((c
!= '\n') && (c
!= EOF
))
1864 else if (lextype
== FFELEX_typeHASH
)
1865 c
= ffelex_hash_ (f
);
1866 else if (lextype
== FFELEX_typeSLASH
)
1868 /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1869 ffelex_card_image_
[0] = '/';
1870 ffelex_card_image_
[1] = c
;
1872 goto bad_first_character
; /* :::::::::::::::::::: */
1875 /* typeERROR or unsupported typeHASH. */
1876 { /* Bad first character, get line and display
1878 column
= ffelex_image_char_ (c
, 0);
1880 bad_first_character
: /* :::::::::::::::::::: */
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);
1891 /* Read past last char in line. */
1895 ffelex_next_line_ ();
1896 goto end_of_file
; /* :::::::::::::::::::: */
1901 ffelex_next_line_ ();
1904 goto end_of_file
; /* :::::::::::::::::::: */
1906 ffelex_bad_line_
= FALSE
;
1907 } /* while [c, first char, means comment] */
1911 || (ffelex_final_nontab_column_
== 0);
1913 if (lextype
== FFELEX_typeDEBUG
)
1914 c
= ' '; /* A 'D' or 'd' in column 1 with the
1915 debug-lines option on. */
1917 column
= ffelex_image_char_ (c
, 0);
1919 /* Read the entire line in as is (with whitespace processing). */
1921 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
1922 column
= ffelex_image_char_ (c
, column
);
1924 if (ffelex_bad_line_
)
1926 ffelex_card_image_
[column
] = '\0';
1927 ffelex_card_length_
= column
;
1928 goto comment_line
; /* :::::::::::::::::::: */
1931 /* If no tab, cut off line after column 72/132. */
1933 if (!ffelex_saw_tab_
&& (column
> ffelex_final_nontab_column_
))
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
1945 column
= ffelex_final_nontab_column_
;
1948 ffelex_card_image_
[column
] = '\0';
1949 ffelex_card_length_
= column
;
1951 /* Save next char in file so we can use register-based c while analyzing
1952 line we just read. */
1954 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
1956 have_content
= FALSE
;
1958 /* Handle label, if any. */
1961 first_label_char
= FFEWHERE_columnUNKNOWN
;
1962 for (column
= 0; column
< 5; ++column
)
1964 switch (c
= ffelex_card_image_
[column
])
1968 goto stop_looking
; /* :::::::::::::::::::: */
1983 label_string
[labi
++] = c
;
1984 if (first_label_char
== FFEWHERE_columnUNKNOWN
)
1985 first_label_char
= column
+ 1;
1991 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
1992 ffelex_linecount_current_
,
1994 goto beginning_of_line_again
; /* :::::::::::::::::::: */
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
; /* :::::::::::::::::::: */
2004 if (ffelex_card_image_
[column
+ 1] == '*')
2005 goto stop_looking
; /* :::::::::::::::::::: */
2008 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2009 ffelex_linecount_current_
, column
+ 1);
2010 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2014 stop_looking
: /* :::::::::::::::::::: */
2016 label_string
[labi
] = '\0';
2018 /* Find first nonblank char starting with continuation column. */
2020 if (column
== 5) /* In which case we didn't see end of line in
2022 while ((c
= ffelex_card_image_
[column
]) == ' ')
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
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.
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:
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
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.
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.
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. */
2061 finish_statement
= FALSE
;
2062 just_do_label
= FALSE
;
2066 case '!': /* ANSI Fortran 90 says ! in column 6 is
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
; /* :::::::::::::::::::: */
2074 if (ffelex_card_image_
[column
+ 1] != '*')
2075 goto some_other_character
; /* :::::::::::::::::::: */
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 '*'. */
2083 goto got_a_continuation
;/* :::::::::::::::::::: */
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. */
2091 no_tokens_on_line
: /* :::::::::::::::::::: */
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
2099 finish_statement
= TRUE
;
2100 have_content
= TRUE
;
2101 just_do_label
= TRUE
;
2104 goto beginning_of_line_again
; /* :::::::::::::::::::: */
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
; /* :::::::::::::::::::: */
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
: /* :::::::::::::::::::: */
2127 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2129 ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION
,
2130 ffelex_linecount_current_
,
2132 ffelex_linecount_current_
,
2134 first_label_char
= FFEWHERE_columnUNKNOWN
;
2136 if (disallow_continuation_line
)
2138 if (!ignore_disallowed_continuation
)
2139 ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION
,
2140 ffelex_linecount_current_
, column
+ 1);
2141 goto beginning_of_line_again
; /* :::::::::::::::::::: */
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_
))
2151 have_content
= TRUE
;
2155 check_for_content
: /* :::::::::::::::::::: */
2157 while ((c
= ffelex_card_image_
[++column
]) == ' ')
2162 && (ffelex_card_image_
[column
+ 1] == '*')))
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
;
2170 have_content
= TRUE
;
2175 some_other_character
: /* :::::::::::::::::::: */
2178 goto got_a_continuation
;/* :::::::::::::::::::: */
2180 /* Here is the very normal case of a regular character starting in
2181 column 7 or beyond with a blank in column 6. */
2183 finish_statement
= TRUE
;
2184 have_content
= TRUE
;
2189 || (first_label_char
!= FFEWHERE_columnUNKNOWN
))
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. */
2198 if (finish_statement
)
2199 ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
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);
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. */
2213 if (finish_statement
)
2214 ffelex_finish_statement_ ();
2216 /* If label is present, enclose it in a NUMBER token and send it along. */
2218 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
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_
;
2233 goto beginning_of_line
; /* :::::::::::::::::::: */
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. */
2245 if (ffelex_raw_mode_
!= 0)
2248 parse_raw_character
: /* :::::::::::::::::::: */
2252 ffewhereColumnNumber i
;
2254 if (ffelex_saw_tab_
|| (column
>= ffelex_final_nontab_column_
))
2255 goto beginning_of_line
; /* :::::::::::::::::::: */
2257 /* Pad out line with "virtual" spaces. */
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
;
2266 switch (ffelex_raw_mode_
)
2269 c
= ffelex_backslash_ (c
, column
);
2273 if (!ffelex_backslash_reconsider_
)
2274 ffelex_append_to_token_ (c
);
2275 ffelex_raw_mode_
= -1;
2279 if (c
== ffelex_raw_char_
)
2281 ffelex_raw_mode_
= -1;
2282 ffelex_append_to_token_ (c
);
2286 ffelex_raw_mode_
= 0;
2287 ffelex_backslash_reconsider_
= TRUE
;
2292 if (c
== ffelex_raw_char_
)
2293 ffelex_raw_mode_
= -2;
2296 c
= ffelex_backslash_ (c
, column
);
2299 ffelex_raw_mode_
= -3;
2303 ffelex_append_to_token_ (c
);
2308 c
= ffelex_backslash_ (c
, column
);
2312 if (!ffelex_backslash_reconsider_
)
2314 ffelex_append_to_token_ (c
);
2320 if (ffelex_backslash_reconsider_
)
2321 ffelex_backslash_reconsider_
= FALSE
;
2323 c
= ffelex_card_image_
[++column
];
2325 if (ffelex_raw_mode_
== 0)
2327 ffelex_send_token_ ();
2328 assert (ffelex_raw_mode_
== 0);
2330 c
= ffelex_card_image_
[++column
];
2334 && (ffelex_card_image_
[column
+ 1] == '*')))
2335 goto beginning_of_line
; /* :::::::::::::::::::: */
2336 goto parse_nonraw_character
; /* :::::::::::::::::::: */
2338 goto parse_raw_character
; /* :::::::::::::::::::: */
2341 parse_nonraw_character
: /* :::::::::::::::::::: */
2343 switch (ffelex_token_
->type
)
2345 case FFELEX_typeNONE
:
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_ ();
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_ ();
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_ ();
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_ ();
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_ ();
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);
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_ ();
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);
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_ ();
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_ ();
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_ ();
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_ ();
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);
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
);
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);
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
;
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);
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);
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);
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_ ();
2494 if (1 || ffe_is_90 ())
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_ ();
2557 c
= ffesrc_char_source (c
);
2559 if (ffesrc_char_match_init (c
, 'H', 'h')
2560 && ffelex_expecting_hollerith_
!= 0)
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
; /* :::::::::::::::::::: */
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
;
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
;
2589 ffelex_append_to_token_ (c
);
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
; /* :::::::::::::::::::: */
2602 case FFELEX_typeNAME
:
2657 c
= ffesrc_char_source (c
);
2672 && !ffe_is_dollar_ok ())
2674 ffelex_send_token_ ();
2675 goto parse_next_character
; /* :::::::::::::::::::: */
2677 ffelex_append_to_token_ (c
);
2681 ffelex_send_token_ ();
2682 goto parse_next_character
; /* :::::::::::::::::::: */
2686 case FFELEX_typeNAMES
:
2741 c
= ffesrc_char_source (c
);
2756 && !ffe_is_dollar_ok ())
2758 ffelex_send_token_ ();
2759 goto parse_next_character
; /* :::::::::::::::::::: */
2761 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
2763 ffewhere_track (&ffelex_token_
->currentnames_line
,
2764 &ffelex_token_
->currentnames_col
,
2765 ffelex_token_
->wheretrack
,
2766 ffelex_token_
->length
,
2767 ffelex_linecount_current_
,
2770 ffelex_append_to_token_ (c
);
2774 ffelex_send_token_ ();
2775 goto parse_next_character
; /* :::::::::::::::::::: */
2779 case FFELEX_typeNUMBER
:
2792 ffelex_append_to_token_ (c
);
2796 ffelex_send_token_ ();
2797 goto parse_next_character
; /* :::::::::::::::::::: */
2801 case FFELEX_typeASTERISK
:
2805 ffelex_token_
->type
= FFELEX_typePOWER
;
2806 ffelex_send_token_ ();
2809 default: /* * not followed by another *. */
2810 ffelex_send_token_ ();
2811 goto parse_next_character
; /* :::::::::::::::::::: */
2815 case FFELEX_typeCOLON
:
2819 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
2820 ffelex_send_token_ ();
2823 default: /* : not followed by another :. */
2824 ffelex_send_token_ ();
2825 goto parse_next_character
; /* :::::::::::::::::::: */
2829 case FFELEX_typeSLASH
:
2833 ffelex_token_
->type
= FFELEX_typeCONCAT
;
2834 ffelex_send_token_ ();
2838 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
2839 ffelex_send_token_ ();
2843 ffelex_token_
->type
= FFELEX_typeREL_NE
;
2844 ffelex_send_token_ ();
2848 ffelex_send_token_ ();
2849 goto parse_next_character
; /* :::::::::::::::::::: */
2853 case FFELEX_typeOPEN_PAREN
:
2857 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
2858 ffelex_send_token_ ();
2862 ffelex_send_token_ ();
2863 goto parse_next_character
; /* :::::::::::::::::::: */
2867 case FFELEX_typeOPEN_ANGLE
:
2871 ffelex_token_
->type
= FFELEX_typeREL_LE
;
2872 ffelex_send_token_ ();
2876 ffelex_send_token_ ();
2877 goto parse_next_character
; /* :::::::::::::::::::: */
2881 case FFELEX_typeEQUALS
:
2885 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
2886 ffelex_send_token_ ();
2890 ffelex_token_
->type
= FFELEX_typePOINTS
;
2891 ffelex_send_token_ ();
2895 ffelex_send_token_ ();
2896 goto parse_next_character
; /* :::::::::::::::::::: */
2900 case FFELEX_typeCLOSE_ANGLE
:
2904 ffelex_token_
->type
= FFELEX_typeREL_GE
;
2905 ffelex_send_token_ ();
2909 ffelex_send_token_ ();
2910 goto parse_next_character
; /* :::::::::::::::::::: */
2915 assert ("Serious error!!" == NULL
);
2920 c
= ffelex_card_image_
[++column
];
2922 parse_next_character
: /* :::::::::::::::::::: */
2924 if (ffelex_raw_mode_
!= 0)
2925 goto parse_raw_character
; /* :::::::::::::::::::: */
2928 c
= ffelex_card_image_
[++column
];
2933 && (ffelex_card_image_
[column
+ 1] == '*')))
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",
2944 ffelex_finish_statement_ ();
2945 disallow_continuation_line
= TRUE
;
2946 ignore_disallowed_continuation
= FALSE
;
2947 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2949 goto beginning_of_line
; /* :::::::::::::::::::: */
2951 goto parse_nonraw_character
; /* :::::::::::::::::::: */
2954 /* ffelex_file_free -- Lex a given file in free source form
2958 ffelex_file_free(wf,f);
2960 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
2963 ffelex_file_free (ffewhereFile wf
, FILE *f
)
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
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. */
2978 assert (ffelex_handler_
!= NULL
);
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';
2990 /* Come here to get a new line. */
2992 beginning_of_line
: /* :::::::::::::::::::: */
2994 c
= latest_char_in_file
;
2995 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
2998 end_of_file
: /* :::::::::::::::::::: */
3000 /* Line ending in EOF instead of \n still counts as a whole line. */
3002 ffelex_finish_statement_ ();
3003 ffewhere_line_kill (ffelex_current_wl_
);
3004 ffewhere_column_kill (ffelex_current_wc_
);
3005 return (ffelexHandler
) ffelex_handler_
;
3008 ffelex_next_line_ ();
3010 ffelex_bad_line_
= FALSE
;
3012 /* Skip over initial-comment and empty lines as quickly as possible! */
3019 c
= ffelex_hash_ (f
);
3021 comment_line
: /* :::::::::::::::::::: */
3023 while ((c
!= '\n') && (c
!= EOF
))
3028 ffelex_next_line_ ();
3029 goto end_of_file
; /* :::::::::::::::::::: */
3034 ffelex_next_line_ ();
3037 goto end_of_file
; /* :::::::::::::::::::: */
3040 ffelex_saw_tab_
= FALSE
;
3042 column
= ffelex_image_char_ (c
, 0);
3044 /* Read the entire line in as is (with whitespace processing). */
3046 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
3047 column
= ffelex_image_char_ (c
, column
);
3049 if (ffelex_bad_line_
)
3051 ffelex_card_image_
[column
] = '\0';
3052 ffelex_card_length_
= column
;
3053 goto comment_line
; /* :::::::::::::::::::: */
3056 /* If no tab, cut off line after column 132. */
3058 if (!ffelex_saw_tab_
&& (column
> FFELEX_FREE_MAX_COLUMNS_
))
3059 column
= FFELEX_FREE_MAX_COLUMNS_
;
3061 ffelex_card_image_
[column
] = '\0';
3062 ffelex_card_length_
= column
;
3064 /* Save next char in file so we can use register-based c while analyzing
3065 line we just read. */
3067 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
3070 continuation_column
= 0;
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). */
3076 while ((c
= ffelex_card_image_
[column
]) == ' ')
3083 goto beginning_of_line
; /* :::::::::::::::::::: */
3086 continuation_column
= column
+ 1;
3093 /* The line definitely has content of some kind, install new end-statement
3094 point for error messages. */
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);
3101 /* Figure out which column to start parsing at. */
3103 if (continuation_line
)
3105 if (continuation_column
== 0)
3107 if (ffelex_raw_mode_
!= 0)
3109 ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE
,
3110 ffelex_linecount_current_
, column
+ 1);
3112 else if (ffelex_token_
->type
!= FFELEX_typeNONE
)
3114 ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE
,
3115 ffelex_linecount_current_
, column
+ 1);
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
; /* :::::::::::::::::::: */
3125 column
= continuation_column
;
3130 c
= ffelex_card_image_
[column
];
3131 continuation_line
= FALSE
;
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_. */
3139 if (ffelex_raw_mode_
!= 0)
3142 parse_raw_character
: /* :::::::::::::::::::: */
3147 if (ffelex_is_free_char_ctx_contin_ (column
+ 1))
3149 continuation_line
= TRUE
;
3150 goto beginning_of_line
; /* :::::::::::::::::::: */
3155 ffelex_finish_statement_ ();
3156 goto beginning_of_line
; /* :::::::::::::::::::: */
3162 switch (ffelex_raw_mode_
)
3165 c
= ffelex_backslash_ (c
, column
);
3169 if (!ffelex_backslash_reconsider_
)
3170 ffelex_append_to_token_ (c
);
3171 ffelex_raw_mode_
= -1;
3175 if (c
== ffelex_raw_char_
)
3177 ffelex_raw_mode_
= -1;
3178 ffelex_append_to_token_ (c
);
3182 ffelex_raw_mode_
= 0;
3183 ffelex_backslash_reconsider_
= TRUE
;
3188 if (c
== ffelex_raw_char_
)
3189 ffelex_raw_mode_
= -2;
3192 c
= ffelex_backslash_ (c
, column
);
3195 ffelex_raw_mode_
= -3;
3199 ffelex_append_to_token_ (c
);
3204 c
= ffelex_backslash_ (c
, column
);
3208 if (!ffelex_backslash_reconsider_
)
3210 ffelex_append_to_token_ (c
);
3216 if (ffelex_backslash_reconsider_
)
3217 ffelex_backslash_reconsider_
= FALSE
;
3219 c
= ffelex_card_image_
[++column
];
3221 if (ffelex_raw_mode_
== 0)
3223 ffelex_send_token_ ();
3224 assert (ffelex_raw_mode_
== 0);
3226 c
= ffelex_card_image_
[++column
];
3227 if ((c
== '\0') || (c
== '!'))
3229 ffelex_finish_statement_ ();
3230 goto beginning_of_line
; /* :::::::::::::::::::: */
3232 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3234 continuation_line
= TRUE
;
3235 goto beginning_of_line
; /* :::::::::::::::::::: */
3237 goto parse_nonraw_character_noncontin
; /* :::::::::::::::::::: */
3239 goto parse_raw_character
; /* :::::::::::::::::::: */
3242 parse_nonraw_character
: /* :::::::::::::::::::: */
3244 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3246 continuation_line
= TRUE
;
3247 goto beginning_of_line
; /* :::::::::::::::::::: */
3250 parse_nonraw_character_noncontin
: /* :::::::::::::::::::: */
3252 switch (ffelex_token_
->type
)
3254 case FFELEX_typeNONE
:
3257 finish-statement/continue-statement
3260 c
= ffelex_card_image_
[++column
];
3261 if ((c
== '\0') || (c
== '!'))
3263 ffelex_finish_statement_ ();
3264 goto beginning_of_line
; /* :::::::::::::::::::: */
3266 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3268 continuation_line
= TRUE
;
3269 goto beginning_of_line
; /* :::::::::::::::::::: */
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_ ();
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_ ();
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_ ();
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_ ();
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_ ();
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);
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_ ();
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);
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_ ();
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_ ();
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_ ();
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_ ();
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);
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
);
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);
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
;
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);
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);
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);
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_ ();
3421 if (1 || ffe_is_90 ())
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_ ();
3484 c
= ffesrc_char_source (c
);
3486 if (ffesrc_char_match_init (c
, 'H', 'h')
3487 && ffelex_expecting_hollerith_
!= 0)
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
; /* :::::::::::::::::::: */
3499 if (ffelex_names_pure_
)
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
;
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
;
3516 ffelex_append_to_token_ (c
);
3520 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
3521 ffelex_linecount_current_
, column
+ 1);
3522 ffelex_finish_statement_ ();
3523 goto beginning_of_line
; /* :::::::::::::::::::: */
3527 case FFELEX_typeNAME
:
3582 c
= ffesrc_char_source (c
);
3597 && !ffe_is_dollar_ok ())
3599 ffelex_send_token_ ();
3600 goto parse_next_character
; /* :::::::::::::::::::: */
3602 ffelex_append_to_token_ (c
);
3606 ffelex_send_token_ ();
3607 goto parse_next_character
; /* :::::::::::::::::::: */
3611 case FFELEX_typeNAMES
:
3666 c
= ffesrc_char_source (c
);
3681 && !ffe_is_dollar_ok ())
3683 ffelex_send_token_ ();
3684 goto parse_next_character
; /* :::::::::::::::::::: */
3686 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
3688 ffewhere_track (&ffelex_token_
->currentnames_line
,
3689 &ffelex_token_
->currentnames_col
,
3690 ffelex_token_
->wheretrack
,
3691 ffelex_token_
->length
,
3692 ffelex_linecount_current_
,
3695 ffelex_append_to_token_ (c
);
3699 ffelex_send_token_ ();
3700 goto parse_next_character
; /* :::::::::::::::::::: */
3704 case FFELEX_typeNUMBER
:
3717 ffelex_append_to_token_ (c
);
3721 ffelex_send_token_ ();
3722 goto parse_next_character
; /* :::::::::::::::::::: */
3726 case FFELEX_typeASTERISK
:
3730 ffelex_token_
->type
= FFELEX_typePOWER
;
3731 ffelex_send_token_ ();
3734 default: /* * not followed by another *. */
3735 ffelex_send_token_ ();
3736 goto parse_next_character
; /* :::::::::::::::::::: */
3740 case FFELEX_typeCOLON
:
3744 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
3745 ffelex_send_token_ ();
3748 default: /* : not followed by another :. */
3749 ffelex_send_token_ ();
3750 goto parse_next_character
; /* :::::::::::::::::::: */
3754 case FFELEX_typeSLASH
:
3758 ffelex_token_
->type
= FFELEX_typeCONCAT
;
3759 ffelex_send_token_ ();
3763 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
3764 ffelex_send_token_ ();
3768 ffelex_token_
->type
= FFELEX_typeREL_NE
;
3769 ffelex_send_token_ ();
3773 ffelex_send_token_ ();
3774 goto parse_next_character
; /* :::::::::::::::::::: */
3778 case FFELEX_typeOPEN_PAREN
:
3782 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
3783 ffelex_send_token_ ();
3787 ffelex_send_token_ ();
3788 goto parse_next_character
; /* :::::::::::::::::::: */
3792 case FFELEX_typeOPEN_ANGLE
:
3796 ffelex_token_
->type
= FFELEX_typeREL_LE
;
3797 ffelex_send_token_ ();
3801 ffelex_send_token_ ();
3802 goto parse_next_character
; /* :::::::::::::::::::: */
3806 case FFELEX_typeEQUALS
:
3810 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
3811 ffelex_send_token_ ();
3815 ffelex_token_
->type
= FFELEX_typePOINTS
;
3816 ffelex_send_token_ ();
3820 ffelex_send_token_ ();
3821 goto parse_next_character
; /* :::::::::::::::::::: */
3825 case FFELEX_typeCLOSE_ANGLE
:
3829 ffelex_token_
->type
= FFELEX_typeREL_GE
;
3830 ffelex_send_token_ ();
3834 ffelex_send_token_ ();
3835 goto parse_next_character
; /* :::::::::::::::::::: */
3840 assert ("Serious error!" == NULL
);
3845 c
= ffelex_card_image_
[++column
];
3847 parse_next_character
: /* :::::::::::::::::::: */
3849 if (ffelex_raw_mode_
!= 0)
3850 goto parse_raw_character
; /* :::::::::::::::::::: */
3852 if ((c
== '\0') || (c
== '!'))
3854 ffelex_finish_statement_ ();
3855 goto beginning_of_line
; /* :::::::::::::::::::: */
3857 goto parse_nonraw_character
; /* :::::::::::::::::::: */
3860 /* See the code in com.c that calls this to understand why. */
3863 ffelex_hash_kludge (FILE *finput
)
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];
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
3879 for (p
= &match
[0], q
= &kludge
[0], c
= getc (finput
);
3880 (c
== *p
) && (*p
!= '\0') && (c
!= EOF
);
3881 ++p
, ++q
, c
= getc (finput
))
3884 *q
= c
; /* Might be EOF, which requires int. */
3887 ffelex_kludge_chars_
= &kludge
[0];
3891 ffelex_kludge_flag_
= TRUE
;
3892 ++ffelex_kludge_chars_
;
3893 ffelex_hash_ (finput
); /* Handle it NOW rather than later. */
3894 ffelex_kludge_flag_
= FALSE
;
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';
3910 for (i
= 0; i
< 256; ++i
)
3911 ffelex_first_char_
[i
] = FFELEX_typeERROR
;
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
;
3925 for (i
= '0'; i
<= '9'; ++i
)
3926 ffelex_first_char_
[i
] = FFELEX_typeRAW
;
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
)))
3934 ffelex_first_char_
['C'] = FFELEX_typeCOMMENT
;
3935 ffelex_first_char_
['D'] = FFELEX_typeCOMMENT
;
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
)))
3943 ffelex_first_char_
['c'] = FFELEX_typeCOMMENT
;
3944 ffelex_first_char_
['d'] = FFELEX_typeCOMMENT
;
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
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 ();
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
;
3967 ffelex_handler_
= NULL
;
3970 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
3972 if (ffelex_is_names_expected())
3973 // Deliver NAMES token
3975 // Deliver NAME token
3977 Must be called while lexer is active, obviously. */
3980 ffelex_is_names_expected ()
3982 return ffelex_names_
;
3985 /* Current card image, which has the master linecount number
3986 ffelex_linecount_current_. */
3991 return ffelex_card_image_
;
3994 /* ffelex_line_length -- Return length of current lexer line
3996 printf("Length is %lu\n",ffelex_line_length());
3998 Must be called while lexer is active, obviously. */
4000 ffewhereColumnNumber
4001 ffelex_line_length ()
4003 return ffelex_card_length_
;
4006 /* Master line count of current card image, or 0 if no card image
4010 ffelex_line_number ()
4012 return ffelex_linecount_current_
;
4015 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4017 ffelex_set_expecting_hollerith(0);
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.
4030 Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4031 character constant. Pass the expected termination character (apostrophe
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).
4039 Pass for which either an apostrophe or quote when passing length of -1.
4040 Else which is a don't-care.
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.
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.
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.
4058 New "which" argument allows caller to specify termination character,
4059 which should be apostrophe or double-quote, to support Fortran 90. */
4062 ffelex_set_expecting_hollerith (long length
, char which
,
4063 ffewhereLine line
, ffewhereColumn column
)
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). */
4070 ffewhere_line_kill (ffelex_raw_where_line_
);
4071 ffewhere_column_kill (ffelex_raw_where_col_
);
4073 /* Now handle the length function. */
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. */
4084 ffelex_raw_mode_
= -1;
4085 ffelex_raw_char_
= which
;
4088 default: /* length > 0 */
4089 ffelex_expecting_hollerith_
= length
;
4093 /* Now set new line/column information from passed args. */
4095 ffelex_raw_where_line_
= ffewhere_line_use (line
);
4096 ffelex_raw_where_col_
= ffewhere_column_use (column
);
4099 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4101 ffelex_set_handler((ffelexHandler) my_first_handler);
4103 Must be called before calling ffelex_file_fixed or ffelex_file_free or
4104 after they return, but not while they are active. */
4107 ffelex_set_handler (ffelexHandler first
)
4109 ffelex_handler_
= first
;
4112 /* ffelex_set_hexnum -- Set hexnum flag
4114 ffelex_set_hexnum(TRUE);
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
4124 ffelex_set_hexnum (bool f
)
4129 /* ffelex_set_include -- Set INCLUDE file to be processed next
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);
4136 Must be called only after receiving the EOS token following a valid
4137 INCLUDE statement specifying a file that has already been successfully
4141 ffelex_set_include (ffewhereFile wf
, bool free_form
, FILE *fi
)
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
;
4151 /* ffelex_set_names -- Set names/name flag, names = TRUE
4153 ffelex_set_names(FALSE);
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
4163 ffelex_set_names (bool f
)
4167 ffelex_names_pure_
= FALSE
;
4170 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4172 ffelex_set_names_pure(FALSE);
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. */
4201 ffelex_set_names_pure (bool f
)
4203 ffelex_names_pure_
= f
;
4207 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4209 return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
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. */
4224 ffelex_splice_tokens (ffelexHandler first
, ffelexToken master
,
4225 ffeTokenLength start
)
4231 p
= ffelex_token_text (master
) + (i
= start
);
4237 t
= ffelex_token_number_from_names (master
, i
);
4238 p
+= ffelex_token_length (t
);
4239 i
+= ffelex_token_length (t
);
4241 else if (ffesrc_is_name_init (*p
))
4243 t
= ffelex_token_name_from_names (master
, i
, 0);
4244 p
+= ffelex_token_length (t
);
4245 i
+= ffelex_token_length (t
);
4249 t
= ffelex_token_dollar_from_names (master
, i
);
4255 t
= ffelex_token_uscore_from_names (master
, i
);
4261 assert ("not a valid NAMES character" == NULL
);
4264 assert (first
!= NULL
);
4265 first
= (ffelexHandler
) (*first
) (t
);
4266 ffelex_token_kill (t
);
4272 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4274 return ffelex_swallow_tokens;
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
4281 ffelex_swallow_tokens (ffelexToken t
, ffelexHandler handler
)
4283 assert (handler
!= NULL
);
4285 if ((t
!= NULL
) && ((ffelex_token_type (t
) == FFELEX_typeEOS
)
4286 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
)))
4287 return (ffelexHandler
) (*handler
) (t
);
4289 ffelex_eos_handler_
= handler
;
4290 return (ffelexHandler
) ffelex_swallow_tokens_
;
4293 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4296 t = ffelex_token_dollar_from_names(t,6);
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. */
4302 ffelex_token_dollar_from_names (ffelexToken t
, ffeTokenLength start
)
4307 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4308 assert (start
< t
->length
);
4309 assert (t
->text
[start
] == '$');
4311 /* Now make the token. */
4313 nt
= ffelex_token_new_ ();
4314 nt
->type
= FFELEX_typeDOLLAR
;
4317 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4318 t
->where_col
, t
->wheretrack
, start
);
4323 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4326 ffelex_token_kill(t);
4328 Complements a call to ffelex_token_use or ffelex_token_new_.... */
4331 ffelex_token_kill (ffelexToken t
)
4335 assert (t
->uses
> 0);
4340 --ffelex_total_tokens_
;
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
));
4352 /* Make a new NAME token that is a substring of a NAMES token. */
4355 ffelex_token_name_from_names (ffelexToken t
, ffeTokenLength start
,
4361 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4362 assert (start
< t
->length
);
4364 len
= t
->length
- start
;
4368 assert ((start
+ len
) <= t
->length
);
4370 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4372 nt
= ffelex_token_new_ ();
4373 nt
->type
= FFELEX_typeNAME
;
4374 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
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",
4382 strncpy (nt
->text
, t
->text
+ start
, len
);
4383 nt
->text
[len
] = '\0';
4387 /* Make a new NAMES token that is a substring of another NAMES token. */
4390 ffelex_token_names_from_names (ffelexToken t
, ffeTokenLength start
,
4396 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4397 assert (start
< t
->length
);
4399 len
= t
->length
- start
;
4403 assert ((start
+ len
) <= t
->length
);
4405 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4407 nt
= ffelex_token_new_ ();
4408 nt
->type
= FFELEX_typeNAMES
;
4409 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
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",
4418 strncpy (nt
->text
, t
->text
+ start
, len
);
4419 nt
->text
[len
] = '\0';
4423 /* Make a new CHARACTER token. */
4426 ffelex_token_new_character (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4430 t
= ffelex_token_new_ ();
4431 t
->type
= FFELEX_typeCHARACTER
;
4432 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4434 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4436 strcpy (t
->text
, s
);
4437 t
->where_line
= ffewhere_line_use (l
);
4438 t
->where_col
= ffewhere_column_new (c
);
4442 /* Make a new EOF token right after end of file. */
4445 ffelex_token_new_eof ()
4449 t
= ffelex_token_new_ ();
4450 t
->type
= FFELEX_typeEOF
;
4453 t
->where_line
= ffewhere_line_new (ffelex_linecount_current_
);
4454 t
->where_col
= ffewhere_column_new (1);
4458 /* Make a new NAME token. */
4461 ffelex_token_new_name (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4465 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4467 t
= ffelex_token_new_ ();
4468 t
->type
= FFELEX_typeNAME
;
4469 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4471 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4473 strcpy (t
->text
, s
);
4474 t
->where_line
= ffewhere_line_use (l
);
4475 t
->where_col
= ffewhere_column_new (c
);
4479 /* Make a new NAMES token. */
4482 ffelex_token_new_names (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4486 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4488 t
= ffelex_token_new_ ();
4489 t
->type
= FFELEX_typeNAMES
;
4490 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4492 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
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
4502 /* Make a new NUMBER token.
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. */
4511 ffelex_token_new_number (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4516 /* How long is the string of decimal digits at s? */
4518 len
= strspn (s
, "0123456789");
4520 /* Make sure there is at least one digit. */
4524 /* Now make the token. */
4526 t
= ffelex_token_new_ ();
4527 t
->type
= FFELEX_typeNUMBER
;
4528 t
->length
= t
->size
= len
; /* Assume it won't get bigger. */
4530 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
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
);
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. */
4543 ffelex_token_new_simple_ (ffelexType type
, ffewhereLine l
, ffewhereColumn c
)
4547 t
= ffelex_token_new_ ();
4551 t
->where_line
= ffewhere_line_use (l
);
4552 t
->where_col
= ffewhere_column_new (c
);
4556 /* Make a new NUMBER token from an existing NAMES token.
4558 Like ffelex_token_new_number, this function calculates the length
4559 of the digit string itself. */
4562 ffelex_token_number_from_names (ffelexToken t
, ffeTokenLength start
)
4568 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4569 assert (start
< t
->length
);
4571 /* How long is the string of decimal digits at s? */
4573 len
= strspn (t
->text
+ start
, "0123456789");
4575 /* Make sure there is at least one digit. */
4579 /* Now make the token. */
4581 nt
= ffelex_token_new_ ();
4582 nt
->type
= FFELEX_typeNUMBER
;
4583 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
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",
4591 strncpy (nt
->text
, t
->text
+ start
, len
);
4592 nt
->text
[len
] = '\0';
4596 /* Make a new UNDERSCORE token from a NAMES token. */
4599 ffelex_token_uscore_from_names (ffelexToken t
, ffeTokenLength start
)
4604 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4605 assert (start
< t
->length
);
4606 assert (t
->text
[start
] == '_');
4608 /* Now make the token. */
4610 nt
= ffelex_token_new_ ();
4611 nt
->type
= FFELEX_typeUNDERSCORE
;
4613 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4614 t
->where_col
, t
->wheretrack
, start
);
4619 /* ffelex_token_use -- Return another instance of a token
4622 t = ffelex_token_use(t);
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.
4627 We use the use count method (easy). */
4630 ffelex_token_use (ffelexToken t
)
4633 assert ("_token_use: null token" == NULL
);
4638 #include "gt-f-lex.h"