1 /* Implementation of Fortran lexer
2 Copyright (C) 1995, 1996, 1997, 1998, 2001 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
36 static void ffelex_append_to_token_ (char c
);
37 static int ffelex_backslash_ (int c
, ffewhereColumnNumber col
);
38 static void ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
,
39 ffewhereColumnNumber cn0
);
40 static void ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
,
41 ffewhereColumnNumber cn0
, ffewhereLineNumber ln1
,
42 ffewhereColumnNumber cn1
);
43 static void ffelex_bad_here_ (int num
, ffewhereLineNumber ln0
,
44 ffewhereColumnNumber cn0
);
45 static void ffelex_finish_statement_ (void);
46 static int ffelex_get_directive_line_ (char **text
, FILE *finput
);
47 static int ffelex_hash_ (FILE *f
);
48 static ffewhereColumnNumber
ffelex_image_char_ (int c
,
49 ffewhereColumnNumber col
);
50 static void ffelex_include_ (void);
51 static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
);
52 static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
);
53 static void ffelex_next_line_ (void);
54 static void ffelex_prepare_eos_ (void);
55 static void ffelex_send_token_ (void);
56 static ffelexHandler
ffelex_swallow_tokens_ (ffelexToken t
);
57 static ffelexToken
ffelex_token_new_ (void);
59 /* Pertaining to the geometry of the input file. */
61 /* Initial size for card image to be allocated. */
62 #define FFELEX_columnINITIAL_SIZE_ 255
64 /* The card image itself, which grows as source lines get longer. It
65 has room for ffelex_card_size_ + 8 characters, and the length of the
66 current image is ffelex_card_length_. (The + 8 characters are made
67 available for easy handling of tabs and such.) */
68 static char *ffelex_card_image_
;
69 static ffewhereColumnNumber ffelex_card_size_
;
70 static ffewhereColumnNumber ffelex_card_length_
;
72 /* Max width for free-form lines (ISO F90). */
73 #define FFELEX_FREE_MAX_COLUMNS_ 132
75 /* True if we saw a tab on the current line, as this (currently) means
76 the line is therefore treated as though final_nontab_column_ were
78 static bool ffelex_saw_tab_
;
80 /* TRUE if current line is known to be erroneous, so don't bother
81 expanding room for it just to display it. */
82 static bool ffelex_bad_line_
= FALSE
;
84 /* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */
85 static ffewhereColumnNumber ffelex_final_nontab_column_
;
87 /* Array for quickly deciding what kind of line the current card has,
88 based on its first character. */
89 static ffelexType ffelex_first_char_
[256];
91 /* Pertaining to file management. */
93 /* The wf argument of the most recent active ffelex_file_(fixed,free)
95 static ffewhereFile ffelex_current_wf_
;
97 /* TRUE if an INCLUDE statement can be processed (ffelex_set_include
99 static bool ffelex_permit_include_
;
101 /* TRUE if an INCLUDE statement is pending (ffelex_set_include has been
103 static bool ffelex_set_include_
;
105 /* Information on the pending INCLUDE file. */
106 static FILE *ffelex_include_file_
;
107 static bool ffelex_include_free_form_
;
108 static ffewhereFile ffelex_include_wherefile_
;
110 /* Current master line count. */
111 static ffewhereLineNumber ffelex_linecount_current_
;
112 /* Next master line count. */
113 static ffewhereLineNumber ffelex_linecount_next_
;
115 /* ffewhere info on the latest (currently active) line read from the
116 active source file. */
117 static ffewhereLine ffelex_current_wl_
;
118 static ffewhereColumn ffelex_current_wc_
;
120 /* Pertaining to tokens in general. */
122 /* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER
124 #define FFELEX_columnTOKEN_SIZE_ 63
125 #if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX
126 #error "token size too small!"
129 /* Current token being lexed. */
130 static ffelexToken ffelex_token_
;
132 /* Handler for current token. */
133 static ffelexHandler ffelex_handler_
;
135 /* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */
136 static bool ffelex_names_
;
138 /* TRUE if both lexers are to generate NAMES instead of NAME tokens. */
139 static bool ffelex_names_pure_
;
141 /* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex
143 static bool ffelex_hexnum_
;
145 /* For ffelex_swallow_tokens(). */
146 static ffelexHandler ffelex_eos_handler_
;
148 /* Number of tokens sent since last EOS or beginning of input file
149 (include INCLUDEd files). */
150 static unsigned long int ffelex_number_of_tokens_
;
152 /* Number of labels sent (as NUMBER tokens) since last reset of
153 ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases.
154 (Fixed-form source only.) */
155 static unsigned long int ffelex_label_tokens_
;
157 /* Metering for token management, to catch token-memory leaks. */
158 static long int ffelex_total_tokens_
= 0;
159 static long int ffelex_old_total_tokens_
= 1;
160 static long int ffelex_token_nextid_
= 0;
162 /* Pertaining to lexing CHARACTER and HOLLERITH tokens. */
164 /* >0 if a Hollerith constant of that length might be in mid-lex, used
165 when the next character seen is 'H' or 'h' to enter HOLLERITH lexing
166 mode (see ffelex_raw_mode_). */
167 static long int ffelex_expecting_hollerith_
;
169 /* -3: Backslash (escape) sequence being lexed in CHARACTER.
170 -2: Possible closing apostrophe/quote seen in CHARACTER.
171 -1: Lexing CHARACTER.
172 0: Not lexing CHARACTER or HOLLERITH.
173 >0: Lexing HOLLERITH, value is # chars remaining to expect. */
174 static long int ffelex_raw_mode_
;
176 /* When lexing CHARACTER, open quote/apostrophe (either ' or "). */
177 static char ffelex_raw_char_
;
179 /* TRUE when backslash processing had to use most recent character
180 to finish its state engine, but that character is not part of
181 the backslash sequence, so must be reconsidered as a "normal"
182 character in CHARACTER/HOLLERITH lexing. */
183 static bool ffelex_backslash_reconsider_
= FALSE
;
185 /* Characters preread before lexing happened (might include EOF). */
186 static int *ffelex_kludge_chars_
= NULL
;
188 /* Doing the kludge processing, so not initialized yet. */
189 static bool ffelex_kludge_flag_
= FALSE
;
191 /* The beginning of a (possible) CHARACTER/HOLLERITH token. */
192 static ffewhereLine ffelex_raw_where_line_
;
193 static ffewhereColumn ffelex_raw_where_col_
;
196 /* Call this to append another character to the current token. If it isn't
197 currently big enough for it, it will be enlarged. The current token
198 must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER. */
201 ffelex_append_to_token_ (char c
)
203 if (ffelex_token_
->text
== NULL
)
206 = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
207 FFELEX_columnTOKEN_SIZE_
+ 1);
208 ffelex_token_
->size
= FFELEX_columnTOKEN_SIZE_
;
209 ffelex_token_
->length
= 0;
211 else if (ffelex_token_
->length
>= ffelex_token_
->size
)
214 = malloc_resize_ksr (malloc_pool_image (),
216 (ffelex_token_
->size
<< 1) + 1,
217 ffelex_token_
->size
+ 1);
218 ffelex_token_
->size
<<= 1;
219 assert (ffelex_token_
->length
< ffelex_token_
->size
);
222 Sorry
, MAP_CHARACTER is
not going to work as expected in GNU Fortran
,
223 please contact fortran@gnu
.org
if you wish to fund work to
224 port g77 to non
-ASCII machines
.
226 ffelex_token_
->text
[ffelex_token_
->length
++] = c
;
229 /* Do backslash (escape) processing for a CHARACTER/HOLLERITH token
233 ffelex_backslash_ (int c
, ffewhereColumnNumber col
)
235 static int state
= 0;
236 static unsigned int count
;
238 static unsigned int firstdig
= 0;
240 static ffewhereLineNumber line
;
241 static ffewhereColumnNumber column
;
243 /* See gcc/c-lex.c readescape() for a straightforward version
244 of this state engine for handling backslashes in character/
245 hollerith constants. */
248 #define warn_traditional 0
249 #define flag_traditional 0
255 && (ffelex_raw_mode_
!= 0)
256 && ffe_is_backslash ())
260 line
= ffelex_linecount_current_
;
266 state
= 0; /* Assume simple case. */
270 if (warn_traditional
)
272 ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional",
273 FFEBAD_severityWARNING
);
274 ffelex_bad_here_ (0, line
, column
);
278 if (flag_traditional
)
287 case '0': case '1': case '2': case '3': case '4':
288 case '5': case '6': case '7':
294 case '\\': case '\'': case '"':
297 #if 0 /* Inappropriate for Fortran. */
299 ffelex_next_line_ ();
305 return TARGET_NEWLINE
;
320 if (warn_traditional
)
322 ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional",
323 FFEBAD_severityWARNING
);
324 ffelex_bad_here_ (0, line
, column
);
328 if (flag_traditional
)
333 #if 0 /* Vertical tab is present in common usage compilers. */
334 if (flag_traditional
)
351 ffebad_start_msg_lex ("Non-ISO-C-standard escape sequence `\\%A' at %0",
352 FFEBAD_severityPEDANTIC
);
353 ffelex_bad_here_ (0, line
, column
);
357 return (c
== 'E' || c
== 'e') ? 033 : c
;
363 if (c
>= 040 && c
< 0177)
369 ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0",
370 FFEBAD_severityPEDANTIC
);
371 ffelex_bad_here_ (0, line
, column
);
377 ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0",
378 FFEBAD_severityPEDANTIC
);
379 ffelex_bad_here_ (0, line
, column
);
386 sprintf (&m
[0], "%x", c
);
387 ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0",
388 FFEBAD_severityPEDANTIC
);
389 ffelex_bad_here_ (0, line
, column
);
399 code
= (code
* 16) + hex_value (c
);
400 if (code
!= 0 || count
!= 0)
414 ffebad_start_msg_lex ("\\x used at %0 with no following hex digits",
415 FFEBAD_severityFATAL
);
416 ffelex_bad_here_ (0, line
, column
);
420 /* Digits are all 0's. Ok. */
422 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
424 && ((1 << (TYPE_PRECISION (integer_type_node
) - (count
- 1) * 4))
427 ffebad_start_msg_lex ("Hex escape at %0 out of range",
428 FFEBAD_severityPEDANTIC
);
429 ffelex_bad_here_ (0, line
, column
);
435 if ((c
<= '7') && (c
>= '0') && (count
++ < 3))
437 code
= (code
* 8) + (c
- '0');
444 assert ("bad backslash state" == NULL
);
448 /* Come here when code has a built character, and c is the next
449 character that might (or might not) be the next one in the constant. */
451 /* Don't bother doing this check for each character going into
452 CHARACTER or HOLLERITH constants, just the escaped-value ones.
453 gcc apparently checks every single character, which seems
454 like it'd be kinda slow and not worth doing anyway. */
457 && TYPE_PRECISION (char_type_node
) < HOST_BITS_PER_INT
458 && code
>= (1 << TYPE_PRECISION (char_type_node
)))
460 ffebad_start_msg_lex ("Escape sequence at %0 out of range for character",
461 FFEBAD_severityFATAL
);
462 ffelex_bad_here_ (0, line
, column
);
468 /* Known end of constant, just append this character. */
469 ffelex_append_to_token_ (code
);
470 if (ffelex_raw_mode_
> 0)
475 /* Have two characters to handle. Do the first, then leave it to the
476 caller to detect anything special about the second. */
478 ffelex_append_to_token_ (code
);
479 if (ffelex_raw_mode_
> 0)
481 ffelex_backslash_reconsider_
= TRUE
;
485 /* ffelex_bad_1_ -- Issue diagnostic with one source point
487 ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1);
489 Creates ffewhere line and column objects for the source point, sends them
490 along with the error code to ffebad, then kills the line and column
491 objects before returning. */
494 ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
)
499 wl0
= ffewhere_line_new (ln0
);
500 wc0
= ffewhere_column_new (cn0
);
501 ffebad_start_lex (errnum
);
502 ffebad_here (0, wl0
, wc0
);
504 ffewhere_line_kill (wl0
);
505 ffewhere_column_kill (wc0
);
508 /* ffelex_bad_2_ -- Issue diagnostic with two source points
510 ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1,
511 otherline,othercolumn);
513 Creates ffewhere line and column objects for the source points, sends them
514 along with the error code to ffebad, then kills the line and column
515 objects before returning. */
518 ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
,
519 ffewhereLineNumber ln1
, ffewhereColumnNumber cn1
)
521 ffewhereLine wl0
, wl1
;
522 ffewhereColumn wc0
, wc1
;
524 wl0
= ffewhere_line_new (ln0
);
525 wc0
= ffewhere_column_new (cn0
);
526 wl1
= ffewhere_line_new (ln1
);
527 wc1
= ffewhere_column_new (cn1
);
528 ffebad_start_lex (errnum
);
529 ffebad_here (0, wl0
, wc0
);
530 ffebad_here (1, wl1
, wc1
);
532 ffewhere_line_kill (wl0
);
533 ffewhere_column_kill (wc0
);
534 ffewhere_line_kill (wl1
);
535 ffewhere_column_kill (wc1
);
539 ffelex_bad_here_ (int n
, ffewhereLineNumber ln0
,
540 ffewhereColumnNumber cn0
)
545 wl0
= ffewhere_line_new (ln0
);
546 wc0
= ffewhere_column_new (cn0
);
547 ffebad_here (n
, wl0
, wc0
);
548 ffewhere_line_kill (wl0
);
549 ffewhere_column_kill (wc0
);
553 ffelex_getc_ (FILE *finput
)
557 if (ffelex_kludge_chars_
== NULL
)
558 return getc (finput
);
560 c
= *ffelex_kludge_chars_
++;
564 ffelex_kludge_chars_
= NULL
;
565 return getc (finput
);
569 ffelex_cfebackslash_ (int *use_d
, int *d
, FILE *finput
)
571 register int c
= getc (finput
);
573 register unsigned count
;
574 unsigned firstdig
= 0;
582 if (warn_traditional
)
583 warning ("the meaning of `\\x' varies with -traditional");
585 if (flag_traditional
)
600 code
= (code
* 16) + hex_value (c
);
601 if (code
!= 0 || count
!= 0)
610 error ("\\x used with no following hex digits");
612 /* Digits are all 0's. Ok. */
614 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
617 << (TYPE_PRECISION (integer_type_node
) - (count
- 1)
620 pedwarn ("hex escape out of range");
623 case '0': case '1': case '2': case '3': case '4':
624 case '5': case '6': case '7':
627 while ((c
<= '7') && (c
>= '0') && (count
++ < 3))
629 code
= (code
* 8) + (c
- '0');
636 case '\\': case '\'': case '"':
640 ffelex_next_line_ ();
650 return TARGET_NEWLINE
;
665 if (warn_traditional
)
666 warning ("the meaning of `\\a' varies with -traditional");
668 if (flag_traditional
)
673 #if 0 /* Vertical tab is present in common usage compilers. */
674 if (flag_traditional
)
682 pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c
);
688 /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */
692 /* `\%' is used to prevent SCCS from getting confused. */
695 pedwarn ("non-ISO escape sequence `\\%c'", c
);
698 if (c
>= 040 && c
< 0177)
699 pedwarn ("unknown escape sequence `\\%c'", c
);
701 pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c
);
705 /* A miniature version of the C front-end lexer. */
708 ffelex_cfelex_ (ffelexToken
*xtoken
, FILE *finput
, int c
)
715 register unsigned buffer_length
;
717 if ((*xtoken
!= NULL
) && !ffelex_kludge_flag_
)
718 ffelex_token_kill (*xtoken
);
722 case '0': case '1': case '2': case '3': case '4':
723 case '5': case '6': case '7': case '8': case '9':
724 buffer_length
= ARRAY_SIZE (buff
);
727 r
= &buff
[buffer_length
];
733 register unsigned bytes_used
= (p
- q
);
736 q
= (char *)xrealloc (q
, buffer_length
);
738 r
= &q
[buffer_length
];
740 c
= ffelex_getc_ (finput
);
745 token
= ffelex_token_new_number (q
, ffewhere_line_unknown (),
746 ffewhere_column_unknown ());
754 buffer_length
= ARRAY_SIZE (buff
);
757 r
= &buff
[buffer_length
];
758 c
= ffelex_getc_ (finput
);
772 case '\\': /* ~~~~~ */
773 c
= ffelex_cfebackslash_ (&use_d
, &d
, finput
);
778 error ("badly formed directive -- no closing quote");
788 if (use_d
!= 2) /* 0=>c, 1=>cd, 2=>nil. */
793 register unsigned bytes_used
= (p
- q
);
795 buffer_length
= bytes_used
* 2;
796 q
= (char *)xrealloc (q
, buffer_length
);
798 r
= &q
[buffer_length
];
807 token
= ffelex_token_new_character (q
, ffewhere_line_unknown (),
808 ffewhere_column_unknown ());
825 ffelex_file_pop_ (const char *input_filename
)
827 if (input_file_stack
->next
)
829 struct file_stack
*p
= input_file_stack
;
830 input_file_stack
= p
->next
;
832 input_file_stack_tick
++;
833 (*debug_hooks
->end_source_file
) (input_file_stack
->line
);
836 error ("#-lines for entering and leaving files don't match");
838 /* Now that we've pushed or popped the input stack,
839 update the name in the top element. */
840 if (input_file_stack
)
841 input_file_stack
->name
= input_filename
;
845 ffelex_file_push_ (int old_lineno
, const char *input_filename
)
848 = (struct file_stack
*) xmalloc (sizeof (struct file_stack
));
850 input_file_stack
->line
= old_lineno
;
851 p
->next
= input_file_stack
;
852 p
->name
= input_filename
;
853 input_file_stack
= p
;
854 input_file_stack_tick
++;
856 (*debug_hooks
->start_source_file
) (0, input_filename
);
858 /* Now that we've pushed or popped the input stack,
859 update the name in the top element. */
860 if (input_file_stack
)
861 input_file_stack
->name
= input_filename
;
864 /* Prepare to finish a statement-in-progress by sending the current
865 token, if any, then setting up EOS as the current token with the
866 appropriate current pointer. The caller can then move the current
867 pointer before actually sending EOS, if desired, as it is in
868 typical fixed-form cases. */
871 ffelex_prepare_eos_ ()
873 if (ffelex_token_
->type
!= FFELEX_typeNONE
)
875 ffelex_backslash_ (EOF
, 0);
877 switch (ffelex_raw_mode_
)
883 ffebad_start_lex ((ffelex_raw_char_
== '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE
884 : FFEBAD_NO_CLOSING_QUOTE
);
885 ffebad_here (0, ffelex_token_
->where_line
, ffelex_token_
->where_col
);
886 ffebad_here (1, ffelex_current_wl_
, ffelex_current_wc_
);
897 ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS
);
898 ffebad_here (0, ffelex_token_
->where_line
, ffelex_token_
->where_col
);
899 ffebad_here (1, ffelex_current_wl_
, ffelex_current_wc_
);
900 sprintf (num
, "%lu", (unsigned long) ffelex_raw_mode_
);
903 /* Make sure the token has some text, might as well fill up with spaces. */
906 ffelex_append_to_token_ (' ');
907 } while (--ffelex_raw_mode_
> 0);
911 ffelex_raw_mode_
= 0;
912 ffelex_send_token_ ();
914 ffelex_token_
->type
= FFELEX_typeEOS
;
915 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
916 ffelex_token_
->where_col
= ffewhere_column_use (ffelex_current_wc_
);
920 ffelex_finish_statement_ ()
922 if ((ffelex_number_of_tokens_
== 0)
923 && (ffelex_token_
->type
== FFELEX_typeNONE
))
924 return; /* Don't have a statement pending. */
926 if (ffelex_token_
->type
!= FFELEX_typeEOS
)
927 ffelex_prepare_eos_ ();
929 ffelex_permit_include_
= TRUE
;
930 ffelex_send_token_ ();
931 ffelex_permit_include_
= FALSE
;
932 ffelex_number_of_tokens_
= 0;
933 ffelex_label_tokens_
= 0;
934 ffelex_names_
= TRUE
;
935 ffelex_names_pure_
= FALSE
; /* Probably not necessary. */
936 ffelex_hexnum_
= FALSE
;
938 if (!ffe_is_ffedebug ())
941 /* For debugging purposes only. */
943 if (ffelex_total_tokens_
!= ffelex_old_total_tokens_
)
945 fprintf (dmpout
, "; token_track had %ld tokens, now have %ld.\n",
946 ffelex_old_total_tokens_
, ffelex_total_tokens_
);
947 ffelex_old_total_tokens_
= ffelex_total_tokens_
;
951 /* Copied from gcc/c-common.c get_directive_line. */
954 ffelex_get_directive_line_ (char **text
, FILE *finput
)
956 static char *directive_buffer
= NULL
;
957 static unsigned buffer_length
= 0;
959 register char *buffer_limit
;
960 register int looking_for
= 0;
961 register int char_escaped
= 0;
963 if (buffer_length
== 0)
965 directive_buffer
= (char *)xmalloc (128);
969 buffer_limit
= &directive_buffer
[buffer_length
];
971 for (p
= directive_buffer
; ; )
975 /* Make buffer bigger if it is full. */
976 if (p
>= buffer_limit
)
978 register unsigned bytes_used
= (p
- directive_buffer
);
982 = (char *)xrealloc (directive_buffer
, buffer_length
);
983 p
= &directive_buffer
[bytes_used
];
984 buffer_limit
= &directive_buffer
[buffer_length
];
989 /* Discard initial whitespace. */
990 if ((c
== ' ' || c
== '\t') && p
== directive_buffer
)
993 /* Detect the end of the directive. */
994 if ((c
== '\n' && looking_for
== 0)
997 if (looking_for
!= 0)
998 error ("bad directive -- missing close-quote");
1001 *text
= directive_buffer
;
1007 ffelex_next_line_ ();
1009 /* Handle string and character constant syntax. */
1012 if (looking_for
== c
&& !char_escaped
)
1013 looking_for
= 0; /* Found terminator... stop looking. */
1016 if (c
== '\'' || c
== '"')
1017 looking_for
= c
; /* Don't stop buffering until we see another
1018 one of these (or an EOF). */
1020 /* Handle backslash. */
1021 char_escaped
= (c
== '\\' && ! char_escaped
);
1025 /* Handle # directives that make it through (or are generated by) the
1026 preprocessor. As much as reasonably possible, emulate the behavior
1027 of the gcc compiler phase cc1, though interactions between #include
1028 and INCLUDE might possibly produce bizarre results in terms of
1029 error reporting and the generation of debugging info vis-a-vis the
1030 locations of some things.
1032 Returns the next character unhandled, which is always newline or EOF. */
1034 #if defined HANDLE_PRAGMA
1035 /* Local versions of these macros, that can be passed as function pointers. */
1039 return getc (finput
);
1046 ungetc (arg
, finput
);
1048 #endif /* HANDLE_PRAGMA */
1051 ffelex_hash_ (FILE *finput
)
1054 ffelexToken token
= NULL
;
1056 /* Read first nonwhite char after the `#'. */
1058 c
= ffelex_getc_ (finput
);
1059 while (c
== ' ' || c
== '\t')
1060 c
= ffelex_getc_ (finput
);
1062 /* If a letter follows, then if the word here is `line', skip
1063 it and ignore it; otherwise, ignore the line, with an error
1064 if the word isn't `pragma', `ident', `define', or `undef'. */
1070 if (getc (finput
) == 'r'
1071 && getc (finput
) == 'a'
1072 && getc (finput
) == 'g'
1073 && getc (finput
) == 'm'
1074 && getc (finput
) == 'a'
1075 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1078 #if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */
1079 static char buffer
[128];
1080 char * buff
= buffer
;
1082 /* Read the pragma name into a buffer.
1083 ISSPACE() may evaluate its argument more than once! */
1084 while (((c
= getc (finput
)), ISSPACE(c
)))
1092 while (c
!= EOF
&& ! ISSPACE (c
) && c
!= '\n'
1093 && buff
< buffer
+ 128);
1098 #ifdef HANDLE_PRAGMA
1099 if (HANDLE_PRAGMA (pragma_getc
, pragma_ungetc
, buffer
))
1101 #endif /* HANDLE_PRAGMA */
1102 #ifdef HANDLE_GENERIC_PRAGMAS
1103 if (handle_generic_pragma (buffer
))
1105 #endif /* !HANDLE_GENERIC_PRAGMAS */
1107 /* Issue a warning message if we have been asked to do so.
1108 Ignoring unknown pragmas in system header file unless
1109 an explcit -Wunknown-pragmas has been given. */
1110 if (warn_unknown_pragmas
> 1
1111 || (warn_unknown_pragmas
&& ! in_system_header
))
1112 warning ("ignoring pragma: %s", token_buffer
);
1120 if (getc (finput
) == 'e'
1121 && getc (finput
) == 'f'
1122 && getc (finput
) == 'i'
1123 && getc (finput
) == 'n'
1124 && getc (finput
) == 'e'
1125 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1130 c
= ffelex_get_directive_line_ (&text
, finput
);
1132 if (debug_info_level
== DINFO_LEVEL_VERBOSE
)
1133 (*debug_hooks
->define
) (lineno
, text
);
1140 if (getc (finput
) == 'n'
1141 && getc (finput
) == 'd'
1142 && getc (finput
) == 'e'
1143 && getc (finput
) == 'f'
1144 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1149 c
= ffelex_get_directive_line_ (&text
, finput
);
1151 if (debug_info_level
== DINFO_LEVEL_VERBOSE
)
1152 (*debug_hooks
->undef
) (lineno
, text
);
1159 if (getc (finput
) == 'i'
1160 && getc (finput
) == 'n'
1161 && getc (finput
) == 'e'
1162 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1167 if (getc (finput
) == 'd'
1168 && getc (finput
) == 'e'
1169 && getc (finput
) == 'n'
1170 && getc (finput
) == 't'
1171 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1173 /* #ident. The pedantic warning is now in cpp. */
1175 /* Here we have just seen `#ident '.
1176 A string constant should follow. */
1178 while (c
== ' ' || c
== '\t')
1181 /* If no argument, ignore the line. */
1182 if (c
== '\n' || c
== EOF
)
1185 c
= ffelex_cfelex_ (&token
, finput
, c
);
1188 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1190 error ("invalid #ident");
1194 if (! flag_no_ident
)
1196 #ifdef ASM_OUTPUT_IDENT
1197 ASM_OUTPUT_IDENT (asm_out_file
,
1198 ffelex_token_text (token
));
1202 /* Skip the rest of this line. */
1207 error ("undefined or invalid # directive");
1212 /* Here we have either `#line' or `# <nonletter>'.
1213 In either case, it should be a line number; a digit should follow. */
1215 while (c
== ' ' || c
== '\t')
1216 c
= ffelex_getc_ (finput
);
1218 /* If the # is the only nonwhite char on the line,
1219 just ignore it. Check the new newline. */
1220 if (c
== '\n' || c
== EOF
)
1223 /* Something follows the #; read a token. */
1225 c
= ffelex_cfelex_ (&token
, finput
, c
);
1228 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1230 int old_lineno
= lineno
;
1231 const char *old_input_filename
= input_filename
;
1234 /* subtract one, because it is the following line that
1235 gets the specified number */
1236 int l
= atoi (ffelex_token_text (token
)) - 1;
1238 /* Is this the last nonwhite stuff on the line? */
1239 while (c
== ' ' || c
== '\t')
1240 c
= ffelex_getc_ (finput
);
1241 if (c
== '\n' || c
== EOF
)
1243 /* No more: store the line number and check following line. */
1245 if (!ffelex_kludge_flag_
)
1247 ffewhere_file_set (NULL
, TRUE
, (ffewhereLineNumber
) l
);
1250 ffelex_token_kill (token
);
1255 /* More follows: it must be a string constant (filename). */
1257 /* Read the string constant. */
1258 c
= ffelex_cfelex_ (&token
, finput
, c
);
1261 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1263 error ("invalid #line");
1269 if (ffelex_kludge_flag_
)
1270 input_filename
= ggc_strdup (ffelex_token_text (token
));
1273 wf
= ffewhere_file_new (ffelex_token_text (token
),
1274 ffelex_token_length (token
));
1275 input_filename
= ffewhere_file_name (wf
);
1276 ffewhere_file_set (wf
, TRUE
, (ffewhereLineNumber
) l
);
1279 #if 0 /* Not sure what g77 should do with this yet. */
1280 /* Each change of file name
1281 reinitializes whether we are now in a system header. */
1282 in_system_header
= 0;
1285 if (main_input_filename
== 0)
1286 main_input_filename
= input_filename
;
1288 /* Is this the last nonwhite stuff on the line? */
1289 while (c
== ' ' || c
== '\t')
1291 if (c
== '\n' || c
== EOF
)
1293 if (!ffelex_kludge_flag_
)
1295 /* Update the name in the top element of input_file_stack. */
1296 if (input_file_stack
)
1297 input_file_stack
->name
= input_filename
;
1300 ffelex_token_kill (token
);
1305 c
= ffelex_cfelex_ (&token
, finput
, c
);
1307 /* `1' after file name means entering new file.
1308 `2' after file name means just left a file. */
1311 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1313 int num
= atoi (ffelex_token_text (token
));
1315 if (ffelex_kludge_flag_
)
1318 input_filename
= old_input_filename
;
1319 error ("use `#line ...' instead of `# ...' in first line");
1324 /* Pushing to a new file. */
1325 ffelex_file_push_ (old_lineno
, input_filename
);
1329 /* Popping out of a file. */
1330 ffelex_file_pop_ (input_filename
);
1333 /* Is this the last nonwhite stuff on the line? */
1334 while (c
== ' ' || c
== '\t')
1336 if (c
== '\n' || c
== EOF
)
1339 ffelex_token_kill (token
);
1343 c
= ffelex_cfelex_ (&token
, finput
, c
);
1346 /* `3' after file name means this is a system header file. */
1348 #if 0 /* Not sure what g77 should do with this yet. */
1350 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
)
1351 && (atoi (ffelex_token_text (token
)) == 3))
1352 in_system_header
= 1;
1355 while (c
== ' ' || c
== '\t')
1357 if (((token
!= NULL
)
1358 || (c
!= '\n' && c
!= EOF
))
1359 && ffelex_kludge_flag_
)
1362 input_filename
= old_input_filename
;
1363 error ("use `#line ...' instead of `# ...' in first line");
1365 if (c
== '\n' || c
== EOF
)
1367 if (token
!= NULL
&& !ffelex_kludge_flag_
)
1368 ffelex_token_kill (token
);
1373 error ("invalid #-line");
1375 /* skip the rest of this line. */
1377 if ((token
!= NULL
) && !ffelex_kludge_flag_
)
1378 ffelex_token_kill (token
);
1379 while ((c
= getc (finput
)) != EOF
&& c
!= '\n')
1384 /* "Image" a character onto the card image, return incremented column number.
1386 Normally invoking this function as in
1387 column = ffelex_image_char_ (c, column);
1388 is the same as doing:
1389 ffelex_card_image_[column++] = c;
1391 However, tabs and carriage returns are handled specially, to preserve
1392 the visual "image" of the input line (in most editors) in the card
1395 Carriage returns are ignored, as they are assumed to be followed
1398 A tab is handled by first doing:
1399 ffelex_card_image_[column++] = ' ';
1400 That is, it translates to at least one space. Then, as many spaces
1401 are imaged as necessary to bring the column number to the next tab
1402 position, where tab positions start in the ninth column and each
1403 eighth column afterwards. ALSO, a static var named ffelex_saw_tab_
1404 is set to TRUE to notify the lexer that a tab was seen.
1406 Columns are numbered and tab stops set as illustrated below:
1408 012345670123456701234567...
1412 xxxxxxx yyyyyyy zzzzzzz
1413 xxxxxxxx yyyyyyyy... */
1415 static ffewhereColumnNumber
1416 ffelex_image_char_ (int c
, ffewhereColumnNumber column
)
1418 ffewhereColumnNumber old_column
= column
;
1420 if (column
>= ffelex_card_size_
)
1422 ffewhereColumnNumber newmax
= ffelex_card_size_
<< 1;
1424 if (ffelex_bad_line_
)
1427 if ((newmax
>> 1) != ffelex_card_size_
)
1428 { /* Overflowed column number. */
1429 overflow
: /* :::::::::::::::::::: */
1431 ffelex_bad_line_
= TRUE
;
1432 strcpy (&ffelex_card_image_
[column
- 3], "...");
1433 ffelex_card_length_
= column
;
1434 ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG
,
1435 ffelex_linecount_current_
, column
+ 1);
1440 = malloc_resize_ksr (malloc_pool_image (),
1443 ffelex_card_size_
+ 9);
1444 ffelex_card_size_
= newmax
;
1453 ffelex_saw_tab_
= TRUE
;
1454 ffelex_card_image_
[column
++] = ' ';
1455 while ((column
& 7) != 0)
1456 ffelex_card_image_
[column
++] = ' ';
1460 if (!ffelex_bad_line_
)
1462 ffelex_bad_line_
= TRUE
;
1463 strcpy (&ffelex_card_image_
[column
], "[\\0]");
1464 ffelex_card_length_
= column
+ 4;
1465 ffebad_start_msg_lex ("Null character at %0 -- line ignored",
1466 FFEBAD_severityFATAL
);
1467 ffelex_bad_here_ (0, ffelex_linecount_current_
, column
+ 1);
1474 ffelex_card_image_
[column
++] = c
;
1478 if (column
< old_column
)
1480 column
= old_column
;
1481 goto overflow
; /* :::::::::::::::::::: */
1490 ffewhereFile include_wherefile
= ffelex_include_wherefile_
;
1491 FILE *include_file
= ffelex_include_file_
;
1492 /* The rest of this is to push, and after the INCLUDE file is processed,
1493 pop, the static lexer state info that pertains to each particular
1496 ffewhereColumnNumber card_size
= ffelex_card_size_
;
1497 ffewhereColumnNumber card_length
= ffelex_card_length_
;
1498 ffewhereLine current_wl
= ffelex_current_wl_
;
1499 ffewhereColumn current_wc
= ffelex_current_wc_
;
1500 bool saw_tab
= ffelex_saw_tab_
;
1501 ffewhereColumnNumber final_nontab_column
= ffelex_final_nontab_column_
;
1502 ffewhereFile current_wf
= ffelex_current_wf_
;
1503 ffewhereLineNumber linecount_current
= ffelex_linecount_current_
;
1504 ffewhereLineNumber linecount_offset
1505 = ffewhere_line_filelinenum (current_wl
);
1506 int old_lineno
= lineno
;
1507 const char *old_input_filename
= input_filename
;
1509 if (card_length
!= 0)
1511 card_image
= malloc_new_ks (malloc_pool_image (),
1512 "FFELEX saved card image",
1514 memcpy (card_image
, ffelex_card_image_
, card_length
);
1519 ffelex_set_include_
= FALSE
;
1521 ffelex_next_line_ ();
1523 ffewhere_file_set (include_wherefile
, TRUE
, 0);
1525 ffelex_file_push_ (old_lineno
, ffewhere_file_name (include_wherefile
));
1527 if (ffelex_include_free_form_
)
1528 ffelex_file_free (include_wherefile
, include_file
);
1530 ffelex_file_fixed (include_wherefile
, include_file
);
1532 ffelex_file_pop_ (ffewhere_file_name (current_wf
));
1534 ffewhere_file_set (current_wf
, TRUE
, linecount_offset
);
1536 ffecom_close_include (include_file
);
1538 if (card_length
!= 0)
1540 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1541 #error "need to handle possible reduction of card size here!!"
1543 assert (ffelex_card_size_
>= card_length
); /* It shrunk?? */
1544 memcpy (ffelex_card_image_
, card_image
, card_length
);
1546 ffelex_card_image_
[card_length
] = '\0';
1548 input_filename
= old_input_filename
;
1549 lineno
= old_lineno
;
1550 ffelex_linecount_current_
= linecount_current
;
1551 ffelex_current_wf_
= current_wf
;
1552 ffelex_final_nontab_column_
= final_nontab_column
;
1553 ffelex_saw_tab_
= saw_tab
;
1554 ffelex_current_wc_
= current_wc
;
1555 ffelex_current_wl_
= current_wl
;
1556 ffelex_card_length_
= card_length
;
1557 ffelex_card_size_
= card_size
;
1560 /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation?
1562 ffewhereColumnNumber col;
1563 int c; // Char at col.
1564 if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1))
1565 // We have a continuation indicator.
1567 If there are <n> spaces starting at ffelex_card_image_[col] up through
1568 the null character, where <n> is 0 or greater, returns TRUE. */
1571 ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
)
1573 while (ffelex_card_image_
[col
] != '\0')
1575 if (ffelex_card_image_
[col
++] != ' ')
1581 /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation?
1583 ffewhereColumnNumber col;
1584 int c; // Char at col.
1585 if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1))
1586 // We have a continuation indicator.
1588 If there are <n> spaces starting at ffelex_card_image_[col] up through
1589 the null character or '!', where <n> is 0 or greater, returns TRUE. */
1592 ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
)
1594 while ((ffelex_card_image_
[col
] != '\0') && (ffelex_card_image_
[col
] != '!'))
1596 if (ffelex_card_image_
[col
++] != ' ')
1603 ffelex_next_line_ ()
1605 ffelex_linecount_current_
= ffelex_linecount_next_
;
1606 ++ffelex_linecount_next_
;
1611 ffelex_send_token_ ()
1613 ++ffelex_number_of_tokens_
;
1615 ffelex_backslash_ (EOF
, 0);
1617 if (ffelex_token_
->text
== NULL
)
1619 if (ffelex_token_
->type
== FFELEX_typeCHARACTER
)
1621 ffelex_append_to_token_ ('\0');
1622 ffelex_token_
->length
= 0;
1626 ffelex_token_
->text
[ffelex_token_
->length
] = '\0';
1628 assert (ffelex_raw_mode_
== 0);
1630 if (ffelex_token_
->type
== FFELEX_typeNAMES
)
1632 ffewhere_line_kill (ffelex_token_
->currentnames_line
);
1633 ffewhere_column_kill (ffelex_token_
->currentnames_col
);
1636 assert (ffelex_handler_
!= NULL
);
1637 ffelex_handler_
= (ffelexHandler
) (*ffelex_handler_
) (ffelex_token_
);
1638 assert (ffelex_handler_
!= NULL
);
1640 ffelex_token_kill (ffelex_token_
);
1642 ffelex_token_
= ffelex_token_new_ ();
1643 ffelex_token_
->uses
= 1;
1644 ffelex_token_
->text
= NULL
;
1645 if (ffelex_raw_mode_
< 0)
1647 ffelex_token_
->type
= FFELEX_typeCHARACTER
;
1648 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
1649 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
1650 ffelex_raw_where_line_
= ffewhere_line_unknown ();
1651 ffelex_raw_where_col_
= ffewhere_column_unknown ();
1655 ffelex_token_
->type
= FFELEX_typeNONE
;
1656 ffelex_token_
->where_line
= ffewhere_line_unknown ();
1657 ffelex_token_
->where_col
= ffewhere_column_unknown ();
1660 if (ffelex_set_include_
)
1664 /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me
1666 return ffelex_swallow_tokens_;
1668 Return this handler when you don't want to look at any more tokens in the
1669 statement because you've encountered an unrecoverable error in the
1672 static ffelexHandler
1673 ffelex_swallow_tokens_ (ffelexToken t
)
1675 assert (ffelex_eos_handler_
!= NULL
);
1677 if ((ffelex_token_type (t
) == FFELEX_typeEOS
)
1678 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
))
1679 return (ffelexHandler
) (*ffelex_eos_handler_
) (t
);
1681 return (ffelexHandler
) ffelex_swallow_tokens_
;
1685 ffelex_token_new_ ()
1689 ++ffelex_total_tokens_
;
1691 t
= (ffelexToken
) malloc_new_ks (malloc_pool_image (),
1692 "FFELEX token", sizeof (*t
));
1693 t
->id_
= ffelex_token_nextid_
++;
1698 ffelex_type_string_ (ffelexType type
)
1700 static const char *const types
[] = {
1702 "FFELEX_typeCOMMENT",
1708 "FFELEX_typeDOLLAR",
1710 "FFELEX_typePERCENT",
1711 "FFELEX_typeAMPERSAND",
1712 "FFELEX_typeAPOSTROPHE",
1713 "FFELEX_typeOPEN_PAREN",
1714 "FFELEX_typeCLOSE_PAREN",
1715 "FFELEX_typeASTERISK",
1718 "FFELEX_typePERIOD",
1720 "FFELEX_typeNUMBER",
1721 "FFELEX_typeOPEN_ANGLE",
1722 "FFELEX_typeEQUALS",
1723 "FFELEX_typeCLOSE_ANGLE",
1727 "FFELEX_typeCONCAT",
1730 "FFELEX_typeHOLLERITH",
1731 "FFELEX_typeCHARACTER",
1733 "FFELEX_typeSEMICOLON",
1734 "FFELEX_typeUNDERSCORE",
1735 "FFELEX_typeQUESTION",
1736 "FFELEX_typeOPEN_ARRAY",
1737 "FFELEX_typeCLOSE_ARRAY",
1738 "FFELEX_typeCOLONCOLON",
1739 "FFELEX_typeREL_LE",
1740 "FFELEX_typeREL_NE",
1741 "FFELEX_typeREL_EQ",
1742 "FFELEX_typePOINTS",
1746 if (type
>= ARRAY_SIZE (types
))
1752 ffelex_display_token (ffelexToken t
)
1757 fprintf (dmpout
, "; Token #%lu is %s (line %" ffewhereLineNumber_f
"u, col %"
1758 ffewhereColumnNumber_f
"u)",
1760 ffelex_type_string_ (t
->type
),
1761 ffewhere_line_number (t
->where_line
),
1762 ffewhere_column_number (t
->where_col
));
1764 if (t
->text
!= NULL
)
1765 fprintf (dmpout
, ": \"%.*s\"\n",
1769 fprintf (dmpout
, ".\n");
1772 /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER
1774 if (ffelex_expecting_character())
1775 // next token delivered by lexer will be CHARACTER.
1777 If the most recent call to ffelex_set_expecting_hollerith since the last
1778 token was delivered by the lexer passed a length of -1, then we return
1779 TRUE, because the next token we deliver will be typeCHARACTER, else we
1783 ffelex_expecting_character ()
1785 return (ffelex_raw_mode_
!= 0);
1788 /* ffelex_file_fixed -- Lex a given file in fixed source form
1792 ffelex_file_fixed(wf,f);
1794 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
1797 ffelex_file_fixed (ffewhereFile wf
, FILE *f
)
1799 register int c
= 0; /* Character currently under consideration. */
1800 register ffewhereColumnNumber column
= 0; /* Not really; 0 means column 1... */
1801 bool disallow_continuation_line
;
1802 bool ignore_disallowed_continuation
= FALSE
;
1803 int latest_char_in_file
= 0; /* For getting back into comment-skipping
1806 ffewhereColumnNumber first_label_char
; /* First char of label --
1808 char label_string
[6]; /* Text of label. */
1809 int labi
; /* Length of label text. */
1810 bool finish_statement
; /* Previous statement finished? */
1811 bool have_content
; /* This line have content? */
1812 bool just_do_label
; /* Nothing but label (and continuation?) on
1815 /* Lex is called for a particular file, not for a particular program unit.
1816 Yet the two events do share common characteristics. The first line in a
1817 file or in a program unit cannot be a continuation line. No token can
1818 be in mid-formation. No current label for the statement exists, since
1819 there is no current statement. */
1821 assert (ffelex_handler_
!= NULL
);
1824 input_filename
= ffewhere_file_name (wf
);
1825 ffelex_current_wf_
= wf
;
1826 disallow_continuation_line
= TRUE
;
1827 ignore_disallowed_continuation
= FALSE
;
1828 ffelex_token_
->type
= FFELEX_typeNONE
;
1829 ffelex_number_of_tokens_
= 0;
1830 ffelex_label_tokens_
= 0;
1831 ffelex_current_wl_
= ffewhere_line_unknown ();
1832 ffelex_current_wc_
= ffewhere_column_unknown ();
1833 latest_char_in_file
= '\n';
1835 goto first_line
; /* :::::::::::::::::::: */
1837 /* Come here to get a new line. */
1839 beginning_of_line
: /* :::::::::::::::::::: */
1841 disallow_continuation_line
= FALSE
;
1843 /* Come here directly when last line didn't clarify the continuation issue. */
1845 beginning_of_line_again
: /* :::::::::::::::::::: */
1847 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1848 if (ffelex_card_size_
!= FFELEX_columnINITIAL_SIZE_
)
1851 = malloc_resize_ks (malloc_pool_image (),
1853 FFELEX_columnINITIAL_SIZE_
+ 9,
1854 ffelex_card_size_
+ 9);
1855 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
1859 first_line
: /* :::::::::::::::::::: */
1861 c
= latest_char_in_file
;
1862 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
1865 end_of_file
: /* :::::::::::::::::::: */
1867 /* Line ending in EOF instead of \n still counts as a whole line. */
1869 ffelex_finish_statement_ ();
1870 ffewhere_line_kill (ffelex_current_wl_
);
1871 ffewhere_column_kill (ffelex_current_wc_
);
1872 return (ffelexHandler
) ffelex_handler_
;
1875 ffelex_next_line_ ();
1877 ffelex_bad_line_
= FALSE
;
1879 /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1881 while (((lextype
= ffelex_first_char_
[c
]) == FFELEX_typeCOMMENT
)
1882 || (lextype
== FFELEX_typeERROR
)
1883 || (lextype
== FFELEX_typeSLASH
)
1884 || (lextype
== FFELEX_typeHASH
))
1886 /* Test most frequent type of line first, etc. */
1887 if ((lextype
== FFELEX_typeCOMMENT
)
1888 || ((lextype
== FFELEX_typeSLASH
)
1889 && ((c
= getc (f
)) == '*'))) /* NOTE SIDE-EFFECT. */
1891 /* Typical case (straight comment), just ignore rest of line. */
1892 comment_line
: /* :::::::::::::::::::: */
1894 while ((c
!= '\n') && (c
!= EOF
))
1897 else if (lextype
== FFELEX_typeHASH
)
1898 c
= ffelex_hash_ (f
);
1899 else if (lextype
== FFELEX_typeSLASH
)
1901 /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1902 ffelex_card_image_
[0] = '/';
1903 ffelex_card_image_
[1] = c
;
1905 goto bad_first_character
; /* :::::::::::::::::::: */
1908 /* typeERROR or unsupported typeHASH. */
1909 { /* Bad first character, get line and display
1911 column
= ffelex_image_char_ (c
, 0);
1913 bad_first_character
: /* :::::::::::::::::::: */
1915 ffelex_bad_line_
= TRUE
;
1916 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
1917 column
= ffelex_image_char_ (c
, column
);
1918 ffelex_card_image_
[column
] = '\0';
1919 ffelex_card_length_
= column
;
1920 ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID
,
1921 ffelex_linecount_current_
, 1);
1924 /* Read past last char in line. */
1928 ffelex_next_line_ ();
1929 goto end_of_file
; /* :::::::::::::::::::: */
1934 ffelex_next_line_ ();
1937 goto end_of_file
; /* :::::::::::::::::::: */
1939 ffelex_bad_line_
= FALSE
;
1940 } /* while [c, first char, means comment] */
1944 || (ffelex_final_nontab_column_
== 0);
1946 if (lextype
== FFELEX_typeDEBUG
)
1947 c
= ' '; /* A 'D' or 'd' in column 1 with the
1948 debug-lines option on. */
1950 column
= ffelex_image_char_ (c
, 0);
1952 /* Read the entire line in as is (with whitespace processing). */
1954 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
1955 column
= ffelex_image_char_ (c
, column
);
1957 if (ffelex_bad_line_
)
1959 ffelex_card_image_
[column
] = '\0';
1960 ffelex_card_length_
= column
;
1961 goto comment_line
; /* :::::::::::::::::::: */
1964 /* If no tab, cut off line after column 72/132. */
1966 if (!ffelex_saw_tab_
&& (column
> ffelex_final_nontab_column_
))
1968 /* Technically, we should now fill ffelex_card_image_ up thru column
1969 72/132 with spaces, since character/hollerith constants must count
1970 them in that manner. To save CPU time in several ways (avoid a loop
1971 here that would be used only when we actually end a line in
1972 character-constant mode; avoid writing memory unnecessarily; avoid a
1973 loop later checking spaces when not scanning for character-constant
1974 characters), we don't do this, and we do the appropriate thing when
1975 we encounter end-of-line while actually processing a character
1978 column
= ffelex_final_nontab_column_
;
1981 ffelex_card_image_
[column
] = '\0';
1982 ffelex_card_length_
= column
;
1984 /* Save next char in file so we can use register-based c while analyzing
1985 line we just read. */
1987 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
1989 have_content
= FALSE
;
1991 /* Handle label, if any. */
1994 first_label_char
= FFEWHERE_columnUNKNOWN
;
1995 for (column
= 0; column
< 5; ++column
)
1997 switch (c
= ffelex_card_image_
[column
])
2001 goto stop_looking
; /* :::::::::::::::::::: */
2016 label_string
[labi
++] = c
;
2017 if (first_label_char
== FFEWHERE_columnUNKNOWN
)
2018 first_label_char
= column
+ 1;
2024 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2025 ffelex_linecount_current_
,
2027 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2029 if (ffe_is_pedantic ())
2030 ffelex_bad_1_ (FFEBAD_AMPERSAND
,
2031 ffelex_linecount_current_
, 1);
2032 finish_statement
= FALSE
;
2033 just_do_label
= FALSE
;
2034 goto got_a_continuation
; /* :::::::::::::::::::: */
2037 if (ffelex_card_image_
[column
+ 1] == '*')
2038 goto stop_looking
; /* :::::::::::::::::::: */
2041 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2042 ffelex_linecount_current_
, column
+ 1);
2043 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2047 stop_looking
: /* :::::::::::::::::::: */
2049 label_string
[labi
] = '\0';
2051 /* Find first nonblank char starting with continuation column. */
2053 if (column
== 5) /* In which case we didn't see end of line in
2055 while ((c
= ffelex_card_image_
[column
]) == ' ')
2058 /* Now we're trying to figure out whether this is a continuation line and
2059 whether there's anything else of substance on the line. The cases are
2062 1. If a line has an explicit continuation character (other than the digit
2063 zero), then if it also has a label, the label is ignored and an error
2064 message is printed. Any remaining text on the line is passed to the
2065 parser tasks, thus even an all-blank line (possibly with an ignored
2066 label) aside from a positive continuation character might have meaning
2067 in the midst of a character or hollerith constant.
2069 2. If a line has no explicit continuation character (that is, it has a
2070 space in column 6 and the first non-space character past column 6 is
2071 not a digit 0-9), then there are two possibilities:
2073 A. A label is present and/or a non-space (and non-comment) character
2074 appears somewhere after column 6. Terminate processing of the previous
2075 statement, if any, send the new label for the next statement, if any,
2076 and start processing a new statement with this non-blank character, if
2079 B. The line is essentially blank, except for a possible comment character.
2080 Don't terminate processing of the previous statement and don't pass any
2081 characters to the parser tasks, since the line is not flagged as a
2082 continuation line. We treat it just like a completely blank line.
2084 3. If a line has a continuation character of zero (0), then we terminate
2085 processing of the previous statement, if any, send the new label for the
2086 next statement, if any, and start processing a new statement, if any
2087 non-blank characters are present.
2089 If, when checking to see if we should terminate the previous statement, it
2090 is found that there is no previous statement but that there is an
2091 outstanding label, substitute CONTINUE as the statement for the label
2092 and display an error message. */
2094 finish_statement
= FALSE
;
2095 just_do_label
= FALSE
;
2099 case '!': /* ANSI Fortran 90 says ! in column 6 is
2101 /* VXT Fortran says ! anywhere is comment, even column 6. */
2102 if (ffe_is_vxt () || (column
!= 5))
2103 goto no_tokens_on_line
; /* :::::::::::::::::::: */
2104 goto got_a_continuation
; /* :::::::::::::::::::: */
2107 if (ffelex_card_image_
[column
+ 1] != '*')
2108 goto some_other_character
; /* :::::::::::::::::::: */
2112 /* This seems right to do. But it is close to call, since / * starting
2113 in column 6 will thus be interpreted as a continuation line
2114 beginning with '*'. */
2116 goto got_a_continuation
;/* :::::::::::::::::::: */
2120 /* End of line. Therefore may be continued-through line, so handle
2121 pending label as possible to-be-continued and drive end-of-statement
2122 for any previous statement, else treat as blank line. */
2124 no_tokens_on_line
: /* :::::::::::::::::::: */
2126 if (ffe_is_pedantic () && (c
== '/'))
2127 ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT
,
2128 ffelex_linecount_current_
, column
+ 1);
2129 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2130 { /* Can't be a continued-through line if it
2132 finish_statement
= TRUE
;
2133 have_content
= TRUE
;
2134 just_do_label
= TRUE
;
2137 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2140 if (ffe_is_pedantic () && (column
!= 5))
2141 ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN
,
2142 ffelex_linecount_current_
, column
+ 1);
2143 finish_statement
= TRUE
;
2144 goto check_for_content
; /* :::::::::::::::::::: */
2156 /* NOTE: This label can be reached directly from the code
2157 that lexes the label field in columns 1-5. */
2158 got_a_continuation
: /* :::::::::::::::::::: */
2160 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2162 ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION
,
2163 ffelex_linecount_current_
,
2165 ffelex_linecount_current_
,
2167 first_label_char
= FFEWHERE_columnUNKNOWN
;
2169 if (disallow_continuation_line
)
2171 if (!ignore_disallowed_continuation
)
2172 ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION
,
2173 ffelex_linecount_current_
, column
+ 1);
2174 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2176 if (ffe_is_pedantic () && (column
!= 5))
2177 ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN
,
2178 ffelex_linecount_current_
, column
+ 1);
2179 if ((ffelex_raw_mode_
!= 0)
2180 && (((c
= ffelex_card_image_
[column
+ 1]) != '\0')
2181 || !ffelex_saw_tab_
))
2184 have_content
= TRUE
;
2188 check_for_content
: /* :::::::::::::::::::: */
2190 while ((c
= ffelex_card_image_
[++column
]) == ' ')
2195 && (ffelex_card_image_
[column
+ 1] == '*')))
2197 if (ffe_is_pedantic () && (c
== '/'))
2198 ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT
,
2199 ffelex_linecount_current_
, column
+ 1);
2200 just_do_label
= TRUE
;
2203 have_content
= TRUE
;
2208 some_other_character
: /* :::::::::::::::::::: */
2211 goto got_a_continuation
;/* :::::::::::::::::::: */
2213 /* Here is the very normal case of a regular character starting in
2214 column 7 or beyond with a blank in column 6. */
2216 finish_statement
= TRUE
;
2217 have_content
= TRUE
;
2222 || (first_label_char
!= FFEWHERE_columnUNKNOWN
))
2224 /* The line has content of some kind, install new end-statement
2225 point for error messages. Note that "content" includes cases
2226 where there's little apparent content but enough to finish
2227 a statement. That's because finishing a statement can trigger
2228 an impending INCLUDE, and that requires accurate line info being
2229 maintained by the lexer. */
2231 if (finish_statement
)
2232 ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
2234 ffewhere_line_kill (ffelex_current_wl_
);
2235 ffewhere_column_kill (ffelex_current_wc_
);
2236 ffelex_current_wl_
= ffewhere_line_new (ffelex_linecount_current_
);
2237 ffelex_current_wc_
= ffewhere_column_new (ffelex_card_length_
+ 1);
2240 /* We delay this for a combination of reasons. Mainly, it can start
2241 INCLUDE processing, and we want to delay that until the lexer's
2242 info on the line is coherent. And we want to delay that until we're
2243 sure there's a reason to make that info coherent, to avoid saving
2244 lots of useless lines. */
2246 if (finish_statement
)
2247 ffelex_finish_statement_ ();
2249 /* If label is present, enclose it in a NUMBER token and send it along. */
2251 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2253 assert (ffelex_token_
->type
== FFELEX_typeNONE
);
2254 ffelex_token_
->type
= FFELEX_typeNUMBER
;
2255 ffelex_append_to_token_ ('\0'); /* Make room for label text. */
2256 strcpy (ffelex_token_
->text
, label_string
);
2257 ffelex_token_
->where_line
2258 = ffewhere_line_use (ffelex_current_wl_
);
2259 ffelex_token_
->where_col
= ffewhere_column_new (first_label_char
);
2260 ffelex_token_
->length
= labi
;
2261 ffelex_send_token_ ();
2262 ++ffelex_label_tokens_
;
2266 goto beginning_of_line
; /* :::::::::::::::::::: */
2268 /* Here is the main engine for parsing. c holds the character at column.
2269 It is already known that c is not a blank, end of line, or shriek,
2270 unless ffelex_raw_mode_ is not 0 (indicating we are in a
2271 character/hollerith constant). A partially filled token may already
2272 exist in ffelex_token_. One special case: if, when the end of the line
2273 is reached, continuation_line is FALSE and the only token on the line is
2274 END, then it is indeed the last statement. We don't look for
2275 continuation lines during this program unit in that case. This is
2276 according to ANSI. */
2278 if (ffelex_raw_mode_
!= 0)
2281 parse_raw_character
: /* :::::::::::::::::::: */
2285 ffewhereColumnNumber i
;
2287 if (ffelex_saw_tab_
|| (column
>= ffelex_final_nontab_column_
))
2288 goto beginning_of_line
; /* :::::::::::::::::::: */
2290 /* Pad out line with "virtual" spaces. */
2292 for (i
= column
; i
< ffelex_final_nontab_column_
; ++i
)
2293 ffelex_card_image_
[i
] = ' ';
2294 ffelex_card_image_
[i
] = '\0';
2295 ffelex_card_length_
= i
;
2299 switch (ffelex_raw_mode_
)
2302 c
= ffelex_backslash_ (c
, column
);
2306 if (!ffelex_backslash_reconsider_
)
2307 ffelex_append_to_token_ (c
);
2308 ffelex_raw_mode_
= -1;
2312 if (c
== ffelex_raw_char_
)
2314 ffelex_raw_mode_
= -1;
2315 ffelex_append_to_token_ (c
);
2319 ffelex_raw_mode_
= 0;
2320 ffelex_backslash_reconsider_
= TRUE
;
2325 if (c
== ffelex_raw_char_
)
2326 ffelex_raw_mode_
= -2;
2329 c
= ffelex_backslash_ (c
, column
);
2332 ffelex_raw_mode_
= -3;
2336 ffelex_append_to_token_ (c
);
2341 c
= ffelex_backslash_ (c
, column
);
2345 if (!ffelex_backslash_reconsider_
)
2347 ffelex_append_to_token_ (c
);
2353 if (ffelex_backslash_reconsider_
)
2354 ffelex_backslash_reconsider_
= FALSE
;
2356 c
= ffelex_card_image_
[++column
];
2358 if (ffelex_raw_mode_
== 0)
2360 ffelex_send_token_ ();
2361 assert (ffelex_raw_mode_
== 0);
2363 c
= ffelex_card_image_
[++column
];
2367 && (ffelex_card_image_
[column
+ 1] == '*')))
2368 goto beginning_of_line
; /* :::::::::::::::::::: */
2369 goto parse_nonraw_character
; /* :::::::::::::::::::: */
2371 goto parse_raw_character
; /* :::::::::::::::::::: */
2374 parse_nonraw_character
: /* :::::::::::::::::::: */
2376 switch (ffelex_token_
->type
)
2378 case FFELEX_typeNONE
:
2382 ffelex_token_
->type
= FFELEX_typeQUOTE
;
2383 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2384 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2385 ffelex_send_token_ ();
2389 ffelex_token_
->type
= FFELEX_typeDOLLAR
;
2390 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2391 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2392 ffelex_send_token_ ();
2396 ffelex_token_
->type
= FFELEX_typePERCENT
;
2397 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2398 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2399 ffelex_send_token_ ();
2403 ffelex_token_
->type
= FFELEX_typeAMPERSAND
;
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_typeAPOSTROPHE
;
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_typeOPEN_PAREN
;
2418 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2419 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2423 ffelex_token_
->type
= FFELEX_typeCLOSE_PAREN
;
2424 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2425 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2426 ffelex_send_token_ ();
2430 ffelex_token_
->type
= FFELEX_typeASTERISK
;
2431 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2432 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2436 ffelex_token_
->type
= FFELEX_typePLUS
;
2437 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2438 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2439 ffelex_send_token_ ();
2443 ffelex_token_
->type
= FFELEX_typeCOMMA
;
2444 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2445 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2446 ffelex_send_token_ ();
2450 ffelex_token_
->type
= FFELEX_typeMINUS
;
2451 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2452 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2453 ffelex_send_token_ ();
2457 ffelex_token_
->type
= FFELEX_typePERIOD
;
2458 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2459 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2460 ffelex_send_token_ ();
2464 ffelex_token_
->type
= FFELEX_typeSLASH
;
2465 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2466 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2480 = ffelex_hexnum_
? FFELEX_typeNAME
: FFELEX_typeNUMBER
;
2481 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2482 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2483 ffelex_append_to_token_ (c
);
2487 ffelex_token_
->type
= FFELEX_typeCOLON
;
2488 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2489 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2493 ffelex_token_
->type
= FFELEX_typeSEMICOLON
;
2494 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2495 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2496 ffelex_permit_include_
= TRUE
;
2497 ffelex_send_token_ ();
2498 ffelex_permit_include_
= FALSE
;
2502 ffelex_token_
->type
= FFELEX_typeOPEN_ANGLE
;
2503 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2504 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2508 ffelex_token_
->type
= FFELEX_typeEQUALS
;
2509 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2510 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2514 ffelex_token_
->type
= FFELEX_typeCLOSE_ANGLE
;
2515 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2516 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2520 ffelex_token_
->type
= FFELEX_typeQUESTION
;
2521 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2522 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2523 ffelex_send_token_ ();
2527 if (1 || ffe_is_90 ())
2529 ffelex_token_
->type
= FFELEX_typeUNDERSCORE
;
2530 ffelex_token_
->where_line
2531 = ffewhere_line_use (ffelex_current_wl_
);
2532 ffelex_token_
->where_col
2533 = ffewhere_column_new (column
+ 1);
2534 ffelex_send_token_ ();
2590 c
= ffesrc_char_source (c
);
2592 if (ffesrc_char_match_init (c
, 'H', 'h')
2593 && ffelex_expecting_hollerith_
!= 0)
2595 ffelex_raw_mode_
= ffelex_expecting_hollerith_
;
2596 ffelex_token_
->type
= FFELEX_typeHOLLERITH
;
2597 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
2598 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
2599 ffelex_raw_where_line_
= ffewhere_line_unknown ();
2600 ffelex_raw_where_col_
= ffewhere_column_unknown ();
2601 c
= ffelex_card_image_
[++column
];
2602 goto parse_raw_character
; /* :::::::::::::::::::: */
2607 ffelex_token_
->where_line
2608 = ffewhere_line_use (ffelex_token_
->currentnames_line
2609 = ffewhere_line_use (ffelex_current_wl_
));
2610 ffelex_token_
->where_col
2611 = ffewhere_column_use (ffelex_token_
->currentnames_col
2612 = ffewhere_column_new (column
+ 1));
2613 ffelex_token_
->type
= FFELEX_typeNAMES
;
2617 ffelex_token_
->where_line
2618 = ffewhere_line_use (ffelex_current_wl_
);
2619 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2620 ffelex_token_
->type
= FFELEX_typeNAME
;
2622 ffelex_append_to_token_ (c
);
2626 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
2627 ffelex_linecount_current_
, column
+ 1);
2628 ffelex_finish_statement_ ();
2629 disallow_continuation_line
= TRUE
;
2630 ignore_disallowed_continuation
= TRUE
;
2631 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2635 case FFELEX_typeNAME
:
2690 c
= ffesrc_char_source (c
);
2705 && !ffe_is_dollar_ok ())
2707 ffelex_send_token_ ();
2708 goto parse_next_character
; /* :::::::::::::::::::: */
2710 ffelex_append_to_token_ (c
);
2714 ffelex_send_token_ ();
2715 goto parse_next_character
; /* :::::::::::::::::::: */
2719 case FFELEX_typeNAMES
:
2774 c
= ffesrc_char_source (c
);
2789 && !ffe_is_dollar_ok ())
2791 ffelex_send_token_ ();
2792 goto parse_next_character
; /* :::::::::::::::::::: */
2794 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
2796 ffewhere_track (&ffelex_token_
->currentnames_line
,
2797 &ffelex_token_
->currentnames_col
,
2798 ffelex_token_
->wheretrack
,
2799 ffelex_token_
->length
,
2800 ffelex_linecount_current_
,
2803 ffelex_append_to_token_ (c
);
2807 ffelex_send_token_ ();
2808 goto parse_next_character
; /* :::::::::::::::::::: */
2812 case FFELEX_typeNUMBER
:
2825 ffelex_append_to_token_ (c
);
2829 ffelex_send_token_ ();
2830 goto parse_next_character
; /* :::::::::::::::::::: */
2834 case FFELEX_typeASTERISK
:
2838 ffelex_token_
->type
= FFELEX_typePOWER
;
2839 ffelex_send_token_ ();
2842 default: /* * not followed by another *. */
2843 ffelex_send_token_ ();
2844 goto parse_next_character
; /* :::::::::::::::::::: */
2848 case FFELEX_typeCOLON
:
2852 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
2853 ffelex_send_token_ ();
2856 default: /* : not followed by another :. */
2857 ffelex_send_token_ ();
2858 goto parse_next_character
; /* :::::::::::::::::::: */
2862 case FFELEX_typeSLASH
:
2866 ffelex_token_
->type
= FFELEX_typeCONCAT
;
2867 ffelex_send_token_ ();
2871 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
2872 ffelex_send_token_ ();
2876 ffelex_token_
->type
= FFELEX_typeREL_NE
;
2877 ffelex_send_token_ ();
2881 ffelex_send_token_ ();
2882 goto parse_next_character
; /* :::::::::::::::::::: */
2886 case FFELEX_typeOPEN_PAREN
:
2890 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
2891 ffelex_send_token_ ();
2895 ffelex_send_token_ ();
2896 goto parse_next_character
; /* :::::::::::::::::::: */
2900 case FFELEX_typeOPEN_ANGLE
:
2904 ffelex_token_
->type
= FFELEX_typeREL_LE
;
2905 ffelex_send_token_ ();
2909 ffelex_send_token_ ();
2910 goto parse_next_character
; /* :::::::::::::::::::: */
2914 case FFELEX_typeEQUALS
:
2918 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
2919 ffelex_send_token_ ();
2923 ffelex_token_
->type
= FFELEX_typePOINTS
;
2924 ffelex_send_token_ ();
2928 ffelex_send_token_ ();
2929 goto parse_next_character
; /* :::::::::::::::::::: */
2933 case FFELEX_typeCLOSE_ANGLE
:
2937 ffelex_token_
->type
= FFELEX_typeREL_GE
;
2938 ffelex_send_token_ ();
2942 ffelex_send_token_ ();
2943 goto parse_next_character
; /* :::::::::::::::::::: */
2948 assert ("Serious error!!" == NULL
);
2953 c
= ffelex_card_image_
[++column
];
2955 parse_next_character
: /* :::::::::::::::::::: */
2957 if (ffelex_raw_mode_
!= 0)
2958 goto parse_raw_character
; /* :::::::::::::::::::: */
2961 c
= ffelex_card_image_
[++column
];
2966 && (ffelex_card_image_
[column
+ 1] == '*')))
2968 if ((ffelex_number_of_tokens_
== ffelex_label_tokens_
)
2969 && (ffelex_token_
->type
== FFELEX_typeNAMES
)
2970 && (ffelex_token_
->length
== 3)
2971 && (ffesrc_strncmp_2c (ffe_case_match (),
2972 ffelex_token_
->text
,
2973 "END", "end", "End",
2977 ffelex_finish_statement_ ();
2978 disallow_continuation_line
= TRUE
;
2979 ignore_disallowed_continuation
= FALSE
;
2980 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2982 goto beginning_of_line
; /* :::::::::::::::::::: */
2984 goto parse_nonraw_character
; /* :::::::::::::::::::: */
2987 /* ffelex_file_free -- Lex a given file in free source form
2991 ffelex_file_free(wf,f);
2993 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
2996 ffelex_file_free (ffewhereFile wf
, FILE *f
)
2998 register int c
= 0; /* Character currently under consideration. */
2999 register ffewhereColumnNumber column
= 0; /* Not really; 0 means column 1... */
3000 bool continuation_line
= FALSE
;
3001 ffewhereColumnNumber continuation_column
;
3002 int latest_char_in_file
= 0; /* For getting back into comment-skipping
3005 /* Lex is called for a particular file, not for a particular program unit.
3006 Yet the two events do share common characteristics. The first line in a
3007 file or in a program unit cannot be a continuation line. No token can
3008 be in mid-formation. No current label for the statement exists, since
3009 there is no current statement. */
3011 assert (ffelex_handler_
!= NULL
);
3014 input_filename
= ffewhere_file_name (wf
);
3015 ffelex_current_wf_
= wf
;
3016 continuation_line
= FALSE
;
3017 ffelex_token_
->type
= FFELEX_typeNONE
;
3018 ffelex_number_of_tokens_
= 0;
3019 ffelex_current_wl_
= ffewhere_line_unknown ();
3020 ffelex_current_wc_
= ffewhere_column_unknown ();
3021 latest_char_in_file
= '\n';
3023 /* Come here to get a new line. */
3025 beginning_of_line
: /* :::::::::::::::::::: */
3027 c
= latest_char_in_file
;
3028 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
3031 end_of_file
: /* :::::::::::::::::::: */
3033 /* Line ending in EOF instead of \n still counts as a whole line. */
3035 ffelex_finish_statement_ ();
3036 ffewhere_line_kill (ffelex_current_wl_
);
3037 ffewhere_column_kill (ffelex_current_wc_
);
3038 return (ffelexHandler
) ffelex_handler_
;
3041 ffelex_next_line_ ();
3043 ffelex_bad_line_
= FALSE
;
3045 /* Skip over initial-comment and empty lines as quickly as possible! */
3052 c
= ffelex_hash_ (f
);
3054 comment_line
: /* :::::::::::::::::::: */
3056 while ((c
!= '\n') && (c
!= EOF
))
3061 ffelex_next_line_ ();
3062 goto end_of_file
; /* :::::::::::::::::::: */
3067 ffelex_next_line_ ();
3070 goto end_of_file
; /* :::::::::::::::::::: */
3073 ffelex_saw_tab_
= FALSE
;
3075 column
= ffelex_image_char_ (c
, 0);
3077 /* Read the entire line in as is (with whitespace processing). */
3079 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
3080 column
= ffelex_image_char_ (c
, column
);
3082 if (ffelex_bad_line_
)
3084 ffelex_card_image_
[column
] = '\0';
3085 ffelex_card_length_
= column
;
3086 goto comment_line
; /* :::::::::::::::::::: */
3089 /* If no tab, cut off line after column 132. */
3091 if (!ffelex_saw_tab_
&& (column
> FFELEX_FREE_MAX_COLUMNS_
))
3092 column
= FFELEX_FREE_MAX_COLUMNS_
;
3094 ffelex_card_image_
[column
] = '\0';
3095 ffelex_card_length_
= column
;
3097 /* Save next char in file so we can use register-based c while analyzing
3098 line we just read. */
3100 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
3103 continuation_column
= 0;
3105 /* Skip over initial spaces to see if the first nonblank character
3106 is exclamation point, newline, or EOF (line is therefore a comment) or
3107 ampersand (line is therefore a continuation line). */
3109 while ((c
= ffelex_card_image_
[column
]) == ' ')
3116 goto beginning_of_line
; /* :::::::::::::::::::: */
3119 continuation_column
= column
+ 1;
3126 /* The line definitely has content of some kind, install new end-statement
3127 point for error messages. */
3129 ffewhere_line_kill (ffelex_current_wl_
);
3130 ffewhere_column_kill (ffelex_current_wc_
);
3131 ffelex_current_wl_
= ffewhere_line_new (ffelex_linecount_current_
);
3132 ffelex_current_wc_
= ffewhere_column_new (ffelex_card_length_
+ 1);
3134 /* Figure out which column to start parsing at. */
3136 if (continuation_line
)
3138 if (continuation_column
== 0)
3140 if (ffelex_raw_mode_
!= 0)
3142 ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE
,
3143 ffelex_linecount_current_
, column
+ 1);
3145 else if (ffelex_token_
->type
!= FFELEX_typeNONE
)
3147 ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE
,
3148 ffelex_linecount_current_
, column
+ 1);
3151 else if (ffelex_is_free_char_ctx_contin_ (continuation_column
))
3152 { /* Line contains only a single "&" as only
3153 nonblank character. */
3154 ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE
,
3155 ffelex_linecount_current_
, continuation_column
);
3156 goto beginning_of_line
; /* :::::::::::::::::::: */
3158 column
= continuation_column
;
3163 c
= ffelex_card_image_
[column
];
3164 continuation_line
= FALSE
;
3166 /* Here is the main engine for parsing. c holds the character at column.
3167 It is already known that c is not a blank, end of line, or shriek,
3168 unless ffelex_raw_mode_ is not 0 (indicating we are in a
3169 character/hollerith constant). A partially filled token may already
3170 exist in ffelex_token_. */
3172 if (ffelex_raw_mode_
!= 0)
3175 parse_raw_character
: /* :::::::::::::::::::: */
3180 if (ffelex_is_free_char_ctx_contin_ (column
+ 1))
3182 continuation_line
= TRUE
;
3183 goto beginning_of_line
; /* :::::::::::::::::::: */
3188 ffelex_finish_statement_ ();
3189 goto beginning_of_line
; /* :::::::::::::::::::: */
3195 switch (ffelex_raw_mode_
)
3198 c
= ffelex_backslash_ (c
, column
);
3202 if (!ffelex_backslash_reconsider_
)
3203 ffelex_append_to_token_ (c
);
3204 ffelex_raw_mode_
= -1;
3208 if (c
== ffelex_raw_char_
)
3210 ffelex_raw_mode_
= -1;
3211 ffelex_append_to_token_ (c
);
3215 ffelex_raw_mode_
= 0;
3216 ffelex_backslash_reconsider_
= TRUE
;
3221 if (c
== ffelex_raw_char_
)
3222 ffelex_raw_mode_
= -2;
3225 c
= ffelex_backslash_ (c
, column
);
3228 ffelex_raw_mode_
= -3;
3232 ffelex_append_to_token_ (c
);
3237 c
= ffelex_backslash_ (c
, column
);
3241 if (!ffelex_backslash_reconsider_
)
3243 ffelex_append_to_token_ (c
);
3249 if (ffelex_backslash_reconsider_
)
3250 ffelex_backslash_reconsider_
= FALSE
;
3252 c
= ffelex_card_image_
[++column
];
3254 if (ffelex_raw_mode_
== 0)
3256 ffelex_send_token_ ();
3257 assert (ffelex_raw_mode_
== 0);
3259 c
= ffelex_card_image_
[++column
];
3260 if ((c
== '\0') || (c
== '!'))
3262 ffelex_finish_statement_ ();
3263 goto beginning_of_line
; /* :::::::::::::::::::: */
3265 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3267 continuation_line
= TRUE
;
3268 goto beginning_of_line
; /* :::::::::::::::::::: */
3270 goto parse_nonraw_character_noncontin
; /* :::::::::::::::::::: */
3272 goto parse_raw_character
; /* :::::::::::::::::::: */
3275 parse_nonraw_character
: /* :::::::::::::::::::: */
3277 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3279 continuation_line
= TRUE
;
3280 goto beginning_of_line
; /* :::::::::::::::::::: */
3283 parse_nonraw_character_noncontin
: /* :::::::::::::::::::: */
3285 switch (ffelex_token_
->type
)
3287 case FFELEX_typeNONE
:
3290 finish-statement/continue-statement
3293 c
= ffelex_card_image_
[++column
];
3294 if ((c
== '\0') || (c
== '!'))
3296 ffelex_finish_statement_ ();
3297 goto beginning_of_line
; /* :::::::::::::::::::: */
3299 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3301 continuation_line
= TRUE
;
3302 goto beginning_of_line
; /* :::::::::::::::::::: */
3309 ffelex_token_
->type
= FFELEX_typeQUOTE
;
3310 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3311 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3312 ffelex_send_token_ ();
3316 ffelex_token_
->type
= FFELEX_typeDOLLAR
;
3317 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3318 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3319 ffelex_send_token_ ();
3323 ffelex_token_
->type
= FFELEX_typePERCENT
;
3324 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3325 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3326 ffelex_send_token_ ();
3330 ffelex_token_
->type
= FFELEX_typeAMPERSAND
;
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_typeAPOSTROPHE
;
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_typeOPEN_PAREN
;
3345 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3346 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3350 ffelex_token_
->type
= FFELEX_typeCLOSE_PAREN
;
3351 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3352 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3353 ffelex_send_token_ ();
3357 ffelex_token_
->type
= FFELEX_typeASTERISK
;
3358 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3359 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3363 ffelex_token_
->type
= FFELEX_typePLUS
;
3364 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3365 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3366 ffelex_send_token_ ();
3370 ffelex_token_
->type
= FFELEX_typeCOMMA
;
3371 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3372 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3373 ffelex_send_token_ ();
3377 ffelex_token_
->type
= FFELEX_typeMINUS
;
3378 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3379 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3380 ffelex_send_token_ ();
3384 ffelex_token_
->type
= FFELEX_typePERIOD
;
3385 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3386 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3387 ffelex_send_token_ ();
3391 ffelex_token_
->type
= FFELEX_typeSLASH
;
3392 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3393 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3407 = ffelex_hexnum_
? FFELEX_typeNAME
: FFELEX_typeNUMBER
;
3408 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3409 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3410 ffelex_append_to_token_ (c
);
3414 ffelex_token_
->type
= FFELEX_typeCOLON
;
3415 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3416 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3420 ffelex_token_
->type
= FFELEX_typeSEMICOLON
;
3421 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3422 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3423 ffelex_permit_include_
= TRUE
;
3424 ffelex_send_token_ ();
3425 ffelex_permit_include_
= FALSE
;
3429 ffelex_token_
->type
= FFELEX_typeOPEN_ANGLE
;
3430 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3431 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3435 ffelex_token_
->type
= FFELEX_typeEQUALS
;
3436 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3437 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3441 ffelex_token_
->type
= FFELEX_typeCLOSE_ANGLE
;
3442 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3443 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3447 ffelex_token_
->type
= FFELEX_typeQUESTION
;
3448 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3449 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3450 ffelex_send_token_ ();
3454 if (1 || ffe_is_90 ())
3456 ffelex_token_
->type
= FFELEX_typeUNDERSCORE
;
3457 ffelex_token_
->where_line
3458 = ffewhere_line_use (ffelex_current_wl_
);
3459 ffelex_token_
->where_col
3460 = ffewhere_column_new (column
+ 1);
3461 ffelex_send_token_ ();
3517 c
= ffesrc_char_source (c
);
3519 if (ffesrc_char_match_init (c
, 'H', 'h')
3520 && ffelex_expecting_hollerith_
!= 0)
3522 ffelex_raw_mode_
= ffelex_expecting_hollerith_
;
3523 ffelex_token_
->type
= FFELEX_typeHOLLERITH
;
3524 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
3525 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
3526 ffelex_raw_where_line_
= ffewhere_line_unknown ();
3527 ffelex_raw_where_col_
= ffewhere_column_unknown ();
3528 c
= ffelex_card_image_
[++column
];
3529 goto parse_raw_character
; /* :::::::::::::::::::: */
3532 if (ffelex_names_pure_
)
3534 ffelex_token_
->where_line
3535 = ffewhere_line_use (ffelex_token_
->currentnames_line
3536 = ffewhere_line_use (ffelex_current_wl_
));
3537 ffelex_token_
->where_col
3538 = ffewhere_column_use (ffelex_token_
->currentnames_col
3539 = ffewhere_column_new (column
+ 1));
3540 ffelex_token_
->type
= FFELEX_typeNAMES
;
3544 ffelex_token_
->where_line
3545 = ffewhere_line_use (ffelex_current_wl_
);
3546 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3547 ffelex_token_
->type
= FFELEX_typeNAME
;
3549 ffelex_append_to_token_ (c
);
3553 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
3554 ffelex_linecount_current_
, column
+ 1);
3555 ffelex_finish_statement_ ();
3556 goto beginning_of_line
; /* :::::::::::::::::::: */
3560 case FFELEX_typeNAME
:
3615 c
= ffesrc_char_source (c
);
3630 && !ffe_is_dollar_ok ())
3632 ffelex_send_token_ ();
3633 goto parse_next_character
; /* :::::::::::::::::::: */
3635 ffelex_append_to_token_ (c
);
3639 ffelex_send_token_ ();
3640 goto parse_next_character
; /* :::::::::::::::::::: */
3644 case FFELEX_typeNAMES
:
3699 c
= ffesrc_char_source (c
);
3714 && !ffe_is_dollar_ok ())
3716 ffelex_send_token_ ();
3717 goto parse_next_character
; /* :::::::::::::::::::: */
3719 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
3721 ffewhere_track (&ffelex_token_
->currentnames_line
,
3722 &ffelex_token_
->currentnames_col
,
3723 ffelex_token_
->wheretrack
,
3724 ffelex_token_
->length
,
3725 ffelex_linecount_current_
,
3728 ffelex_append_to_token_ (c
);
3732 ffelex_send_token_ ();
3733 goto parse_next_character
; /* :::::::::::::::::::: */
3737 case FFELEX_typeNUMBER
:
3750 ffelex_append_to_token_ (c
);
3754 ffelex_send_token_ ();
3755 goto parse_next_character
; /* :::::::::::::::::::: */
3759 case FFELEX_typeASTERISK
:
3763 ffelex_token_
->type
= FFELEX_typePOWER
;
3764 ffelex_send_token_ ();
3767 default: /* * not followed by another *. */
3768 ffelex_send_token_ ();
3769 goto parse_next_character
; /* :::::::::::::::::::: */
3773 case FFELEX_typeCOLON
:
3777 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
3778 ffelex_send_token_ ();
3781 default: /* : not followed by another :. */
3782 ffelex_send_token_ ();
3783 goto parse_next_character
; /* :::::::::::::::::::: */
3787 case FFELEX_typeSLASH
:
3791 ffelex_token_
->type
= FFELEX_typeCONCAT
;
3792 ffelex_send_token_ ();
3796 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
3797 ffelex_send_token_ ();
3801 ffelex_token_
->type
= FFELEX_typeREL_NE
;
3802 ffelex_send_token_ ();
3806 ffelex_send_token_ ();
3807 goto parse_next_character
; /* :::::::::::::::::::: */
3811 case FFELEX_typeOPEN_PAREN
:
3815 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
3816 ffelex_send_token_ ();
3820 ffelex_send_token_ ();
3821 goto parse_next_character
; /* :::::::::::::::::::: */
3825 case FFELEX_typeOPEN_ANGLE
:
3829 ffelex_token_
->type
= FFELEX_typeREL_LE
;
3830 ffelex_send_token_ ();
3834 ffelex_send_token_ ();
3835 goto parse_next_character
; /* :::::::::::::::::::: */
3839 case FFELEX_typeEQUALS
:
3843 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
3844 ffelex_send_token_ ();
3848 ffelex_token_
->type
= FFELEX_typePOINTS
;
3849 ffelex_send_token_ ();
3853 ffelex_send_token_ ();
3854 goto parse_next_character
; /* :::::::::::::::::::: */
3858 case FFELEX_typeCLOSE_ANGLE
:
3862 ffelex_token_
->type
= FFELEX_typeREL_GE
;
3863 ffelex_send_token_ ();
3867 ffelex_send_token_ ();
3868 goto parse_next_character
; /* :::::::::::::::::::: */
3873 assert ("Serious error!" == NULL
);
3878 c
= ffelex_card_image_
[++column
];
3880 parse_next_character
: /* :::::::::::::::::::: */
3882 if (ffelex_raw_mode_
!= 0)
3883 goto parse_raw_character
; /* :::::::::::::::::::: */
3885 if ((c
== '\0') || (c
== '!'))
3887 ffelex_finish_statement_ ();
3888 goto beginning_of_line
; /* :::::::::::::::::::: */
3890 goto parse_nonraw_character
; /* :::::::::::::::::::: */
3893 /* See the code in com.c that calls this to understand why. */
3896 ffelex_hash_kludge (FILE *finput
)
3898 /* If you change this constant string, you have to change whatever
3899 code might thus be affected by it in terms of having to use
3900 ffelex_getc_() instead of getc() in the lexers and _hash_. */
3901 static const char match
[] = "# 1 \"";
3902 static int kludge
[ARRAY_SIZE (match
) + 1];
3907 /* Read chars as long as they match the target string.
3908 Copy them into an array that will serve as a record
3909 of what we read (essentially a multi-char ungetc(),
3910 for code that uses ffelex_getc_ instead of getc() elsewhere
3912 for (p
= &match
[0], q
= &kludge
[0], c
= getc (finput
);
3913 (c
== *p
) && (*p
!= '\0') && (c
!= EOF
);
3914 ++p
, ++q
, c
= getc (finput
))
3917 *q
= c
; /* Might be EOF, which requires int. */
3920 ffelex_kludge_chars_
= &kludge
[0];
3924 ffelex_kludge_flag_
= TRUE
;
3925 ++ffelex_kludge_chars_
;
3926 ffelex_hash_ (finput
); /* Handle it NOW rather than later. */
3927 ffelex_kludge_flag_
= FALSE
;
3936 ffelex_final_nontab_column_
= ffe_fixed_line_length ();
3937 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
3938 ffelex_card_image_
= malloc_new_ksr (malloc_pool_image (),
3939 "FFELEX card image",
3940 FFELEX_columnINITIAL_SIZE_
+ 9);
3941 ffelex_card_image_
[0] = '\0';
3943 for (i
= 0; i
< 256; ++i
)
3944 ffelex_first_char_
[i
] = FFELEX_typeERROR
;
3946 ffelex_first_char_
['\t'] = FFELEX_typeRAW
;
3947 ffelex_first_char_
['\n'] = FFELEX_typeCOMMENT
;
3948 ffelex_first_char_
['\v'] = FFELEX_typeCOMMENT
;
3949 ffelex_first_char_
['\f'] = FFELEX_typeCOMMENT
;
3950 ffelex_first_char_
['\r'] = FFELEX_typeRAW
;
3951 ffelex_first_char_
[' '] = FFELEX_typeRAW
;
3952 ffelex_first_char_
['!'] = FFELEX_typeCOMMENT
;
3953 ffelex_first_char_
['*'] = FFELEX_typeCOMMENT
;
3954 ffelex_first_char_
['/'] = FFELEX_typeSLASH
;
3955 ffelex_first_char_
['&'] = FFELEX_typeRAW
;
3956 ffelex_first_char_
['#'] = FFELEX_typeHASH
;
3958 for (i
= '0'; i
<= '9'; ++i
)
3959 ffelex_first_char_
[i
] = FFELEX_typeRAW
;
3961 if ((ffe_case_match () == FFE_caseNONE
)
3962 || ((ffe_case_match () == FFE_caseUPPER
)
3963 && (ffe_case_source () != FFE_caseLOWER
)) /* Idiot! :-) */
3964 || ((ffe_case_match () == FFE_caseLOWER
)
3965 && (ffe_case_source () == FFE_caseLOWER
)))
3967 ffelex_first_char_
['C'] = FFELEX_typeCOMMENT
;
3968 ffelex_first_char_
['D'] = FFELEX_typeCOMMENT
;
3970 if ((ffe_case_match () == FFE_caseNONE
)
3971 || ((ffe_case_match () == FFE_caseLOWER
)
3972 && (ffe_case_source () != FFE_caseUPPER
)) /* Idiot! :-) */
3973 || ((ffe_case_match () == FFE_caseUPPER
)
3974 && (ffe_case_source () == FFE_caseUPPER
)))
3976 ffelex_first_char_
['c'] = FFELEX_typeCOMMENT
;
3977 ffelex_first_char_
['d'] = FFELEX_typeCOMMENT
;
3980 ffelex_linecount_current_
= 0;
3981 ffelex_linecount_next_
= 1;
3982 ffelex_raw_mode_
= 0;
3983 ffelex_set_include_
= FALSE
;
3984 ffelex_permit_include_
= FALSE
;
3985 ffelex_names_
= TRUE
; /* First token in program is a names. */
3986 ffelex_names_pure_
= FALSE
; /* Free-form lexer does NAMES only for
3988 ffelex_hexnum_
= FALSE
;
3989 ffelex_expecting_hollerith_
= 0;
3990 ffelex_raw_where_line_
= ffewhere_line_unknown ();
3991 ffelex_raw_where_col_
= ffewhere_column_unknown ();
3993 ffelex_token_
= ffelex_token_new_ ();
3994 ffelex_token_
->type
= FFELEX_typeNONE
;
3995 ffelex_token_
->uses
= 1;
3996 ffelex_token_
->where_line
= ffewhere_line_unknown ();
3997 ffelex_token_
->where_col
= ffewhere_column_unknown ();
3998 ffelex_token_
->text
= NULL
;
4000 ffelex_handler_
= NULL
;
4003 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
4005 if (ffelex_is_names_expected())
4006 // Deliver NAMES token
4008 // Deliver NAME token
4010 Must be called while lexer is active, obviously. */
4013 ffelex_is_names_expected ()
4015 return ffelex_names_
;
4018 /* Current card image, which has the master linecount number
4019 ffelex_linecount_current_. */
4024 return ffelex_card_image_
;
4027 /* ffelex_line_length -- Return length of current lexer line
4029 printf("Length is %lu\n",ffelex_line_length());
4031 Must be called while lexer is active, obviously. */
4033 ffewhereColumnNumber
4034 ffelex_line_length ()
4036 return ffelex_card_length_
;
4039 /* Master line count of current card image, or 0 if no card image
4043 ffelex_line_number ()
4045 return ffelex_linecount_current_
;
4048 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4050 ffelex_set_expecting_hollerith(0);
4052 Lex initially assumes no hollerith constant is about to show up. If
4053 syntactic analysis expects one, it should call this function with the
4054 number of characters expected in the constant immediately after recognizing
4055 the decimal number preceding the "H" and the constant itself. Then, if
4056 the next character is indeed H, the lexer will interpret it as beginning
4057 a hollerith constant and ship the token formed by reading the specified
4058 number of characters (interpreting blanks and otherwise-comments too)
4059 from the input file. It is up to syntactic analysis to call this routine
4060 again with 0 to turn hollerith detection off immediately upon receiving
4061 the token that might or might not be HOLLERITH.
4063 Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4064 character constant. Pass the expected termination character (apostrophe
4067 Pass for length either the length of the hollerith (must be > 0), -1
4068 meaning expecting a character constant, or 0 to cancel expectation of
4069 a hollerith only after calling it with a length of > 0 and receiving the
4070 next token (which may or may not have been a HOLLERITH token).
4072 Pass for which either an apostrophe or quote when passing length of -1.
4073 Else which is a don't-care.
4075 Pass for line and column the line/column info for the token beginning the
4076 character or hollerith constant, for use in error messages, when passing
4077 a length of -1 -- this function will invoke ffewhere_line/column_use to
4078 make its own copies. Else line and column are don't-cares (when length
4079 is 0) and the outstanding copies of the previous line/column info, if
4080 still around, are killed.
4083 When called with length of 0, also zero ffelex_raw_mode_. This is
4084 so ffest_save_ can undo the effects of replaying tokens like
4085 APOSTROPHE and QUOTE.
4087 New line, column arguments allow error messages to point to the true
4088 beginning of a character/hollerith constant, rather than the beginning
4089 of the content part, which makes them more consistent and helpful.
4091 New "which" argument allows caller to specify termination character,
4092 which should be apostrophe or double-quote, to support Fortran 90. */
4095 ffelex_set_expecting_hollerith (long length
, char which
,
4096 ffewhereLine line
, ffewhereColumn column
)
4099 /* First kill the pending line/col info, if any (should only be pending
4100 when this call has length==0, the previous call had length>0, and a
4101 non-HOLLERITH token was sent in between the calls, but play it safe). */
4103 ffewhere_line_kill (ffelex_raw_where_line_
);
4104 ffewhere_column_kill (ffelex_raw_where_col_
);
4106 /* Now handle the length function. */
4110 ffelex_expecting_hollerith_
= 0;
4111 ffelex_raw_mode_
= 0;
4112 ffelex_raw_where_line_
= ffewhere_line_unknown ();
4113 ffelex_raw_where_col_
= ffewhere_column_unknown ();
4114 return; /* Don't set new line/column info from args. */
4117 ffelex_raw_mode_
= -1;
4118 ffelex_raw_char_
= which
;
4121 default: /* length > 0 */
4122 ffelex_expecting_hollerith_
= length
;
4126 /* Now set new line/column information from passed args. */
4128 ffelex_raw_where_line_
= ffewhere_line_use (line
);
4129 ffelex_raw_where_col_
= ffewhere_column_use (column
);
4132 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4134 ffelex_set_handler((ffelexHandler) my_first_handler);
4136 Must be called before calling ffelex_file_fixed or ffelex_file_free or
4137 after they return, but not while they are active. */
4140 ffelex_set_handler (ffelexHandler first
)
4142 ffelex_handler_
= first
;
4145 /* ffelex_set_hexnum -- Set hexnum flag
4147 ffelex_set_hexnum(TRUE);
4149 Lex normally interprets a token starting with [0-9] as a NUMBER token,
4150 so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves
4151 the character as the first of the next token. But when parsing a
4152 hexadecimal number, by calling this function with TRUE before starting
4153 the parse of the token itself, lex will interpret [0-9] as the start
4157 ffelex_set_hexnum (bool f
)
4162 /* ffelex_set_include -- Set INCLUDE file to be processed next
4164 ffewhereFile wf; // The ffewhereFile object for the file.
4165 bool free_form; // TRUE means read free-form file, FALSE fixed-form.
4166 FILE *fi; // The file to INCLUDE.
4167 ffelex_set_include(wf,free_form,fi);
4169 Must be called only after receiving the EOS token following a valid
4170 INCLUDE statement specifying a file that has already been successfully
4174 ffelex_set_include (ffewhereFile wf
, bool free_form
, FILE *fi
)
4176 assert (ffelex_permit_include_
);
4177 assert (!ffelex_set_include_
);
4178 ffelex_set_include_
= TRUE
;
4179 ffelex_include_free_form_
= free_form
;
4180 ffelex_include_file_
= fi
;
4181 ffelex_include_wherefile_
= wf
;
4184 /* ffelex_set_names -- Set names/name flag, names = TRUE
4186 ffelex_set_names(FALSE);
4188 Lex initially assumes multiple names should be formed. If this function is
4189 called with FALSE, then single names are formed instead. The differences
4190 are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME)
4191 and in whether full source-location tracking is performed (it is for
4192 multiple names, not for single names), which is more expensive in terms of
4196 ffelex_set_names (bool f
)
4200 ffelex_names_pure_
= FALSE
;
4203 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4205 ffelex_set_names_pure(FALSE);
4207 Like ffelex_set_names, except affects both lexers. Normally, the
4208 free-form lexer need not generate NAMES tokens because adjacent NAME
4209 tokens must be separated by spaces which causes the lexer to generate
4210 separate tokens for analysis (whereas in fixed-form the spaces are
4211 ignored resulting in one long token). But in FORMAT statements, for
4212 some reason, the Fortran 90 standard specifies that spaces can occur
4213 anywhere within a format-item-list with no effect on the format spec
4214 (except of course within character string edit descriptors), which means
4215 that "1PE14.2" and "1 P E 1 4 . 2" are equivalent. For the FORMAT
4216 statement handling, the existence of spaces makes it hard to deal with,
4217 because each token is seen distinctly (i.e. seven tokens in the latter
4218 example). But when no spaces are provided, as in the former example,
4219 then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD,
4220 NUMBER ("2"). By generating a NAMES instead of NAME, three things happen:
4221 One, ffest_kw_format_ does a substring rather than full-string match,
4222 and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions
4223 may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token;
4224 and three, error reporting can point to the actual character rather than
4225 at or prior to it. The first two things could be resolved by providing
4226 alternate functions fairly easy, thus allowing FORMAT handling to expect
4227 both lexers to generate NAME tokens instead of NAMES (with otherwise minor
4228 changes to FORMAT parsing), but the third, error reporting, would suffer,
4229 and when one makes mistakes in a FORMAT, believe me, one wants a pointer
4230 to exactly where the compilers thinks the problem is, to even begin to get
4231 a handle on it. So there. */
4234 ffelex_set_names_pure (bool f
)
4236 ffelex_names_pure_
= f
;
4240 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4242 return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
4245 Returns first_handler if start_char_index chars into master_token (which
4246 must be a NAMES token) is '\0'. Else, creates a subtoken from that
4247 char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar),
4248 an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign)
4249 and sends it to first_handler. If anything other than NAME is sent, the
4250 character at the end of it in the master token is examined to see if it
4251 begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so,
4252 the handler returned by first_handler is invoked with that token, and
4253 this process is repeated until the end of the master token or a NAME
4254 token is reached. */
4257 ffelex_splice_tokens (ffelexHandler first
, ffelexToken master
,
4258 ffeTokenLength start
)
4264 p
= ffelex_token_text (master
) + (i
= start
);
4270 t
= ffelex_token_number_from_names (master
, i
);
4271 p
+= ffelex_token_length (t
);
4272 i
+= ffelex_token_length (t
);
4274 else if (ffesrc_is_name_init (*p
))
4276 t
= ffelex_token_name_from_names (master
, i
, 0);
4277 p
+= ffelex_token_length (t
);
4278 i
+= ffelex_token_length (t
);
4282 t
= ffelex_token_dollar_from_names (master
, i
);
4288 t
= ffelex_token_uscore_from_names (master
, i
);
4294 assert ("not a valid NAMES character" == NULL
);
4297 assert (first
!= NULL
);
4298 first
= (ffelexHandler
) (*first
) (t
);
4299 ffelex_token_kill (t
);
4305 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4307 return ffelex_swallow_tokens;
4309 Return this handler when you don't want to look at any more tokens in the
4310 statement because you've encountered an unrecoverable error in the
4314 ffelex_swallow_tokens (ffelexToken t
, ffelexHandler handler
)
4316 assert (handler
!= NULL
);
4318 if ((t
!= NULL
) && ((ffelex_token_type (t
) == FFELEX_typeEOS
)
4319 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
)))
4320 return (ffelexHandler
) (*handler
) (t
);
4322 ffelex_eos_handler_
= handler
;
4323 return (ffelexHandler
) ffelex_swallow_tokens_
;
4326 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4329 t = ffelex_token_dollar_from_names(t,6);
4331 It's as if you made a new token of dollar type having the dollar
4332 at, in the example above, the sixth character of the NAMES token. */
4335 ffelex_token_dollar_from_names (ffelexToken t
, ffeTokenLength start
)
4340 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4341 assert (start
< t
->length
);
4342 assert (t
->text
[start
] == '$');
4344 /* Now make the token. */
4346 nt
= ffelex_token_new_ ();
4347 nt
->type
= FFELEX_typeDOLLAR
;
4350 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4351 t
->where_col
, t
->wheretrack
, start
);
4356 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4359 ffelex_token_kill(t);
4361 Complements a call to ffelex_token_use or ffelex_token_new_.... */
4364 ffelex_token_kill (ffelexToken t
)
4368 assert (t
->uses
> 0);
4373 --ffelex_total_tokens_
;
4375 if (t
->type
== FFELEX_typeNAMES
)
4376 ffewhere_track_kill (t
->where_line
, t
->where_col
,
4377 t
->wheretrack
, t
->length
);
4378 ffewhere_line_kill (t
->where_line
);
4379 ffewhere_column_kill (t
->where_col
);
4380 if (t
->text
!= NULL
)
4381 malloc_kill_ksr (malloc_pool_image (), t
->text
, t
->size
+ 1);
4382 malloc_kill_ks (malloc_pool_image (), t
, sizeof (*t
));
4385 /* Make a new NAME token that is a substring of a NAMES token. */
4388 ffelex_token_name_from_names (ffelexToken t
, ffeTokenLength start
,
4394 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4395 assert (start
< t
->length
);
4397 len
= t
->length
- start
;
4401 assert ((start
+ len
) <= t
->length
);
4403 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4405 nt
= ffelex_token_new_ ();
4406 nt
->type
= FFELEX_typeNAME
;
4407 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4411 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4412 t
->where_col
, t
->wheretrack
, start
);
4413 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4415 strncpy (nt
->text
, t
->text
+ start
, len
);
4416 nt
->text
[len
] = '\0';
4420 /* Make a new NAMES token that is a substring of another NAMES token. */
4423 ffelex_token_names_from_names (ffelexToken t
, ffeTokenLength start
,
4429 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4430 assert (start
< t
->length
);
4432 len
= t
->length
- start
;
4436 assert ((start
+ len
) <= t
->length
);
4438 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4440 nt
= ffelex_token_new_ ();
4441 nt
->type
= FFELEX_typeNAMES
;
4442 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4446 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4447 t
->where_col
, t
->wheretrack
, start
);
4448 ffewhere_track_copy (nt
->wheretrack
, t
->wheretrack
, start
, len
);
4449 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4451 strncpy (nt
->text
, t
->text
+ start
, len
);
4452 nt
->text
[len
] = '\0';
4456 /* Make a new CHARACTER token. */
4459 ffelex_token_new_character (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4463 t
= ffelex_token_new_ ();
4464 t
->type
= FFELEX_typeCHARACTER
;
4465 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4467 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4469 strcpy (t
->text
, s
);
4470 t
->where_line
= ffewhere_line_use (l
);
4471 t
->where_col
= ffewhere_column_new (c
);
4475 /* Make a new EOF token right after end of file. */
4478 ffelex_token_new_eof ()
4482 t
= ffelex_token_new_ ();
4483 t
->type
= FFELEX_typeEOF
;
4486 t
->where_line
= ffewhere_line_new (ffelex_linecount_current_
);
4487 t
->where_col
= ffewhere_column_new (1);
4491 /* Make a new NAME token. */
4494 ffelex_token_new_name (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4498 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4500 t
= ffelex_token_new_ ();
4501 t
->type
= FFELEX_typeNAME
;
4502 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4504 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4506 strcpy (t
->text
, s
);
4507 t
->where_line
= ffewhere_line_use (l
);
4508 t
->where_col
= ffewhere_column_new (c
);
4512 /* Make a new NAMES token. */
4515 ffelex_token_new_names (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4519 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4521 t
= ffelex_token_new_ ();
4522 t
->type
= FFELEX_typeNAMES
;
4523 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4525 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4527 strcpy (t
->text
, s
);
4528 t
->where_line
= ffewhere_line_use (l
);
4529 t
->where_col
= ffewhere_column_new (c
);
4530 ffewhere_track_clear (t
->wheretrack
, t
->length
); /* Assume contiguous
4535 /* Make a new NUMBER token.
4537 The first character of the string must be a digit, and only the digits
4538 are copied into the new number. So this may be used to easily extract
4539 a NUMBER token from within any text string. Then the length of the
4540 resulting token may be used to calculate where the digits stopped
4541 in the original string. */
4544 ffelex_token_new_number (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4549 /* How long is the string of decimal digits at s? */
4551 len
= strspn (s
, "0123456789");
4553 /* Make sure there is at least one digit. */
4557 /* Now make the token. */
4559 t
= ffelex_token_new_ ();
4560 t
->type
= FFELEX_typeNUMBER
;
4561 t
->length
= t
->size
= len
; /* Assume it won't get bigger. */
4563 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4565 strncpy (t
->text
, s
, len
);
4566 t
->text
[len
] = '\0';
4567 t
->where_line
= ffewhere_line_use (l
);
4568 t
->where_col
= ffewhere_column_new (c
);
4572 /* Make a new token of any type that doesn't contain text. A private
4573 function that is used by public macros in the interface file. */
4576 ffelex_token_new_simple_ (ffelexType type
, ffewhereLine l
, ffewhereColumn c
)
4580 t
= ffelex_token_new_ ();
4584 t
->where_line
= ffewhere_line_use (l
);
4585 t
->where_col
= ffewhere_column_new (c
);
4589 /* Make a new NUMBER token from an existing NAMES token.
4591 Like ffelex_token_new_number, this function calculates the length
4592 of the digit string itself. */
4595 ffelex_token_number_from_names (ffelexToken t
, ffeTokenLength start
)
4601 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4602 assert (start
< t
->length
);
4604 /* How long is the string of decimal digits at s? */
4606 len
= strspn (t
->text
+ start
, "0123456789");
4608 /* Make sure there is at least one digit. */
4612 /* Now make the token. */
4614 nt
= ffelex_token_new_ ();
4615 nt
->type
= FFELEX_typeNUMBER
;
4616 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4620 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4621 t
->where_col
, t
->wheretrack
, start
);
4622 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4624 strncpy (nt
->text
, t
->text
+ start
, len
);
4625 nt
->text
[len
] = '\0';
4629 /* Make a new UNDERSCORE token from a NAMES token. */
4632 ffelex_token_uscore_from_names (ffelexToken t
, ffeTokenLength start
)
4637 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4638 assert (start
< t
->length
);
4639 assert (t
->text
[start
] == '_');
4641 /* Now make the token. */
4643 nt
= ffelex_token_new_ ();
4644 nt
->type
= FFELEX_typeUNDERSCORE
;
4646 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4647 t
->where_col
, t
->wheretrack
, start
);
4652 /* ffelex_token_use -- Return another instance of a token
4655 t = ffelex_token_use(t);
4657 In a sense, the new token is a copy of the old, though it might be the
4658 same with just a new use count.
4660 We use the use count method (easy). */
4663 ffelex_token_use (ffelexToken t
)
4666 assert ("_token_use: null token" == NULL
);