1 /* Implementation of Fortran lexer
2 Copyright (C) 1995, 1996, 1997, 1998 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
29 #if FFECOM_targetCURRENT == FFECOM_targetGCC
37 #ifdef DWARF_DEBUGGING_INFO
41 static void ffelex_append_to_token_ (char c
);
42 static int ffelex_backslash_ (int c
, ffewhereColumnNumber col
);
43 static void ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
,
44 ffewhereColumnNumber cn0
);
45 static void ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
,
46 ffewhereColumnNumber cn0
, ffewhereLineNumber ln1
,
47 ffewhereColumnNumber cn1
);
48 static void ffelex_bad_here_ (int num
, ffewhereLineNumber ln0
,
49 ffewhereColumnNumber cn0
);
50 static void ffelex_finish_statement_ (void);
51 #if FFECOM_targetCURRENT == FFECOM_targetGCC
52 static int ffelex_get_directive_line_ (char **text
, FILE *finput
);
53 static int ffelex_hash_ (FILE *f
);
55 static ffewhereColumnNumber
ffelex_image_char_ (int c
,
56 ffewhereColumnNumber col
);
57 static void ffelex_include_ (void);
58 static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
);
59 static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
);
60 static void ffelex_next_line_ (void);
61 static void ffelex_prepare_eos_ (void);
62 static void ffelex_send_token_ (void);
63 static ffelexHandler
ffelex_swallow_tokens_ (ffelexToken t
);
64 static ffelexToken
ffelex_token_new_ (void);
66 /* Pertaining to the geometry of the input file. */
68 /* Initial size for card image to be allocated. */
69 #define FFELEX_columnINITIAL_SIZE_ 255
71 /* The card image itself, which grows as source lines get longer. It
72 has room for ffelex_card_size_ + 8 characters, and the length of the
73 current image is ffelex_card_length_. (The + 8 characters are made
74 available for easy handling of tabs and such.) */
75 static char *ffelex_card_image_
;
76 static ffewhereColumnNumber ffelex_card_size_
;
77 static ffewhereColumnNumber ffelex_card_length_
;
79 /* Max width for free-form lines (ISO F90). */
80 #define FFELEX_FREE_MAX_COLUMNS_ 132
82 /* True if we saw a tab on the current line, as this (currently) means
83 the line is therefore treated as though final_nontab_column_ were
85 static bool ffelex_saw_tab_
;
87 /* TRUE if current line is known to be erroneous, so don't bother
88 expanding room for it just to display it. */
89 static bool ffelex_bad_line_
= FALSE
;
91 /* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */
92 static ffewhereColumnNumber ffelex_final_nontab_column_
;
94 /* Array for quickly deciding what kind of line the current card has,
95 based on its first character. */
96 static ffelexType ffelex_first_char_
[256];
98 /* Pertaining to file management. */
100 /* The wf argument of the most recent active ffelex_file_(fixed,free)
102 static ffewhereFile ffelex_current_wf_
;
104 /* TRUE if an INCLUDE statement can be processed (ffelex_set_include
106 static bool ffelex_permit_include_
;
108 /* TRUE if an INCLUDE statement is pending (ffelex_set_include has been
110 static bool ffelex_set_include_
;
112 /* Information on the pending INCLUDE file. */
113 static FILE *ffelex_include_file_
;
114 static bool ffelex_include_free_form_
;
115 static ffewhereFile ffelex_include_wherefile_
;
117 /* Current master line count. */
118 static ffewhereLineNumber ffelex_linecount_current_
;
119 /* Next master line count. */
120 static ffewhereLineNumber ffelex_linecount_next_
;
122 /* ffewhere info on the latest (currently active) line read from the
123 active source file. */
124 static ffewhereLine ffelex_current_wl_
;
125 static ffewhereColumn ffelex_current_wc_
;
127 /* Pertaining to tokens in general. */
129 /* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER
131 #define FFELEX_columnTOKEN_SIZE_ 63
132 #if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX
133 #error "token size too small!"
136 /* Current token being lexed. */
137 static ffelexToken ffelex_token_
;
139 /* Handler for current token. */
140 static ffelexHandler ffelex_handler_
;
142 /* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */
143 static bool ffelex_names_
;
145 /* TRUE if both lexers are to generate NAMES instead of NAME tokens. */
146 static bool ffelex_names_pure_
;
148 /* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex
150 static bool ffelex_hexnum_
;
152 /* For ffelex_swallow_tokens(). */
153 static ffelexHandler ffelex_eos_handler_
;
155 /* Number of tokens sent since last EOS or beginning of input file
156 (include INCLUDEd files). */
157 static unsigned long int ffelex_number_of_tokens_
;
159 /* Number of labels sent (as NUMBER tokens) since last reset of
160 ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases.
161 (Fixed-form source only.) */
162 static unsigned long int ffelex_label_tokens_
;
164 /* Metering for token management, to catch token-memory leaks. */
165 static long int ffelex_total_tokens_
= 0;
166 static long int ffelex_old_total_tokens_
= 1;
167 static long int ffelex_token_nextid_
= 0;
169 /* Pertaining to lexing CHARACTER and HOLLERITH tokens. */
171 /* >0 if a Hollerith constant of that length might be in mid-lex, used
172 when the next character seen is 'H' or 'h' to enter HOLLERITH lexing
173 mode (see ffelex_raw_mode_). */
174 static long int ffelex_expecting_hollerith_
;
176 /* -3: Backslash (escape) sequence being lexed in CHARACTER.
177 -2: Possible closing apostrophe/quote seen in CHARACTER.
178 -1: Lexing CHARACTER.
179 0: Not lexing CHARACTER or HOLLERITH.
180 >0: Lexing HOLLERITH, value is # chars remaining to expect. */
181 static long int ffelex_raw_mode_
;
183 /* When lexing CHARACTER, open quote/apostrophe (either ' or "). */
184 static char ffelex_raw_char_
;
186 /* TRUE when backslash processing had to use most recent character
187 to finish its state engine, but that character is not part of
188 the backslash sequence, so must be reconsidered as a "normal"
189 character in CHARACTER/HOLLERITH lexing. */
190 static bool ffelex_backslash_reconsider_
= FALSE
;
192 /* Characters preread before lexing happened (might include EOF). */
193 static int *ffelex_kludge_chars_
= NULL
;
195 /* Doing the kludge processing, so not initialized yet. */
196 static bool ffelex_kludge_flag_
= FALSE
;
198 /* The beginning of a (possible) CHARACTER/HOLLERITH token. */
199 static ffewhereLine ffelex_raw_where_line_
;
200 static ffewhereColumn ffelex_raw_where_col_
;
203 /* Call this to append another character to the current token. If it isn't
204 currently big enough for it, it will be enlarged. The current token
205 must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER. */
208 ffelex_append_to_token_ (char c
)
210 if (ffelex_token_
->text
== NULL
)
213 = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
214 FFELEX_columnTOKEN_SIZE_
+ 1);
215 ffelex_token_
->size
= FFELEX_columnTOKEN_SIZE_
;
216 ffelex_token_
->length
= 0;
218 else if (ffelex_token_
->length
>= ffelex_token_
->size
)
221 = malloc_resize_ksr (malloc_pool_image (),
223 (ffelex_token_
->size
<< 1) + 1,
224 ffelex_token_
->size
+ 1);
225 ffelex_token_
->size
<<= 1;
226 assert (ffelex_token_
->length
< ffelex_token_
->size
);
229 Sorry
, MAP_CHARACTER is
not going to work as expected in GNU Fortran
,
230 please contact fortran@gnu
.org
if you wish to fund work to
231 port g77 to non
-ASCII machines
.
233 ffelex_token_
->text
[ffelex_token_
->length
++] = c
;
236 /* Do backslash (escape) processing for a CHARACTER/HOLLERITH token
240 ffelex_backslash_ (int c
, ffewhereColumnNumber col
)
242 static int state
= 0;
243 static unsigned int count
;
245 static unsigned int firstdig
= 0;
247 static ffewhereLineNumber line
;
248 static ffewhereColumnNumber column
;
250 /* See gcc/c-lex.c readescape() for a straightforward version
251 of this state engine for handling backslashes in character/
252 hollerith constants. */
255 #define warn_traditional 0
256 #define flag_traditional 0
262 && (ffelex_raw_mode_
!= 0)
263 && ffe_is_backslash ())
267 line
= ffelex_linecount_current_
;
273 state
= 0; /* Assume simple case. */
277 if (warn_traditional
)
279 ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional",
280 FFEBAD_severityWARNING
);
281 ffelex_bad_here_ (0, line
, column
);
285 if (flag_traditional
)
294 case '0': case '1': case '2': case '3': case '4':
295 case '5': case '6': case '7':
301 case '\\': case '\'': case '"':
304 #if 0 /* Inappropriate for Fortran. */
306 ffelex_next_line_ ();
312 return TARGET_NEWLINE
;
327 if (warn_traditional
)
329 ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional",
330 FFEBAD_severityWARNING
);
331 ffelex_bad_here_ (0, line
, column
);
335 if (flag_traditional
)
340 #if 0 /* Vertical tab is present in common usage compilers. */
341 if (flag_traditional
)
358 ffebad_start_msg_lex ("Non-ANSI-C-standard escape sequence `\\%A' at %0",
359 FFEBAD_severityPEDANTIC
);
360 ffelex_bad_here_ (0, line
, column
);
364 return (c
== 'E' || c
== 'e') ? 033 : c
;
370 if (c
>= 040 && c
< 0177)
376 ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0",
377 FFEBAD_severityPEDANTIC
);
378 ffelex_bad_here_ (0, line
, column
);
384 ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0",
385 FFEBAD_severityPEDANTIC
);
386 ffelex_bad_here_ (0, line
, column
);
393 sprintf (&m
[0], "%x", c
);
394 ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0",
395 FFEBAD_severityPEDANTIC
);
396 ffelex_bad_here_ (0, line
, column
);
404 if ((c
>= 'a' && c
<= 'f')
405 || (c
>= 'A' && c
<= 'F')
406 || (c
>= '0' && c
<= '9'))
409 if (c
>= 'a' && c
<= 'f')
410 code
+= c
- 'a' + 10;
411 if (c
>= 'A' && c
<= 'F')
412 code
+= c
- 'A' + 10;
413 if (c
>= '0' && c
<= '9')
415 if (code
!= 0 || count
!= 0)
429 ffebad_start_msg_lex ("\\x used at %0 with no following hex digits",
430 FFEBAD_severityFATAL
);
431 ffelex_bad_here_ (0, line
, column
);
435 /* Digits are all 0's. Ok. */
437 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
439 && ((1 << (TYPE_PRECISION (integer_type_node
) - (count
- 1) * 4))
442 ffebad_start_msg_lex ("Hex escape at %0 out of range",
443 FFEBAD_severityPEDANTIC
);
444 ffelex_bad_here_ (0, line
, column
);
450 if ((c
<= '7') && (c
>= '0') && (count
++ < 3))
452 code
= (code
* 8) + (c
- '0');
459 assert ("bad backslash state" == NULL
);
463 /* Come here when code has a built character, and c is the next
464 character that might (or might not) be the next one in the constant. */
466 /* Don't bother doing this check for each character going into
467 CHARACTER or HOLLERITH constants, just the escaped-value ones.
468 gcc apparently checks every single character, which seems
469 like it'd be kinda slow and not worth doing anyway. */
472 && TYPE_PRECISION (char_type_node
) < HOST_BITS_PER_INT
473 && code
>= (1 << TYPE_PRECISION (char_type_node
)))
475 ffebad_start_msg_lex ("Escape sequence at %0 out of range for character",
476 FFEBAD_severityFATAL
);
477 ffelex_bad_here_ (0, line
, column
);
483 /* Known end of constant, just append this character. */
484 ffelex_append_to_token_ (code
);
485 if (ffelex_raw_mode_
> 0)
490 /* Have two characters to handle. Do the first, then leave it to the
491 caller to detect anything special about the second. */
493 ffelex_append_to_token_ (code
);
494 if (ffelex_raw_mode_
> 0)
496 ffelex_backslash_reconsider_
= TRUE
;
500 /* ffelex_bad_1_ -- Issue diagnostic with one source point
502 ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1);
504 Creates ffewhere line and column objects for the source point, sends them
505 along with the error code to ffebad, then kills the line and column
506 objects before returning. */
509 ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
)
514 wl0
= ffewhere_line_new (ln0
);
515 wc0
= ffewhere_column_new (cn0
);
516 ffebad_start_lex (errnum
);
517 ffebad_here (0, wl0
, wc0
);
519 ffewhere_line_kill (wl0
);
520 ffewhere_column_kill (wc0
);
523 /* ffelex_bad_2_ -- Issue diagnostic with two source points
525 ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1,
526 otherline,othercolumn);
528 Creates ffewhere line and column objects for the source points, sends them
529 along with the error code to ffebad, then kills the line and column
530 objects before returning. */
533 ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
,
534 ffewhereLineNumber ln1
, ffewhereColumnNumber cn1
)
536 ffewhereLine wl0
, wl1
;
537 ffewhereColumn wc0
, wc1
;
539 wl0
= ffewhere_line_new (ln0
);
540 wc0
= ffewhere_column_new (cn0
);
541 wl1
= ffewhere_line_new (ln1
);
542 wc1
= ffewhere_column_new (cn1
);
543 ffebad_start_lex (errnum
);
544 ffebad_here (0, wl0
, wc0
);
545 ffebad_here (1, wl1
, wc1
);
547 ffewhere_line_kill (wl0
);
548 ffewhere_column_kill (wc0
);
549 ffewhere_line_kill (wl1
);
550 ffewhere_column_kill (wc1
);
554 ffelex_bad_here_ (int n
, ffewhereLineNumber ln0
,
555 ffewhereColumnNumber cn0
)
560 wl0
= ffewhere_line_new (ln0
);
561 wc0
= ffewhere_column_new (cn0
);
562 ffebad_here (n
, wl0
, wc0
);
563 ffewhere_line_kill (wl0
);
564 ffewhere_column_kill (wc0
);
567 #if FFECOM_targetCURRENT == FFECOM_targetGCC
569 ffelex_getc_ (FILE *finput
)
573 if (ffelex_kludge_chars_
== NULL
)
574 return getc (finput
);
576 c
= *ffelex_kludge_chars_
++;
580 ffelex_kludge_chars_
= NULL
;
581 return getc (finput
);
585 #if FFECOM_targetCURRENT == FFECOM_targetGCC
587 ffelex_cfebackslash_ (int *use_d
, int *d
, FILE *finput
)
589 register int c
= getc (finput
);
591 register unsigned count
;
592 unsigned firstdig
= 0;
600 if (warn_traditional
)
601 warning ("the meaning of `\\x' varies with -traditional");
603 if (flag_traditional
)
612 if (!(c
>= 'a' && c
<= 'f')
613 && !(c
>= 'A' && c
<= 'F')
614 && !(c
>= '0' && c
<= '9'))
621 if (c
>= 'a' && c
<= 'f')
622 code
+= c
- 'a' + 10;
623 if (c
>= 'A' && c
<= 'F')
624 code
+= c
- 'A' + 10;
625 if (c
>= '0' && c
<= '9')
627 if (code
!= 0 || count
!= 0)
636 error ("\\x used with no following hex digits");
638 /* Digits are all 0's. Ok. */
640 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
643 << (TYPE_PRECISION (integer_type_node
) - (count
- 1)
646 pedwarn ("hex escape out of range");
649 case '0': case '1': case '2': case '3': case '4':
650 case '5': case '6': case '7':
653 while ((c
<= '7') && (c
>= '0') && (count
++ < 3))
655 code
= (code
* 8) + (c
- '0');
662 case '\\': case '\'': case '"':
666 ffelex_next_line_ ();
676 return TARGET_NEWLINE
;
691 if (warn_traditional
)
692 warning ("the meaning of `\\a' varies with -traditional");
694 if (flag_traditional
)
699 #if 0 /* Vertical tab is present in common usage compilers. */
700 if (flag_traditional
)
708 pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c
);
714 /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */
718 /* `\%' is used to prevent SCCS from getting confused. */
721 pedwarn ("non-ANSI escape sequence `\\%c'", c
);
724 if (c
>= 040 && c
< 0177)
725 pedwarn ("unknown escape sequence `\\%c'", c
);
727 pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c
);
732 /* A miniature version of the C front-end lexer. */
734 #if FFECOM_targetCURRENT == FFECOM_targetGCC
736 ffelex_cfelex_ (ffelexToken
*xtoken
, FILE *finput
, int c
)
743 register unsigned buffer_length
;
745 if ((*xtoken
!= NULL
) && !ffelex_kludge_flag_
)
746 ffelex_token_kill (*xtoken
);
750 case '0': case '1': case '2': case '3': case '4':
751 case '5': case '6': case '7': case '8': case '9':
752 buffer_length
= ARRAY_SIZE (buff
);
755 r
= &buff
[buffer_length
];
761 register unsigned bytes_used
= (p
- q
);
764 q
= (char *)xrealloc (q
, buffer_length
);
766 r
= &q
[buffer_length
];
768 c
= ffelex_getc_ (finput
);
773 token
= ffelex_token_new_number (q
, ffewhere_line_unknown (),
774 ffewhere_column_unknown ());
782 buffer_length
= ARRAY_SIZE (buff
);
785 r
= &buff
[buffer_length
];
786 c
= ffelex_getc_ (finput
);
800 case '\\': /* ~~~~~ */
801 c
= ffelex_cfebackslash_ (&use_d
, &d
, finput
);
806 fatal ("Badly formed directive -- no closing quote");
816 if (use_d
!= 2) /* 0=>c, 1=>cd, 2=>nil. */
821 register unsigned bytes_used
= (p
- q
);
823 buffer_length
= bytes_used
* 2;
824 q
= (char *)xrealloc (q
, buffer_length
);
826 r
= &q
[buffer_length
];
835 token
= ffelex_token_new_character (q
, ffewhere_line_unknown (),
836 ffewhere_column_unknown ());
853 #if FFECOM_targetCURRENT == FFECOM_targetGCC
855 ffelex_file_pop_ (const char *input_filename
)
857 if (input_file_stack
->next
)
859 struct file_stack
*p
= input_file_stack
;
860 input_file_stack
= p
->next
;
862 input_file_stack_tick
++;
863 #ifdef DWARF_DEBUGGING_INFO
864 if (debug_info_level
== DINFO_LEVEL_VERBOSE
865 && write_symbols
== DWARF_DEBUG
)
866 dwarfout_resume_previous_source_file (input_file_stack
->line
);
867 #endif /* DWARF_DEBUGGING_INFO */
870 error ("#-lines for entering and leaving files don't match");
872 /* Now that we've pushed or popped the input stack,
873 update the name in the top element. */
874 if (input_file_stack
)
875 input_file_stack
->name
= input_filename
;
879 #if FFECOM_targetCURRENT == FFECOM_targetGCC
881 ffelex_file_push_ (int old_lineno
, const char *input_filename
)
884 = (struct file_stack
*) xmalloc (sizeof (struct file_stack
));
886 input_file_stack
->line
= old_lineno
;
887 p
->next
= input_file_stack
;
888 p
->name
= input_filename
;
889 input_file_stack
= p
;
890 input_file_stack_tick
++;
891 #ifdef DWARF_DEBUGGING_INFO
892 if (debug_info_level
== DINFO_LEVEL_VERBOSE
893 && write_symbols
== DWARF_DEBUG
)
894 dwarfout_start_new_source_file (input_filename
);
895 #endif /* DWARF_DEBUGGING_INFO */
897 /* Now that we've pushed or popped the input stack,
898 update the name in the top element. */
899 if (input_file_stack
)
900 input_file_stack
->name
= input_filename
;
904 /* Prepare to finish a statement-in-progress by sending the current
905 token, if any, then setting up EOS as the current token with the
906 appropriate current pointer. The caller can then move the current
907 pointer before actually sending EOS, if desired, as it is in
908 typical fixed-form cases. */
911 ffelex_prepare_eos_ ()
913 if (ffelex_token_
->type
!= FFELEX_typeNONE
)
915 ffelex_backslash_ (EOF
, 0);
917 switch (ffelex_raw_mode_
)
923 ffebad_start_lex ((ffelex_raw_char_
== '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE
924 : FFEBAD_NO_CLOSING_QUOTE
);
925 ffebad_here (0, ffelex_token_
->where_line
, ffelex_token_
->where_col
);
926 ffebad_here (1, ffelex_current_wl_
, ffelex_current_wc_
);
937 ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS
);
938 ffebad_here (0, ffelex_token_
->where_line
, ffelex_token_
->where_col
);
939 ffebad_here (1, ffelex_current_wl_
, ffelex_current_wc_
);
940 sprintf (num
, "%lu", (unsigned long) ffelex_raw_mode_
);
943 /* Make sure the token has some text, might as well fill up with spaces. */
946 ffelex_append_to_token_ (' ');
947 } while (--ffelex_raw_mode_
> 0);
951 ffelex_raw_mode_
= 0;
952 ffelex_send_token_ ();
954 ffelex_token_
->type
= FFELEX_typeEOS
;
955 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
956 ffelex_token_
->where_col
= ffewhere_column_use (ffelex_current_wc_
);
960 ffelex_finish_statement_ ()
962 if ((ffelex_number_of_tokens_
== 0)
963 && (ffelex_token_
->type
== FFELEX_typeNONE
))
964 return; /* Don't have a statement pending. */
966 if (ffelex_token_
->type
!= FFELEX_typeEOS
)
967 ffelex_prepare_eos_ ();
969 ffelex_permit_include_
= TRUE
;
970 ffelex_send_token_ ();
971 ffelex_permit_include_
= FALSE
;
972 ffelex_number_of_tokens_
= 0;
973 ffelex_label_tokens_
= 0;
974 ffelex_names_
= TRUE
;
975 ffelex_names_pure_
= FALSE
; /* Probably not necessary. */
976 ffelex_hexnum_
= FALSE
;
978 if (!ffe_is_ffedebug ())
981 /* For debugging purposes only. */
983 if (ffelex_total_tokens_
!= ffelex_old_total_tokens_
)
985 fprintf (dmpout
, "; token_track had %ld tokens, now have %ld.\n",
986 ffelex_old_total_tokens_
, ffelex_total_tokens_
);
987 ffelex_old_total_tokens_
= ffelex_total_tokens_
;
991 /* Copied from gcc/c-common.c get_directive_line. */
993 #if FFECOM_targetCURRENT == FFECOM_targetGCC
995 ffelex_get_directive_line_ (char **text
, FILE *finput
)
997 static char *directive_buffer
= NULL
;
998 static unsigned buffer_length
= 0;
1000 register char *buffer_limit
;
1001 register int looking_for
= 0;
1002 register int char_escaped
= 0;
1004 if (buffer_length
== 0)
1006 directive_buffer
= (char *)xmalloc (128);
1007 buffer_length
= 128;
1010 buffer_limit
= &directive_buffer
[buffer_length
];
1012 for (p
= directive_buffer
; ; )
1016 /* Make buffer bigger if it is full. */
1017 if (p
>= buffer_limit
)
1019 register unsigned bytes_used
= (p
- directive_buffer
);
1023 = (char *)xrealloc (directive_buffer
, buffer_length
);
1024 p
= &directive_buffer
[bytes_used
];
1025 buffer_limit
= &directive_buffer
[buffer_length
];
1030 /* Discard initial whitespace. */
1031 if ((c
== ' ' || c
== '\t') && p
== directive_buffer
)
1034 /* Detect the end of the directive. */
1035 if ((c
== '\n' && looking_for
== 0)
1038 if (looking_for
!= 0)
1039 fatal ("Bad directive -- missing close-quote");
1042 *text
= directive_buffer
;
1048 ffelex_next_line_ ();
1050 /* Handle string and character constant syntax. */
1053 if (looking_for
== c
&& !char_escaped
)
1054 looking_for
= 0; /* Found terminator... stop looking. */
1057 if (c
== '\'' || c
== '"')
1058 looking_for
= c
; /* Don't stop buffering until we see another
1059 one of these (or an EOF). */
1061 /* Handle backslash. */
1062 char_escaped
= (c
== '\\' && ! char_escaped
);
1067 /* Handle # directives that make it through (or are generated by) the
1068 preprocessor. As much as reasonably possible, emulate the behavior
1069 of the gcc compiler phase cc1, though interactions between #include
1070 and INCLUDE might possibly produce bizarre results in terms of
1071 error reporting and the generation of debugging info vis-a-vis the
1072 locations of some things.
1074 Returns the next character unhandled, which is always newline or EOF. */
1076 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1078 #if defined HANDLE_PRAGMA
1079 /* Local versions of these macros, that can be passed as function pointers. */
1083 return getc (finput
);
1090 ungetc (arg
, finput
);
1092 #endif /* HANDLE_PRAGMA */
1095 ffelex_hash_ (FILE *finput
)
1098 ffelexToken token
= NULL
;
1100 /* Read first nonwhite char after the `#'. */
1102 c
= ffelex_getc_ (finput
);
1103 while (c
== ' ' || c
== '\t')
1104 c
= ffelex_getc_ (finput
);
1106 /* If a letter follows, then if the word here is `line', skip
1107 it and ignore it; otherwise, ignore the line, with an error
1108 if the word isn't `pragma', `ident', `define', or `undef'. */
1110 if ((c
>= 'a' && c
<= 'z') || (c
>= 'A' && c
<= 'Z'))
1114 if (getc (finput
) == 'r'
1115 && getc (finput
) == 'a'
1116 && getc (finput
) == 'g'
1117 && getc (finput
) == 'm'
1118 && getc (finput
) == 'a'
1119 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1122 #if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */
1123 static char buffer
[128];
1124 char * buff
= buffer
;
1126 /* Read the pragma name into a buffer.
1127 ISSPACE() may evaluate its argument more than once! */
1128 while (((c
= getc (finput
)), ISSPACE(c
)))
1136 while (c
!= EOF
&& ! ISSPACE (c
) && c
!= '\n'
1137 && buff
< buffer
+ 128);
1142 #ifdef HANDLE_PRAGMA
1143 if (HANDLE_PRAGMA (pragma_getc
, pragma_ungetc
, buffer
))
1145 #endif /* HANDLE_PRAGMA */
1146 #ifdef HANDLE_GENERIC_PRAGMAS
1147 if (handle_generic_pragma (buffer
))
1149 #endif /* !HANDLE_GENERIC_PRAGMAS */
1151 /* Issue a warning message if we have been asked to do so.
1152 Ignoring unknown pragmas in system header file unless
1153 an explcit -Wunknown-pragmas has been given. */
1154 if (warn_unknown_pragmas
> 1
1155 || (warn_unknown_pragmas
&& ! in_system_header
))
1156 warning ("ignoring pragma: %s", token_buffer
);
1164 if (getc (finput
) == 'e'
1165 && getc (finput
) == 'f'
1166 && getc (finput
) == 'i'
1167 && getc (finput
) == 'n'
1168 && getc (finput
) == 'e'
1169 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1174 c
= ffelex_get_directive_line_ (&text
, finput
);
1176 #ifdef DWARF_DEBUGGING_INFO
1177 if ((debug_info_level
== DINFO_LEVEL_VERBOSE
)
1178 && (write_symbols
== DWARF_DEBUG
))
1179 dwarfout_define (lineno
, text
);
1180 #endif /* DWARF_DEBUGGING_INFO */
1187 if (getc (finput
) == 'n'
1188 && getc (finput
) == 'd'
1189 && getc (finput
) == 'e'
1190 && getc (finput
) == 'f'
1191 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1196 c
= ffelex_get_directive_line_ (&text
, finput
);
1198 #ifdef DWARF_DEBUGGING_INFO
1199 if ((debug_info_level
== DINFO_LEVEL_VERBOSE
)
1200 && (write_symbols
== DWARF_DEBUG
))
1201 dwarfout_undef (lineno
, text
);
1202 #endif /* DWARF_DEBUGGING_INFO */
1209 if (getc (finput
) == 'i'
1210 && getc (finput
) == 'n'
1211 && getc (finput
) == 'e'
1212 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1217 if (getc (finput
) == 'd'
1218 && getc (finput
) == 'e'
1219 && getc (finput
) == 'n'
1220 && getc (finput
) == 't'
1221 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1223 /* #ident. The pedantic warning is now in cpp. */
1225 /* Here we have just seen `#ident '.
1226 A string constant should follow. */
1228 while (c
== ' ' || c
== '\t')
1231 /* If no argument, ignore the line. */
1232 if (c
== '\n' || c
== EOF
)
1235 c
= ffelex_cfelex_ (&token
, finput
, c
);
1238 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1240 error ("invalid #ident");
1244 if (! flag_no_ident
)
1246 #ifdef ASM_OUTPUT_IDENT
1247 ASM_OUTPUT_IDENT (asm_out_file
,
1248 ffelex_token_text (token
));
1252 /* Skip the rest of this line. */
1257 error ("undefined or invalid # directive");
1262 /* Here we have either `#line' or `# <nonletter>'.
1263 In either case, it should be a line number; a digit should follow. */
1265 while (c
== ' ' || c
== '\t')
1266 c
= ffelex_getc_ (finput
);
1268 /* If the # is the only nonwhite char on the line,
1269 just ignore it. Check the new newline. */
1270 if (c
== '\n' || c
== EOF
)
1273 /* Something follows the #; read a token. */
1275 c
= ffelex_cfelex_ (&token
, finput
, c
);
1278 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1280 int old_lineno
= lineno
;
1281 const char *old_input_filename
= input_filename
;
1284 /* subtract one, because it is the following line that
1285 gets the specified number */
1286 int l
= atoi (ffelex_token_text (token
)) - 1;
1288 /* Is this the last nonwhite stuff on the line? */
1289 while (c
== ' ' || c
== '\t')
1290 c
= ffelex_getc_ (finput
);
1291 if (c
== '\n' || c
== EOF
)
1293 /* No more: store the line number and check following line. */
1295 if (!ffelex_kludge_flag_
)
1297 ffewhere_file_set (NULL
, TRUE
, (ffewhereLineNumber
) l
);
1300 ffelex_token_kill (token
);
1305 /* More follows: it must be a string constant (filename). */
1307 /* Read the string constant. */
1308 c
= ffelex_cfelex_ (&token
, finput
, c
);
1311 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1313 error ("invalid #line");
1319 if (ffelex_kludge_flag_
)
1320 input_filename
= ggc_alloc_string (ffelex_token_text (token
), -1);
1323 wf
= ffewhere_file_new (ffelex_token_text (token
),
1324 ffelex_token_length (token
));
1325 input_filename
= ffewhere_file_name (wf
);
1326 ffewhere_file_set (wf
, TRUE
, (ffewhereLineNumber
) l
);
1329 #if 0 /* Not sure what g77 should do with this yet. */
1330 /* Each change of file name
1331 reinitializes whether we are now in a system header. */
1332 in_system_header
= 0;
1335 if (main_input_filename
== 0)
1336 main_input_filename
= input_filename
;
1338 /* Is this the last nonwhite stuff on the line? */
1339 while (c
== ' ' || c
== '\t')
1341 if (c
== '\n' || c
== EOF
)
1343 if (!ffelex_kludge_flag_
)
1345 /* Update the name in the top element of input_file_stack. */
1346 if (input_file_stack
)
1347 input_file_stack
->name
= input_filename
;
1350 ffelex_token_kill (token
);
1355 c
= ffelex_cfelex_ (&token
, finput
, c
);
1357 /* `1' after file name means entering new file.
1358 `2' after file name means just left a file. */
1361 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1363 int num
= atoi (ffelex_token_text (token
));
1365 if (ffelex_kludge_flag_
)
1368 input_filename
= old_input_filename
;
1369 fatal ("Use `#line ...' instead of `# ...' in first line");
1374 /* Pushing to a new file. */
1375 ffelex_file_push_ (old_lineno
, input_filename
);
1379 /* Popping out of a file. */
1380 ffelex_file_pop_ (input_filename
);
1383 /* Is this the last nonwhite stuff on the line? */
1384 while (c
== ' ' || c
== '\t')
1386 if (c
== '\n' || c
== EOF
)
1389 ffelex_token_kill (token
);
1393 c
= ffelex_cfelex_ (&token
, finput
, c
);
1396 /* `3' after file name means this is a system header file. */
1398 #if 0 /* Not sure what g77 should do with this yet. */
1400 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
)
1401 && (atoi (ffelex_token_text (token
)) == 3))
1402 in_system_header
= 1;
1405 while (c
== ' ' || c
== '\t')
1407 if (((token
!= NULL
)
1408 || (c
!= '\n' && c
!= EOF
))
1409 && ffelex_kludge_flag_
)
1412 input_filename
= old_input_filename
;
1413 fatal ("Use `#line ...' instead of `# ...' in first line");
1417 error ("invalid #-line");
1419 /* skip the rest of this line. */
1421 if ((token
!= NULL
) && !ffelex_kludge_flag_
)
1422 ffelex_token_kill (token
);
1423 while ((c
= getc (finput
)) != EOF
&& c
!= '\n')
1427 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1429 /* "Image" a character onto the card image, return incremented column number.
1431 Normally invoking this function as in
1432 column = ffelex_image_char_ (c, column);
1433 is the same as doing:
1434 ffelex_card_image_[column++] = c;
1436 However, tabs and carriage returns are handled specially, to preserve
1437 the visual "image" of the input line (in most editors) in the card
1440 Carriage returns are ignored, as they are assumed to be followed
1443 A tab is handled by first doing:
1444 ffelex_card_image_[column++] = ' ';
1445 That is, it translates to at least one space. Then, as many spaces
1446 are imaged as necessary to bring the column number to the next tab
1447 position, where tab positions start in the ninth column and each
1448 eighth column afterwards. ALSO, a static var named ffelex_saw_tab_
1449 is set to TRUE to notify the lexer that a tab was seen.
1451 Columns are numbered and tab stops set as illustrated below:
1453 012345670123456701234567...
1457 xxxxxxx yyyyyyy zzzzzzz
1458 xxxxxxxx yyyyyyyy... */
1460 static ffewhereColumnNumber
1461 ffelex_image_char_ (int c
, ffewhereColumnNumber column
)
1463 ffewhereColumnNumber old_column
= column
;
1465 if (column
>= ffelex_card_size_
)
1467 ffewhereColumnNumber newmax
= ffelex_card_size_
<< 1;
1469 if (ffelex_bad_line_
)
1472 if ((newmax
>> 1) != ffelex_card_size_
)
1473 { /* Overflowed column number. */
1474 overflow
: /* :::::::::::::::::::: */
1476 ffelex_bad_line_
= TRUE
;
1477 strcpy (&ffelex_card_image_
[column
- 3], "...");
1478 ffelex_card_length_
= column
;
1479 ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG
,
1480 ffelex_linecount_current_
, column
+ 1);
1485 = malloc_resize_ksr (malloc_pool_image (),
1488 ffelex_card_size_
+ 9);
1489 ffelex_card_size_
= newmax
;
1498 ffelex_saw_tab_
= TRUE
;
1499 ffelex_card_image_
[column
++] = ' ';
1500 while ((column
& 7) != 0)
1501 ffelex_card_image_
[column
++] = ' ';
1505 if (!ffelex_bad_line_
)
1507 ffelex_bad_line_
= TRUE
;
1508 strcpy (&ffelex_card_image_
[column
], "[\\0]");
1509 ffelex_card_length_
= column
+ 4;
1510 ffebad_start_msg_lex ("Null character at %0 -- line ignored",
1511 FFEBAD_severityFATAL
);
1512 ffelex_bad_here_ (0, ffelex_linecount_current_
, column
+ 1);
1519 ffelex_card_image_
[column
++] = c
;
1523 if (column
< old_column
)
1525 column
= old_column
;
1526 goto overflow
; /* :::::::::::::::::::: */
1535 ffewhereFile include_wherefile
= ffelex_include_wherefile_
;
1536 FILE *include_file
= ffelex_include_file_
;
1537 /* The rest of this is to push, and after the INCLUDE file is processed,
1538 pop, the static lexer state info that pertains to each particular
1541 ffewhereColumnNumber card_size
= ffelex_card_size_
;
1542 ffewhereColumnNumber card_length
= ffelex_card_length_
;
1543 ffewhereLine current_wl
= ffelex_current_wl_
;
1544 ffewhereColumn current_wc
= ffelex_current_wc_
;
1545 bool saw_tab
= ffelex_saw_tab_
;
1546 ffewhereColumnNumber final_nontab_column
= ffelex_final_nontab_column_
;
1547 ffewhereFile current_wf
= ffelex_current_wf_
;
1548 ffewhereLineNumber linecount_current
= ffelex_linecount_current_
;
1549 ffewhereLineNumber linecount_offset
1550 = ffewhere_line_filelinenum (current_wl
);
1551 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1552 int old_lineno
= lineno
;
1553 const char *old_input_filename
= input_filename
;
1556 if (card_length
!= 0)
1558 card_image
= malloc_new_ks (malloc_pool_image (),
1559 "FFELEX saved card image",
1561 memcpy (card_image
, ffelex_card_image_
, card_length
);
1566 ffelex_set_include_
= FALSE
;
1568 ffelex_next_line_ ();
1570 ffewhere_file_set (include_wherefile
, TRUE
, 0);
1572 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1573 ffelex_file_push_ (old_lineno
, ffewhere_file_name (include_wherefile
));
1574 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1576 if (ffelex_include_free_form_
)
1577 ffelex_file_free (include_wherefile
, include_file
);
1579 ffelex_file_fixed (include_wherefile
, include_file
);
1581 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1582 ffelex_file_pop_ (ffewhere_file_name (current_wf
));
1583 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1585 ffewhere_file_set (current_wf
, TRUE
, linecount_offset
);
1587 ffecom_close_include (include_file
);
1589 if (card_length
!= 0)
1591 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1592 #error "need to handle possible reduction of card size here!!"
1594 assert (ffelex_card_size_
>= card_length
); /* It shrunk?? */
1595 memcpy (ffelex_card_image_
, card_image
, card_length
);
1597 ffelex_card_image_
[card_length
] = '\0';
1599 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1600 input_filename
= old_input_filename
;
1601 lineno
= old_lineno
;
1603 ffelex_linecount_current_
= linecount_current
;
1604 ffelex_current_wf_
= current_wf
;
1605 ffelex_final_nontab_column_
= final_nontab_column
;
1606 ffelex_saw_tab_
= saw_tab
;
1607 ffelex_current_wc_
= current_wc
;
1608 ffelex_current_wl_
= current_wl
;
1609 ffelex_card_length_
= card_length
;
1610 ffelex_card_size_
= card_size
;
1613 /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation?
1615 ffewhereColumnNumber col;
1616 int c; // Char at col.
1617 if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1))
1618 // We have a continuation indicator.
1620 If there are <n> spaces starting at ffelex_card_image_[col] up through
1621 the null character, where <n> is 0 or greater, returns TRUE. */
1624 ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
)
1626 while (ffelex_card_image_
[col
] != '\0')
1628 if (ffelex_card_image_
[col
++] != ' ')
1634 /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation?
1636 ffewhereColumnNumber col;
1637 int c; // Char at col.
1638 if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1))
1639 // We have a continuation indicator.
1641 If there are <n> spaces starting at ffelex_card_image_[col] up through
1642 the null character or '!', where <n> is 0 or greater, returns TRUE. */
1645 ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
)
1647 while ((ffelex_card_image_
[col
] != '\0') && (ffelex_card_image_
[col
] != '!'))
1649 if (ffelex_card_image_
[col
++] != ' ')
1656 ffelex_next_line_ ()
1658 ffelex_linecount_current_
= ffelex_linecount_next_
;
1659 ++ffelex_linecount_next_
;
1660 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1666 ffelex_send_token_ ()
1668 ++ffelex_number_of_tokens_
;
1670 ffelex_backslash_ (EOF
, 0);
1672 if (ffelex_token_
->text
== NULL
)
1674 if (ffelex_token_
->type
== FFELEX_typeCHARACTER
)
1676 ffelex_append_to_token_ ('\0');
1677 ffelex_token_
->length
= 0;
1681 ffelex_token_
->text
[ffelex_token_
->length
] = '\0';
1683 assert (ffelex_raw_mode_
== 0);
1685 if (ffelex_token_
->type
== FFELEX_typeNAMES
)
1687 ffewhere_line_kill (ffelex_token_
->currentnames_line
);
1688 ffewhere_column_kill (ffelex_token_
->currentnames_col
);
1691 assert (ffelex_handler_
!= NULL
);
1692 ffelex_handler_
= (ffelexHandler
) (*ffelex_handler_
) (ffelex_token_
);
1693 assert (ffelex_handler_
!= NULL
);
1695 ffelex_token_kill (ffelex_token_
);
1697 ffelex_token_
= ffelex_token_new_ ();
1698 ffelex_token_
->uses
= 1;
1699 ffelex_token_
->text
= NULL
;
1700 if (ffelex_raw_mode_
< 0)
1702 ffelex_token_
->type
= FFELEX_typeCHARACTER
;
1703 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
1704 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
1705 ffelex_raw_where_line_
= ffewhere_line_unknown ();
1706 ffelex_raw_where_col_
= ffewhere_column_unknown ();
1710 ffelex_token_
->type
= FFELEX_typeNONE
;
1711 ffelex_token_
->where_line
= ffewhere_line_unknown ();
1712 ffelex_token_
->where_col
= ffewhere_column_unknown ();
1715 if (ffelex_set_include_
)
1719 /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me
1721 return ffelex_swallow_tokens_;
1723 Return this handler when you don't want to look at any more tokens in the
1724 statement because you've encountered an unrecoverable error in the
1727 static ffelexHandler
1728 ffelex_swallow_tokens_ (ffelexToken t
)
1730 assert (ffelex_eos_handler_
!= NULL
);
1732 if ((ffelex_token_type (t
) == FFELEX_typeEOS
)
1733 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
))
1734 return (ffelexHandler
) (*ffelex_eos_handler_
) (t
);
1736 return (ffelexHandler
) ffelex_swallow_tokens_
;
1740 ffelex_token_new_ ()
1744 ++ffelex_total_tokens_
;
1746 t
= (ffelexToken
) malloc_new_ks (malloc_pool_image (),
1747 "FFELEX token", sizeof (*t
));
1748 t
->id_
= ffelex_token_nextid_
++;
1753 ffelex_type_string_ (ffelexType type
)
1755 static const char *types
[] = {
1757 "FFELEX_typeCOMMENT",
1763 "FFELEX_typeDOLLAR",
1765 "FFELEX_typePERCENT",
1766 "FFELEX_typeAMPERSAND",
1767 "FFELEX_typeAPOSTROPHE",
1768 "FFELEX_typeOPEN_PAREN",
1769 "FFELEX_typeCLOSE_PAREN",
1770 "FFELEX_typeASTERISK",
1773 "FFELEX_typePERIOD",
1775 "FFELEX_typeNUMBER",
1776 "FFELEX_typeOPEN_ANGLE",
1777 "FFELEX_typeEQUALS",
1778 "FFELEX_typeCLOSE_ANGLE",
1782 "FFELEX_typeCONCAT",
1785 "FFELEX_typeHOLLERITH",
1786 "FFELEX_typeCHARACTER",
1788 "FFELEX_typeSEMICOLON",
1789 "FFELEX_typeUNDERSCORE",
1790 "FFELEX_typeQUESTION",
1791 "FFELEX_typeOPEN_ARRAY",
1792 "FFELEX_typeCLOSE_ARRAY",
1793 "FFELEX_typeCOLONCOLON",
1794 "FFELEX_typeREL_LE",
1795 "FFELEX_typeREL_NE",
1796 "FFELEX_typeREL_EQ",
1797 "FFELEX_typePOINTS",
1801 if (type
>= ARRAY_SIZE (types
))
1807 ffelex_display_token (ffelexToken t
)
1812 fprintf (dmpout
, "; Token #%lu is %s (line %" ffewhereLineNumber_f
"u, col %"
1813 ffewhereColumnNumber_f
"u)",
1815 ffelex_type_string_ (t
->type
),
1816 ffewhere_line_number (t
->where_line
),
1817 ffewhere_column_number (t
->where_col
));
1819 if (t
->text
!= NULL
)
1820 fprintf (dmpout
, ": \"%.*s\"\n",
1824 fprintf (dmpout
, ".\n");
1827 /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER
1829 if (ffelex_expecting_character())
1830 // next token delivered by lexer will be CHARACTER.
1832 If the most recent call to ffelex_set_expecting_hollerith since the last
1833 token was delivered by the lexer passed a length of -1, then we return
1834 TRUE, because the next token we deliver will be typeCHARACTER, else we
1838 ffelex_expecting_character ()
1840 return (ffelex_raw_mode_
!= 0);
1843 /* ffelex_file_fixed -- Lex a given file in fixed source form
1847 ffelex_file_fixed(wf,f);
1849 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
1852 ffelex_file_fixed (ffewhereFile wf
, FILE *f
)
1854 register int c
= 0; /* Character currently under consideration. */
1855 register ffewhereColumnNumber column
= 0; /* Not really; 0 means column 1... */
1856 bool disallow_continuation_line
;
1857 bool ignore_disallowed_continuation
= FALSE
;
1858 int latest_char_in_file
= 0; /* For getting back into comment-skipping
1861 ffewhereColumnNumber first_label_char
; /* First char of label --
1863 char label_string
[6]; /* Text of label. */
1864 int labi
; /* Length of label text. */
1865 bool finish_statement
; /* Previous statement finished? */
1866 bool have_content
; /* This line have content? */
1867 bool just_do_label
; /* Nothing but label (and continuation?) on
1870 /* Lex is called for a particular file, not for a particular program unit.
1871 Yet the two events do share common characteristics. The first line in a
1872 file or in a program unit cannot be a continuation line. No token can
1873 be in mid-formation. No current label for the statement exists, since
1874 there is no current statement. */
1876 assert (ffelex_handler_
!= NULL
);
1878 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1880 input_filename
= ffewhere_file_name (wf
);
1882 ffelex_current_wf_
= wf
;
1883 disallow_continuation_line
= TRUE
;
1884 ignore_disallowed_continuation
= FALSE
;
1885 ffelex_token_
->type
= FFELEX_typeNONE
;
1886 ffelex_number_of_tokens_
= 0;
1887 ffelex_label_tokens_
= 0;
1888 ffelex_current_wl_
= ffewhere_line_unknown ();
1889 ffelex_current_wc_
= ffewhere_column_unknown ();
1890 latest_char_in_file
= '\n';
1892 if (ffe_is_null_version ())
1894 /* Just substitute a "program" directly here. */
1896 char line
[] = " call g77__fvers;call g77__ivers;call g77__uvers;end";
1900 for (p
= &line
[0]; *p
!= '\0'; ++p
)
1901 column
= ffelex_image_char_ (*p
, column
);
1905 goto have_line
; /* :::::::::::::::::::: */
1908 goto first_line
; /* :::::::::::::::::::: */
1910 /* Come here to get a new line. */
1912 beginning_of_line
: /* :::::::::::::::::::: */
1914 disallow_continuation_line
= FALSE
;
1916 /* Come here directly when last line didn't clarify the continuation issue. */
1918 beginning_of_line_again
: /* :::::::::::::::::::: */
1920 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1921 if (ffelex_card_size_
!= FFELEX_columnINITIAL_SIZE_
)
1924 = malloc_resize_ks (malloc_pool_image (),
1926 FFELEX_columnINITIAL_SIZE_
+ 9,
1927 ffelex_card_size_
+ 9);
1928 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
1932 first_line
: /* :::::::::::::::::::: */
1934 c
= latest_char_in_file
;
1935 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
1938 end_of_file
: /* :::::::::::::::::::: */
1940 /* Line ending in EOF instead of \n still counts as a whole line. */
1942 ffelex_finish_statement_ ();
1943 ffewhere_line_kill (ffelex_current_wl_
);
1944 ffewhere_column_kill (ffelex_current_wc_
);
1945 return (ffelexHandler
) ffelex_handler_
;
1948 ffelex_next_line_ ();
1950 ffelex_bad_line_
= FALSE
;
1952 /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1954 while (((lextype
= ffelex_first_char_
[c
]) == FFELEX_typeCOMMENT
)
1955 || (lextype
== FFELEX_typeERROR
)
1956 || (lextype
== FFELEX_typeSLASH
)
1957 || (lextype
== FFELEX_typeHASH
))
1959 /* Test most frequent type of line first, etc. */
1960 if ((lextype
== FFELEX_typeCOMMENT
)
1961 || ((lextype
== FFELEX_typeSLASH
)
1962 && ((c
= getc (f
)) == '*'))) /* NOTE SIDE-EFFECT. */
1964 /* Typical case (straight comment), just ignore rest of line. */
1965 comment_line
: /* :::::::::::::::::::: */
1967 while ((c
!= '\n') && (c
!= EOF
))
1970 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1971 else if (lextype
== FFELEX_typeHASH
)
1972 c
= ffelex_hash_ (f
);
1974 else if (lextype
== FFELEX_typeSLASH
)
1976 /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1977 ffelex_card_image_
[0] = '/';
1978 ffelex_card_image_
[1] = c
;
1980 goto bad_first_character
; /* :::::::::::::::::::: */
1983 /* typeERROR or unsupported typeHASH. */
1984 { /* Bad first character, get line and display
1986 column
= ffelex_image_char_ (c
, 0);
1988 bad_first_character
: /* :::::::::::::::::::: */
1990 ffelex_bad_line_
= TRUE
;
1991 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
1992 column
= ffelex_image_char_ (c
, column
);
1993 ffelex_card_image_
[column
] = '\0';
1994 ffelex_card_length_
= column
;
1995 ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID
,
1996 ffelex_linecount_current_
, 1);
1999 /* Read past last char in line. */
2003 ffelex_next_line_ ();
2004 goto end_of_file
; /* :::::::::::::::::::: */
2009 ffelex_next_line_ ();
2012 goto end_of_file
; /* :::::::::::::::::::: */
2014 ffelex_bad_line_
= FALSE
;
2015 } /* while [c, first char, means comment] */
2019 || (ffelex_final_nontab_column_
== 0);
2021 if (lextype
== FFELEX_typeDEBUG
)
2022 c
= ' '; /* A 'D' or 'd' in column 1 with the
2023 debug-lines option on. */
2025 column
= ffelex_image_char_ (c
, 0);
2027 /* Read the entire line in as is (with whitespace processing). */
2029 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
2030 column
= ffelex_image_char_ (c
, column
);
2032 if (ffelex_bad_line_
)
2034 ffelex_card_image_
[column
] = '\0';
2035 ffelex_card_length_
= column
;
2036 goto comment_line
; /* :::::::::::::::::::: */
2039 /* If no tab, cut off line after column 72/132. */
2041 if (!ffelex_saw_tab_
&& (column
> ffelex_final_nontab_column_
))
2043 /* Technically, we should now fill ffelex_card_image_ up thru column
2044 72/132 with spaces, since character/hollerith constants must count
2045 them in that manner. To save CPU time in several ways (avoid a loop
2046 here that would be used only when we actually end a line in
2047 character-constant mode; avoid writing memory unnecessarily; avoid a
2048 loop later checking spaces when not scanning for character-constant
2049 characters), we don't do this, and we do the appropriate thing when
2050 we encounter end-of-line while actually processing a character
2053 column
= ffelex_final_nontab_column_
;
2056 have_line
: /* :::::::::::::::::::: */
2058 ffelex_card_image_
[column
] = '\0';
2059 ffelex_card_length_
= column
;
2061 /* Save next char in file so we can use register-based c while analyzing
2062 line we just read. */
2064 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
2066 have_content
= FALSE
;
2068 /* Handle label, if any. */
2071 first_label_char
= FFEWHERE_columnUNKNOWN
;
2072 for (column
= 0; column
< 5; ++column
)
2074 switch (c
= ffelex_card_image_
[column
])
2078 goto stop_looking
; /* :::::::::::::::::::: */
2093 label_string
[labi
++] = c
;
2094 if (first_label_char
== FFEWHERE_columnUNKNOWN
)
2095 first_label_char
= column
+ 1;
2101 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2102 ffelex_linecount_current_
,
2104 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2106 if (ffe_is_pedantic ())
2107 ffelex_bad_1_ (FFEBAD_AMPERSAND
,
2108 ffelex_linecount_current_
, 1);
2109 finish_statement
= FALSE
;
2110 just_do_label
= FALSE
;
2111 goto got_a_continuation
; /* :::::::::::::::::::: */
2114 if (ffelex_card_image_
[column
+ 1] == '*')
2115 goto stop_looking
; /* :::::::::::::::::::: */
2118 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2119 ffelex_linecount_current_
, column
+ 1);
2120 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2124 stop_looking
: /* :::::::::::::::::::: */
2126 label_string
[labi
] = '\0';
2128 /* Find first nonblank char starting with continuation column. */
2130 if (column
== 5) /* In which case we didn't see end of line in
2132 while ((c
= ffelex_card_image_
[column
]) == ' ')
2135 /* Now we're trying to figure out whether this is a continuation line and
2136 whether there's anything else of substance on the line. The cases are
2139 1. If a line has an explicit continuation character (other than the digit
2140 zero), then if it also has a label, the label is ignored and an error
2141 message is printed. Any remaining text on the line is passed to the
2142 parser tasks, thus even an all-blank line (possibly with an ignored
2143 label) aside from a positive continuation character might have meaning
2144 in the midst of a character or hollerith constant.
2146 2. If a line has no explicit continuation character (that is, it has a
2147 space in column 6 and the first non-space character past column 6 is
2148 not a digit 0-9), then there are two possibilities:
2150 A. A label is present and/or a non-space (and non-comment) character
2151 appears somewhere after column 6. Terminate processing of the previous
2152 statement, if any, send the new label for the next statement, if any,
2153 and start processing a new statement with this non-blank character, if
2156 B. The line is essentially blank, except for a possible comment character.
2157 Don't terminate processing of the previous statement and don't pass any
2158 characters to the parser tasks, since the line is not flagged as a
2159 continuation line. We treat it just like a completely blank line.
2161 3. If a line has a continuation character of zero (0), then we terminate
2162 processing of the previous statement, if any, send the new label for the
2163 next statement, if any, and start processing a new statement, if any
2164 non-blank characters are present.
2166 If, when checking to see if we should terminate the previous statement, it
2167 is found that there is no previous statement but that there is an
2168 outstanding label, substitute CONTINUE as the statement for the label
2169 and display an error message. */
2171 finish_statement
= FALSE
;
2172 just_do_label
= FALSE
;
2176 case '!': /* ANSI Fortran 90 says ! in column 6 is
2178 /* VXT Fortran says ! anywhere is comment, even column 6. */
2179 if (ffe_is_vxt () || (column
!= 5))
2180 goto no_tokens_on_line
; /* :::::::::::::::::::: */
2181 goto got_a_continuation
; /* :::::::::::::::::::: */
2184 if (ffelex_card_image_
[column
+ 1] != '*')
2185 goto some_other_character
; /* :::::::::::::::::::: */
2189 /* This seems right to do. But it is close to call, since / * starting
2190 in column 6 will thus be interpreted as a continuation line
2191 beginning with '*'. */
2193 goto got_a_continuation
;/* :::::::::::::::::::: */
2197 /* End of line. Therefore may be continued-through line, so handle
2198 pending label as possible to-be-continued and drive end-of-statement
2199 for any previous statement, else treat as blank line. */
2201 no_tokens_on_line
: /* :::::::::::::::::::: */
2203 if (ffe_is_pedantic () && (c
== '/'))
2204 ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT
,
2205 ffelex_linecount_current_
, column
+ 1);
2206 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2207 { /* Can't be a continued-through line if it
2209 finish_statement
= TRUE
;
2210 have_content
= TRUE
;
2211 just_do_label
= TRUE
;
2214 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2217 if (ffe_is_pedantic () && (column
!= 5))
2218 ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN
,
2219 ffelex_linecount_current_
, column
+ 1);
2220 finish_statement
= TRUE
;
2221 goto check_for_content
; /* :::::::::::::::::::: */
2233 /* NOTE: This label can be reached directly from the code
2234 that lexes the label field in columns 1-5. */
2235 got_a_continuation
: /* :::::::::::::::::::: */
2237 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2239 ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION
,
2240 ffelex_linecount_current_
,
2242 ffelex_linecount_current_
,
2244 first_label_char
= FFEWHERE_columnUNKNOWN
;
2246 if (disallow_continuation_line
)
2248 if (!ignore_disallowed_continuation
)
2249 ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION
,
2250 ffelex_linecount_current_
, column
+ 1);
2251 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2253 if (ffe_is_pedantic () && (column
!= 5))
2254 ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN
,
2255 ffelex_linecount_current_
, column
+ 1);
2256 if ((ffelex_raw_mode_
!= 0)
2257 && (((c
= ffelex_card_image_
[column
+ 1]) != '\0')
2258 || !ffelex_saw_tab_
))
2261 have_content
= TRUE
;
2265 check_for_content
: /* :::::::::::::::::::: */
2267 while ((c
= ffelex_card_image_
[++column
]) == ' ')
2272 && (ffelex_card_image_
[column
+ 1] == '*')))
2274 if (ffe_is_pedantic () && (c
== '/'))
2275 ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT
,
2276 ffelex_linecount_current_
, column
+ 1);
2277 just_do_label
= TRUE
;
2280 have_content
= TRUE
;
2285 some_other_character
: /* :::::::::::::::::::: */
2288 goto got_a_continuation
;/* :::::::::::::::::::: */
2290 /* Here is the very normal case of a regular character starting in
2291 column 7 or beyond with a blank in column 6. */
2293 finish_statement
= TRUE
;
2294 have_content
= TRUE
;
2299 || (first_label_char
!= FFEWHERE_columnUNKNOWN
))
2301 /* The line has content of some kind, install new end-statement
2302 point for error messages. Note that "content" includes cases
2303 where there's little apparent content but enough to finish
2304 a statement. That's because finishing a statement can trigger
2305 an impending INCLUDE, and that requires accurate line info being
2306 maintained by the lexer. */
2308 if (finish_statement
)
2309 ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
2311 ffewhere_line_kill (ffelex_current_wl_
);
2312 ffewhere_column_kill (ffelex_current_wc_
);
2313 ffelex_current_wl_
= ffewhere_line_new (ffelex_linecount_current_
);
2314 ffelex_current_wc_
= ffewhere_column_new (ffelex_card_length_
+ 1);
2317 /* We delay this for a combination of reasons. Mainly, it can start
2318 INCLUDE processing, and we want to delay that until the lexer's
2319 info on the line is coherent. And we want to delay that until we're
2320 sure there's a reason to make that info coherent, to avoid saving
2321 lots of useless lines. */
2323 if (finish_statement
)
2324 ffelex_finish_statement_ ();
2326 /* If label is present, enclose it in a NUMBER token and send it along. */
2328 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2330 assert (ffelex_token_
->type
== FFELEX_typeNONE
);
2331 ffelex_token_
->type
= FFELEX_typeNUMBER
;
2332 ffelex_append_to_token_ ('\0'); /* Make room for label text. */
2333 strcpy (ffelex_token_
->text
, label_string
);
2334 ffelex_token_
->where_line
2335 = ffewhere_line_use (ffelex_current_wl_
);
2336 ffelex_token_
->where_col
= ffewhere_column_new (first_label_char
);
2337 ffelex_token_
->length
= labi
;
2338 ffelex_send_token_ ();
2339 ++ffelex_label_tokens_
;
2343 goto beginning_of_line
; /* :::::::::::::::::::: */
2345 /* Here is the main engine for parsing. c holds the character at column.
2346 It is already known that c is not a blank, end of line, or shriek,
2347 unless ffelex_raw_mode_ is not 0 (indicating we are in a
2348 character/hollerith constant). A partially filled token may already
2349 exist in ffelex_token_. One special case: if, when the end of the line
2350 is reached, continuation_line is FALSE and the only token on the line is
2351 END, then it is indeed the last statement. We don't look for
2352 continuation lines during this program unit in that case. This is
2353 according to ANSI. */
2355 if (ffelex_raw_mode_
!= 0)
2358 parse_raw_character
: /* :::::::::::::::::::: */
2362 ffewhereColumnNumber i
;
2364 if (ffelex_saw_tab_
|| (column
>= ffelex_final_nontab_column_
))
2365 goto beginning_of_line
; /* :::::::::::::::::::: */
2367 /* Pad out line with "virtual" spaces. */
2369 for (i
= column
; i
< ffelex_final_nontab_column_
; ++i
)
2370 ffelex_card_image_
[i
] = ' ';
2371 ffelex_card_image_
[i
] = '\0';
2372 ffelex_card_length_
= i
;
2376 switch (ffelex_raw_mode_
)
2379 c
= ffelex_backslash_ (c
, column
);
2383 if (!ffelex_backslash_reconsider_
)
2384 ffelex_append_to_token_ (c
);
2385 ffelex_raw_mode_
= -1;
2389 if (c
== ffelex_raw_char_
)
2391 ffelex_raw_mode_
= -1;
2392 ffelex_append_to_token_ (c
);
2396 ffelex_raw_mode_
= 0;
2397 ffelex_backslash_reconsider_
= TRUE
;
2402 if (c
== ffelex_raw_char_
)
2403 ffelex_raw_mode_
= -2;
2406 c
= ffelex_backslash_ (c
, column
);
2409 ffelex_raw_mode_
= -3;
2413 ffelex_append_to_token_ (c
);
2418 c
= ffelex_backslash_ (c
, column
);
2422 if (!ffelex_backslash_reconsider_
)
2424 ffelex_append_to_token_ (c
);
2430 if (ffelex_backslash_reconsider_
)
2431 ffelex_backslash_reconsider_
= FALSE
;
2433 c
= ffelex_card_image_
[++column
];
2435 if (ffelex_raw_mode_
== 0)
2437 ffelex_send_token_ ();
2438 assert (ffelex_raw_mode_
== 0);
2440 c
= ffelex_card_image_
[++column
];
2444 && (ffelex_card_image_
[column
+ 1] == '*')))
2445 goto beginning_of_line
; /* :::::::::::::::::::: */
2446 goto parse_nonraw_character
; /* :::::::::::::::::::: */
2448 goto parse_raw_character
; /* :::::::::::::::::::: */
2451 parse_nonraw_character
: /* :::::::::::::::::::: */
2453 switch (ffelex_token_
->type
)
2455 case FFELEX_typeNONE
:
2459 ffelex_token_
->type
= FFELEX_typeQUOTE
;
2460 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2461 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2462 ffelex_send_token_ ();
2466 ffelex_token_
->type
= FFELEX_typeDOLLAR
;
2467 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2468 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2469 ffelex_send_token_ ();
2473 ffelex_token_
->type
= FFELEX_typePERCENT
;
2474 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2475 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2476 ffelex_send_token_ ();
2480 ffelex_token_
->type
= FFELEX_typeAMPERSAND
;
2481 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2482 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2483 ffelex_send_token_ ();
2487 ffelex_token_
->type
= FFELEX_typeAPOSTROPHE
;
2488 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2489 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2490 ffelex_send_token_ ();
2494 ffelex_token_
->type
= FFELEX_typeOPEN_PAREN
;
2495 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2496 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2500 ffelex_token_
->type
= FFELEX_typeCLOSE_PAREN
;
2501 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2502 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2503 ffelex_send_token_ ();
2507 ffelex_token_
->type
= FFELEX_typeASTERISK
;
2508 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2509 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2513 ffelex_token_
->type
= FFELEX_typePLUS
;
2514 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2515 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2516 ffelex_send_token_ ();
2520 ffelex_token_
->type
= FFELEX_typeCOMMA
;
2521 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2522 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2523 ffelex_send_token_ ();
2527 ffelex_token_
->type
= FFELEX_typeMINUS
;
2528 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2529 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2530 ffelex_send_token_ ();
2534 ffelex_token_
->type
= FFELEX_typePERIOD
;
2535 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2536 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2537 ffelex_send_token_ ();
2541 ffelex_token_
->type
= FFELEX_typeSLASH
;
2542 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2543 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2557 = ffelex_hexnum_
? FFELEX_typeNAME
: FFELEX_typeNUMBER
;
2558 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2559 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2560 ffelex_append_to_token_ (c
);
2564 ffelex_token_
->type
= FFELEX_typeCOLON
;
2565 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2566 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2570 ffelex_token_
->type
= FFELEX_typeSEMICOLON
;
2571 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2572 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2573 ffelex_permit_include_
= TRUE
;
2574 ffelex_send_token_ ();
2575 ffelex_permit_include_
= FALSE
;
2579 ffelex_token_
->type
= FFELEX_typeOPEN_ANGLE
;
2580 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2581 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2585 ffelex_token_
->type
= FFELEX_typeEQUALS
;
2586 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2587 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2591 ffelex_token_
->type
= FFELEX_typeCLOSE_ANGLE
;
2592 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2593 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2597 ffelex_token_
->type
= FFELEX_typeQUESTION
;
2598 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2599 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2600 ffelex_send_token_ ();
2604 if (1 || ffe_is_90 ())
2606 ffelex_token_
->type
= FFELEX_typeUNDERSCORE
;
2607 ffelex_token_
->where_line
2608 = ffewhere_line_use (ffelex_current_wl_
);
2609 ffelex_token_
->where_col
2610 = ffewhere_column_new (column
+ 1);
2611 ffelex_send_token_ ();
2667 c
= ffesrc_char_source (c
);
2669 if (ffesrc_char_match_init (c
, 'H', 'h')
2670 && ffelex_expecting_hollerith_
!= 0)
2672 ffelex_raw_mode_
= ffelex_expecting_hollerith_
;
2673 ffelex_token_
->type
= FFELEX_typeHOLLERITH
;
2674 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
2675 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
2676 ffelex_raw_where_line_
= ffewhere_line_unknown ();
2677 ffelex_raw_where_col_
= ffewhere_column_unknown ();
2678 c
= ffelex_card_image_
[++column
];
2679 goto parse_raw_character
; /* :::::::::::::::::::: */
2684 ffelex_token_
->where_line
2685 = ffewhere_line_use (ffelex_token_
->currentnames_line
2686 = ffewhere_line_use (ffelex_current_wl_
));
2687 ffelex_token_
->where_col
2688 = ffewhere_column_use (ffelex_token_
->currentnames_col
2689 = ffewhere_column_new (column
+ 1));
2690 ffelex_token_
->type
= FFELEX_typeNAMES
;
2694 ffelex_token_
->where_line
2695 = ffewhere_line_use (ffelex_current_wl_
);
2696 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2697 ffelex_token_
->type
= FFELEX_typeNAME
;
2699 ffelex_append_to_token_ (c
);
2703 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
2704 ffelex_linecount_current_
, column
+ 1);
2705 ffelex_finish_statement_ ();
2706 disallow_continuation_line
= TRUE
;
2707 ignore_disallowed_continuation
= TRUE
;
2708 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2712 case FFELEX_typeNAME
:
2767 c
= ffesrc_char_source (c
);
2782 && !ffe_is_dollar_ok ())
2784 ffelex_send_token_ ();
2785 goto parse_next_character
; /* :::::::::::::::::::: */
2787 ffelex_append_to_token_ (c
);
2791 ffelex_send_token_ ();
2792 goto parse_next_character
; /* :::::::::::::::::::: */
2796 case FFELEX_typeNAMES
:
2851 c
= ffesrc_char_source (c
);
2866 && !ffe_is_dollar_ok ())
2868 ffelex_send_token_ ();
2869 goto parse_next_character
; /* :::::::::::::::::::: */
2871 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
2873 ffewhere_track (&ffelex_token_
->currentnames_line
,
2874 &ffelex_token_
->currentnames_col
,
2875 ffelex_token_
->wheretrack
,
2876 ffelex_token_
->length
,
2877 ffelex_linecount_current_
,
2880 ffelex_append_to_token_ (c
);
2884 ffelex_send_token_ ();
2885 goto parse_next_character
; /* :::::::::::::::::::: */
2889 case FFELEX_typeNUMBER
:
2902 ffelex_append_to_token_ (c
);
2906 ffelex_send_token_ ();
2907 goto parse_next_character
; /* :::::::::::::::::::: */
2911 case FFELEX_typeASTERISK
:
2915 ffelex_token_
->type
= FFELEX_typePOWER
;
2916 ffelex_send_token_ ();
2919 default: /* * not followed by another *. */
2920 ffelex_send_token_ ();
2921 goto parse_next_character
; /* :::::::::::::::::::: */
2925 case FFELEX_typeCOLON
:
2929 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
2930 ffelex_send_token_ ();
2933 default: /* : not followed by another :. */
2934 ffelex_send_token_ ();
2935 goto parse_next_character
; /* :::::::::::::::::::: */
2939 case FFELEX_typeSLASH
:
2943 ffelex_token_
->type
= FFELEX_typeCONCAT
;
2944 ffelex_send_token_ ();
2948 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
2949 ffelex_send_token_ ();
2953 ffelex_token_
->type
= FFELEX_typeREL_NE
;
2954 ffelex_send_token_ ();
2958 ffelex_send_token_ ();
2959 goto parse_next_character
; /* :::::::::::::::::::: */
2963 case FFELEX_typeOPEN_PAREN
:
2967 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
2968 ffelex_send_token_ ();
2972 ffelex_send_token_ ();
2973 goto parse_next_character
; /* :::::::::::::::::::: */
2977 case FFELEX_typeOPEN_ANGLE
:
2981 ffelex_token_
->type
= FFELEX_typeREL_LE
;
2982 ffelex_send_token_ ();
2986 ffelex_send_token_ ();
2987 goto parse_next_character
; /* :::::::::::::::::::: */
2991 case FFELEX_typeEQUALS
:
2995 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
2996 ffelex_send_token_ ();
3000 ffelex_token_
->type
= FFELEX_typePOINTS
;
3001 ffelex_send_token_ ();
3005 ffelex_send_token_ ();
3006 goto parse_next_character
; /* :::::::::::::::::::: */
3010 case FFELEX_typeCLOSE_ANGLE
:
3014 ffelex_token_
->type
= FFELEX_typeREL_GE
;
3015 ffelex_send_token_ ();
3019 ffelex_send_token_ ();
3020 goto parse_next_character
; /* :::::::::::::::::::: */
3025 assert ("Serious error!!" == NULL
);
3030 c
= ffelex_card_image_
[++column
];
3032 parse_next_character
: /* :::::::::::::::::::: */
3034 if (ffelex_raw_mode_
!= 0)
3035 goto parse_raw_character
; /* :::::::::::::::::::: */
3038 c
= ffelex_card_image_
[++column
];
3043 && (ffelex_card_image_
[column
+ 1] == '*')))
3045 if ((ffelex_number_of_tokens_
== ffelex_label_tokens_
)
3046 && (ffelex_token_
->type
== FFELEX_typeNAMES
)
3047 && (ffelex_token_
->length
== 3)
3048 && (ffesrc_strncmp_2c (ffe_case_match (),
3049 ffelex_token_
->text
,
3050 "END", "end", "End",
3054 ffelex_finish_statement_ ();
3055 disallow_continuation_line
= TRUE
;
3056 ignore_disallowed_continuation
= FALSE
;
3057 goto beginning_of_line_again
; /* :::::::::::::::::::: */
3059 goto beginning_of_line
; /* :::::::::::::::::::: */
3061 goto parse_nonraw_character
; /* :::::::::::::::::::: */
3064 /* ffelex_file_free -- Lex a given file in free source form
3068 ffelex_file_free(wf,f);
3070 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
3073 ffelex_file_free (ffewhereFile wf
, FILE *f
)
3075 register int c
= 0; /* Character currently under consideration. */
3076 register ffewhereColumnNumber column
= 0; /* Not really; 0 means column 1... */
3077 bool continuation_line
= FALSE
;
3078 ffewhereColumnNumber continuation_column
;
3079 int latest_char_in_file
= 0; /* For getting back into comment-skipping
3082 /* Lex is called for a particular file, not for a particular program unit.
3083 Yet the two events do share common characteristics. The first line in a
3084 file or in a program unit cannot be a continuation line. No token can
3085 be in mid-formation. No current label for the statement exists, since
3086 there is no current statement. */
3088 assert (ffelex_handler_
!= NULL
);
3090 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3092 input_filename
= ffewhere_file_name (wf
);
3094 ffelex_current_wf_
= wf
;
3095 continuation_line
= FALSE
;
3096 ffelex_token_
->type
= FFELEX_typeNONE
;
3097 ffelex_number_of_tokens_
= 0;
3098 ffelex_current_wl_
= ffewhere_line_unknown ();
3099 ffelex_current_wc_
= ffewhere_column_unknown ();
3100 latest_char_in_file
= '\n';
3102 /* Come here to get a new line. */
3104 beginning_of_line
: /* :::::::::::::::::::: */
3106 c
= latest_char_in_file
;
3107 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
3110 end_of_file
: /* :::::::::::::::::::: */
3112 /* Line ending in EOF instead of \n still counts as a whole line. */
3114 ffelex_finish_statement_ ();
3115 ffewhere_line_kill (ffelex_current_wl_
);
3116 ffewhere_column_kill (ffelex_current_wc_
);
3117 return (ffelexHandler
) ffelex_handler_
;
3120 ffelex_next_line_ ();
3122 ffelex_bad_line_
= FALSE
;
3124 /* Skip over initial-comment and empty lines as quickly as possible! */
3132 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3133 c
= ffelex_hash_ (f
);
3135 /* Don't skip over # line after all. */
3140 comment_line
: /* :::::::::::::::::::: */
3142 while ((c
!= '\n') && (c
!= EOF
))
3147 ffelex_next_line_ ();
3148 goto end_of_file
; /* :::::::::::::::::::: */
3153 ffelex_next_line_ ();
3156 goto end_of_file
; /* :::::::::::::::::::: */
3159 ffelex_saw_tab_
= FALSE
;
3161 column
= ffelex_image_char_ (c
, 0);
3163 /* Read the entire line in as is (with whitespace processing). */
3165 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
3166 column
= ffelex_image_char_ (c
, column
);
3168 if (ffelex_bad_line_
)
3170 ffelex_card_image_
[column
] = '\0';
3171 ffelex_card_length_
= column
;
3172 goto comment_line
; /* :::::::::::::::::::: */
3175 /* If no tab, cut off line after column 132. */
3177 if (!ffelex_saw_tab_
&& (column
> FFELEX_FREE_MAX_COLUMNS_
))
3178 column
= FFELEX_FREE_MAX_COLUMNS_
;
3180 ffelex_card_image_
[column
] = '\0';
3181 ffelex_card_length_
= column
;
3183 /* Save next char in file so we can use register-based c while analyzing
3184 line we just read. */
3186 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
3189 continuation_column
= 0;
3191 /* Skip over initial spaces to see if the first nonblank character
3192 is exclamation point, newline, or EOF (line is therefore a comment) or
3193 ampersand (line is therefore a continuation line). */
3195 while ((c
= ffelex_card_image_
[column
]) == ' ')
3202 goto beginning_of_line
; /* :::::::::::::::::::: */
3205 continuation_column
= column
+ 1;
3212 /* The line definitely has content of some kind, install new end-statement
3213 point for error messages. */
3215 ffewhere_line_kill (ffelex_current_wl_
);
3216 ffewhere_column_kill (ffelex_current_wc_
);
3217 ffelex_current_wl_
= ffewhere_line_new (ffelex_linecount_current_
);
3218 ffelex_current_wc_
= ffewhere_column_new (ffelex_card_length_
+ 1);
3220 /* Figure out which column to start parsing at. */
3222 if (continuation_line
)
3224 if (continuation_column
== 0)
3226 if (ffelex_raw_mode_
!= 0)
3228 ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE
,
3229 ffelex_linecount_current_
, column
+ 1);
3231 else if (ffelex_token_
->type
!= FFELEX_typeNONE
)
3233 ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE
,
3234 ffelex_linecount_current_
, column
+ 1);
3237 else if (ffelex_is_free_char_ctx_contin_ (continuation_column
))
3238 { /* Line contains only a single "&" as only
3239 nonblank character. */
3240 ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE
,
3241 ffelex_linecount_current_
, continuation_column
);
3242 goto beginning_of_line
; /* :::::::::::::::::::: */
3244 column
= continuation_column
;
3249 c
= ffelex_card_image_
[column
];
3250 continuation_line
= FALSE
;
3252 /* Here is the main engine for parsing. c holds the character at column.
3253 It is already known that c is not a blank, end of line, or shriek,
3254 unless ffelex_raw_mode_ is not 0 (indicating we are in a
3255 character/hollerith constant). A partially filled token may already
3256 exist in ffelex_token_. */
3258 if (ffelex_raw_mode_
!= 0)
3261 parse_raw_character
: /* :::::::::::::::::::: */
3266 if (ffelex_is_free_char_ctx_contin_ (column
+ 1))
3268 continuation_line
= TRUE
;
3269 goto beginning_of_line
; /* :::::::::::::::::::: */
3274 ffelex_finish_statement_ ();
3275 goto beginning_of_line
; /* :::::::::::::::::::: */
3281 switch (ffelex_raw_mode_
)
3284 c
= ffelex_backslash_ (c
, column
);
3288 if (!ffelex_backslash_reconsider_
)
3289 ffelex_append_to_token_ (c
);
3290 ffelex_raw_mode_
= -1;
3294 if (c
== ffelex_raw_char_
)
3296 ffelex_raw_mode_
= -1;
3297 ffelex_append_to_token_ (c
);
3301 ffelex_raw_mode_
= 0;
3302 ffelex_backslash_reconsider_
= TRUE
;
3307 if (c
== ffelex_raw_char_
)
3308 ffelex_raw_mode_
= -2;
3311 c
= ffelex_backslash_ (c
, column
);
3314 ffelex_raw_mode_
= -3;
3318 ffelex_append_to_token_ (c
);
3323 c
= ffelex_backslash_ (c
, column
);
3327 if (!ffelex_backslash_reconsider_
)
3329 ffelex_append_to_token_ (c
);
3335 if (ffelex_backslash_reconsider_
)
3336 ffelex_backslash_reconsider_
= FALSE
;
3338 c
= ffelex_card_image_
[++column
];
3340 if (ffelex_raw_mode_
== 0)
3342 ffelex_send_token_ ();
3343 assert (ffelex_raw_mode_
== 0);
3345 c
= ffelex_card_image_
[++column
];
3346 if ((c
== '\0') || (c
== '!'))
3348 ffelex_finish_statement_ ();
3349 goto beginning_of_line
; /* :::::::::::::::::::: */
3351 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3353 continuation_line
= TRUE
;
3354 goto beginning_of_line
; /* :::::::::::::::::::: */
3356 goto parse_nonraw_character_noncontin
; /* :::::::::::::::::::: */
3358 goto parse_raw_character
; /* :::::::::::::::::::: */
3361 parse_nonraw_character
: /* :::::::::::::::::::: */
3363 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3365 continuation_line
= TRUE
;
3366 goto beginning_of_line
; /* :::::::::::::::::::: */
3369 parse_nonraw_character_noncontin
: /* :::::::::::::::::::: */
3371 switch (ffelex_token_
->type
)
3373 case FFELEX_typeNONE
:
3376 finish-statement/continue-statement
3379 c
= ffelex_card_image_
[++column
];
3380 if ((c
== '\0') || (c
== '!'))
3382 ffelex_finish_statement_ ();
3383 goto beginning_of_line
; /* :::::::::::::::::::: */
3385 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3387 continuation_line
= TRUE
;
3388 goto beginning_of_line
; /* :::::::::::::::::::: */
3395 ffelex_token_
->type
= FFELEX_typeQUOTE
;
3396 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3397 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3398 ffelex_send_token_ ();
3402 ffelex_token_
->type
= FFELEX_typeDOLLAR
;
3403 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3404 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3405 ffelex_send_token_ ();
3409 ffelex_token_
->type
= FFELEX_typePERCENT
;
3410 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3411 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3412 ffelex_send_token_ ();
3416 ffelex_token_
->type
= FFELEX_typeAMPERSAND
;
3417 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3418 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3419 ffelex_send_token_ ();
3423 ffelex_token_
->type
= FFELEX_typeAPOSTROPHE
;
3424 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3425 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3426 ffelex_send_token_ ();
3430 ffelex_token_
->type
= FFELEX_typeOPEN_PAREN
;
3431 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3432 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3436 ffelex_token_
->type
= FFELEX_typeCLOSE_PAREN
;
3437 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3438 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3439 ffelex_send_token_ ();
3443 ffelex_token_
->type
= FFELEX_typeASTERISK
;
3444 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3445 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3449 ffelex_token_
->type
= FFELEX_typePLUS
;
3450 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3451 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3452 ffelex_send_token_ ();
3456 ffelex_token_
->type
= FFELEX_typeCOMMA
;
3457 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3458 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3459 ffelex_send_token_ ();
3463 ffelex_token_
->type
= FFELEX_typeMINUS
;
3464 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3465 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3466 ffelex_send_token_ ();
3470 ffelex_token_
->type
= FFELEX_typePERIOD
;
3471 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3472 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3473 ffelex_send_token_ ();
3477 ffelex_token_
->type
= FFELEX_typeSLASH
;
3478 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3479 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3493 = ffelex_hexnum_
? FFELEX_typeNAME
: FFELEX_typeNUMBER
;
3494 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3495 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3496 ffelex_append_to_token_ (c
);
3500 ffelex_token_
->type
= FFELEX_typeCOLON
;
3501 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3502 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3506 ffelex_token_
->type
= FFELEX_typeSEMICOLON
;
3507 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3508 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3509 ffelex_permit_include_
= TRUE
;
3510 ffelex_send_token_ ();
3511 ffelex_permit_include_
= FALSE
;
3515 ffelex_token_
->type
= FFELEX_typeOPEN_ANGLE
;
3516 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3517 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3521 ffelex_token_
->type
= FFELEX_typeEQUALS
;
3522 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3523 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3527 ffelex_token_
->type
= FFELEX_typeCLOSE_ANGLE
;
3528 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3529 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3533 ffelex_token_
->type
= FFELEX_typeQUESTION
;
3534 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3535 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3536 ffelex_send_token_ ();
3540 if (1 || ffe_is_90 ())
3542 ffelex_token_
->type
= FFELEX_typeUNDERSCORE
;
3543 ffelex_token_
->where_line
3544 = ffewhere_line_use (ffelex_current_wl_
);
3545 ffelex_token_
->where_col
3546 = ffewhere_column_new (column
+ 1);
3547 ffelex_send_token_ ();
3603 c
= ffesrc_char_source (c
);
3605 if (ffesrc_char_match_init (c
, 'H', 'h')
3606 && ffelex_expecting_hollerith_
!= 0)
3608 ffelex_raw_mode_
= ffelex_expecting_hollerith_
;
3609 ffelex_token_
->type
= FFELEX_typeHOLLERITH
;
3610 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
3611 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
3612 ffelex_raw_where_line_
= ffewhere_line_unknown ();
3613 ffelex_raw_where_col_
= ffewhere_column_unknown ();
3614 c
= ffelex_card_image_
[++column
];
3615 goto parse_raw_character
; /* :::::::::::::::::::: */
3618 if (ffelex_names_pure_
)
3620 ffelex_token_
->where_line
3621 = ffewhere_line_use (ffelex_token_
->currentnames_line
3622 = ffewhere_line_use (ffelex_current_wl_
));
3623 ffelex_token_
->where_col
3624 = ffewhere_column_use (ffelex_token_
->currentnames_col
3625 = ffewhere_column_new (column
+ 1));
3626 ffelex_token_
->type
= FFELEX_typeNAMES
;
3630 ffelex_token_
->where_line
3631 = ffewhere_line_use (ffelex_current_wl_
);
3632 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3633 ffelex_token_
->type
= FFELEX_typeNAME
;
3635 ffelex_append_to_token_ (c
);
3639 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
3640 ffelex_linecount_current_
, column
+ 1);
3641 ffelex_finish_statement_ ();
3642 goto beginning_of_line
; /* :::::::::::::::::::: */
3646 case FFELEX_typeNAME
:
3701 c
= ffesrc_char_source (c
);
3716 && !ffe_is_dollar_ok ())
3718 ffelex_send_token_ ();
3719 goto parse_next_character
; /* :::::::::::::::::::: */
3721 ffelex_append_to_token_ (c
);
3725 ffelex_send_token_ ();
3726 goto parse_next_character
; /* :::::::::::::::::::: */
3730 case FFELEX_typeNAMES
:
3785 c
= ffesrc_char_source (c
);
3800 && !ffe_is_dollar_ok ())
3802 ffelex_send_token_ ();
3803 goto parse_next_character
; /* :::::::::::::::::::: */
3805 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
3807 ffewhere_track (&ffelex_token_
->currentnames_line
,
3808 &ffelex_token_
->currentnames_col
,
3809 ffelex_token_
->wheretrack
,
3810 ffelex_token_
->length
,
3811 ffelex_linecount_current_
,
3814 ffelex_append_to_token_ (c
);
3818 ffelex_send_token_ ();
3819 goto parse_next_character
; /* :::::::::::::::::::: */
3823 case FFELEX_typeNUMBER
:
3836 ffelex_append_to_token_ (c
);
3840 ffelex_send_token_ ();
3841 goto parse_next_character
; /* :::::::::::::::::::: */
3845 case FFELEX_typeASTERISK
:
3849 ffelex_token_
->type
= FFELEX_typePOWER
;
3850 ffelex_send_token_ ();
3853 default: /* * not followed by another *. */
3854 ffelex_send_token_ ();
3855 goto parse_next_character
; /* :::::::::::::::::::: */
3859 case FFELEX_typeCOLON
:
3863 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
3864 ffelex_send_token_ ();
3867 default: /* : not followed by another :. */
3868 ffelex_send_token_ ();
3869 goto parse_next_character
; /* :::::::::::::::::::: */
3873 case FFELEX_typeSLASH
:
3877 ffelex_token_
->type
= FFELEX_typeCONCAT
;
3878 ffelex_send_token_ ();
3882 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
3883 ffelex_send_token_ ();
3887 ffelex_token_
->type
= FFELEX_typeREL_NE
;
3888 ffelex_send_token_ ();
3892 ffelex_send_token_ ();
3893 goto parse_next_character
; /* :::::::::::::::::::: */
3897 case FFELEX_typeOPEN_PAREN
:
3901 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
3902 ffelex_send_token_ ();
3906 ffelex_send_token_ ();
3907 goto parse_next_character
; /* :::::::::::::::::::: */
3911 case FFELEX_typeOPEN_ANGLE
:
3915 ffelex_token_
->type
= FFELEX_typeREL_LE
;
3916 ffelex_send_token_ ();
3920 ffelex_send_token_ ();
3921 goto parse_next_character
; /* :::::::::::::::::::: */
3925 case FFELEX_typeEQUALS
:
3929 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
3930 ffelex_send_token_ ();
3934 ffelex_token_
->type
= FFELEX_typePOINTS
;
3935 ffelex_send_token_ ();
3939 ffelex_send_token_ ();
3940 goto parse_next_character
; /* :::::::::::::::::::: */
3944 case FFELEX_typeCLOSE_ANGLE
:
3948 ffelex_token_
->type
= FFELEX_typeREL_GE
;
3949 ffelex_send_token_ ();
3953 ffelex_send_token_ ();
3954 goto parse_next_character
; /* :::::::::::::::::::: */
3959 assert ("Serious error!" == NULL
);
3964 c
= ffelex_card_image_
[++column
];
3966 parse_next_character
: /* :::::::::::::::::::: */
3968 if (ffelex_raw_mode_
!= 0)
3969 goto parse_raw_character
; /* :::::::::::::::::::: */
3971 if ((c
== '\0') || (c
== '!'))
3973 ffelex_finish_statement_ ();
3974 goto beginning_of_line
; /* :::::::::::::::::::: */
3976 goto parse_nonraw_character
; /* :::::::::::::::::::: */
3979 /* See the code in com.c that calls this to understand why. */
3981 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3983 ffelex_hash_kludge (FILE *finput
)
3985 /* If you change this constant string, you have to change whatever
3986 code might thus be affected by it in terms of having to use
3987 ffelex_getc_() instead of getc() in the lexers and _hash_. */
3988 static char match
[] = "# 1 \"";
3989 static int kludge
[ARRAY_SIZE (match
) + 1];
3994 /* Read chars as long as they match the target string.
3995 Copy them into an array that will serve as a record
3996 of what we read (essentially a multi-char ungetc(),
3997 for code that uses ffelex_getc_ instead of getc() elsewhere
3999 for (p
= &match
[0], q
= &kludge
[0], c
= getc (finput
);
4000 (c
== *p
) && (*p
!= '\0') && (c
!= EOF
);
4001 ++p
, ++q
, c
= getc (finput
))
4004 *q
= c
; /* Might be EOF, which requires int. */
4007 ffelex_kludge_chars_
= &kludge
[0];
4011 ffelex_kludge_flag_
= TRUE
;
4012 ++ffelex_kludge_chars_
;
4013 ffelex_hash_ (finput
); /* Handle it NOW rather than later. */
4014 ffelex_kludge_flag_
= FALSE
;
4024 ffelex_final_nontab_column_
= ffe_fixed_line_length ();
4025 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
4026 ffelex_card_image_
= malloc_new_ksr (malloc_pool_image (),
4027 "FFELEX card image",
4028 FFELEX_columnINITIAL_SIZE_
+ 9);
4029 ffelex_card_image_
[0] = '\0';
4031 for (i
= 0; i
< 256; ++i
)
4032 ffelex_first_char_
[i
] = FFELEX_typeERROR
;
4034 ffelex_first_char_
['\t'] = FFELEX_typeRAW
;
4035 ffelex_first_char_
['\n'] = FFELEX_typeCOMMENT
;
4036 ffelex_first_char_
['\v'] = FFELEX_typeCOMMENT
;
4037 ffelex_first_char_
['\f'] = FFELEX_typeCOMMENT
;
4038 ffelex_first_char_
['\r'] = FFELEX_typeRAW
;
4039 ffelex_first_char_
[' '] = FFELEX_typeRAW
;
4040 ffelex_first_char_
['!'] = FFELEX_typeCOMMENT
;
4041 ffelex_first_char_
['*'] = FFELEX_typeCOMMENT
;
4042 ffelex_first_char_
['/'] = FFELEX_typeSLASH
;
4043 ffelex_first_char_
['&'] = FFELEX_typeRAW
;
4044 ffelex_first_char_
['#'] = FFELEX_typeHASH
;
4046 for (i
= '0'; i
<= '9'; ++i
)
4047 ffelex_first_char_
[i
] = FFELEX_typeRAW
;
4049 if ((ffe_case_match () == FFE_caseNONE
)
4050 || ((ffe_case_match () == FFE_caseUPPER
)
4051 && (ffe_case_source () != FFE_caseLOWER
)) /* Idiot! :-) */
4052 || ((ffe_case_match () == FFE_caseLOWER
)
4053 && (ffe_case_source () == FFE_caseLOWER
)))
4055 ffelex_first_char_
['C'] = FFELEX_typeCOMMENT
;
4056 ffelex_first_char_
['D'] = FFELEX_typeCOMMENT
;
4058 if ((ffe_case_match () == FFE_caseNONE
)
4059 || ((ffe_case_match () == FFE_caseLOWER
)
4060 && (ffe_case_source () != FFE_caseUPPER
)) /* Idiot! :-) */
4061 || ((ffe_case_match () == FFE_caseUPPER
)
4062 && (ffe_case_source () == FFE_caseUPPER
)))
4064 ffelex_first_char_
['c'] = FFELEX_typeCOMMENT
;
4065 ffelex_first_char_
['d'] = FFELEX_typeCOMMENT
;
4068 ffelex_linecount_current_
= 0;
4069 ffelex_linecount_next_
= 1;
4070 ffelex_raw_mode_
= 0;
4071 ffelex_set_include_
= FALSE
;
4072 ffelex_permit_include_
= FALSE
;
4073 ffelex_names_
= TRUE
; /* First token in program is a names. */
4074 ffelex_names_pure_
= FALSE
; /* Free-form lexer does NAMES only for
4076 ffelex_hexnum_
= FALSE
;
4077 ffelex_expecting_hollerith_
= 0;
4078 ffelex_raw_where_line_
= ffewhere_line_unknown ();
4079 ffelex_raw_where_col_
= ffewhere_column_unknown ();
4081 ffelex_token_
= ffelex_token_new_ ();
4082 ffelex_token_
->type
= FFELEX_typeNONE
;
4083 ffelex_token_
->uses
= 1;
4084 ffelex_token_
->where_line
= ffewhere_line_unknown ();
4085 ffelex_token_
->where_col
= ffewhere_column_unknown ();
4086 ffelex_token_
->text
= NULL
;
4088 ffelex_handler_
= NULL
;
4091 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
4093 if (ffelex_is_names_expected())
4094 // Deliver NAMES token
4096 // Deliver NAME token
4098 Must be called while lexer is active, obviously. */
4101 ffelex_is_names_expected ()
4103 return ffelex_names_
;
4106 /* Current card image, which has the master linecount number
4107 ffelex_linecount_current_. */
4112 return ffelex_card_image_
;
4115 /* ffelex_line_length -- Return length of current lexer line
4117 printf("Length is %lu\n",ffelex_line_length());
4119 Must be called while lexer is active, obviously. */
4121 ffewhereColumnNumber
4122 ffelex_line_length ()
4124 return ffelex_card_length_
;
4127 /* Master line count of current card image, or 0 if no card image
4131 ffelex_line_number ()
4133 return ffelex_linecount_current_
;
4136 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4138 ffelex_set_expecting_hollerith(0);
4140 Lex initially assumes no hollerith constant is about to show up. If
4141 syntactic analysis expects one, it should call this function with the
4142 number of characters expected in the constant immediately after recognizing
4143 the decimal number preceding the "H" and the constant itself. Then, if
4144 the next character is indeed H, the lexer will interpret it as beginning
4145 a hollerith constant and ship the token formed by reading the specified
4146 number of characters (interpreting blanks and otherwise-comments too)
4147 from the input file. It is up to syntactic analysis to call this routine
4148 again with 0 to turn hollerith detection off immediately upon receiving
4149 the token that might or might not be HOLLERITH.
4151 Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4152 character constant. Pass the expected termination character (apostrophe
4155 Pass for length either the length of the hollerith (must be > 0), -1
4156 meaning expecting a character constant, or 0 to cancel expectation of
4157 a hollerith only after calling it with a length of > 0 and receiving the
4158 next token (which may or may not have been a HOLLERITH token).
4160 Pass for which either an apostrophe or quote when passing length of -1.
4161 Else which is a don't-care.
4163 Pass for line and column the line/column info for the token beginning the
4164 character or hollerith constant, for use in error messages, when passing
4165 a length of -1 -- this function will invoke ffewhere_line/column_use to
4166 make its own copies. Else line and column are don't-cares (when length
4167 is 0) and the outstanding copies of the previous line/column info, if
4168 still around, are killed.
4171 When called with length of 0, also zero ffelex_raw_mode_. This is
4172 so ffest_save_ can undo the effects of replaying tokens like
4173 APOSTROPHE and QUOTE.
4175 New line, column arguments allow error messages to point to the true
4176 beginning of a character/hollerith constant, rather than the beginning
4177 of the content part, which makes them more consistent and helpful.
4179 New "which" argument allows caller to specify termination character,
4180 which should be apostrophe or double-quote, to support Fortran 90. */
4183 ffelex_set_expecting_hollerith (long length
, char which
,
4184 ffewhereLine line
, ffewhereColumn column
)
4187 /* First kill the pending line/col info, if any (should only be pending
4188 when this call has length==0, the previous call had length>0, and a
4189 non-HOLLERITH token was sent in between the calls, but play it safe). */
4191 ffewhere_line_kill (ffelex_raw_where_line_
);
4192 ffewhere_column_kill (ffelex_raw_where_col_
);
4194 /* Now handle the length function. */
4198 ffelex_expecting_hollerith_
= 0;
4199 ffelex_raw_mode_
= 0;
4200 ffelex_raw_where_line_
= ffewhere_line_unknown ();
4201 ffelex_raw_where_col_
= ffewhere_column_unknown ();
4202 return; /* Don't set new line/column info from args. */
4205 ffelex_raw_mode_
= -1;
4206 ffelex_raw_char_
= which
;
4209 default: /* length > 0 */
4210 ffelex_expecting_hollerith_
= length
;
4214 /* Now set new line/column information from passed args. */
4216 ffelex_raw_where_line_
= ffewhere_line_use (line
);
4217 ffelex_raw_where_col_
= ffewhere_column_use (column
);
4220 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4222 ffelex_set_handler((ffelexHandler) my_first_handler);
4224 Must be called before calling ffelex_file_fixed or ffelex_file_free or
4225 after they return, but not while they are active. */
4228 ffelex_set_handler (ffelexHandler first
)
4230 ffelex_handler_
= first
;
4233 /* ffelex_set_hexnum -- Set hexnum flag
4235 ffelex_set_hexnum(TRUE);
4237 Lex normally interprets a token starting with [0-9] as a NUMBER token,
4238 so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves
4239 the character as the first of the next token. But when parsing a
4240 hexadecimal number, by calling this function with TRUE before starting
4241 the parse of the token itself, lex will interpret [0-9] as the start
4245 ffelex_set_hexnum (bool f
)
4250 /* ffelex_set_include -- Set INCLUDE file to be processed next
4252 ffewhereFile wf; // The ffewhereFile object for the file.
4253 bool free_form; // TRUE means read free-form file, FALSE fixed-form.
4254 FILE *fi; // The file to INCLUDE.
4255 ffelex_set_include(wf,free_form,fi);
4257 Must be called only after receiving the EOS token following a valid
4258 INCLUDE statement specifying a file that has already been successfully
4262 ffelex_set_include (ffewhereFile wf
, bool free_form
, FILE *fi
)
4264 assert (ffelex_permit_include_
);
4265 assert (!ffelex_set_include_
);
4266 ffelex_set_include_
= TRUE
;
4267 ffelex_include_free_form_
= free_form
;
4268 ffelex_include_file_
= fi
;
4269 ffelex_include_wherefile_
= wf
;
4272 /* ffelex_set_names -- Set names/name flag, names = TRUE
4274 ffelex_set_names(FALSE);
4276 Lex initially assumes multiple names should be formed. If this function is
4277 called with FALSE, then single names are formed instead. The differences
4278 are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME)
4279 and in whether full source-location tracking is performed (it is for
4280 multiple names, not for single names), which is more expensive in terms of
4284 ffelex_set_names (bool f
)
4288 ffelex_names_pure_
= FALSE
;
4291 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4293 ffelex_set_names_pure(FALSE);
4295 Like ffelex_set_names, except affects both lexers. Normally, the
4296 free-form lexer need not generate NAMES tokens because adjacent NAME
4297 tokens must be separated by spaces which causes the lexer to generate
4298 separate tokens for analysis (whereas in fixed-form the spaces are
4299 ignored resulting in one long token). But in FORMAT statements, for
4300 some reason, the Fortran 90 standard specifies that spaces can occur
4301 anywhere within a format-item-list with no effect on the format spec
4302 (except of course within character string edit descriptors), which means
4303 that "1PE14.2" and "1 P E 1 4 . 2" are equivalent. For the FORMAT
4304 statement handling, the existence of spaces makes it hard to deal with,
4305 because each token is seen distinctly (i.e. seven tokens in the latter
4306 example). But when no spaces are provided, as in the former example,
4307 then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD,
4308 NUMBER ("2"). By generating a NAMES instead of NAME, three things happen:
4309 One, ffest_kw_format_ does a substring rather than full-string match,
4310 and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions
4311 may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token;
4312 and three, error reporting can point to the actual character rather than
4313 at or prior to it. The first two things could be resolved by providing
4314 alternate functions fairly easy, thus allowing FORMAT handling to expect
4315 both lexers to generate NAME tokens instead of NAMES (with otherwise minor
4316 changes to FORMAT parsing), but the third, error reporting, would suffer,
4317 and when one makes mistakes in a FORMAT, believe me, one wants a pointer
4318 to exactly where the compilers thinks the problem is, to even begin to get
4319 a handle on it. So there. */
4322 ffelex_set_names_pure (bool f
)
4324 ffelex_names_pure_
= f
;
4328 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4330 return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
4333 Returns first_handler if start_char_index chars into master_token (which
4334 must be a NAMES token) is '\0'. Else, creates a subtoken from that
4335 char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar),
4336 an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign)
4337 and sends it to first_handler. If anything other than NAME is sent, the
4338 character at the end of it in the master token is examined to see if it
4339 begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so,
4340 the handler returned by first_handler is invoked with that token, and
4341 this process is repeated until the end of the master token or a NAME
4342 token is reached. */
4345 ffelex_splice_tokens (ffelexHandler first
, ffelexToken master
,
4346 ffeTokenLength start
)
4352 p
= ffelex_token_text (master
) + (i
= start
);
4358 t
= ffelex_token_number_from_names (master
, i
);
4359 p
+= ffelex_token_length (t
);
4360 i
+= ffelex_token_length (t
);
4362 else if (ffesrc_is_name_init (*p
))
4364 t
= ffelex_token_name_from_names (master
, i
, 0);
4365 p
+= ffelex_token_length (t
);
4366 i
+= ffelex_token_length (t
);
4370 t
= ffelex_token_dollar_from_names (master
, i
);
4376 t
= ffelex_token_uscore_from_names (master
, i
);
4382 assert ("not a valid NAMES character" == NULL
);
4385 assert (first
!= NULL
);
4386 first
= (ffelexHandler
) (*first
) (t
);
4387 ffelex_token_kill (t
);
4393 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4395 return ffelex_swallow_tokens;
4397 Return this handler when you don't want to look at any more tokens in the
4398 statement because you've encountered an unrecoverable error in the
4402 ffelex_swallow_tokens (ffelexToken t
, ffelexHandler handler
)
4404 assert (handler
!= NULL
);
4406 if ((t
!= NULL
) && ((ffelex_token_type (t
) == FFELEX_typeEOS
)
4407 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
)))
4408 return (ffelexHandler
) (*handler
) (t
);
4410 ffelex_eos_handler_
= handler
;
4411 return (ffelexHandler
) ffelex_swallow_tokens_
;
4414 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4417 t = ffelex_token_dollar_from_names(t,6);
4419 It's as if you made a new token of dollar type having the dollar
4420 at, in the example above, the sixth character of the NAMES token. */
4423 ffelex_token_dollar_from_names (ffelexToken t
, ffeTokenLength start
)
4428 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4429 assert (start
< t
->length
);
4430 assert (t
->text
[start
] == '$');
4432 /* Now make the token. */
4434 nt
= ffelex_token_new_ ();
4435 nt
->type
= FFELEX_typeDOLLAR
;
4438 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4439 t
->where_col
, t
->wheretrack
, start
);
4444 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4447 ffelex_token_kill(t);
4449 Complements a call to ffelex_token_use or ffelex_token_new_.... */
4452 ffelex_token_kill (ffelexToken t
)
4456 assert (t
->uses
> 0);
4461 --ffelex_total_tokens_
;
4463 if (t
->type
== FFELEX_typeNAMES
)
4464 ffewhere_track_kill (t
->where_line
, t
->where_col
,
4465 t
->wheretrack
, t
->length
);
4466 ffewhere_line_kill (t
->where_line
);
4467 ffewhere_column_kill (t
->where_col
);
4468 if (t
->text
!= NULL
)
4469 malloc_kill_ksr (malloc_pool_image (), t
->text
, t
->size
+ 1);
4470 malloc_kill_ks (malloc_pool_image (), t
, sizeof (*t
));
4473 /* Make a new NAME token that is a substring of a NAMES token. */
4476 ffelex_token_name_from_names (ffelexToken t
, ffeTokenLength start
,
4482 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4483 assert (start
< t
->length
);
4485 len
= t
->length
- start
;
4489 assert ((start
+ len
) <= t
->length
);
4491 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4493 nt
= ffelex_token_new_ ();
4494 nt
->type
= FFELEX_typeNAME
;
4495 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4499 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4500 t
->where_col
, t
->wheretrack
, start
);
4501 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4503 strncpy (nt
->text
, t
->text
+ start
, len
);
4504 nt
->text
[len
] = '\0';
4508 /* Make a new NAMES token that is a substring of another NAMES token. */
4511 ffelex_token_names_from_names (ffelexToken t
, ffeTokenLength start
,
4517 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4518 assert (start
< t
->length
);
4520 len
= t
->length
- start
;
4524 assert ((start
+ len
) <= t
->length
);
4526 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4528 nt
= ffelex_token_new_ ();
4529 nt
->type
= FFELEX_typeNAMES
;
4530 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4534 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4535 t
->where_col
, t
->wheretrack
, start
);
4536 ffewhere_track_copy (nt
->wheretrack
, t
->wheretrack
, start
, len
);
4537 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4539 strncpy (nt
->text
, t
->text
+ start
, len
);
4540 nt
->text
[len
] = '\0';
4544 /* Make a new CHARACTER token. */
4547 ffelex_token_new_character (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4551 t
= ffelex_token_new_ ();
4552 t
->type
= FFELEX_typeCHARACTER
;
4553 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4555 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4557 strcpy (t
->text
, s
);
4558 t
->where_line
= ffewhere_line_use (l
);
4559 t
->where_col
= ffewhere_column_new (c
);
4563 /* Make a new EOF token right after end of file. */
4566 ffelex_token_new_eof ()
4570 t
= ffelex_token_new_ ();
4571 t
->type
= FFELEX_typeEOF
;
4574 t
->where_line
= ffewhere_line_new (ffelex_linecount_current_
);
4575 t
->where_col
= ffewhere_column_new (1);
4579 /* Make a new NAME token. */
4582 ffelex_token_new_name (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4586 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4588 t
= ffelex_token_new_ ();
4589 t
->type
= FFELEX_typeNAME
;
4590 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4592 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4594 strcpy (t
->text
, s
);
4595 t
->where_line
= ffewhere_line_use (l
);
4596 t
->where_col
= ffewhere_column_new (c
);
4600 /* Make a new NAMES token. */
4603 ffelex_token_new_names (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4607 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4609 t
= ffelex_token_new_ ();
4610 t
->type
= FFELEX_typeNAMES
;
4611 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4613 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4615 strcpy (t
->text
, s
);
4616 t
->where_line
= ffewhere_line_use (l
);
4617 t
->where_col
= ffewhere_column_new (c
);
4618 ffewhere_track_clear (t
->wheretrack
, t
->length
); /* Assume contiguous
4623 /* Make a new NUMBER token.
4625 The first character of the string must be a digit, and only the digits
4626 are copied into the new number. So this may be used to easily extract
4627 a NUMBER token from within any text string. Then the length of the
4628 resulting token may be used to calculate where the digits stopped
4629 in the original string. */
4632 ffelex_token_new_number (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4637 /* How long is the string of decimal digits at s? */
4639 len
= strspn (s
, "0123456789");
4641 /* Make sure there is at least one digit. */
4645 /* Now make the token. */
4647 t
= ffelex_token_new_ ();
4648 t
->type
= FFELEX_typeNUMBER
;
4649 t
->length
= t
->size
= len
; /* Assume it won't get bigger. */
4651 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4653 strncpy (t
->text
, s
, len
);
4654 t
->text
[len
] = '\0';
4655 t
->where_line
= ffewhere_line_use (l
);
4656 t
->where_col
= ffewhere_column_new (c
);
4660 /* Make a new token of any type that doesn't contain text. A private
4661 function that is used by public macros in the interface file. */
4664 ffelex_token_new_simple_ (ffelexType type
, ffewhereLine l
, ffewhereColumn c
)
4668 t
= ffelex_token_new_ ();
4672 t
->where_line
= ffewhere_line_use (l
);
4673 t
->where_col
= ffewhere_column_new (c
);
4677 /* Make a new NUMBER token from an existing NAMES token.
4679 Like ffelex_token_new_number, this function calculates the length
4680 of the digit string itself. */
4683 ffelex_token_number_from_names (ffelexToken t
, ffeTokenLength start
)
4689 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4690 assert (start
< t
->length
);
4692 /* How long is the string of decimal digits at s? */
4694 len
= strspn (t
->text
+ start
, "0123456789");
4696 /* Make sure there is at least one digit. */
4700 /* Now make the token. */
4702 nt
= ffelex_token_new_ ();
4703 nt
->type
= FFELEX_typeNUMBER
;
4704 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4708 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4709 t
->where_col
, t
->wheretrack
, start
);
4710 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4712 strncpy (nt
->text
, t
->text
+ start
, len
);
4713 nt
->text
[len
] = '\0';
4717 /* Make a new UNDERSCORE token from a NAMES token. */
4720 ffelex_token_uscore_from_names (ffelexToken t
, ffeTokenLength start
)
4725 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4726 assert (start
< t
->length
);
4727 assert (t
->text
[start
] == '_');
4729 /* Now make the token. */
4731 nt
= ffelex_token_new_ ();
4732 nt
->type
= FFELEX_typeUNDERSCORE
;
4734 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4735 t
->where_col
, t
->wheretrack
, start
);
4740 /* ffelex_token_use -- Return another instance of a token
4743 t = ffelex_token_use(t);
4745 In a sense, the new token is a copy of the old, though it might be the
4746 same with just a new use count.
4748 We use the use count method (easy). */
4751 ffelex_token_use (ffelexToken t
)
4754 assert ("_token_use: null token" == NULL
);