1 /* Implementation of Fortran lexer
2 Copyright (C) 1995-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
34 #include "output.j" /* Must follow tree.j so TREE_CODE is defined! */
37 #ifdef DWARF_DEBUGGING_INFO
38 void dwarfout_resume_previous_source_file (register unsigned);
39 void dwarfout_start_new_source_file (register char *);
40 void dwarfout_define (register unsigned, register char *);
41 void dwarfout_undef (register unsigned, register char *);
42 #endif DWARF_DEBUGGING_INFO
44 static void ffelex_append_to_token_ (char c
);
45 static int ffelex_backslash_ (int c
, ffewhereColumnNumber col
);
46 static void ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
,
47 ffewhereColumnNumber cn0
);
48 static void ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
,
49 ffewhereColumnNumber cn0
, ffewhereLineNumber ln1
,
50 ffewhereColumnNumber cn1
);
51 static void ffelex_bad_here_ (int num
, ffewhereLineNumber ln0
,
52 ffewhereColumnNumber cn0
);
53 static void ffelex_finish_statement_ (void);
54 #if FFECOM_targetCURRENT == FFECOM_targetGCC
55 static int ffelex_get_directive_line_ (char **text
, FILE *finput
);
56 static int ffelex_hash_ (FILE *f
);
58 static ffewhereColumnNumber
ffelex_image_char_ (int c
,
59 ffewhereColumnNumber col
);
60 static void ffelex_include_ (void);
61 static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
);
62 static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
);
63 static void ffelex_next_line_ (void);
64 static void ffelex_prepare_eos_ (void);
65 static void ffelex_send_token_ (void);
66 static ffelexHandler
ffelex_swallow_tokens_ (ffelexToken t
);
67 static ffelexToken
ffelex_token_new_ (void);
69 /* Pertaining to the geometry of the input file. */
71 /* Initial size for card image to be allocated. */
72 #define FFELEX_columnINITIAL_SIZE_ 255
74 /* The card image itself, which grows as source lines get longer. It
75 has room for ffelex_card_size_ + 8 characters, and the length of the
76 current image is ffelex_card_length_. (The + 8 characters are made
77 available for easy handling of tabs and such.) */
78 static char *ffelex_card_image_
;
79 static ffewhereColumnNumber ffelex_card_size_
;
80 static ffewhereColumnNumber ffelex_card_length_
;
82 /* Max width for free-form lines (ISO F90). */
83 #define FFELEX_FREE_MAX_COLUMNS_ 132
85 /* True if we saw a tab on the current line, as this (currently) means
86 the line is therefore treated as though final_nontab_column_ were
88 static bool ffelex_saw_tab_
;
90 /* TRUE if current line is known to be erroneous, so don't bother
91 expanding room for it just to display it. */
92 static bool ffelex_bad_line_
= FALSE
;
94 /* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */
95 static ffewhereColumnNumber ffelex_final_nontab_column_
;
97 /* Array for quickly deciding what kind of line the current card has,
98 based on its first character. */
99 static ffelexType ffelex_first_char_
[256];
101 /* Pertaining to file management. */
103 /* The wf argument of the most recent active ffelex_file_(fixed,free)
105 static ffewhereFile ffelex_current_wf_
;
107 /* TRUE if an INCLUDE statement can be processed (ffelex_set_include
109 static bool ffelex_permit_include_
;
111 /* TRUE if an INCLUDE statement is pending (ffelex_set_include has been
113 static bool ffelex_set_include_
;
115 /* Information on the pending INCLUDE file. */
116 static FILE *ffelex_include_file_
;
117 static bool ffelex_include_free_form_
;
118 static ffewhereFile ffelex_include_wherefile_
;
120 /* Current master line count. */
121 static ffewhereLineNumber ffelex_linecount_current_
;
122 /* Next master line count. */
123 static ffewhereLineNumber ffelex_linecount_next_
;
125 /* ffewhere info on the latest (currently active) line read from the
126 active source file. */
127 static ffewhereLine ffelex_current_wl_
;
128 static ffewhereColumn ffelex_current_wc_
;
130 /* Pertaining to tokens in general. */
132 /* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER
134 #define FFELEX_columnTOKEN_SIZE_ 63
135 #if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX
136 #error "token size too small!"
139 /* Current token being lexed. */
140 static ffelexToken ffelex_token_
;
142 /* Handler for current token. */
143 static ffelexHandler ffelex_handler_
;
145 /* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */
146 static bool ffelex_names_
;
148 /* TRUE if both lexers are to generate NAMES instead of NAME tokens. */
149 static bool ffelex_names_pure_
;
151 /* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex
153 static bool ffelex_hexnum_
;
155 /* For ffelex_swallow_tokens(). */
156 static ffelexHandler ffelex_eos_handler_
;
158 /* Number of tokens sent since last EOS or beginning of input file
159 (include INCLUDEd files). */
160 static unsigned long int ffelex_number_of_tokens_
;
162 /* Number of labels sent (as NUMBER tokens) since last reset of
163 ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases.
164 (Fixed-form source only.) */
165 static unsigned long int ffelex_label_tokens_
;
167 /* Metering for token management, to catch token-memory leaks. */
168 static long int ffelex_total_tokens_
= 0;
169 static long int ffelex_old_total_tokens_
= 1;
170 static long int ffelex_token_nextid_
= 0;
172 /* Pertaining to lexing CHARACTER and HOLLERITH tokens. */
174 /* >0 if a Hollerith constant of that length might be in mid-lex, used
175 when the next character seen is 'H' or 'h' to enter HOLLERITH lexing
176 mode (see ffelex_raw_mode_). */
177 static long int ffelex_expecting_hollerith_
;
179 /* -3: Backslash (escape) sequence being lexed in CHARACTER.
180 -2: Possible closing apostrophe/quote seen in CHARACTER.
181 -1: Lexing CHARACTER.
182 0: Not lexing CHARACTER or HOLLERITH.
183 >0: Lexing HOLLERITH, value is # chars remaining to expect. */
184 static long int ffelex_raw_mode_
;
186 /* When lexing CHARACTER, open quote/apostrophe (either ' or "). */
187 static char ffelex_raw_char_
;
189 /* TRUE when backslash processing had to use most recent character
190 to finish its state engine, but that character is not part of
191 the backslash sequence, so must be reconsidered as a "normal"
192 character in CHARACTER/HOLLERITH lexing. */
193 static bool ffelex_backslash_reconsider_
= FALSE
;
195 /* Characters preread before lexing happened (might include EOF). */
196 static int *ffelex_kludge_chars_
= NULL
;
198 /* Doing the kludge processing, so not initialized yet. */
199 static bool ffelex_kludge_flag_
= FALSE
;
201 /* The beginning of a (possible) CHARACTER/HOLLERITH token. */
202 static ffewhereLine ffelex_raw_where_line_
;
203 static ffewhereColumn ffelex_raw_where_col_
;
206 /* Call this to append another character to the current token. If it isn't
207 currently big enough for it, it will be enlarged. The current token
208 must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER. */
211 ffelex_append_to_token_ (char c
)
213 if (ffelex_token_
->text
== NULL
)
216 = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
217 FFELEX_columnTOKEN_SIZE_
+ 1);
218 ffelex_token_
->size
= FFELEX_columnTOKEN_SIZE_
;
219 ffelex_token_
->length
= 0;
221 else if (ffelex_token_
->length
>= ffelex_token_
->size
)
224 = malloc_resize_ksr (malloc_pool_image (),
226 (ffelex_token_
->size
<< 1) + 1,
227 ffelex_token_
->size
+ 1);
228 ffelex_token_
->size
<<= 1;
229 assert (ffelex_token_
->length
< ffelex_token_
->size
);
232 Sorry
, MAP_CHARACTER is
not going to work as expected in GNU Fortran
,
233 please contact fortran@gnu
.org
if you wish to fund work to
234 port g77 to non
-ASCII machines
.
236 ffelex_token_
->text
[ffelex_token_
->length
++] = c
;
239 /* Do backslash (escape) processing for a CHARACTER/HOLLERITH token
243 ffelex_backslash_ (int c
, ffewhereColumnNumber col
)
245 static int state
= 0;
246 static unsigned int count
;
248 static unsigned int firstdig
= 0;
250 static ffewhereLineNumber line
;
251 static ffewhereColumnNumber column
;
253 /* See gcc/c-lex.c readescape() for a straightforward version
254 of this state engine for handling backslashes in character/
255 hollerith constants. */
258 #define warn_traditional 0
259 #define flag_traditional 0
265 && (ffelex_raw_mode_
!= 0)
266 && ffe_is_backslash ())
270 line
= ffelex_linecount_current_
;
276 state
= 0; /* Assume simple case. */
280 if (warn_traditional
)
282 ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional",
283 FFEBAD_severityWARNING
);
284 ffelex_bad_here_ (0, line
, column
);
288 if (flag_traditional
)
297 case '0': case '1': case '2': case '3': case '4':
298 case '5': case '6': case '7':
304 case '\\': case '\'': case '"':
307 #if 0 /* Inappropriate for Fortran. */
309 ffelex_next_line_ ();
315 return TARGET_NEWLINE
;
330 if (warn_traditional
)
332 ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional",
333 FFEBAD_severityWARNING
);
334 ffelex_bad_here_ (0, line
, column
);
338 if (flag_traditional
)
343 #if 0 /* Vertical tab is present in common usage compilers. */
344 if (flag_traditional
)
361 ffebad_start_msg_lex ("Non-ANSI-C-standard escape sequence `\\%A' at %0",
362 FFEBAD_severityPEDANTIC
);
363 ffelex_bad_here_ (0, line
, column
);
367 return (c
== 'E' || c
== 'e') ? 033 : c
;
373 if (c
>= 040 && c
< 0177)
379 ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0",
380 FFEBAD_severityPEDANTIC
);
381 ffelex_bad_here_ (0, line
, column
);
387 ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0",
388 FFEBAD_severityPEDANTIC
);
389 ffelex_bad_here_ (0, line
, column
);
396 sprintf (&m
[0], "%x", c
);
397 ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0",
398 FFEBAD_severityPEDANTIC
);
399 ffelex_bad_here_ (0, line
, column
);
407 if ((c
>= 'a' && c
<= 'f')
408 || (c
>= 'A' && c
<= 'F')
409 || (c
>= '0' && c
<= '9'))
412 if (c
>= 'a' && c
<= 'f')
413 code
+= c
- 'a' + 10;
414 if (c
>= 'A' && c
<= 'F')
415 code
+= c
- 'A' + 10;
416 if (c
>= '0' && c
<= '9')
418 if (code
!= 0 || count
!= 0)
432 ffebad_start_msg_lex ("\\x used at %0 with no following hex digits",
433 FFEBAD_severityFATAL
);
434 ffelex_bad_here_ (0, line
, column
);
438 /* Digits are all 0's. Ok. */
440 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
442 && ((1 << (TYPE_PRECISION (integer_type_node
) - (count
- 1) * 4))
445 ffebad_start_msg_lex ("Hex escape at %0 out of range",
446 FFEBAD_severityPEDANTIC
);
447 ffelex_bad_here_ (0, line
, column
);
453 if ((c
<= '7') && (c
>= '0') && (count
++ < 3))
455 code
= (code
* 8) + (c
- '0');
462 assert ("bad backslash state" == NULL
);
466 /* Come here when code has a built character, and c is the next
467 character that might (or might not) be the next one in the constant. */
469 /* Don't bother doing this check for each character going into
470 CHARACTER or HOLLERITH constants, just the escaped-value ones.
471 gcc apparently checks every single character, which seems
472 like it'd be kinda slow and not worth doing anyway. */
475 && TYPE_PRECISION (char_type_node
) < HOST_BITS_PER_INT
476 && code
>= (1 << TYPE_PRECISION (char_type_node
)))
478 ffebad_start_msg_lex ("Escape sequence at %0 out of range for character",
479 FFEBAD_severityFATAL
);
480 ffelex_bad_here_ (0, line
, column
);
486 /* Known end of constant, just append this character. */
487 ffelex_append_to_token_ (code
);
488 if (ffelex_raw_mode_
> 0)
493 /* Have two characters to handle. Do the first, then leave it to the
494 caller to detect anything special about the second. */
496 ffelex_append_to_token_ (code
);
497 if (ffelex_raw_mode_
> 0)
499 ffelex_backslash_reconsider_
= TRUE
;
503 /* ffelex_bad_1_ -- Issue diagnostic with one source point
505 ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1);
507 Creates ffewhere line and column objects for the source point, sends them
508 along with the error code to ffebad, then kills the line and column
509 objects before returning. */
512 ffelex_bad_1_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
)
517 wl0
= ffewhere_line_new (ln0
);
518 wc0
= ffewhere_column_new (cn0
);
519 ffebad_start_lex (errnum
);
520 ffebad_here (0, wl0
, wc0
);
522 ffewhere_line_kill (wl0
);
523 ffewhere_column_kill (wc0
);
526 /* ffelex_bad_2_ -- Issue diagnostic with two source points
528 ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1,
529 otherline,othercolumn);
531 Creates ffewhere line and column objects for the source points, sends them
532 along with the error code to ffebad, then kills the line and column
533 objects before returning. */
536 ffelex_bad_2_ (ffebad errnum
, ffewhereLineNumber ln0
, ffewhereColumnNumber cn0
,
537 ffewhereLineNumber ln1
, ffewhereColumnNumber cn1
)
539 ffewhereLine wl0
, wl1
;
540 ffewhereColumn wc0
, wc1
;
542 wl0
= ffewhere_line_new (ln0
);
543 wc0
= ffewhere_column_new (cn0
);
544 wl1
= ffewhere_line_new (ln1
);
545 wc1
= ffewhere_column_new (cn1
);
546 ffebad_start_lex (errnum
);
547 ffebad_here (0, wl0
, wc0
);
548 ffebad_here (1, wl1
, wc1
);
550 ffewhere_line_kill (wl0
);
551 ffewhere_column_kill (wc0
);
552 ffewhere_line_kill (wl1
);
553 ffewhere_column_kill (wc1
);
557 ffelex_bad_here_ (int n
, ffewhereLineNumber ln0
,
558 ffewhereColumnNumber cn0
)
563 wl0
= ffewhere_line_new (ln0
);
564 wc0
= ffewhere_column_new (cn0
);
565 ffebad_here (n
, wl0
, wc0
);
566 ffewhere_line_kill (wl0
);
567 ffewhere_column_kill (wc0
);
570 #if FFECOM_targetCURRENT == FFECOM_targetGCC
572 ffelex_getc_ (FILE *finput
)
576 if (ffelex_kludge_chars_
== NULL
)
577 return getc (finput
);
579 c
= *ffelex_kludge_chars_
++;
583 ffelex_kludge_chars_
= NULL
;
584 return getc (finput
);
588 #if FFECOM_targetCURRENT == FFECOM_targetGCC
590 ffelex_cfebackslash_ (int *use_d
, int *d
, FILE *finput
)
592 register int c
= getc (finput
);
594 register unsigned count
;
595 unsigned firstdig
= 0;
603 if (warn_traditional
)
604 warning ("the meaning of `\\x' varies with -traditional");
606 if (flag_traditional
)
615 if (!(c
>= 'a' && c
<= 'f')
616 && !(c
>= 'A' && c
<= 'F')
617 && !(c
>= '0' && c
<= '9'))
624 if (c
>= 'a' && c
<= 'f')
625 code
+= c
- 'a' + 10;
626 if (c
>= 'A' && c
<= 'F')
627 code
+= c
- 'A' + 10;
628 if (c
>= '0' && c
<= '9')
630 if (code
!= 0 || count
!= 0)
639 error ("\\x used with no following hex digits");
641 /* Digits are all 0's. Ok. */
643 else if ((count
- 1) * 4 >= TYPE_PRECISION (integer_type_node
)
646 << (TYPE_PRECISION (integer_type_node
) - (count
- 1)
649 pedwarn ("hex escape out of range");
652 case '0': case '1': case '2': case '3': case '4':
653 case '5': case '6': case '7':
656 while ((c
<= '7') && (c
>= '0') && (count
++ < 3))
658 code
= (code
* 8) + (c
- '0');
665 case '\\': case '\'': case '"':
669 ffelex_next_line_ ();
679 return TARGET_NEWLINE
;
694 if (warn_traditional
)
695 warning ("the meaning of `\\a' varies with -traditional");
697 if (flag_traditional
)
702 #if 0 /* Vertical tab is present in common usage compilers. */
703 if (flag_traditional
)
711 pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c
);
717 /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */
721 /* `\%' is used to prevent SCCS from getting confused. */
724 pedwarn ("non-ANSI escape sequence `\\%c'", c
);
727 if (c
>= 040 && c
< 0177)
728 pedwarn ("unknown escape sequence `\\%c'", c
);
730 pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c
);
735 /* A miniature version of the C front-end lexer. */
737 #if FFECOM_targetCURRENT == FFECOM_targetGCC
739 ffelex_cfelex_ (ffelexToken
*xtoken
, FILE *finput
, int c
)
746 register unsigned buffer_length
;
748 if ((*xtoken
!= NULL
) && !ffelex_kludge_flag_
)
749 ffelex_token_kill (*xtoken
);
753 case '0': case '1': case '2': case '3': case '4':
754 case '5': case '6': case '7': case '8': case '9':
755 buffer_length
= ARRAY_SIZE (buff
);
758 r
= &buff
[buffer_length
];
764 register unsigned bytes_used
= (p
- q
);
767 q
= (char *)xrealloc (q
, buffer_length
);
769 r
= &q
[buffer_length
];
771 c
= ffelex_getc_ (finput
);
776 token
= ffelex_token_new_number (q
, ffewhere_line_unknown (),
777 ffewhere_column_unknown ());
785 buffer_length
= ARRAY_SIZE (buff
);
788 r
= &buff
[buffer_length
];
789 c
= ffelex_getc_ (finput
);
803 case '\\': /* ~~~~~ */
804 c
= ffelex_cfebackslash_ (&use_d
, &d
, finput
);
809 fatal ("Badly formed directive -- no closing quote");
819 if (use_d
!= 2) /* 0=>c, 1=>cd, 2=>nil. */
824 register unsigned bytes_used
= (p
- q
);
826 buffer_length
= bytes_used
* 2;
827 q
= (char *)xrealloc (q
, buffer_length
);
829 r
= &q
[buffer_length
];
838 token
= ffelex_token_new_character (q
, ffewhere_line_unknown (),
839 ffewhere_column_unknown ());
856 #if FFECOM_targetCURRENT == FFECOM_targetGCC
858 ffelex_file_pop_ (char *input_filename
)
860 if (input_file_stack
->next
)
862 struct file_stack
*p
= input_file_stack
;
863 input_file_stack
= p
->next
;
865 input_file_stack_tick
++;
866 #ifdef DWARF_DEBUGGING_INFO
867 if (debug_info_level
== DINFO_LEVEL_VERBOSE
868 && write_symbols
== DWARF_DEBUG
)
869 dwarfout_resume_previous_source_file (input_file_stack
->line
);
870 #endif /* DWARF_DEBUGGING_INFO */
873 error ("#-lines for entering and leaving files don't match");
875 /* Now that we've pushed or popped the input stack,
876 update the name in the top element. */
877 if (input_file_stack
)
878 input_file_stack
->name
= input_filename
;
882 #if FFECOM_targetCURRENT == FFECOM_targetGCC
884 ffelex_file_push_ (int old_lineno
, char *input_filename
)
887 = (struct file_stack
*) xmalloc (sizeof (struct file_stack
));
889 input_file_stack
->line
= old_lineno
;
890 p
->next
= input_file_stack
;
891 p
->name
= input_filename
;
892 input_file_stack
= p
;
893 input_file_stack_tick
++;
894 #ifdef DWARF_DEBUGGING_INFO
895 if (debug_info_level
== DINFO_LEVEL_VERBOSE
896 && write_symbols
== DWARF_DEBUG
)
897 dwarfout_start_new_source_file (input_filename
);
898 #endif /* DWARF_DEBUGGING_INFO */
900 /* Now that we've pushed or popped the input stack,
901 update the name in the top element. */
902 if (input_file_stack
)
903 input_file_stack
->name
= input_filename
;
907 /* Prepare to finish a statement-in-progress by sending the current
908 token, if any, then setting up EOS as the current token with the
909 appropriate current pointer. The caller can then move the current
910 pointer before actually sending EOS, if desired, as it is in
911 typical fixed-form cases. */
914 ffelex_prepare_eos_ ()
916 if (ffelex_token_
->type
!= FFELEX_typeNONE
)
918 ffelex_backslash_ (EOF
, 0);
920 switch (ffelex_raw_mode_
)
926 ffebad_start_lex ((ffelex_raw_char_
== '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE
927 : FFEBAD_NO_CLOSING_QUOTE
);
928 ffebad_here (0, ffelex_token_
->where_line
, ffelex_token_
->where_col
);
929 ffebad_here (1, ffelex_current_wl_
, ffelex_current_wc_
);
940 ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS
);
941 ffebad_here (0, ffelex_token_
->where_line
, ffelex_token_
->where_col
);
942 ffebad_here (1, ffelex_current_wl_
, ffelex_current_wc_
);
943 sprintf (num
, "%lu", (unsigned long) ffelex_raw_mode_
);
946 /* Make sure the token has some text, might as well fill up with spaces. */
949 ffelex_append_to_token_ (' ');
950 } while (--ffelex_raw_mode_
> 0);
954 ffelex_raw_mode_
= 0;
955 ffelex_send_token_ ();
957 ffelex_token_
->type
= FFELEX_typeEOS
;
958 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
959 ffelex_token_
->where_col
= ffewhere_column_use (ffelex_current_wc_
);
963 ffelex_finish_statement_ ()
965 if ((ffelex_number_of_tokens_
== 0)
966 && (ffelex_token_
->type
== FFELEX_typeNONE
))
967 return; /* Don't have a statement pending. */
969 if (ffelex_token_
->type
!= FFELEX_typeEOS
)
970 ffelex_prepare_eos_ ();
972 ffelex_permit_include_
= TRUE
;
973 ffelex_send_token_ ();
974 ffelex_permit_include_
= FALSE
;
975 ffelex_number_of_tokens_
= 0;
976 ffelex_label_tokens_
= 0;
977 ffelex_names_
= TRUE
;
978 ffelex_names_pure_
= FALSE
; /* Probably not necessary. */
979 ffelex_hexnum_
= FALSE
;
981 if (!ffe_is_ffedebug ())
984 /* For debugging purposes only. */
986 if (ffelex_total_tokens_
!= ffelex_old_total_tokens_
)
988 fprintf (dmpout
, "; token_track had %ld tokens, now have %ld.\n",
989 ffelex_old_total_tokens_
, ffelex_total_tokens_
);
990 ffelex_old_total_tokens_
= ffelex_total_tokens_
;
994 /* Copied from gcc/c-common.c get_directive_line. */
996 #if FFECOM_targetCURRENT == FFECOM_targetGCC
998 ffelex_get_directive_line_ (char **text
, FILE *finput
)
1000 static char *directive_buffer
= NULL
;
1001 static unsigned buffer_length
= 0;
1003 register char *buffer_limit
;
1004 register int looking_for
= 0;
1005 register int char_escaped
= 0;
1007 if (buffer_length
== 0)
1009 directive_buffer
= (char *)xmalloc (128);
1010 buffer_length
= 128;
1013 buffer_limit
= &directive_buffer
[buffer_length
];
1015 for (p
= directive_buffer
; ; )
1019 /* Make buffer bigger if it is full. */
1020 if (p
>= buffer_limit
)
1022 register unsigned bytes_used
= (p
- directive_buffer
);
1026 = (char *)xrealloc (directive_buffer
, buffer_length
);
1027 p
= &directive_buffer
[bytes_used
];
1028 buffer_limit
= &directive_buffer
[buffer_length
];
1033 /* Discard initial whitespace. */
1034 if ((c
== ' ' || c
== '\t') && p
== directive_buffer
)
1037 /* Detect the end of the directive. */
1038 if ((c
== '\n' && looking_for
== 0)
1041 if (looking_for
!= 0)
1042 fatal ("Bad directive -- missing close-quote");
1045 *text
= directive_buffer
;
1051 ffelex_next_line_ ();
1053 /* Handle string and character constant syntax. */
1056 if (looking_for
== c
&& !char_escaped
)
1057 looking_for
= 0; /* Found terminator... stop looking. */
1060 if (c
== '\'' || c
== '"')
1061 looking_for
= c
; /* Don't stop buffering until we see another
1062 one of these (or an EOF). */
1064 /* Handle backslash. */
1065 char_escaped
= (c
== '\\' && ! char_escaped
);
1070 /* Handle # directives that make it through (or are generated by) the
1071 preprocessor. As much as reasonably possible, emulate the behavior
1072 of the gcc compiler phase cc1, though interactions between #include
1073 and INCLUDE might possibly produce bizarre results in terms of
1074 error reporting and the generation of debugging info vis-a-vis the
1075 locations of some things.
1077 Returns the next character unhandled, which is always newline or EOF. */
1079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1081 #if defined HANDLE_PRAGMA
1082 /* Local versions of these macros, that can be passed as function pointers. */
1086 return getc (finput
);
1093 ungetc (arg
, finput
);
1095 #endif /* HANDLE_PRAGMA */
1098 ffelex_hash_ (FILE *finput
)
1101 ffelexToken token
= NULL
;
1103 /* Read first nonwhite char after the `#'. */
1105 c
= ffelex_getc_ (finput
);
1106 while (c
== ' ' || c
== '\t')
1107 c
= ffelex_getc_ (finput
);
1109 /* If a letter follows, then if the word here is `line', skip
1110 it and ignore it; otherwise, ignore the line, with an error
1111 if the word isn't `pragma', `ident', `define', or `undef'. */
1113 if ((c
>= 'a' && c
<= 'z') || (c
>= 'A' && c
<= 'Z'))
1117 if (getc (finput
) == 'r'
1118 && getc (finput
) == 'a'
1119 && getc (finput
) == 'g'
1120 && getc (finput
) == 'm'
1121 && getc (finput
) == 'a'
1122 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1125 #if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */
1126 static char buffer
[128];
1127 char * buff
= buffer
;
1129 /* Read the pragma name into a buffer. */
1130 while (isspace (c
= getc (finput
)))
1138 while (c
!= EOF
&& ! isspace (c
) && c
!= '\n'
1139 && buff
< buffer
+ 128);
1144 #ifdef HANDLE_PRAGMA
1145 if (HANDLE_PRAGMA (pragma_getc
, pragma_ungetc
, buffer
))
1147 #endif /* HANDLE_PRAGMA */
1148 #ifdef HANDLE_GENERIC_PRAGMAS
1149 if (handle_generic_pragma (buffer
))
1151 #endif /* !HANDLE_GENERIC_PRAGMAS */
1153 /* Issue a warning message if we have been asked to do so.
1154 Ignoring unknown pragmas in system header file unless
1155 an explcit -Wunknown-pragmas has been given. */
1156 if (warn_unknown_pragmas
> 1
1157 || (warn_unknown_pragmas
&& ! in_system_header
))
1158 warning ("ignoring pragma: %s", token_buffer
);
1166 if (getc (finput
) == 'e'
1167 && getc (finput
) == 'f'
1168 && getc (finput
) == 'i'
1169 && getc (finput
) == 'n'
1170 && getc (finput
) == 'e'
1171 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1176 c
= ffelex_get_directive_line_ (&text
, finput
);
1178 #ifdef DWARF_DEBUGGING_INFO
1179 if ((debug_info_level
== DINFO_LEVEL_VERBOSE
)
1180 && (write_symbols
== DWARF_DEBUG
))
1181 dwarfout_define (lineno
, text
);
1182 #endif /* DWARF_DEBUGGING_INFO */
1189 if (getc (finput
) == 'n'
1190 && getc (finput
) == 'd'
1191 && getc (finput
) == 'e'
1192 && getc (finput
) == 'f'
1193 && ((c
= getc (finput
)) == ' ' || c
== '\t' || c
== '\n'
1198 c
= ffelex_get_directive_line_ (&text
, finput
);
1200 #ifdef DWARF_DEBUGGING_INFO
1201 if ((debug_info_level
== DINFO_LEVEL_VERBOSE
)
1202 && (write_symbols
== DWARF_DEBUG
))
1203 dwarfout_undef (lineno
, text
);
1204 #endif /* DWARF_DEBUGGING_INFO */
1211 if (getc (finput
) == 'i'
1212 && getc (finput
) == 'n'
1213 && getc (finput
) == 'e'
1214 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1219 if (getc (finput
) == 'd'
1220 && getc (finput
) == 'e'
1221 && getc (finput
) == 'n'
1222 && getc (finput
) == 't'
1223 && ((c
= getc (finput
)) == ' ' || c
== '\t'))
1225 /* #ident. The pedantic warning is now in cccp.c. */
1227 /* Here we have just seen `#ident '.
1228 A string constant should follow. */
1230 while (c
== ' ' || c
== '\t')
1233 /* If no argument, ignore the line. */
1234 if (c
== '\n' || c
== EOF
)
1237 c
= ffelex_cfelex_ (&token
, finput
, c
);
1240 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1242 error ("invalid #ident");
1246 if (! flag_no_ident
)
1248 #ifdef ASM_OUTPUT_IDENT
1249 ASM_OUTPUT_IDENT (asm_out_file
,
1250 ffelex_token_text (token
));
1254 /* Skip the rest of this line. */
1259 error ("undefined or invalid # directive");
1264 /* Here we have either `#line' or `# <nonletter>'.
1265 In either case, it should be a line number; a digit should follow. */
1267 while (c
== ' ' || c
== '\t')
1268 c
= ffelex_getc_ (finput
);
1270 /* If the # is the only nonwhite char on the line,
1271 just ignore it. Check the new newline. */
1272 if (c
== '\n' || c
== EOF
)
1275 /* Something follows the #; read a token. */
1277 c
= ffelex_cfelex_ (&token
, finput
, c
);
1280 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1282 int old_lineno
= lineno
;
1283 char *old_input_filename
= input_filename
;
1286 /* subtract one, because it is the following line that
1287 gets the specified number */
1288 int l
= atoi (ffelex_token_text (token
)) - 1;
1290 /* Is this the last nonwhite stuff on the line? */
1291 while (c
== ' ' || c
== '\t')
1292 c
= ffelex_getc_ (finput
);
1293 if (c
== '\n' || c
== EOF
)
1295 /* No more: store the line number and check following line. */
1297 if (!ffelex_kludge_flag_
)
1299 ffewhere_file_set (NULL
, TRUE
, (ffewhereLineNumber
) l
);
1302 ffelex_token_kill (token
);
1307 /* More follows: it must be a string constant (filename). */
1309 /* Read the string constant. */
1310 c
= ffelex_cfelex_ (&token
, finput
, c
);
1313 || (ffelex_token_type (token
) != FFELEX_typeCHARACTER
))
1315 error ("invalid #line");
1321 if (ffelex_kludge_flag_
)
1322 input_filename
= ffelex_token_text (token
);
1325 wf
= ffewhere_file_new (ffelex_token_text (token
),
1326 ffelex_token_length (token
));
1327 input_filename
= ffewhere_file_name (wf
);
1328 ffewhere_file_set (wf
, TRUE
, (ffewhereLineNumber
) l
);
1331 #if 0 /* Not sure what g77 should do with this yet. */
1332 /* Each change of file name
1333 reinitializes whether we are now in a system header. */
1334 in_system_header
= 0;
1337 if (main_input_filename
== 0)
1338 main_input_filename
= input_filename
;
1340 /* Is this the last nonwhite stuff on the line? */
1341 while (c
== ' ' || c
== '\t')
1343 if (c
== '\n' || c
== EOF
)
1345 if (!ffelex_kludge_flag_
)
1347 /* Update the name in the top element of input_file_stack. */
1348 if (input_file_stack
)
1349 input_file_stack
->name
= input_filename
;
1352 ffelex_token_kill (token
);
1357 c
= ffelex_cfelex_ (&token
, finput
, c
);
1359 /* `1' after file name means entering new file.
1360 `2' after file name means just left a file. */
1363 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
))
1365 int num
= atoi (ffelex_token_text (token
));
1367 if (ffelex_kludge_flag_
)
1370 input_filename
= old_input_filename
;
1371 fatal ("Use `#line ...' instead of `# ...' in first line");
1376 /* Pushing to a new file. */
1377 ffelex_file_push_ (old_lineno
, input_filename
);
1381 /* Popping out of a file. */
1382 ffelex_file_pop_ (input_filename
);
1385 /* Is this the last nonwhite stuff on the line? */
1386 while (c
== ' ' || c
== '\t')
1388 if (c
== '\n' || c
== EOF
)
1391 ffelex_token_kill (token
);
1395 c
= ffelex_cfelex_ (&token
, finput
, c
);
1398 /* `3' after file name means this is a system header file. */
1400 #if 0 /* Not sure what g77 should do with this yet. */
1402 && (ffelex_token_type (token
) == FFELEX_typeNUMBER
)
1403 && (atoi (ffelex_token_text (token
)) == 3))
1404 in_system_header
= 1;
1407 while (c
== ' ' || c
== '\t')
1409 if (((token
!= NULL
)
1410 || (c
!= '\n' && c
!= EOF
))
1411 && ffelex_kludge_flag_
)
1414 input_filename
= old_input_filename
;
1415 fatal ("Use `#line ...' instead of `# ...' in first line");
1419 error ("invalid #-line");
1421 /* skip the rest of this line. */
1423 if ((token
!= NULL
) && !ffelex_kludge_flag_
)
1424 ffelex_token_kill (token
);
1425 while ((c
= getc (finput
)) != EOF
&& c
!= '\n')
1429 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1431 /* "Image" a character onto the card image, return incremented column number.
1433 Normally invoking this function as in
1434 column = ffelex_image_char_ (c, column);
1435 is the same as doing:
1436 ffelex_card_image_[column++] = c;
1438 However, tabs and carriage returns are handled specially, to preserve
1439 the visual "image" of the input line (in most editors) in the card
1442 Carriage returns are ignored, as they are assumed to be followed
1445 A tab is handled by first doing:
1446 ffelex_card_image_[column++] = ' ';
1447 That is, it translates to at least one space. Then, as many spaces
1448 are imaged as necessary to bring the column number to the next tab
1449 position, where tab positions start in the ninth column and each
1450 eighth column afterwards. ALSO, a static var named ffelex_saw_tab_
1451 is set to TRUE to notify the lexer that a tab was seen.
1453 Columns are numbered and tab stops set as illustrated below:
1455 012345670123456701234567...
1459 xxxxxxx yyyyyyy zzzzzzz
1460 xxxxxxxx yyyyyyyy... */
1462 static ffewhereColumnNumber
1463 ffelex_image_char_ (int c
, ffewhereColumnNumber column
)
1465 ffewhereColumnNumber old_column
= column
;
1467 if (column
>= ffelex_card_size_
)
1469 ffewhereColumnNumber newmax
= ffelex_card_size_
<< 1;
1471 if (ffelex_bad_line_
)
1474 if ((newmax
>> 1) != ffelex_card_size_
)
1475 { /* Overflowed column number. */
1476 overflow
: /* :::::::::::::::::::: */
1478 ffelex_bad_line_
= TRUE
;
1479 strcpy (&ffelex_card_image_
[column
- 3], "...");
1480 ffelex_card_length_
= column
;
1481 ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG
,
1482 ffelex_linecount_current_
, column
+ 1);
1487 = malloc_resize_ksr (malloc_pool_image (),
1490 ffelex_card_size_
+ 9);
1491 ffelex_card_size_
= newmax
;
1500 ffelex_saw_tab_
= TRUE
;
1501 ffelex_card_image_
[column
++] = ' ';
1502 while ((column
& 7) != 0)
1503 ffelex_card_image_
[column
++] = ' ';
1507 if (!ffelex_bad_line_
)
1509 ffelex_bad_line_
= TRUE
;
1510 strcpy (&ffelex_card_image_
[column
], "[\\0]");
1511 ffelex_card_length_
= column
+ 4;
1512 ffebad_start_msg_lex ("Null character at %0 -- line ignored",
1513 FFEBAD_severityFATAL
);
1514 ffelex_bad_here_ (0, ffelex_linecount_current_
, column
+ 1);
1521 ffelex_card_image_
[column
++] = c
;
1525 if (column
< old_column
)
1527 column
= old_column
;
1528 goto overflow
; /* :::::::::::::::::::: */
1537 ffewhereFile include_wherefile
= ffelex_include_wherefile_
;
1538 FILE *include_file
= ffelex_include_file_
;
1539 /* The rest of this is to push, and after the INCLUDE file is processed,
1540 pop, the static lexer state info that pertains to each particular
1543 ffewhereColumnNumber card_size
= ffelex_card_size_
;
1544 ffewhereColumnNumber card_length
= ffelex_card_length_
;
1545 ffewhereLine current_wl
= ffelex_current_wl_
;
1546 ffewhereColumn current_wc
= ffelex_current_wc_
;
1547 bool saw_tab
= ffelex_saw_tab_
;
1548 ffewhereColumnNumber final_nontab_column
= ffelex_final_nontab_column_
;
1549 ffewhereFile current_wf
= ffelex_current_wf_
;
1550 ffewhereLineNumber linecount_current
= ffelex_linecount_current_
;
1551 ffewhereLineNumber linecount_offset
1552 = ffewhere_line_filelinenum (current_wl
);
1553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1554 int old_lineno
= lineno
;
1555 char *old_input_filename
= input_filename
;
1558 if (card_length
!= 0)
1560 card_image
= malloc_new_ks (malloc_pool_image (),
1561 "FFELEX saved card image",
1563 memcpy (card_image
, ffelex_card_image_
, card_length
);
1568 ffelex_set_include_
= FALSE
;
1570 ffelex_next_line_ ();
1572 ffewhere_file_set (include_wherefile
, TRUE
, 0);
1574 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1575 ffelex_file_push_ (old_lineno
, ffewhere_file_name (include_wherefile
));
1576 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1578 if (ffelex_include_free_form_
)
1579 ffelex_file_free (include_wherefile
, include_file
);
1581 ffelex_file_fixed (include_wherefile
, include_file
);
1583 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1584 ffelex_file_pop_ (ffewhere_file_name (current_wf
));
1585 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1587 ffewhere_file_set (current_wf
, TRUE
, linecount_offset
);
1589 ffecom_close_include (include_file
);
1591 if (card_length
!= 0)
1593 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1594 #error "need to handle possible reduction of card size here!!"
1596 assert (ffelex_card_size_
>= card_length
); /* It shrunk?? */
1597 memcpy (ffelex_card_image_
, card_image
, card_length
);
1599 ffelex_card_image_
[card_length
] = '\0';
1601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1602 input_filename
= old_input_filename
;
1603 lineno
= old_lineno
;
1605 ffelex_linecount_current_
= linecount_current
;
1606 ffelex_current_wf_
= current_wf
;
1607 ffelex_final_nontab_column_
= final_nontab_column
;
1608 ffelex_saw_tab_
= saw_tab
;
1609 ffelex_current_wc_
= current_wc
;
1610 ffelex_current_wl_
= current_wl
;
1611 ffelex_card_length_
= card_length
;
1612 ffelex_card_size_
= card_size
;
1615 /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation?
1617 ffewhereColumnNumber col;
1618 int c; // Char at col.
1619 if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1))
1620 // We have a continuation indicator.
1622 If there are <n> spaces starting at ffelex_card_image_[col] up through
1623 the null character, where <n> is 0 or greater, returns TRUE. */
1626 ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col
)
1628 while (ffelex_card_image_
[col
] != '\0')
1630 if (ffelex_card_image_
[col
++] != ' ')
1636 /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation?
1638 ffewhereColumnNumber col;
1639 int c; // Char at col.
1640 if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1))
1641 // We have a continuation indicator.
1643 If there are <n> spaces starting at ffelex_card_image_[col] up through
1644 the null character or '!', where <n> is 0 or greater, returns TRUE. */
1647 ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col
)
1649 while ((ffelex_card_image_
[col
] != '\0') && (ffelex_card_image_
[col
] != '!'))
1651 if (ffelex_card_image_
[col
++] != ' ')
1658 ffelex_next_line_ ()
1660 ffelex_linecount_current_
= ffelex_linecount_next_
;
1661 ++ffelex_linecount_next_
;
1662 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1668 ffelex_send_token_ ()
1670 ++ffelex_number_of_tokens_
;
1672 ffelex_backslash_ (EOF
, 0);
1674 if (ffelex_token_
->text
== NULL
)
1676 if (ffelex_token_
->type
== FFELEX_typeCHARACTER
)
1678 ffelex_append_to_token_ ('\0');
1679 ffelex_token_
->length
= 0;
1683 ffelex_token_
->text
[ffelex_token_
->length
] = '\0';
1685 assert (ffelex_raw_mode_
== 0);
1687 if (ffelex_token_
->type
== FFELEX_typeNAMES
)
1689 ffewhere_line_kill (ffelex_token_
->currentnames_line
);
1690 ffewhere_column_kill (ffelex_token_
->currentnames_col
);
1693 assert (ffelex_handler_
!= NULL
);
1694 ffelex_handler_
= (ffelexHandler
) (*ffelex_handler_
) (ffelex_token_
);
1695 assert (ffelex_handler_
!= NULL
);
1697 ffelex_token_kill (ffelex_token_
);
1699 ffelex_token_
= ffelex_token_new_ ();
1700 ffelex_token_
->uses
= 1;
1701 ffelex_token_
->text
= NULL
;
1702 if (ffelex_raw_mode_
< 0)
1704 ffelex_token_
->type
= FFELEX_typeCHARACTER
;
1705 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
1706 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
1707 ffelex_raw_where_line_
= ffewhere_line_unknown ();
1708 ffelex_raw_where_col_
= ffewhere_column_unknown ();
1712 ffelex_token_
->type
= FFELEX_typeNONE
;
1713 ffelex_token_
->where_line
= ffewhere_line_unknown ();
1714 ffelex_token_
->where_col
= ffewhere_column_unknown ();
1717 if (ffelex_set_include_
)
1721 /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me
1723 return ffelex_swallow_tokens_;
1725 Return this handler when you don't want to look at any more tokens in the
1726 statement because you've encountered an unrecoverable error in the
1729 static ffelexHandler
1730 ffelex_swallow_tokens_ (ffelexToken t
)
1732 assert (ffelex_eos_handler_
!= NULL
);
1734 if ((ffelex_token_type (t
) == FFELEX_typeEOS
)
1735 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
))
1736 return (ffelexHandler
) (*ffelex_eos_handler_
) (t
);
1738 return (ffelexHandler
) ffelex_swallow_tokens_
;
1742 ffelex_token_new_ ()
1746 ++ffelex_total_tokens_
;
1748 t
= (ffelexToken
) malloc_new_ks (malloc_pool_image (),
1749 "FFELEX token", sizeof (*t
));
1750 t
->id_
= ffelex_token_nextid_
++;
1755 ffelex_type_string_ (ffelexType type
)
1757 static const char *types
[] = {
1759 "FFELEX_typeCOMMENT",
1765 "FFELEX_typeDOLLAR",
1767 "FFELEX_typePERCENT",
1768 "FFELEX_typeAMPERSAND",
1769 "FFELEX_typeAPOSTROPHE",
1770 "FFELEX_typeOPEN_PAREN",
1771 "FFELEX_typeCLOSE_PAREN",
1772 "FFELEX_typeASTERISK",
1775 "FFELEX_typePERIOD",
1777 "FFELEX_typeNUMBER",
1778 "FFELEX_typeOPEN_ANGLE",
1779 "FFELEX_typeEQUALS",
1780 "FFELEX_typeCLOSE_ANGLE",
1784 "FFELEX_typeCONCAT",
1787 "FFELEX_typeHOLLERITH",
1788 "FFELEX_typeCHARACTER",
1790 "FFELEX_typeSEMICOLON",
1791 "FFELEX_typeUNDERSCORE",
1792 "FFELEX_typeQUESTION",
1793 "FFELEX_typeOPEN_ARRAY",
1794 "FFELEX_typeCLOSE_ARRAY",
1795 "FFELEX_typeCOLONCOLON",
1796 "FFELEX_typeREL_LE",
1797 "FFELEX_typeREL_NE",
1798 "FFELEX_typeREL_EQ",
1799 "FFELEX_typePOINTS",
1803 if (type
>= ARRAY_SIZE (types
))
1809 ffelex_display_token (ffelexToken t
)
1814 fprintf (dmpout
, "; Token #%lu is %s (line %" ffewhereLineNumber_f
"u, col %"
1815 ffewhereColumnNumber_f
"u)",
1817 ffelex_type_string_ (t
->type
),
1818 ffewhere_line_number (t
->where_line
),
1819 ffewhere_column_number (t
->where_col
));
1821 if (t
->text
!= NULL
)
1822 fprintf (dmpout
, ": \"%.*s\"\n",
1826 fprintf (dmpout
, ".\n");
1829 /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER
1831 if (ffelex_expecting_character())
1832 // next token delivered by lexer will be CHARACTER.
1834 If the most recent call to ffelex_set_expecting_hollerith since the last
1835 token was delivered by the lexer passed a length of -1, then we return
1836 TRUE, because the next token we deliver will be typeCHARACTER, else we
1840 ffelex_expecting_character ()
1842 return (ffelex_raw_mode_
!= 0);
1845 /* ffelex_file_fixed -- Lex a given file in fixed source form
1849 ffelex_file_fixed(wf,f);
1851 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
1854 ffelex_file_fixed (ffewhereFile wf
, FILE *f
)
1856 register int c
= 0; /* Character currently under consideration. */
1857 register ffewhereColumnNumber column
= 0; /* Not really; 0 means column 1... */
1858 bool disallow_continuation_line
;
1859 bool ignore_disallowed_continuation
= FALSE
;
1860 int latest_char_in_file
= 0; /* For getting back into comment-skipping
1863 ffewhereColumnNumber first_label_char
; /* First char of label --
1865 char label_string
[6]; /* Text of label. */
1866 int labi
; /* Length of label text. */
1867 bool finish_statement
; /* Previous statement finished? */
1868 bool have_content
; /* This line have content? */
1869 bool just_do_label
; /* Nothing but label (and continuation?) on
1872 /* Lex is called for a particular file, not for a particular program unit.
1873 Yet the two events do share common characteristics. The first line in a
1874 file or in a program unit cannot be a continuation line. No token can
1875 be in mid-formation. No current label for the statement exists, since
1876 there is no current statement. */
1878 assert (ffelex_handler_
!= NULL
);
1880 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1882 input_filename
= ffewhere_file_name (wf
);
1884 ffelex_current_wf_
= wf
;
1885 disallow_continuation_line
= TRUE
;
1886 ignore_disallowed_continuation
= FALSE
;
1887 ffelex_token_
->type
= FFELEX_typeNONE
;
1888 ffelex_number_of_tokens_
= 0;
1889 ffelex_label_tokens_
= 0;
1890 ffelex_current_wl_
= ffewhere_line_unknown ();
1891 ffelex_current_wc_
= ffewhere_column_unknown ();
1892 latest_char_in_file
= '\n';
1894 if (ffe_is_null_version ())
1896 /* Just substitute a "program" directly here. */
1898 char line
[] = " call g77__fvers;call g77__ivers;call g77__uvers;end";
1902 for (p
= &line
[0]; *p
!= '\0'; ++p
)
1903 column
= ffelex_image_char_ (*p
, column
);
1907 goto have_line
; /* :::::::::::::::::::: */
1910 goto first_line
; /* :::::::::::::::::::: */
1912 /* Come here to get a new line. */
1914 beginning_of_line
: /* :::::::::::::::::::: */
1916 disallow_continuation_line
= FALSE
;
1918 /* Come here directly when last line didn't clarify the continuation issue. */
1920 beginning_of_line_again
: /* :::::::::::::::::::: */
1922 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */
1923 if (ffelex_card_size_
!= FFELEX_columnINITIAL_SIZE_
)
1926 = malloc_resize_ks (malloc_pool_image (),
1928 FFELEX_columnINITIAL_SIZE_
+ 9,
1929 ffelex_card_size_
+ 9);
1930 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
1934 first_line
: /* :::::::::::::::::::: */
1936 c
= latest_char_in_file
;
1937 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
1940 end_of_file
: /* :::::::::::::::::::: */
1942 /* Line ending in EOF instead of \n still counts as a whole line. */
1944 ffelex_finish_statement_ ();
1945 ffewhere_line_kill (ffelex_current_wl_
);
1946 ffewhere_column_kill (ffelex_current_wc_
);
1947 return (ffelexHandler
) ffelex_handler_
;
1950 ffelex_next_line_ ();
1952 ffelex_bad_line_
= FALSE
;
1954 /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1956 while (((lextype
= ffelex_first_char_
[c
]) == FFELEX_typeCOMMENT
)
1957 || (lextype
== FFELEX_typeERROR
)
1958 || (lextype
== FFELEX_typeSLASH
)
1959 || (lextype
== FFELEX_typeHASH
))
1961 /* Test most frequent type of line first, etc. */
1962 if ((lextype
== FFELEX_typeCOMMENT
)
1963 || ((lextype
== FFELEX_typeSLASH
)
1964 && ((c
= getc (f
)) == '*'))) /* NOTE SIDE-EFFECT. */
1966 /* Typical case (straight comment), just ignore rest of line. */
1967 comment_line
: /* :::::::::::::::::::: */
1969 while ((c
!= '\n') && (c
!= EOF
))
1972 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1973 else if (lextype
== FFELEX_typeHASH
)
1974 c
= ffelex_hash_ (f
);
1976 else if (lextype
== FFELEX_typeSLASH
)
1978 /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1979 ffelex_card_image_
[0] = '/';
1980 ffelex_card_image_
[1] = c
;
1982 goto bad_first_character
; /* :::::::::::::::::::: */
1985 /* typeERROR or unsupported typeHASH. */
1986 { /* Bad first character, get line and display
1988 column
= ffelex_image_char_ (c
, 0);
1990 bad_first_character
: /* :::::::::::::::::::: */
1992 ffelex_bad_line_
= TRUE
;
1993 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
1994 column
= ffelex_image_char_ (c
, column
);
1995 ffelex_card_image_
[column
] = '\0';
1996 ffelex_card_length_
= column
;
1997 ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID
,
1998 ffelex_linecount_current_
, 1);
2001 /* Read past last char in line. */
2005 ffelex_next_line_ ();
2006 goto end_of_file
; /* :::::::::::::::::::: */
2011 ffelex_next_line_ ();
2014 goto end_of_file
; /* :::::::::::::::::::: */
2016 ffelex_bad_line_
= FALSE
;
2017 } /* while [c, first char, means comment] */
2021 || (ffelex_final_nontab_column_
== 0);
2023 if (lextype
== FFELEX_typeDEBUG
)
2024 c
= ' '; /* A 'D' or 'd' in column 1 with the
2025 debug-lines option on. */
2027 column
= ffelex_image_char_ (c
, 0);
2029 /* Read the entire line in as is (with whitespace processing). */
2031 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
2032 column
= ffelex_image_char_ (c
, column
);
2034 if (ffelex_bad_line_
)
2036 ffelex_card_image_
[column
] = '\0';
2037 ffelex_card_length_
= column
;
2038 goto comment_line
; /* :::::::::::::::::::: */
2041 /* If no tab, cut off line after column 72/132. */
2043 if (!ffelex_saw_tab_
&& (column
> ffelex_final_nontab_column_
))
2045 /* Technically, we should now fill ffelex_card_image_ up thru column
2046 72/132 with spaces, since character/hollerith constants must count
2047 them in that manner. To save CPU time in several ways (avoid a loop
2048 here that would be used only when we actually end a line in
2049 character-constant mode; avoid writing memory unnecessarily; avoid a
2050 loop later checking spaces when not scanning for character-constant
2051 characters), we don't do this, and we do the appropriate thing when
2052 we encounter end-of-line while actually processing a character
2055 column
= ffelex_final_nontab_column_
;
2058 have_line
: /* :::::::::::::::::::: */
2060 ffelex_card_image_
[column
] = '\0';
2061 ffelex_card_length_
= column
;
2063 /* Save next char in file so we can use register-based c while analyzing
2064 line we just read. */
2066 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
2068 have_content
= FALSE
;
2070 /* Handle label, if any. */
2073 first_label_char
= FFEWHERE_columnUNKNOWN
;
2074 for (column
= 0; column
< 5; ++column
)
2076 switch (c
= ffelex_card_image_
[column
])
2080 goto stop_looking
; /* :::::::::::::::::::: */
2095 label_string
[labi
++] = c
;
2096 if (first_label_char
== FFEWHERE_columnUNKNOWN
)
2097 first_label_char
= column
+ 1;
2103 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2104 ffelex_linecount_current_
,
2106 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2108 if (ffe_is_pedantic ())
2109 ffelex_bad_1_ (FFEBAD_AMPERSAND
,
2110 ffelex_linecount_current_
, 1);
2111 finish_statement
= FALSE
;
2112 just_do_label
= FALSE
;
2113 goto got_a_continuation
; /* :::::::::::::::::::: */
2116 if (ffelex_card_image_
[column
+ 1] == '*')
2117 goto stop_looking
; /* :::::::::::::::::::: */
2120 ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC
,
2121 ffelex_linecount_current_
, column
+ 1);
2122 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2126 stop_looking
: /* :::::::::::::::::::: */
2128 label_string
[labi
] = '\0';
2130 /* Find first nonblank char starting with continuation column. */
2132 if (column
== 5) /* In which case we didn't see end of line in
2134 while ((c
= ffelex_card_image_
[column
]) == ' ')
2137 /* Now we're trying to figure out whether this is a continuation line and
2138 whether there's anything else of substance on the line. The cases are
2141 1. If a line has an explicit continuation character (other than the digit
2142 zero), then if it also has a label, the label is ignored and an error
2143 message is printed. Any remaining text on the line is passed to the
2144 parser tasks, thus even an all-blank line (possibly with an ignored
2145 label) aside from a positive continuation character might have meaning
2146 in the midst of a character or hollerith constant.
2148 2. If a line has no explicit continuation character (that is, it has a
2149 space in column 6 and the first non-space character past column 6 is
2150 not a digit 0-9), then there are two possibilities:
2152 A. A label is present and/or a non-space (and non-comment) character
2153 appears somewhere after column 6. Terminate processing of the previous
2154 statement, if any, send the new label for the next statement, if any,
2155 and start processing a new statement with this non-blank character, if
2158 B. The line is essentially blank, except for a possible comment character.
2159 Don't terminate processing of the previous statement and don't pass any
2160 characters to the parser tasks, since the line is not flagged as a
2161 continuation line. We treat it just like a completely blank line.
2163 3. If a line has a continuation character of zero (0), then we terminate
2164 processing of the previous statement, if any, send the new label for the
2165 next statement, if any, and start processing a new statement, if any
2166 non-blank characters are present.
2168 If, when checking to see if we should terminate the previous statement, it
2169 is found that there is no previous statement but that there is an
2170 outstanding label, substitute CONTINUE as the statement for the label
2171 and display an error message. */
2173 finish_statement
= FALSE
;
2174 just_do_label
= FALSE
;
2178 case '!': /* ANSI Fortran 90 says ! in column 6 is
2180 /* VXT Fortran says ! anywhere is comment, even column 6. */
2181 if (ffe_is_vxt () || (column
!= 5))
2182 goto no_tokens_on_line
; /* :::::::::::::::::::: */
2183 goto got_a_continuation
; /* :::::::::::::::::::: */
2186 if (ffelex_card_image_
[column
+ 1] != '*')
2187 goto some_other_character
; /* :::::::::::::::::::: */
2191 /* This seems right to do. But it is close to call, since / * starting
2192 in column 6 will thus be interpreted as a continuation line
2193 beginning with '*'. */
2195 goto got_a_continuation
;/* :::::::::::::::::::: */
2199 /* End of line. Therefore may be continued-through line, so handle
2200 pending label as possible to-be-continued and drive end-of-statement
2201 for any previous statement, else treat as blank line. */
2203 no_tokens_on_line
: /* :::::::::::::::::::: */
2205 if (ffe_is_pedantic () && (c
== '/'))
2206 ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT
,
2207 ffelex_linecount_current_
, column
+ 1);
2208 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2209 { /* Can't be a continued-through line if it
2211 finish_statement
= TRUE
;
2212 have_content
= TRUE
;
2213 just_do_label
= TRUE
;
2216 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2219 if (ffe_is_pedantic () && (column
!= 5))
2220 ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN
,
2221 ffelex_linecount_current_
, column
+ 1);
2222 finish_statement
= TRUE
;
2223 goto check_for_content
; /* :::::::::::::::::::: */
2235 /* NOTE: This label can be reached directly from the code
2236 that lexes the label field in columns 1-5. */
2237 got_a_continuation
: /* :::::::::::::::::::: */
2239 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2241 ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION
,
2242 ffelex_linecount_current_
,
2244 ffelex_linecount_current_
,
2246 first_label_char
= FFEWHERE_columnUNKNOWN
;
2248 if (disallow_continuation_line
)
2250 if (!ignore_disallowed_continuation
)
2251 ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION
,
2252 ffelex_linecount_current_
, column
+ 1);
2253 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2255 if (ffe_is_pedantic () && (column
!= 5))
2256 ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN
,
2257 ffelex_linecount_current_
, column
+ 1);
2258 if ((ffelex_raw_mode_
!= 0)
2259 && (((c
= ffelex_card_image_
[column
+ 1]) != '\0')
2260 || !ffelex_saw_tab_
))
2263 have_content
= TRUE
;
2267 check_for_content
: /* :::::::::::::::::::: */
2269 while ((c
= ffelex_card_image_
[++column
]) == ' ')
2274 && (ffelex_card_image_
[column
+ 1] == '*')))
2276 if (ffe_is_pedantic () && (c
== '/'))
2277 ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT
,
2278 ffelex_linecount_current_
, column
+ 1);
2279 just_do_label
= TRUE
;
2282 have_content
= TRUE
;
2287 some_other_character
: /* :::::::::::::::::::: */
2290 goto got_a_continuation
;/* :::::::::::::::::::: */
2292 /* Here is the very normal case of a regular character starting in
2293 column 7 or beyond with a blank in column 6. */
2295 finish_statement
= TRUE
;
2296 have_content
= TRUE
;
2301 || (first_label_char
!= FFEWHERE_columnUNKNOWN
))
2303 /* The line has content of some kind, install new end-statement
2304 point for error messages. Note that "content" includes cases
2305 where there's little apparent content but enough to finish
2306 a statement. That's because finishing a statement can trigger
2307 an impending INCLUDE, and that requires accurate line info being
2308 maintained by the lexer. */
2310 if (finish_statement
)
2311 ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
2313 ffewhere_line_kill (ffelex_current_wl_
);
2314 ffewhere_column_kill (ffelex_current_wc_
);
2315 ffelex_current_wl_
= ffewhere_line_new (ffelex_linecount_current_
);
2316 ffelex_current_wc_
= ffewhere_column_new (ffelex_card_length_
+ 1);
2319 /* We delay this for a combination of reasons. Mainly, it can start
2320 INCLUDE processing, and we want to delay that until the lexer's
2321 info on the line is coherent. And we want to delay that until we're
2322 sure there's a reason to make that info coherent, to avoid saving
2323 lots of useless lines. */
2325 if (finish_statement
)
2326 ffelex_finish_statement_ ();
2328 /* If label is present, enclose it in a NUMBER token and send it along. */
2330 if (first_label_char
!= FFEWHERE_columnUNKNOWN
)
2332 assert (ffelex_token_
->type
== FFELEX_typeNONE
);
2333 ffelex_token_
->type
= FFELEX_typeNUMBER
;
2334 ffelex_append_to_token_ ('\0'); /* Make room for label text. */
2335 strcpy (ffelex_token_
->text
, label_string
);
2336 ffelex_token_
->where_line
2337 = ffewhere_line_use (ffelex_current_wl_
);
2338 ffelex_token_
->where_col
= ffewhere_column_new (first_label_char
);
2339 ffelex_token_
->length
= labi
;
2340 ffelex_send_token_ ();
2341 ++ffelex_label_tokens_
;
2345 goto beginning_of_line
; /* :::::::::::::::::::: */
2347 /* Here is the main engine for parsing. c holds the character at column.
2348 It is already known that c is not a blank, end of line, or shriek,
2349 unless ffelex_raw_mode_ is not 0 (indicating we are in a
2350 character/hollerith constant). A partially filled token may already
2351 exist in ffelex_token_. One special case: if, when the end of the line
2352 is reached, continuation_line is FALSE and the only token on the line is
2353 END, then it is indeed the last statement. We don't look for
2354 continuation lines during this program unit in that case. This is
2355 according to ANSI. */
2357 if (ffelex_raw_mode_
!= 0)
2360 parse_raw_character
: /* :::::::::::::::::::: */
2364 ffewhereColumnNumber i
;
2366 if (ffelex_saw_tab_
|| (column
>= ffelex_final_nontab_column_
))
2367 goto beginning_of_line
; /* :::::::::::::::::::: */
2369 /* Pad out line with "virtual" spaces. */
2371 for (i
= column
; i
< ffelex_final_nontab_column_
; ++i
)
2372 ffelex_card_image_
[i
] = ' ';
2373 ffelex_card_image_
[i
] = '\0';
2374 ffelex_card_length_
= i
;
2378 switch (ffelex_raw_mode_
)
2381 c
= ffelex_backslash_ (c
, column
);
2385 if (!ffelex_backslash_reconsider_
)
2386 ffelex_append_to_token_ (c
);
2387 ffelex_raw_mode_
= -1;
2391 if (c
== ffelex_raw_char_
)
2393 ffelex_raw_mode_
= -1;
2394 ffelex_append_to_token_ (c
);
2398 ffelex_raw_mode_
= 0;
2399 ffelex_backslash_reconsider_
= TRUE
;
2404 if (c
== ffelex_raw_char_
)
2405 ffelex_raw_mode_
= -2;
2408 c
= ffelex_backslash_ (c
, column
);
2411 ffelex_raw_mode_
= -3;
2415 ffelex_append_to_token_ (c
);
2420 c
= ffelex_backslash_ (c
, column
);
2424 if (!ffelex_backslash_reconsider_
)
2426 ffelex_append_to_token_ (c
);
2432 if (ffelex_backslash_reconsider_
)
2433 ffelex_backslash_reconsider_
= FALSE
;
2435 c
= ffelex_card_image_
[++column
];
2437 if (ffelex_raw_mode_
== 0)
2439 ffelex_send_token_ ();
2440 assert (ffelex_raw_mode_
== 0);
2442 c
= ffelex_card_image_
[++column
];
2446 && (ffelex_card_image_
[column
+ 1] == '*')))
2447 goto beginning_of_line
; /* :::::::::::::::::::: */
2448 goto parse_nonraw_character
; /* :::::::::::::::::::: */
2450 goto parse_raw_character
; /* :::::::::::::::::::: */
2453 parse_nonraw_character
: /* :::::::::::::::::::: */
2455 switch (ffelex_token_
->type
)
2457 case FFELEX_typeNONE
:
2461 ffelex_token_
->type
= FFELEX_typeQUOTE
;
2462 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2463 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2464 ffelex_send_token_ ();
2468 ffelex_token_
->type
= FFELEX_typeDOLLAR
;
2469 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2470 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2471 ffelex_send_token_ ();
2475 ffelex_token_
->type
= FFELEX_typePERCENT
;
2476 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2477 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2478 ffelex_send_token_ ();
2482 ffelex_token_
->type
= FFELEX_typeAMPERSAND
;
2483 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2484 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2485 ffelex_send_token_ ();
2489 ffelex_token_
->type
= FFELEX_typeAPOSTROPHE
;
2490 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2491 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2492 ffelex_send_token_ ();
2496 ffelex_token_
->type
= FFELEX_typeOPEN_PAREN
;
2497 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2498 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2502 ffelex_token_
->type
= FFELEX_typeCLOSE_PAREN
;
2503 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2504 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2505 ffelex_send_token_ ();
2509 ffelex_token_
->type
= FFELEX_typeASTERISK
;
2510 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2511 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2515 ffelex_token_
->type
= FFELEX_typePLUS
;
2516 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2517 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2518 ffelex_send_token_ ();
2522 ffelex_token_
->type
= FFELEX_typeCOMMA
;
2523 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2524 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2525 ffelex_send_token_ ();
2529 ffelex_token_
->type
= FFELEX_typeMINUS
;
2530 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2531 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2532 ffelex_send_token_ ();
2536 ffelex_token_
->type
= FFELEX_typePERIOD
;
2537 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2538 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2539 ffelex_send_token_ ();
2543 ffelex_token_
->type
= FFELEX_typeSLASH
;
2544 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2545 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2559 = ffelex_hexnum_
? FFELEX_typeNAME
: FFELEX_typeNUMBER
;
2560 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2561 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2562 ffelex_append_to_token_ (c
);
2566 ffelex_token_
->type
= FFELEX_typeCOLON
;
2567 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2568 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2572 ffelex_token_
->type
= FFELEX_typeSEMICOLON
;
2573 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2574 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2575 ffelex_permit_include_
= TRUE
;
2576 ffelex_send_token_ ();
2577 ffelex_permit_include_
= FALSE
;
2581 ffelex_token_
->type
= FFELEX_typeOPEN_ANGLE
;
2582 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2583 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2587 ffelex_token_
->type
= FFELEX_typeEQUALS
;
2588 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2589 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2593 ffelex_token_
->type
= FFELEX_typeCLOSE_ANGLE
;
2594 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2595 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2599 ffelex_token_
->type
= FFELEX_typeQUESTION
;
2600 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
2601 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2602 ffelex_send_token_ ();
2606 if (1 || ffe_is_90 ())
2608 ffelex_token_
->type
= FFELEX_typeUNDERSCORE
;
2609 ffelex_token_
->where_line
2610 = ffewhere_line_use (ffelex_current_wl_
);
2611 ffelex_token_
->where_col
2612 = ffewhere_column_new (column
+ 1);
2613 ffelex_send_token_ ();
2669 c
= ffesrc_char_source (c
);
2671 if (ffesrc_char_match_init (c
, 'H', 'h')
2672 && ffelex_expecting_hollerith_
!= 0)
2674 ffelex_raw_mode_
= ffelex_expecting_hollerith_
;
2675 ffelex_token_
->type
= FFELEX_typeHOLLERITH
;
2676 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
2677 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
2678 ffelex_raw_where_line_
= ffewhere_line_unknown ();
2679 ffelex_raw_where_col_
= ffewhere_column_unknown ();
2680 c
= ffelex_card_image_
[++column
];
2681 goto parse_raw_character
; /* :::::::::::::::::::: */
2686 ffelex_token_
->where_line
2687 = ffewhere_line_use (ffelex_token_
->currentnames_line
2688 = ffewhere_line_use (ffelex_current_wl_
));
2689 ffelex_token_
->where_col
2690 = ffewhere_column_use (ffelex_token_
->currentnames_col
2691 = ffewhere_column_new (column
+ 1));
2692 ffelex_token_
->type
= FFELEX_typeNAMES
;
2696 ffelex_token_
->where_line
2697 = ffewhere_line_use (ffelex_current_wl_
);
2698 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
2699 ffelex_token_
->type
= FFELEX_typeNAME
;
2701 ffelex_append_to_token_ (c
);
2705 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
2706 ffelex_linecount_current_
, column
+ 1);
2707 ffelex_finish_statement_ ();
2708 disallow_continuation_line
= TRUE
;
2709 ignore_disallowed_continuation
= TRUE
;
2710 goto beginning_of_line_again
; /* :::::::::::::::::::: */
2714 case FFELEX_typeNAME
:
2769 c
= ffesrc_char_source (c
);
2784 && !ffe_is_dollar_ok ())
2786 ffelex_send_token_ ();
2787 goto parse_next_character
; /* :::::::::::::::::::: */
2789 ffelex_append_to_token_ (c
);
2793 ffelex_send_token_ ();
2794 goto parse_next_character
; /* :::::::::::::::::::: */
2798 case FFELEX_typeNAMES
:
2853 c
= ffesrc_char_source (c
);
2868 && !ffe_is_dollar_ok ())
2870 ffelex_send_token_ ();
2871 goto parse_next_character
; /* :::::::::::::::::::: */
2873 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
2875 ffewhere_track (&ffelex_token_
->currentnames_line
,
2876 &ffelex_token_
->currentnames_col
,
2877 ffelex_token_
->wheretrack
,
2878 ffelex_token_
->length
,
2879 ffelex_linecount_current_
,
2882 ffelex_append_to_token_ (c
);
2886 ffelex_send_token_ ();
2887 goto parse_next_character
; /* :::::::::::::::::::: */
2891 case FFELEX_typeNUMBER
:
2904 ffelex_append_to_token_ (c
);
2908 ffelex_send_token_ ();
2909 goto parse_next_character
; /* :::::::::::::::::::: */
2913 case FFELEX_typeASTERISK
:
2917 ffelex_token_
->type
= FFELEX_typePOWER
;
2918 ffelex_send_token_ ();
2921 default: /* * not followed by another *. */
2922 ffelex_send_token_ ();
2923 goto parse_next_character
; /* :::::::::::::::::::: */
2927 case FFELEX_typeCOLON
:
2931 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
2932 ffelex_send_token_ ();
2935 default: /* : not followed by another :. */
2936 ffelex_send_token_ ();
2937 goto parse_next_character
; /* :::::::::::::::::::: */
2941 case FFELEX_typeSLASH
:
2945 ffelex_token_
->type
= FFELEX_typeCONCAT
;
2946 ffelex_send_token_ ();
2950 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
2951 ffelex_send_token_ ();
2955 ffelex_token_
->type
= FFELEX_typeREL_NE
;
2956 ffelex_send_token_ ();
2960 ffelex_send_token_ ();
2961 goto parse_next_character
; /* :::::::::::::::::::: */
2965 case FFELEX_typeOPEN_PAREN
:
2969 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
2970 ffelex_send_token_ ();
2974 ffelex_send_token_ ();
2975 goto parse_next_character
; /* :::::::::::::::::::: */
2979 case FFELEX_typeOPEN_ANGLE
:
2983 ffelex_token_
->type
= FFELEX_typeREL_LE
;
2984 ffelex_send_token_ ();
2988 ffelex_send_token_ ();
2989 goto parse_next_character
; /* :::::::::::::::::::: */
2993 case FFELEX_typeEQUALS
:
2997 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
2998 ffelex_send_token_ ();
3002 ffelex_token_
->type
= FFELEX_typePOINTS
;
3003 ffelex_send_token_ ();
3007 ffelex_send_token_ ();
3008 goto parse_next_character
; /* :::::::::::::::::::: */
3012 case FFELEX_typeCLOSE_ANGLE
:
3016 ffelex_token_
->type
= FFELEX_typeREL_GE
;
3017 ffelex_send_token_ ();
3021 ffelex_send_token_ ();
3022 goto parse_next_character
; /* :::::::::::::::::::: */
3027 assert ("Serious error!!" == NULL
);
3032 c
= ffelex_card_image_
[++column
];
3034 parse_next_character
: /* :::::::::::::::::::: */
3036 if (ffelex_raw_mode_
!= 0)
3037 goto parse_raw_character
; /* :::::::::::::::::::: */
3040 c
= ffelex_card_image_
[++column
];
3045 && (ffelex_card_image_
[column
+ 1] == '*')))
3047 if ((ffelex_number_of_tokens_
== ffelex_label_tokens_
)
3048 && (ffelex_token_
->type
== FFELEX_typeNAMES
)
3049 && (ffelex_token_
->length
== 3)
3050 && (ffesrc_strncmp_2c (ffe_case_match (),
3051 ffelex_token_
->text
,
3052 "END", "end", "End",
3056 ffelex_finish_statement_ ();
3057 disallow_continuation_line
= TRUE
;
3058 ignore_disallowed_continuation
= FALSE
;
3059 goto beginning_of_line_again
; /* :::::::::::::::::::: */
3061 goto beginning_of_line
; /* :::::::::::::::::::: */
3063 goto parse_nonraw_character
; /* :::::::::::::::::::: */
3066 /* ffelex_file_free -- Lex a given file in free source form
3070 ffelex_file_free(wf,f);
3072 Lexes the file according to Fortran 90 ANSI + VXT specifications. */
3075 ffelex_file_free (ffewhereFile wf
, FILE *f
)
3077 register int c
= 0; /* Character currently under consideration. */
3078 register ffewhereColumnNumber column
= 0; /* Not really; 0 means column 1... */
3079 bool continuation_line
= FALSE
;
3080 ffewhereColumnNumber continuation_column
;
3081 int latest_char_in_file
= 0; /* For getting back into comment-skipping
3084 /* Lex is called for a particular file, not for a particular program unit.
3085 Yet the two events do share common characteristics. The first line in a
3086 file or in a program unit cannot be a continuation line. No token can
3087 be in mid-formation. No current label for the statement exists, since
3088 there is no current statement. */
3090 assert (ffelex_handler_
!= NULL
);
3092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3094 input_filename
= ffewhere_file_name (wf
);
3096 ffelex_current_wf_
= wf
;
3097 continuation_line
= FALSE
;
3098 ffelex_token_
->type
= FFELEX_typeNONE
;
3099 ffelex_number_of_tokens_
= 0;
3100 ffelex_current_wl_
= ffewhere_line_unknown ();
3101 ffelex_current_wc_
= ffewhere_column_unknown ();
3102 latest_char_in_file
= '\n';
3104 /* Come here to get a new line. */
3106 beginning_of_line
: /* :::::::::::::::::::: */
3108 c
= latest_char_in_file
;
3109 if ((c
== EOF
) || ((c
= ffelex_getc_ (f
)) == EOF
))
3112 end_of_file
: /* :::::::::::::::::::: */
3114 /* Line ending in EOF instead of \n still counts as a whole line. */
3116 ffelex_finish_statement_ ();
3117 ffewhere_line_kill (ffelex_current_wl_
);
3118 ffewhere_column_kill (ffelex_current_wc_
);
3119 return (ffelexHandler
) ffelex_handler_
;
3122 ffelex_next_line_ ();
3124 ffelex_bad_line_
= FALSE
;
3126 /* Skip over initial-comment and empty lines as quickly as possible! */
3134 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3135 c
= ffelex_hash_ (f
);
3137 /* Don't skip over # line after all. */
3142 comment_line
: /* :::::::::::::::::::: */
3144 while ((c
!= '\n') && (c
!= EOF
))
3149 ffelex_next_line_ ();
3150 goto end_of_file
; /* :::::::::::::::::::: */
3155 ffelex_next_line_ ();
3158 goto end_of_file
; /* :::::::::::::::::::: */
3161 ffelex_saw_tab_
= FALSE
;
3163 column
= ffelex_image_char_ (c
, 0);
3165 /* Read the entire line in as is (with whitespace processing). */
3167 while (((c
= getc (f
)) != '\n') && (c
!= EOF
))
3168 column
= ffelex_image_char_ (c
, column
);
3170 if (ffelex_bad_line_
)
3172 ffelex_card_image_
[column
] = '\0';
3173 ffelex_card_length_
= column
;
3174 goto comment_line
; /* :::::::::::::::::::: */
3177 /* If no tab, cut off line after column 132. */
3179 if (!ffelex_saw_tab_
&& (column
> FFELEX_FREE_MAX_COLUMNS_
))
3180 column
= FFELEX_FREE_MAX_COLUMNS_
;
3182 ffelex_card_image_
[column
] = '\0';
3183 ffelex_card_length_
= column
;
3185 /* Save next char in file so we can use register-based c while analyzing
3186 line we just read. */
3188 latest_char_in_file
= c
; /* Should be either '\n' or EOF. */
3191 continuation_column
= 0;
3193 /* Skip over initial spaces to see if the first nonblank character
3194 is exclamation point, newline, or EOF (line is therefore a comment) or
3195 ampersand (line is therefore a continuation line). */
3197 while ((c
= ffelex_card_image_
[column
]) == ' ')
3204 goto beginning_of_line
; /* :::::::::::::::::::: */
3207 continuation_column
= column
+ 1;
3214 /* The line definitely has content of some kind, install new end-statement
3215 point for error messages. */
3217 ffewhere_line_kill (ffelex_current_wl_
);
3218 ffewhere_column_kill (ffelex_current_wc_
);
3219 ffelex_current_wl_
= ffewhere_line_new (ffelex_linecount_current_
);
3220 ffelex_current_wc_
= ffewhere_column_new (ffelex_card_length_
+ 1);
3222 /* Figure out which column to start parsing at. */
3224 if (continuation_line
)
3226 if (continuation_column
== 0)
3228 if (ffelex_raw_mode_
!= 0)
3230 ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE
,
3231 ffelex_linecount_current_
, column
+ 1);
3233 else if (ffelex_token_
->type
!= FFELEX_typeNONE
)
3235 ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE
,
3236 ffelex_linecount_current_
, column
+ 1);
3239 else if (ffelex_is_free_char_ctx_contin_ (continuation_column
))
3240 { /* Line contains only a single "&" as only
3241 nonblank character. */
3242 ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE
,
3243 ffelex_linecount_current_
, continuation_column
);
3244 goto beginning_of_line
; /* :::::::::::::::::::: */
3246 column
= continuation_column
;
3251 c
= ffelex_card_image_
[column
];
3252 continuation_line
= FALSE
;
3254 /* Here is the main engine for parsing. c holds the character at column.
3255 It is already known that c is not a blank, end of line, or shriek,
3256 unless ffelex_raw_mode_ is not 0 (indicating we are in a
3257 character/hollerith constant). A partially filled token may already
3258 exist in ffelex_token_. */
3260 if (ffelex_raw_mode_
!= 0)
3263 parse_raw_character
: /* :::::::::::::::::::: */
3268 if (ffelex_is_free_char_ctx_contin_ (column
+ 1))
3270 continuation_line
= TRUE
;
3271 goto beginning_of_line
; /* :::::::::::::::::::: */
3276 ffelex_finish_statement_ ();
3277 goto beginning_of_line
; /* :::::::::::::::::::: */
3283 switch (ffelex_raw_mode_
)
3286 c
= ffelex_backslash_ (c
, column
);
3290 if (!ffelex_backslash_reconsider_
)
3291 ffelex_append_to_token_ (c
);
3292 ffelex_raw_mode_
= -1;
3296 if (c
== ffelex_raw_char_
)
3298 ffelex_raw_mode_
= -1;
3299 ffelex_append_to_token_ (c
);
3303 ffelex_raw_mode_
= 0;
3304 ffelex_backslash_reconsider_
= TRUE
;
3309 if (c
== ffelex_raw_char_
)
3310 ffelex_raw_mode_
= -2;
3313 c
= ffelex_backslash_ (c
, column
);
3316 ffelex_raw_mode_
= -3;
3320 ffelex_append_to_token_ (c
);
3325 c
= ffelex_backslash_ (c
, column
);
3329 if (!ffelex_backslash_reconsider_
)
3331 ffelex_append_to_token_ (c
);
3337 if (ffelex_backslash_reconsider_
)
3338 ffelex_backslash_reconsider_
= FALSE
;
3340 c
= ffelex_card_image_
[++column
];
3342 if (ffelex_raw_mode_
== 0)
3344 ffelex_send_token_ ();
3345 assert (ffelex_raw_mode_
== 0);
3347 c
= ffelex_card_image_
[++column
];
3348 if ((c
== '\0') || (c
== '!'))
3350 ffelex_finish_statement_ ();
3351 goto beginning_of_line
; /* :::::::::::::::::::: */
3353 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3355 continuation_line
= TRUE
;
3356 goto beginning_of_line
; /* :::::::::::::::::::: */
3358 goto parse_nonraw_character_noncontin
; /* :::::::::::::::::::: */
3360 goto parse_raw_character
; /* :::::::::::::::::::: */
3363 parse_nonraw_character
: /* :::::::::::::::::::: */
3365 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3367 continuation_line
= TRUE
;
3368 goto beginning_of_line
; /* :::::::::::::::::::: */
3371 parse_nonraw_character_noncontin
: /* :::::::::::::::::::: */
3373 switch (ffelex_token_
->type
)
3375 case FFELEX_typeNONE
:
3378 finish-statement/continue-statement
3381 c
= ffelex_card_image_
[++column
];
3382 if ((c
== '\0') || (c
== '!'))
3384 ffelex_finish_statement_ ();
3385 goto beginning_of_line
; /* :::::::::::::::::::: */
3387 if ((c
== '&') && ffelex_is_free_nonc_ctx_contin_ (column
+ 1))
3389 continuation_line
= TRUE
;
3390 goto beginning_of_line
; /* :::::::::::::::::::: */
3397 ffelex_token_
->type
= FFELEX_typeQUOTE
;
3398 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3399 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3400 ffelex_send_token_ ();
3404 ffelex_token_
->type
= FFELEX_typeDOLLAR
;
3405 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3406 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3407 ffelex_send_token_ ();
3411 ffelex_token_
->type
= FFELEX_typePERCENT
;
3412 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3413 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3414 ffelex_send_token_ ();
3418 ffelex_token_
->type
= FFELEX_typeAMPERSAND
;
3419 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3420 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3421 ffelex_send_token_ ();
3425 ffelex_token_
->type
= FFELEX_typeAPOSTROPHE
;
3426 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3427 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3428 ffelex_send_token_ ();
3432 ffelex_token_
->type
= FFELEX_typeOPEN_PAREN
;
3433 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3434 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3438 ffelex_token_
->type
= FFELEX_typeCLOSE_PAREN
;
3439 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3440 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3441 ffelex_send_token_ ();
3445 ffelex_token_
->type
= FFELEX_typeASTERISK
;
3446 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3447 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3451 ffelex_token_
->type
= FFELEX_typePLUS
;
3452 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3453 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3454 ffelex_send_token_ ();
3458 ffelex_token_
->type
= FFELEX_typeCOMMA
;
3459 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3460 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3461 ffelex_send_token_ ();
3465 ffelex_token_
->type
= FFELEX_typeMINUS
;
3466 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3467 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3468 ffelex_send_token_ ();
3472 ffelex_token_
->type
= FFELEX_typePERIOD
;
3473 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3474 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3475 ffelex_send_token_ ();
3479 ffelex_token_
->type
= FFELEX_typeSLASH
;
3480 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3481 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3495 = ffelex_hexnum_
? FFELEX_typeNAME
: FFELEX_typeNUMBER
;
3496 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3497 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3498 ffelex_append_to_token_ (c
);
3502 ffelex_token_
->type
= FFELEX_typeCOLON
;
3503 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3504 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3508 ffelex_token_
->type
= FFELEX_typeSEMICOLON
;
3509 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3510 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3511 ffelex_permit_include_
= TRUE
;
3512 ffelex_send_token_ ();
3513 ffelex_permit_include_
= FALSE
;
3517 ffelex_token_
->type
= FFELEX_typeOPEN_ANGLE
;
3518 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3519 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3523 ffelex_token_
->type
= FFELEX_typeEQUALS
;
3524 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3525 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3529 ffelex_token_
->type
= FFELEX_typeCLOSE_ANGLE
;
3530 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3531 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3535 ffelex_token_
->type
= FFELEX_typeQUESTION
;
3536 ffelex_token_
->where_line
= ffewhere_line_use (ffelex_current_wl_
);
3537 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3538 ffelex_send_token_ ();
3542 if (1 || ffe_is_90 ())
3544 ffelex_token_
->type
= FFELEX_typeUNDERSCORE
;
3545 ffelex_token_
->where_line
3546 = ffewhere_line_use (ffelex_current_wl_
);
3547 ffelex_token_
->where_col
3548 = ffewhere_column_new (column
+ 1);
3549 ffelex_send_token_ ();
3605 c
= ffesrc_char_source (c
);
3607 if (ffesrc_char_match_init (c
, 'H', 'h')
3608 && ffelex_expecting_hollerith_
!= 0)
3610 ffelex_raw_mode_
= ffelex_expecting_hollerith_
;
3611 ffelex_token_
->type
= FFELEX_typeHOLLERITH
;
3612 ffelex_token_
->where_line
= ffelex_raw_where_line_
;
3613 ffelex_token_
->where_col
= ffelex_raw_where_col_
;
3614 ffelex_raw_where_line_
= ffewhere_line_unknown ();
3615 ffelex_raw_where_col_
= ffewhere_column_unknown ();
3616 c
= ffelex_card_image_
[++column
];
3617 goto parse_raw_character
; /* :::::::::::::::::::: */
3620 if (ffelex_names_pure_
)
3622 ffelex_token_
->where_line
3623 = ffewhere_line_use (ffelex_token_
->currentnames_line
3624 = ffewhere_line_use (ffelex_current_wl_
));
3625 ffelex_token_
->where_col
3626 = ffewhere_column_use (ffelex_token_
->currentnames_col
3627 = ffewhere_column_new (column
+ 1));
3628 ffelex_token_
->type
= FFELEX_typeNAMES
;
3632 ffelex_token_
->where_line
3633 = ffewhere_line_use (ffelex_current_wl_
);
3634 ffelex_token_
->where_col
= ffewhere_column_new (column
+ 1);
3635 ffelex_token_
->type
= FFELEX_typeNAME
;
3637 ffelex_append_to_token_ (c
);
3641 ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER
,
3642 ffelex_linecount_current_
, column
+ 1);
3643 ffelex_finish_statement_ ();
3644 goto beginning_of_line
; /* :::::::::::::::::::: */
3648 case FFELEX_typeNAME
:
3703 c
= ffesrc_char_source (c
);
3718 && !ffe_is_dollar_ok ())
3720 ffelex_send_token_ ();
3721 goto parse_next_character
; /* :::::::::::::::::::: */
3723 ffelex_append_to_token_ (c
);
3727 ffelex_send_token_ ();
3728 goto parse_next_character
; /* :::::::::::::::::::: */
3732 case FFELEX_typeNAMES
:
3787 c
= ffesrc_char_source (c
);
3802 && !ffe_is_dollar_ok ())
3804 ffelex_send_token_ ();
3805 goto parse_next_character
; /* :::::::::::::::::::: */
3807 if (ffelex_token_
->length
< FFEWHERE_indexMAX
)
3809 ffewhere_track (&ffelex_token_
->currentnames_line
,
3810 &ffelex_token_
->currentnames_col
,
3811 ffelex_token_
->wheretrack
,
3812 ffelex_token_
->length
,
3813 ffelex_linecount_current_
,
3816 ffelex_append_to_token_ (c
);
3820 ffelex_send_token_ ();
3821 goto parse_next_character
; /* :::::::::::::::::::: */
3825 case FFELEX_typeNUMBER
:
3838 ffelex_append_to_token_ (c
);
3842 ffelex_send_token_ ();
3843 goto parse_next_character
; /* :::::::::::::::::::: */
3847 case FFELEX_typeASTERISK
:
3851 ffelex_token_
->type
= FFELEX_typePOWER
;
3852 ffelex_send_token_ ();
3855 default: /* * not followed by another *. */
3856 ffelex_send_token_ ();
3857 goto parse_next_character
; /* :::::::::::::::::::: */
3861 case FFELEX_typeCOLON
:
3865 ffelex_token_
->type
= FFELEX_typeCOLONCOLON
;
3866 ffelex_send_token_ ();
3869 default: /* : not followed by another :. */
3870 ffelex_send_token_ ();
3871 goto parse_next_character
; /* :::::::::::::::::::: */
3875 case FFELEX_typeSLASH
:
3879 ffelex_token_
->type
= FFELEX_typeCONCAT
;
3880 ffelex_send_token_ ();
3884 ffelex_token_
->type
= FFELEX_typeCLOSE_ARRAY
;
3885 ffelex_send_token_ ();
3889 ffelex_token_
->type
= FFELEX_typeREL_NE
;
3890 ffelex_send_token_ ();
3894 ffelex_send_token_ ();
3895 goto parse_next_character
; /* :::::::::::::::::::: */
3899 case FFELEX_typeOPEN_PAREN
:
3903 ffelex_token_
->type
= FFELEX_typeOPEN_ARRAY
;
3904 ffelex_send_token_ ();
3908 ffelex_send_token_ ();
3909 goto parse_next_character
; /* :::::::::::::::::::: */
3913 case FFELEX_typeOPEN_ANGLE
:
3917 ffelex_token_
->type
= FFELEX_typeREL_LE
;
3918 ffelex_send_token_ ();
3922 ffelex_send_token_ ();
3923 goto parse_next_character
; /* :::::::::::::::::::: */
3927 case FFELEX_typeEQUALS
:
3931 ffelex_token_
->type
= FFELEX_typeREL_EQ
;
3932 ffelex_send_token_ ();
3936 ffelex_token_
->type
= FFELEX_typePOINTS
;
3937 ffelex_send_token_ ();
3941 ffelex_send_token_ ();
3942 goto parse_next_character
; /* :::::::::::::::::::: */
3946 case FFELEX_typeCLOSE_ANGLE
:
3950 ffelex_token_
->type
= FFELEX_typeREL_GE
;
3951 ffelex_send_token_ ();
3955 ffelex_send_token_ ();
3956 goto parse_next_character
; /* :::::::::::::::::::: */
3961 assert ("Serious error!" == NULL
);
3966 c
= ffelex_card_image_
[++column
];
3968 parse_next_character
: /* :::::::::::::::::::: */
3970 if (ffelex_raw_mode_
!= 0)
3971 goto parse_raw_character
; /* :::::::::::::::::::: */
3973 if ((c
== '\0') || (c
== '!'))
3975 ffelex_finish_statement_ ();
3976 goto beginning_of_line
; /* :::::::::::::::::::: */
3978 goto parse_nonraw_character
; /* :::::::::::::::::::: */
3981 /* See the code in com.c that calls this to understand why. */
3983 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3985 ffelex_hash_kludge (FILE *finput
)
3987 /* If you change this constant string, you have to change whatever
3988 code might thus be affected by it in terms of having to use
3989 ffelex_getc_() instead of getc() in the lexers and _hash_. */
3990 static char match
[] = "# 1 \"";
3991 static int kludge
[ARRAY_SIZE (match
) + 1];
3996 /* Read chars as long as they match the target string.
3997 Copy them into an array that will serve as a record
3998 of what we read (essentially a multi-char ungetc(),
3999 for code that uses ffelex_getc_ instead of getc() elsewhere
4001 for (p
= &match
[0], q
= &kludge
[0], c
= getc (finput
);
4002 (c
== *p
) && (*p
!= '\0') && (c
!= EOF
);
4003 ++p
, ++q
, c
= getc (finput
))
4006 *q
= c
; /* Might be EOF, which requires int. */
4009 ffelex_kludge_chars_
= &kludge
[0];
4013 ffelex_kludge_flag_
= TRUE
;
4014 ++ffelex_kludge_chars_
;
4015 ffelex_hash_ (finput
); /* Handle it NOW rather than later. */
4016 ffelex_kludge_flag_
= FALSE
;
4026 ffelex_final_nontab_column_
= ffe_fixed_line_length ();
4027 ffelex_card_size_
= FFELEX_columnINITIAL_SIZE_
;
4028 ffelex_card_image_
= malloc_new_ksr (malloc_pool_image (),
4029 "FFELEX card image",
4030 FFELEX_columnINITIAL_SIZE_
+ 9);
4031 ffelex_card_image_
[0] = '\0';
4033 for (i
= 0; i
< 256; ++i
)
4034 ffelex_first_char_
[i
] = FFELEX_typeERROR
;
4036 ffelex_first_char_
['\t'] = FFELEX_typeRAW
;
4037 ffelex_first_char_
['\n'] = FFELEX_typeCOMMENT
;
4038 ffelex_first_char_
['\v'] = FFELEX_typeCOMMENT
;
4039 ffelex_first_char_
['\f'] = FFELEX_typeCOMMENT
;
4040 ffelex_first_char_
['\r'] = FFELEX_typeRAW
;
4041 ffelex_first_char_
[' '] = FFELEX_typeRAW
;
4042 ffelex_first_char_
['!'] = FFELEX_typeCOMMENT
;
4043 ffelex_first_char_
['*'] = FFELEX_typeCOMMENT
;
4044 ffelex_first_char_
['/'] = FFELEX_typeSLASH
;
4045 ffelex_first_char_
['&'] = FFELEX_typeRAW
;
4046 ffelex_first_char_
['#'] = FFELEX_typeHASH
;
4048 for (i
= '0'; i
<= '9'; ++i
)
4049 ffelex_first_char_
[i
] = FFELEX_typeRAW
;
4051 if ((ffe_case_match () == FFE_caseNONE
)
4052 || ((ffe_case_match () == FFE_caseUPPER
)
4053 && (ffe_case_source () != FFE_caseLOWER
)) /* Idiot! :-) */
4054 || ((ffe_case_match () == FFE_caseLOWER
)
4055 && (ffe_case_source () == FFE_caseLOWER
)))
4057 ffelex_first_char_
['C'] = FFELEX_typeCOMMENT
;
4058 ffelex_first_char_
['D'] = FFELEX_typeCOMMENT
;
4060 if ((ffe_case_match () == FFE_caseNONE
)
4061 || ((ffe_case_match () == FFE_caseLOWER
)
4062 && (ffe_case_source () != FFE_caseUPPER
)) /* Idiot! :-) */
4063 || ((ffe_case_match () == FFE_caseUPPER
)
4064 && (ffe_case_source () == FFE_caseUPPER
)))
4066 ffelex_first_char_
['c'] = FFELEX_typeCOMMENT
;
4067 ffelex_first_char_
['d'] = FFELEX_typeCOMMENT
;
4070 ffelex_linecount_current_
= 0;
4071 ffelex_linecount_next_
= 1;
4072 ffelex_raw_mode_
= 0;
4073 ffelex_set_include_
= FALSE
;
4074 ffelex_permit_include_
= FALSE
;
4075 ffelex_names_
= TRUE
; /* First token in program is a names. */
4076 ffelex_names_pure_
= FALSE
; /* Free-form lexer does NAMES only for
4078 ffelex_hexnum_
= FALSE
;
4079 ffelex_expecting_hollerith_
= 0;
4080 ffelex_raw_where_line_
= ffewhere_line_unknown ();
4081 ffelex_raw_where_col_
= ffewhere_column_unknown ();
4083 ffelex_token_
= ffelex_token_new_ ();
4084 ffelex_token_
->type
= FFELEX_typeNONE
;
4085 ffelex_token_
->uses
= 1;
4086 ffelex_token_
->where_line
= ffewhere_line_unknown ();
4087 ffelex_token_
->where_col
= ffewhere_column_unknown ();
4088 ffelex_token_
->text
= NULL
;
4090 ffelex_handler_
= NULL
;
4093 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
4095 if (ffelex_is_names_expected())
4096 // Deliver NAMES token
4098 // Deliver NAME token
4100 Must be called while lexer is active, obviously. */
4103 ffelex_is_names_expected ()
4105 return ffelex_names_
;
4108 /* Current card image, which has the master linecount number
4109 ffelex_linecount_current_. */
4114 return ffelex_card_image_
;
4117 /* ffelex_line_length -- Return length of current lexer line
4119 printf("Length is %lu\n",ffelex_line_length());
4121 Must be called while lexer is active, obviously. */
4123 ffewhereColumnNumber
4124 ffelex_line_length ()
4126 return ffelex_card_length_
;
4129 /* Master line count of current card image, or 0 if no card image
4133 ffelex_line_number ()
4135 return ffelex_linecount_current_
;
4138 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4140 ffelex_set_expecting_hollerith(0);
4142 Lex initially assumes no hollerith constant is about to show up. If
4143 syntactic analysis expects one, it should call this function with the
4144 number of characters expected in the constant immediately after recognizing
4145 the decimal number preceding the "H" and the constant itself. Then, if
4146 the next character is indeed H, the lexer will interpret it as beginning
4147 a hollerith constant and ship the token formed by reading the specified
4148 number of characters (interpreting blanks and otherwise-comments too)
4149 from the input file. It is up to syntactic analysis to call this routine
4150 again with 0 to turn hollerith detection off immediately upon receiving
4151 the token that might or might not be HOLLERITH.
4153 Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4154 character constant. Pass the expected termination character (apostrophe
4157 Pass for length either the length of the hollerith (must be > 0), -1
4158 meaning expecting a character constant, or 0 to cancel expectation of
4159 a hollerith only after calling it with a length of > 0 and receiving the
4160 next token (which may or may not have been a HOLLERITH token).
4162 Pass for which either an apostrophe or quote when passing length of -1.
4163 Else which is a don't-care.
4165 Pass for line and column the line/column info for the token beginning the
4166 character or hollerith constant, for use in error messages, when passing
4167 a length of -1 -- this function will invoke ffewhere_line/column_use to
4168 make its own copies. Else line and column are don't-cares (when length
4169 is 0) and the outstanding copies of the previous line/column info, if
4170 still around, are killed.
4173 When called with length of 0, also zero ffelex_raw_mode_. This is
4174 so ffest_save_ can undo the effects of replaying tokens like
4175 APOSTROPHE and QUOTE.
4177 New line, column arguments allow error messages to point to the true
4178 beginning of a character/hollerith constant, rather than the beginning
4179 of the content part, which makes them more consistent and helpful.
4181 New "which" argument allows caller to specify termination character,
4182 which should be apostrophe or double-quote, to support Fortran 90. */
4185 ffelex_set_expecting_hollerith (long length
, char which
,
4186 ffewhereLine line
, ffewhereColumn column
)
4189 /* First kill the pending line/col info, if any (should only be pending
4190 when this call has length==0, the previous call had length>0, and a
4191 non-HOLLERITH token was sent in between the calls, but play it safe). */
4193 ffewhere_line_kill (ffelex_raw_where_line_
);
4194 ffewhere_column_kill (ffelex_raw_where_col_
);
4196 /* Now handle the length function. */
4200 ffelex_expecting_hollerith_
= 0;
4201 ffelex_raw_mode_
= 0;
4202 ffelex_raw_where_line_
= ffewhere_line_unknown ();
4203 ffelex_raw_where_col_
= ffewhere_column_unknown ();
4204 return; /* Don't set new line/column info from args. */
4207 ffelex_raw_mode_
= -1;
4208 ffelex_raw_char_
= which
;
4211 default: /* length > 0 */
4212 ffelex_expecting_hollerith_
= length
;
4216 /* Now set new line/column information from passed args. */
4218 ffelex_raw_where_line_
= ffewhere_line_use (line
);
4219 ffelex_raw_where_col_
= ffewhere_column_use (column
);
4222 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4224 ffelex_set_handler((ffelexHandler) my_first_handler);
4226 Must be called before calling ffelex_file_fixed or ffelex_file_free or
4227 after they return, but not while they are active. */
4230 ffelex_set_handler (ffelexHandler first
)
4232 ffelex_handler_
= first
;
4235 /* ffelex_set_hexnum -- Set hexnum flag
4237 ffelex_set_hexnum(TRUE);
4239 Lex normally interprets a token starting with [0-9] as a NUMBER token,
4240 so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves
4241 the character as the first of the next token. But when parsing a
4242 hexadecimal number, by calling this function with TRUE before starting
4243 the parse of the token itself, lex will interpret [0-9] as the start
4247 ffelex_set_hexnum (bool f
)
4252 /* ffelex_set_include -- Set INCLUDE file to be processed next
4254 ffewhereFile wf; // The ffewhereFile object for the file.
4255 bool free_form; // TRUE means read free-form file, FALSE fixed-form.
4256 FILE *fi; // The file to INCLUDE.
4257 ffelex_set_include(wf,free_form,fi);
4259 Must be called only after receiving the EOS token following a valid
4260 INCLUDE statement specifying a file that has already been successfully
4264 ffelex_set_include (ffewhereFile wf
, bool free_form
, FILE *fi
)
4266 assert (ffelex_permit_include_
);
4267 assert (!ffelex_set_include_
);
4268 ffelex_set_include_
= TRUE
;
4269 ffelex_include_free_form_
= free_form
;
4270 ffelex_include_file_
= fi
;
4271 ffelex_include_wherefile_
= wf
;
4274 /* ffelex_set_names -- Set names/name flag, names = TRUE
4276 ffelex_set_names(FALSE);
4278 Lex initially assumes multiple names should be formed. If this function is
4279 called with FALSE, then single names are formed instead. The differences
4280 are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME)
4281 and in whether full source-location tracking is performed (it is for
4282 multiple names, not for single names), which is more expensive in terms of
4286 ffelex_set_names (bool f
)
4290 ffelex_names_pure_
= FALSE
;
4293 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4295 ffelex_set_names_pure(FALSE);
4297 Like ffelex_set_names, except affects both lexers. Normally, the
4298 free-form lexer need not generate NAMES tokens because adjacent NAME
4299 tokens must be separated by spaces which causes the lexer to generate
4300 separate tokens for analysis (whereas in fixed-form the spaces are
4301 ignored resulting in one long token). But in FORMAT statements, for
4302 some reason, the Fortran 90 standard specifies that spaces can occur
4303 anywhere within a format-item-list with no effect on the format spec
4304 (except of course within character string edit descriptors), which means
4305 that "1PE14.2" and "1 P E 1 4 . 2" are equivalent. For the FORMAT
4306 statement handling, the existence of spaces makes it hard to deal with,
4307 because each token is seen distinctly (i.e. seven tokens in the latter
4308 example). But when no spaces are provided, as in the former example,
4309 then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD,
4310 NUMBER ("2"). By generating a NAMES instead of NAME, three things happen:
4311 One, ffest_kw_format_ does a substring rather than full-string match,
4312 and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions
4313 may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token;
4314 and three, error reporting can point to the actual character rather than
4315 at or prior to it. The first two things could be resolved by providing
4316 alternate functions fairly easy, thus allowing FORMAT handling to expect
4317 both lexers to generate NAME tokens instead of NAMES (with otherwise minor
4318 changes to FORMAT parsing), but the third, error reporting, would suffer,
4319 and when one makes mistakes in a FORMAT, believe me, one wants a pointer
4320 to exactly where the compilers thinks the problem is, to even begin to get
4321 a handle on it. So there. */
4324 ffelex_set_names_pure (bool f
)
4326 ffelex_names_pure_
= f
;
4330 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4332 return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
4335 Returns first_handler if start_char_index chars into master_token (which
4336 must be a NAMES token) is '\0'. Else, creates a subtoken from that
4337 char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar),
4338 an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign)
4339 and sends it to first_handler. If anything other than NAME is sent, the
4340 character at the end of it in the master token is examined to see if it
4341 begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so,
4342 the handler returned by first_handler is invoked with that token, and
4343 this process is repeated until the end of the master token or a NAME
4344 token is reached. */
4347 ffelex_splice_tokens (ffelexHandler first
, ffelexToken master
,
4348 ffeTokenLength start
)
4354 p
= ffelex_token_text (master
) + (i
= start
);
4360 t
= ffelex_token_number_from_names (master
, i
);
4361 p
+= ffelex_token_length (t
);
4362 i
+= ffelex_token_length (t
);
4364 else if (ffesrc_is_name_init (*p
))
4366 t
= ffelex_token_name_from_names (master
, i
, 0);
4367 p
+= ffelex_token_length (t
);
4368 i
+= ffelex_token_length (t
);
4372 t
= ffelex_token_dollar_from_names (master
, i
);
4378 t
= ffelex_token_uscore_from_names (master
, i
);
4384 assert ("not a valid NAMES character" == NULL
);
4387 assert (first
!= NULL
);
4388 first
= (ffelexHandler
) (*first
) (t
);
4389 ffelex_token_kill (t
);
4395 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4397 return ffelex_swallow_tokens;
4399 Return this handler when you don't want to look at any more tokens in the
4400 statement because you've encountered an unrecoverable error in the
4404 ffelex_swallow_tokens (ffelexToken t
, ffelexHandler handler
)
4406 assert (handler
!= NULL
);
4408 if ((t
!= NULL
) && ((ffelex_token_type (t
) == FFELEX_typeEOS
)
4409 || (ffelex_token_type (t
) == FFELEX_typeSEMICOLON
)))
4410 return (ffelexHandler
) (*handler
) (t
);
4412 ffelex_eos_handler_
= handler
;
4413 return (ffelexHandler
) ffelex_swallow_tokens_
;
4416 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4419 t = ffelex_token_dollar_from_names(t,6);
4421 It's as if you made a new token of dollar type having the dollar
4422 at, in the example above, the sixth character of the NAMES token. */
4425 ffelex_token_dollar_from_names (ffelexToken t
, ffeTokenLength start
)
4430 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4431 assert (start
< t
->length
);
4432 assert (t
->text
[start
] == '$');
4434 /* Now make the token. */
4436 nt
= ffelex_token_new_ ();
4437 nt
->type
= FFELEX_typeDOLLAR
;
4440 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4441 t
->where_col
, t
->wheretrack
, start
);
4446 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4449 ffelex_token_kill(t);
4451 Complements a call to ffelex_token_use or ffelex_token_new_.... */
4454 ffelex_token_kill (ffelexToken t
)
4458 assert (t
->uses
> 0);
4463 --ffelex_total_tokens_
;
4465 if (t
->type
== FFELEX_typeNAMES
)
4466 ffewhere_track_kill (t
->where_line
, t
->where_col
,
4467 t
->wheretrack
, t
->length
);
4468 ffewhere_line_kill (t
->where_line
);
4469 ffewhere_column_kill (t
->where_col
);
4470 if (t
->text
!= NULL
)
4471 malloc_kill_ksr (malloc_pool_image (), t
->text
, t
->size
+ 1);
4472 malloc_kill_ks (malloc_pool_image (), t
, sizeof (*t
));
4475 /* Make a new NAME token that is a substring of a NAMES token. */
4478 ffelex_token_name_from_names (ffelexToken t
, ffeTokenLength start
,
4484 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4485 assert (start
< t
->length
);
4487 len
= t
->length
- start
;
4491 assert ((start
+ len
) <= t
->length
);
4493 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4495 nt
= ffelex_token_new_ ();
4496 nt
->type
= FFELEX_typeNAME
;
4497 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4501 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4502 t
->where_col
, t
->wheretrack
, start
);
4503 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4505 strncpy (nt
->text
, t
->text
+ start
, len
);
4506 nt
->text
[len
] = '\0';
4510 /* Make a new NAMES token that is a substring of another NAMES token. */
4513 ffelex_token_names_from_names (ffelexToken t
, ffeTokenLength start
,
4519 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4520 assert (start
< t
->length
);
4522 len
= t
->length
- start
;
4526 assert ((start
+ len
) <= t
->length
);
4528 assert (ffelex_is_firstnamechar ((unsigned char)(t
->text
[start
])));
4530 nt
= ffelex_token_new_ ();
4531 nt
->type
= FFELEX_typeNAMES
;
4532 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4536 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4537 t
->where_col
, t
->wheretrack
, start
);
4538 ffewhere_track_copy (nt
->wheretrack
, t
->wheretrack
, start
, len
);
4539 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4541 strncpy (nt
->text
, t
->text
+ start
, len
);
4542 nt
->text
[len
] = '\0';
4546 /* Make a new CHARACTER token. */
4549 ffelex_token_new_character (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4553 t
= ffelex_token_new_ ();
4554 t
->type
= FFELEX_typeCHARACTER
;
4555 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4557 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4559 strcpy (t
->text
, s
);
4560 t
->where_line
= ffewhere_line_use (l
);
4561 t
->where_col
= ffewhere_column_new (c
);
4565 /* Make a new EOF token right after end of file. */
4568 ffelex_token_new_eof ()
4572 t
= ffelex_token_new_ ();
4573 t
->type
= FFELEX_typeEOF
;
4576 t
->where_line
= ffewhere_line_new (ffelex_linecount_current_
);
4577 t
->where_col
= ffewhere_column_new (1);
4581 /* Make a new NAME token. */
4584 ffelex_token_new_name (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4588 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4590 t
= ffelex_token_new_ ();
4591 t
->type
= FFELEX_typeNAME
;
4592 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4594 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4596 strcpy (t
->text
, s
);
4597 t
->where_line
= ffewhere_line_use (l
);
4598 t
->where_col
= ffewhere_column_new (c
);
4602 /* Make a new NAMES token. */
4605 ffelex_token_new_names (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4609 assert (ffelex_is_firstnamechar ((unsigned char)*s
));
4611 t
= ffelex_token_new_ ();
4612 t
->type
= FFELEX_typeNAMES
;
4613 t
->length
= t
->size
= strlen (s
); /* Assume it won't get bigger. */
4615 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4617 strcpy (t
->text
, s
);
4618 t
->where_line
= ffewhere_line_use (l
);
4619 t
->where_col
= ffewhere_column_new (c
);
4620 ffewhere_track_clear (t
->wheretrack
, t
->length
); /* Assume contiguous
4625 /* Make a new NUMBER token.
4627 The first character of the string must be a digit, and only the digits
4628 are copied into the new number. So this may be used to easily extract
4629 a NUMBER token from within any text string. Then the length of the
4630 resulting token may be used to calculate where the digits stopped
4631 in the original string. */
4634 ffelex_token_new_number (const char *s
, ffewhereLine l
, ffewhereColumn c
)
4639 /* How long is the string of decimal digits at s? */
4641 len
= strspn (s
, "0123456789");
4643 /* Make sure there is at least one digit. */
4647 /* Now make the token. */
4649 t
= ffelex_token_new_ ();
4650 t
->type
= FFELEX_typeNUMBER
;
4651 t
->length
= t
->size
= len
; /* Assume it won't get bigger. */
4653 t
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4655 strncpy (t
->text
, s
, len
);
4656 t
->text
[len
] = '\0';
4657 t
->where_line
= ffewhere_line_use (l
);
4658 t
->where_col
= ffewhere_column_new (c
);
4662 /* Make a new token of any type that doesn't contain text. A private
4663 function that is used by public macros in the interface file. */
4666 ffelex_token_new_simple_ (ffelexType type
, ffewhereLine l
, ffewhereColumn c
)
4670 t
= ffelex_token_new_ ();
4674 t
->where_line
= ffewhere_line_use (l
);
4675 t
->where_col
= ffewhere_column_new (c
);
4679 /* Make a new NUMBER token from an existing NAMES token.
4681 Like ffelex_token_new_number, this function calculates the length
4682 of the digit string itself. */
4685 ffelex_token_number_from_names (ffelexToken t
, ffeTokenLength start
)
4691 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4692 assert (start
< t
->length
);
4694 /* How long is the string of decimal digits at s? */
4696 len
= strspn (t
->text
+ start
, "0123456789");
4698 /* Make sure there is at least one digit. */
4702 /* Now make the token. */
4704 nt
= ffelex_token_new_ ();
4705 nt
->type
= FFELEX_typeNUMBER
;
4706 nt
->size
= len
; /* Assume nobody's gonna fiddle with token
4710 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4711 t
->where_col
, t
->wheretrack
, start
);
4712 nt
->text
= malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4714 strncpy (nt
->text
, t
->text
+ start
, len
);
4715 nt
->text
[len
] = '\0';
4719 /* Make a new UNDERSCORE token from a NAMES token. */
4722 ffelex_token_uscore_from_names (ffelexToken t
, ffeTokenLength start
)
4727 assert (ffelex_token_type (t
) == FFELEX_typeNAMES
);
4728 assert (start
< t
->length
);
4729 assert (t
->text
[start
] == '_');
4731 /* Now make the token. */
4733 nt
= ffelex_token_new_ ();
4734 nt
->type
= FFELEX_typeUNDERSCORE
;
4736 ffewhere_set_from_track (&nt
->where_line
, &nt
->where_col
, t
->where_line
,
4737 t
->where_col
, t
->wheretrack
, start
);
4742 /* ffelex_token_use -- Return another instance of a token
4745 t = ffelex_token_use(t);
4747 In a sense, the new token is a copy of the old, though it might be the
4748 same with just a new use count.
4750 We use the use count method (easy). */
4753 ffelex_token_use (ffelexToken t
)
4756 assert ("_token_use: null token" == NULL
);