diff options
Diffstat (limited to 'gcc/f/lex.c')
| -rw-r--r-- | gcc/f/lex.c | 4697 |
1 files changed, 4697 insertions, 0 deletions
diff --git a/gcc/f/lex.c b/gcc/f/lex.c new file mode 100644 index 00000000000..acb439157af --- /dev/null +++ b/gcc/f/lex.c @@ -0,0 +1,4697 @@ +/* Implementation of Fortran lexer + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#include "proj.h" +#include <ctype.h> +#include "top.h" +#include "bad.h" +#include "com.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#include "config.j" +#include "flags.j" +#include "input.j" +#include "tree.j" +#endif + +#ifdef DWARF_DEBUGGING_INFO +void dwarfout_resume_previous_source_file (register unsigned); +void dwarfout_start_new_source_file (register char *); +void dwarfout_define (register unsigned, register char *); +void dwarfout_undef (register unsigned, register char *); +#endif DWARF_DEBUGGING_INFO + +static void ffelex_append_to_token_ (char c); +static int ffelex_backslash_ (int c, ffewhereColumnNumber col); +static void ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0); +static void ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0, ffewhereLineNumber ln1, + ffewhereColumnNumber cn1); +static void ffelex_bad_here_ (int num, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0); +static void ffelex_finish_statement_ (void); +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int ffelex_get_directive_line_ (char **text, FILE *finput); +static int ffelex_hash_ (FILE *f); +#endif +static ffewhereColumnNumber ffelex_image_char_ (int c, + ffewhereColumnNumber col); +static void ffelex_include_ (void); +static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col); +static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col); +static void ffelex_next_line_ (void); +static void ffelex_prepare_eos_ (void); +static void ffelex_send_token_ (void); +static ffelexHandler ffelex_swallow_tokens_ (ffelexToken t); +static ffelexToken ffelex_token_new_ (void); + +/* Pertaining to the geometry of the input file. */ + +/* Initial size for card image to be allocated. */ +#define FFELEX_columnINITIAL_SIZE_ 255 + +/* The card image itself, which grows as source lines get longer. It + has room for ffelex_card_size_ + 8 characters, and the length of the + current image is ffelex_card_length_. (The + 8 characters are made + available for easy handling of tabs and such.) */ +static char *ffelex_card_image_; +static ffewhereColumnNumber ffelex_card_size_; +static ffewhereColumnNumber ffelex_card_length_; + +/* Max width for free-form lines (ISO F90). */ +#define FFELEX_FREE_MAX_COLUMNS_ 132 + +/* True if we saw a tab on the current line, as this (currently) means + the line is therefore treated as though final_nontab_column_ were + infinite. */ +static bool ffelex_saw_tab_; + +/* TRUE if current line is known to be erroneous, so don't bother + expanding room for it just to display it. */ +static bool ffelex_bad_line_ = FALSE; + +/* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */ +static ffewhereColumnNumber ffelex_final_nontab_column_; + +/* Array for quickly deciding what kind of line the current card has, + based on its first character. */ +static ffelexType ffelex_first_char_[256]; + +/* Pertaining to file management. */ + +/* The wf argument of the most recent active ffelex_file_(fixed,free) + function. */ +static ffewhereFile ffelex_current_wf_; + +/* TRUE if an INCLUDE statement can be processed (ffelex_set_include + can be called). */ +static bool ffelex_permit_include_; + +/* TRUE if an INCLUDE statement is pending (ffelex_set_include has been + called). */ +static bool ffelex_set_include_; + +/* Information on the pending INCLUDE file. */ +static FILE *ffelex_include_file_; +static bool ffelex_include_free_form_; +static ffewhereFile ffelex_include_wherefile_; + +/* Current master line count. */ +static ffewhereLineNumber ffelex_linecount_current_; +/* Next master line count. */ +static ffewhereLineNumber ffelex_linecount_next_; + +/* ffewhere info on the latest (currently active) line read from the + active source file. */ +static ffewhereLine ffelex_current_wl_; +static ffewhereColumn ffelex_current_wc_; + +/* Pertaining to tokens in general. */ + +/* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER + token. */ +#define FFELEX_columnTOKEN_SIZE_ 63 +#if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX +#error "token size too small!" +#endif + +/* Current token being lexed. */ +static ffelexToken ffelex_token_; + +/* Handler for current token. */ +static ffelexHandler ffelex_handler_; + +/* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */ +static bool ffelex_names_; + +/* TRUE if both lexers are to generate NAMES instead of NAME tokens. */ +static bool ffelex_names_pure_; + +/* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex + numbers. */ +static bool ffelex_hexnum_; + +/* For ffelex_swallow_tokens(). */ +static ffelexHandler ffelex_eos_handler_; + +/* Number of tokens sent since last EOS or beginning of input file + (include INCLUDEd files). */ +static unsigned long int ffelex_number_of_tokens_; + +/* Number of labels sent (as NUMBER tokens) since last reset of + ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases. + (Fixed-form source only.) */ +static unsigned long int ffelex_label_tokens_; + +/* Metering for token management, to catch token-memory leaks. */ +static long int ffelex_total_tokens_ = 0; +static long int ffelex_old_total_tokens_ = 1; +static long int ffelex_token_nextid_ = 0; + +/* Pertaining to lexing CHARACTER and HOLLERITH tokens. */ + +/* >0 if a Hollerith constant of that length might be in mid-lex, used + when the next character seen is 'H' or 'h' to enter HOLLERITH lexing + mode (see ffelex_raw_mode_). */ +static long int ffelex_expecting_hollerith_; + +/* -3: Backslash (escape) sequence being lexed in CHARACTER. + -2: Possible closing apostrophe/quote seen in CHARACTER. + -1: Lexing CHARACTER. + 0: Not lexing CHARACTER or HOLLERITH. + >0: Lexing HOLLERITH, value is # chars remaining to expect. */ +static long int ffelex_raw_mode_; + +/* When lexing CHARACTER, open quote/apostrophe (either ' or "). */ +static char ffelex_raw_char_; + +/* TRUE when backslash processing had to use most recent character + to finish its state engine, but that character is not part of + the backslash sequence, so must be reconsidered as a "normal" + character in CHARACTER/HOLLERITH lexing. */ +static bool ffelex_backslash_reconsider_ = FALSE; + +/* Characters preread before lexing happened (might include EOF). */ +static int *ffelex_kludge_chars_ = NULL; + +/* Doing the kludge processing, so not initialized yet. */ +static bool ffelex_kludge_flag_ = FALSE; + +/* The beginning of a (possible) CHARACTER/HOLLERITH token. */ +static ffewhereLine ffelex_raw_where_line_; +static ffewhereColumn ffelex_raw_where_col_; + + +/* Call this to append another character to the current token. If it isn't + currently big enough for it, it will be enlarged. The current token + must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER. */ + +static void +ffelex_append_to_token_ (char c) +{ + if (ffelex_token_->text == NULL) + { + ffelex_token_->text + = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + FFELEX_columnTOKEN_SIZE_ + 1); + ffelex_token_->size = FFELEX_columnTOKEN_SIZE_; + ffelex_token_->length = 0; + } + else if (ffelex_token_->length >= ffelex_token_->size) + { + ffelex_token_->text + = malloc_resize_ksr (malloc_pool_image (), + ffelex_token_->text, + (ffelex_token_->size << 1) + 1, + ffelex_token_->size + 1); + ffelex_token_->size <<= 1; + assert (ffelex_token_->length < ffelex_token_->size); + } +#ifdef MAP_CHARACTER +Sorry, MAP_CHARACTER is not going to work as expected in GNU Fortran, +please contact fortran@gnu.ai.mit.edu if you wish to fund work to +port g77 to non-ASCII machines. +#endif + ffelex_token_->text[ffelex_token_->length++] = c; +} + +/* Do backslash (escape) processing for a CHARACTER/HOLLERITH token + being lexed. */ + +static int +ffelex_backslash_ (int c, ffewhereColumnNumber col) +{ + static int state = 0; + static unsigned int count; + static int code; + static unsigned int firstdig = 0; + static int nonnull; + static ffewhereLineNumber line; + static ffewhereColumnNumber column; + + /* See gcc/c-lex.c readescape() for a straightforward version + of this state engine for handling backslashes in character/ + hollerith constants. */ + +#define wide_flag 0 +#define warn_traditional 0 +#define flag_traditional 0 + + switch (state) + { + case 0: + if ((c == '\\') + && (ffelex_raw_mode_ != 0) + && ffe_is_backslash ()) + { + state = 1; + column = col + 1; + line = ffelex_linecount_current_; + return EOF; + } + return c; + + case 1: + state = 0; /* Assume simple case. */ + switch (c) + { + case 'x': + if (warn_traditional) + { + ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional", + FFEBAD_severityWARNING); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + + if (flag_traditional) + return c; + + code = 0; + count = 0; + nonnull = 0; + state = 2; + return EOF; + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + code = c - '0'; + count = 1; + state = 3; + return EOF; + + case '\\': case '\'': case '"': + return c; + +#if 0 /* Inappropriate for Fortran. */ + case '\n': + ffelex_next_line_ (); + *ignore_ptr = 1; + return 0; +#endif + + case 'n': + return TARGET_NEWLINE; + + case 't': + return TARGET_TAB; + + case 'r': + return TARGET_CR; + + case 'f': + return TARGET_FF; + + case 'b': + return TARGET_BS; + + case 'a': + if (warn_traditional) + { + ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional", + FFEBAD_severityWARNING); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + + if (flag_traditional) + return c; + return TARGET_BELL; + + case 'v': +#if 0 /* Vertical tab is present in common usage compilers. */ + if (flag_traditional) + return c; +#endif + return TARGET_VT; + + case 'e': + case 'E': + case '(': + case '{': + case '[': + case '%': + if (pedantic) + { + char m[2]; + + m[0] = c; + m[1] = '\0'; + ffebad_start_msg_lex ("Non-ANSI-C-standard escape sequence `\\%A' at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_string (m); + ffebad_finish (); + } + return (c == 'E' || c == 'e') ? 033 : c; + + case '?': + return c; + + default: + if (c >= 040 && c < 0177) + { + char m[2]; + + m[0] = c; + m[1] = '\0'; + ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_string (m); + ffebad_finish (); + } + else if (c == EOF) + { + ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + else + { + char m[20]; + + sprintf (&m[0], "%x", c); + ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_string (m); + ffebad_finish (); + } + } + return c; + + case 2: + if ((c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + || (c >= '0' && c <= '9')) + { + code *= 16; + if (c >= 'a' && c <= 'f') + code += c - 'a' + 10; + if (c >= 'A' && c <= 'F') + code += c - 'A' + 10; + if (c >= '0' && c <= '9') + code += c - '0'; + if (code != 0 || count != 0) + { + if (count == 0) + firstdig = code; + count++; + } + nonnull = 1; + return EOF; + } + + state = 0; + + if (! nonnull) + { + ffebad_start_msg_lex ("\\x used at %0 with no following hex digits", + FFEBAD_severityFATAL); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + else if (count == 0) + /* Digits are all 0's. Ok. */ + ; + else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node) + || (count > 1 + && ((1 << (TYPE_PRECISION (integer_type_node) - (count - 1) * 4)) + <= (int) firstdig))) + { + ffebad_start_msg_lex ("Hex escape at %0 out of range", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + break; + + case 3: + if ((c <= '7') && (c >= '0') && (count++ < 3)) + { + code = (code * 8) + (c - '0'); + return EOF; + } + state = 0; + break; + + default: + assert ("bad backslash state" == NULL); + abort (); + } + + /* Come here when code has a built character, and c is the next + character that might (or might not) be the next one in the constant. */ + + /* Don't bother doing this check for each character going into + CHARACTER or HOLLERITH constants, just the escaped-value ones. + gcc apparently checks every single character, which seems + like it'd be kinda slow and not worth doing anyway. */ + + if (!wide_flag + && TYPE_PRECISION (char_type_node) < HOST_BITS_PER_INT + && code >= (1 << TYPE_PRECISION (char_type_node))) + { + ffebad_start_msg_lex ("Escape sequence at %0 out of range for character", + FFEBAD_severityFATAL); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + + if (c == EOF) + { + /* Known end of constant, just append this character. */ + ffelex_append_to_token_ (code); + if (ffelex_raw_mode_ > 0) + --ffelex_raw_mode_; + return EOF; + } + + /* Have two characters to handle. Do the first, then leave it to the + caller to detect anything special about the second. */ + + ffelex_append_to_token_ (code); + if (ffelex_raw_mode_ > 0) + --ffelex_raw_mode_; + ffelex_backslash_reconsider_ = TRUE; + return c; +} + +/* ffelex_bad_1_ -- Issue diagnostic with one source point + + ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1); + + Creates ffewhere line and column objects for the source point, sends them + along with the error code to ffebad, then kills the line and column + objects before returning. */ + +static void +ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0) +{ + ffewhereLine wl0; + ffewhereColumn wc0; + + wl0 = ffewhere_line_new (ln0); + wc0 = ffewhere_column_new (cn0); + ffebad_start_lex (errnum); + ffebad_here (0, wl0, wc0); + ffebad_finish (); + ffewhere_line_kill (wl0); + ffewhere_column_kill (wc0); +} + +/* ffelex_bad_2_ -- Issue diagnostic with two source points + + ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1, + otherline,othercolumn); + + Creates ffewhere line and column objects for the source points, sends them + along with the error code to ffebad, then kills the line and column + objects before returning. */ + +static void +ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0, + ffewhereLineNumber ln1, ffewhereColumnNumber cn1) +{ + ffewhereLine wl0, wl1; + ffewhereColumn wc0, wc1; + + wl0 = ffewhere_line_new (ln0); + wc0 = ffewhere_column_new (cn0); + wl1 = ffewhere_line_new (ln1); + wc1 = ffewhere_column_new (cn1); + ffebad_start_lex (errnum); + ffebad_here (0, wl0, wc0); + ffebad_here (1, wl1, wc1); + ffebad_finish (); + ffewhere_line_kill (wl0); + ffewhere_column_kill (wc0); + ffewhere_line_kill (wl1); + ffewhere_column_kill (wc1); +} + +static void +ffelex_bad_here_ (int n, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0) +{ + ffewhereLine wl0; + ffewhereColumn wc0; + + wl0 = ffewhere_line_new (ln0); + wc0 = ffewhere_column_new (cn0); + ffebad_here (n, wl0, wc0); + ffewhere_line_kill (wl0); + ffewhere_column_kill (wc0); +} + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_getc_ (FILE *finput) +{ + int c; + + if (ffelex_kludge_chars_ == NULL) + return getc (finput); + + c = *ffelex_kludge_chars_++; + if (c != 0) + return c; + + ffelex_kludge_chars_ = NULL; + return getc (finput); +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_cfebackslash_ (int *use_d, int *d, FILE *finput) +{ + register int c = getc (finput); + register int code; + register unsigned count; + unsigned firstdig = 0; + int nonnull; + + *use_d = 0; + + switch (c) + { + case 'x': + if (warn_traditional) + warning ("the meaning of `\\x' varies with -traditional"); + + if (flag_traditional) + return c; + + code = 0; + count = 0; + nonnull = 0; + while (1) + { + c = getc (finput); + if (!(c >= 'a' && c <= 'f') + && !(c >= 'A' && c <= 'F') + && !(c >= '0' && c <= '9')) + { + *use_d = 1; + *d = c; + break; + } + code *= 16; + if (c >= 'a' && c <= 'f') + code += c - 'a' + 10; + if (c >= 'A' && c <= 'F') + code += c - 'A' + 10; + if (c >= '0' && c <= '9') + code += c - '0'; + if (code != 0 || count != 0) + { + if (count == 0) + firstdig = code; + count++; + } + nonnull = 1; + } + if (! nonnull) + error ("\\x used with no following hex digits"); + else if (count == 0) + /* Digits are all 0's. Ok. */ + ; + else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node) + || (count > 1 + && (((unsigned) 1 + << (TYPE_PRECISION (integer_type_node) - (count - 1) + * 4)) + <= firstdig))) + pedwarn ("hex escape out of range"); + return code; + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + code = 0; + count = 0; + while ((c <= '7') && (c >= '0') && (count++ < 3)) + { + code = (code * 8) + (c - '0'); + c = getc (finput); + } + *use_d = 1; + *d = c; + return code; + + case '\\': case '\'': case '"': + return c; + + case '\n': + ffelex_next_line_ (); + *use_d = 2; + return 0; + + case EOF: + *use_d = 1; + *d = EOF; + return EOF; + + case 'n': + return TARGET_NEWLINE; + + case 't': + return TARGET_TAB; + + case 'r': + return TARGET_CR; + + case 'f': + return TARGET_FF; + + case 'b': + return TARGET_BS; + + case 'a': + if (warn_traditional) + warning ("the meaning of `\\a' varies with -traditional"); + + if (flag_traditional) + return c; + return TARGET_BELL; + + case 'v': +#if 0 /* Vertical tab is present in common usage compilers. */ + if (flag_traditional) + return c; +#endif + return TARGET_VT; + + case 'e': + case 'E': + if (pedantic) + pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c); + return 033; + + case '?': + return c; + + /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */ + case '(': + case '{': + case '[': + /* `\%' is used to prevent SCCS from getting confused. */ + case '%': + if (pedantic) + pedwarn ("non-ANSI escape sequence `\\%c'", c); + return c; + } + if (c >= 040 && c < 0177) + pedwarn ("unknown escape sequence `\\%c'", c); + else + pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c); + return c; +} + +#endif +/* A miniature version of the C front-end lexer. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_cfelex_ (ffelexToken *xtoken, FILE *finput, int c) +{ + ffelexToken token; + char buff[129]; + char *p; + char *q; + char *r; + register unsigned buffer_length; + + if ((*xtoken != NULL) && !ffelex_kludge_flag_) + ffelex_token_kill (*xtoken); + + switch (c) + { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + buffer_length = ARRAY_SIZE (buff); + p = &buff[0]; + q = p; + r = &buff[buffer_length]; + for (;;) + { + *p++ = c; + if (p >= r) + { + register unsigned bytes_used = (p - q); + + buffer_length *= 2; + q = (char *)xrealloc (q, buffer_length); + p = &q[bytes_used]; + r = &q[buffer_length]; + } + c = ffelex_getc_ (finput); + if (!isdigit (c)) + break; + } + *p = '\0'; + token = ffelex_token_new_number (q, ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + if (q != &buff[0]) + free (q); + + break; + + case '\"': + buffer_length = ARRAY_SIZE (buff); + p = &buff[0]; + q = p; + r = &buff[buffer_length]; + c = ffelex_getc_ (finput); + for (;;) + { + bool done = FALSE; + int use_d = 0; + int d; + + switch (c) + { + case '\"': + c = getc (finput); + done = TRUE; + break; + + case '\\': /* ~~~~~ */ + c = ffelex_cfebackslash_ (&use_d, &d, finput); + break; + + case EOF: + case '\n': + fatal ("Badly formed directive -- no closing quote"); + done = TRUE; + break; + + default: + break; + } + if (done) + break; + + if (use_d != 2) /* 0=>c, 1=>cd, 2=>nil. */ + { + *p++ = c; + if (p >= r) + { + register unsigned bytes_used = (p - q); + + buffer_length = bytes_used * 2; + q = (char *)xrealloc (q, buffer_length); + p = &q[bytes_used]; + r = &q[buffer_length]; + } + } + if (use_d == 1) + c = d; + else + c = getc (finput); + } + *p = '\0'; + token = ffelex_token_new_character (q, ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + if (q != &buff[0]) + free (q); + + break; + + default: + token = NULL; + break; + } + + *xtoken = token; + return c; +} +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffelex_file_pop_ (char *input_filename) +{ + if (input_file_stack->next) + { + struct file_stack *p = input_file_stack; + input_file_stack = p->next; + free (p); + input_file_stack_tick++; +#ifdef DWARF_DEBUGGING_INFO + if (debug_info_level == DINFO_LEVEL_VERBOSE + && write_symbols == DWARF_DEBUG) + dwarfout_resume_previous_source_file (input_file_stack->line); +#endif /* DWARF_DEBUGGING_INFO */ + } + else + error ("#-lines for entering and leaving files don't match"); + + /* Now that we've pushed or popped the input stack, + update the name in the top element. */ + if (input_file_stack) + input_file_stack->name = input_filename; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffelex_file_push_ (int old_lineno, char *input_filename) +{ + struct file_stack *p + = (struct file_stack *) xmalloc (sizeof (struct file_stack)); + + input_file_stack->line = old_lineno; + p->next = input_file_stack; + p->name = input_filename; + input_file_stack = p; + input_file_stack_tick++; +#ifdef DWARF_DEBUGGING_INFO + if (debug_info_level == DINFO_LEVEL_VERBOSE + && write_symbols == DWARF_DEBUG) + dwarfout_start_new_source_file (input_filename); +#endif /* DWARF_DEBUGGING_INFO */ + + /* Now that we've pushed or popped the input stack, + update the name in the top element. */ + if (input_file_stack) + input_file_stack->name = input_filename; +} +#endif + +/* Prepare to finish a statement-in-progress by sending the current + token, if any, then setting up EOS as the current token with the + appropriate current pointer. The caller can then move the current + pointer before actually sending EOS, if desired, as it is in + typical fixed-form cases. */ + +static void +ffelex_prepare_eos_ () +{ + if (ffelex_token_->type != FFELEX_typeNONE) + { + ffelex_backslash_ (EOF, 0); + + switch (ffelex_raw_mode_) + { + case -2: + break; + + case -1: + ffebad_start_lex ((ffelex_raw_char_ == '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE + : FFEBAD_NO_CLOSING_QUOTE); + ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col); + ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_); + ffebad_finish (); + break; + + case 0: + break; + + default: + { + char num[20]; + + ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS); + ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col); + ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_); + sprintf (num, "%lu", (unsigned long) ffelex_raw_mode_); + ffebad_string (num); + ffebad_finish (); + /* Make sure the token has some text, might as well fill up with spaces. */ + do + { + ffelex_append_to_token_ (' '); + } while (--ffelex_raw_mode_ > 0); + break; + } + } + ffelex_raw_mode_ = 0; + ffelex_send_token_ (); + } + ffelex_token_->type = FFELEX_typeEOS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_use (ffelex_current_wc_); +} + +static void +ffelex_finish_statement_ () +{ + if ((ffelex_number_of_tokens_ == 0) + && (ffelex_token_->type == FFELEX_typeNONE)) + return; /* Don't have a statement pending. */ + + if (ffelex_token_->type != FFELEX_typeEOS) + ffelex_prepare_eos_ (); + + ffelex_permit_include_ = TRUE; + ffelex_send_token_ (); + ffelex_permit_include_ = FALSE; + ffelex_number_of_tokens_ = 0; + ffelex_label_tokens_ = 0; + ffelex_names_ = TRUE; + ffelex_names_pure_ = FALSE; /* Probably not necessary. */ + ffelex_hexnum_ = FALSE; + + if (!ffe_is_ffedebug ()) + return; + + /* For debugging purposes only. */ + + if (ffelex_total_tokens_ != ffelex_old_total_tokens_) + { + fprintf (dmpout, "; token_track had %ld tokens, now have %ld.\n", + ffelex_old_total_tokens_, ffelex_total_tokens_); + ffelex_old_total_tokens_ = ffelex_total_tokens_; + } +} + +/* Copied from gcc/c-common.c get_directive_line. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_get_directive_line_ (char **text, FILE *finput) +{ + static char *directive_buffer = NULL; + static unsigned buffer_length = 0; + register char *p; + register char *buffer_limit; + register int looking_for = 0; + register int char_escaped = 0; + + if (buffer_length == 0) + { + directive_buffer = (char *)xmalloc (128); + buffer_length = 128; + } + + buffer_limit = &directive_buffer[buffer_length]; + + for (p = directive_buffer; ; ) + { + int c; + + /* Make buffer bigger if it is full. */ + if (p >= buffer_limit) + { + register unsigned bytes_used = (p - directive_buffer); + + buffer_length *= 2; + directive_buffer + = (char *)xrealloc (directive_buffer, buffer_length); + p = &directive_buffer[bytes_used]; + buffer_limit = &directive_buffer[buffer_length]; + } + + c = getc (finput); + + /* Discard initial whitespace. */ + if ((c == ' ' || c == '\t') && p == directive_buffer) + continue; + + /* Detect the end of the directive. */ + if ((c == '\n' && looking_for == 0) + || c == EOF) + { + if (looking_for != 0) + fatal ("Bad directive -- missing close-quote"); + + *p++ = '\0'; + *text = directive_buffer; + return c; + } + + *p++ = c; + if (c == '\n') + ffelex_next_line_ (); + + /* Handle string and character constant syntax. */ + if (looking_for) + { + if (looking_for == c && !char_escaped) + looking_for = 0; /* Found terminator... stop looking. */ + } + else + if (c == '\'' || c == '"') + looking_for = c; /* Don't stop buffering until we see another + another one of these (or an EOF). */ + + /* Handle backslash. */ + char_escaped = (c == '\\' && ! char_escaped); + } +} +#endif + +/* Handle # directives that make it through (or are generated by) the + preprocessor. As much as reasonably possible, emulate the behavior + of the gcc compiler phase cc1, though interactions between #include + and INCLUDE might possibly produce bizarre results in terms of + error reporting and the generation of debugging info vis-a-vis the + locations of some things. + + Returns the next character unhandled, which is always newline or EOF. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_hash_ (FILE *finput) +{ + register int c; + ffelexToken token = NULL; + + /* Read first nonwhite char after the `#'. */ + + c = ffelex_getc_ (finput); + while (c == ' ' || c == '\t') + c = ffelex_getc_ (finput); + + /* If a letter follows, then if the word here is `line', skip + it and ignore it; otherwise, ignore the line, with an error + if the word isn't `pragma', `ident', `define', or `undef'. */ + + if ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) + { + if (c == 'p') + { + if (getc (finput) == 'r' + && getc (finput) == 'a' + && getc (finput) == 'g' + && getc (finput) == 'm' + && getc (finput) == 'a' + && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' + || c == EOF)) + { + goto skipline; +#if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */ +#ifdef HANDLE_SYSV_PRAGMA + return handle_sysv_pragma (finput, c); +#else /* !HANDLE_SYSV_PRAGMA */ +#ifdef HANDLE_PRAGMA + HANDLE_PRAGMA (finput); +#endif /* HANDLE_PRAGMA */ + goto skipline; +#endif /* !HANDLE_SYSV_PRAGMA */ +#endif /* 0 */ + } + } + + else if (c == 'd') + { + if (getc (finput) == 'e' + && getc (finput) == 'f' + && getc (finput) == 'i' + && getc (finput) == 'n' + && getc (finput) == 'e' + && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' + || c == EOF)) + { + char *text; + + c = ffelex_get_directive_line_ (&text, finput); + +#ifdef DWARF_DEBUGGING_INFO + if ((debug_info_level == DINFO_LEVEL_VERBOSE) + && (write_symbols == DWARF_DEBUG)) + dwarfout_define (lineno, text); +#endif /* DWARF_DEBUGGING_INFO */ + + goto skipline; + } + } + else if (c == 'u') + { + if (getc (finput) == 'n' + && getc (finput) == 'd' + && getc (finput) == 'e' + && getc (finput) == 'f' + && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' + || c == EOF)) + { + char *text; + + c = ffelex_get_directive_line_ (&text, finput); + +#ifdef DWARF_DEBUGGING_INFO + if ((debug_info_level == DINFO_LEVEL_VERBOSE) + && (write_symbols == DWARF_DEBUG)) + dwarfout_undef (lineno, text); +#endif /* DWARF_DEBUGGING_INFO */ + + goto skipline; + } + } + else if (c == 'l') + { + if (getc (finput) == 'i' + && getc (finput) == 'n' + && getc (finput) == 'e' + && ((c = getc (finput)) == ' ' || c == '\t')) + goto linenum; + } + else if (c == 'i') + { + if (getc (finput) == 'd' + && getc (finput) == 'e' + && getc (finput) == 'n' + && getc (finput) == 't' + && ((c = getc (finput)) == ' ' || c == '\t')) + { + /* #ident. The pedantic warning is now in cccp.c. */ + + /* Here we have just seen `#ident '. + A string constant should follow. */ + + while (c == ' ' || c == '\t') + c = getc (finput); + + /* If no argument, ignore the line. */ + if (c == '\n' || c == EOF) + return c; + + c = ffelex_cfelex_ (&token, finput, c); + + if ((token == NULL) + || (ffelex_token_type (token) != FFELEX_typeCHARACTER)) + { + error ("invalid #ident"); + goto skipline; + } + + if (ffe_is_ident ()) + { +#ifdef ASM_OUTPUT_IDENT + ASM_OUTPUT_IDENT (asm_out_file, + ffelex_token_text (token)); +#endif + } + + /* Skip the rest of this line. */ + goto skipline; + } + } + + error ("undefined or invalid # directive"); + goto skipline; + } + + linenum: + /* Here we have either `#line' or `# <nonletter>'. + In either case, it should be a line number; a digit should follow. */ + + while (c == ' ' || c == '\t') + c = ffelex_getc_ (finput); + + /* If the # is the only nonwhite char on the line, + just ignore it. Check the new newline. */ + if (c == '\n' || c == EOF) + return c; + + /* Something follows the #; read a token. */ + + c = ffelex_cfelex_ (&token, finput, c); + + if ((token != NULL) + && (ffelex_token_type (token) == FFELEX_typeNUMBER)) + { + int old_lineno = lineno; + char *old_input_filename = input_filename; + ffewhereFile wf; + + /* subtract one, because it is the following line that + gets the specified number */ + int l = atoi (ffelex_token_text (token)) - 1; + + /* Is this the last nonwhite stuff on the line? */ + while (c == ' ' || c == '\t') + c = ffelex_getc_ (finput); + if (c == '\n' || c == EOF) + { + /* No more: store the line number and check following line. */ + lineno = l; + if (!ffelex_kludge_flag_) + { + ffewhere_file_set (NULL, TRUE, (ffewhereLineNumber) l); + + if (token != NULL) + ffelex_token_kill (token); + } + return c; + } + + /* More follows: it must be a string constant (filename). */ + + /* Read the string constant. */ + c = ffelex_cfelex_ (&token, finput, c); + + if ((token == NULL) + || (ffelex_token_type (token) != FFELEX_typeCHARACTER)) + { + error ("invalid #line"); + goto skipline; + } + + lineno = l; + + if (ffelex_kludge_flag_) + input_filename = ffelex_token_text (token); + else + { + wf = ffewhere_file_new (ffelex_token_text (token), + ffelex_token_length (token)); + input_filename = ffewhere_file_name (wf); + ffewhere_file_set (wf, TRUE, (ffewhereLineNumber) l); + } + +#if 0 /* Not sure what g77 should do with this yet. */ + /* Each change of file name + reinitializes whether we are now in a system header. */ + in_system_header = 0; +#endif + + if (main_input_filename == 0) + main_input_filename = input_filename; + + /* Is this the last nonwhite stuff on the line? */ + while (c == ' ' || c == '\t') + c = getc (finput); + if (c == '\n' || c == EOF) + { + if (!ffelex_kludge_flag_) + { + /* Update the name in the top element of input_file_stack. */ + if (input_file_stack) + input_file_stack->name = input_filename; + + if (token != NULL) + ffelex_token_kill (token); + } + return c; + } + + c = ffelex_cfelex_ (&token, finput, c); + + /* `1' after file name means entering new file. + `2' after file name means just left a file. */ + + if ((token != NULL) + && (ffelex_token_type (token) == FFELEX_typeNUMBER)) + { + int num = atoi (ffelex_token_text (token)); + + if (ffelex_kludge_flag_) + { + lineno = 1; + input_filename = old_input_filename; + fatal ("Use `#line ...' instead of `# ...' in first line"); + } + + if (num == 1) + { + /* Pushing to a new file. */ + ffelex_file_push_ (old_lineno, input_filename); + } + else if (num == 2) + { + /* Popping out of a file. */ + ffelex_file_pop_ (input_filename); + } + + /* Is this the last nonwhite stuff on the line? */ + while (c == ' ' || c == '\t') + c = getc (finput); + if (c == '\n' || c == EOF) + { + if (token != NULL) + ffelex_token_kill (token); + return c; + } + + c = ffelex_cfelex_ (&token, finput, c); + } + + /* `3' after file name means this is a system header file. */ + +#if 0 /* Not sure what g77 should do with this yet. */ + if ((token != NULL) + && (ffelex_token_type (token) == FFELEX_typeNUMBER) + && (atoi (ffelex_token_text (token)) == 3)) + in_system_header = 1; +#endif + + while (c == ' ' || c == '\t') + c = getc (finput); + if (((token != NULL) + || (c != '\n' && c != EOF)) + && ffelex_kludge_flag_) + { + lineno = 1; + input_filename = old_input_filename; + fatal ("Use `#line ...' instead of `# ...' in first line"); + } + } + else + error ("invalid #-line"); + + /* skip the rest of this line. */ + skipline: + if ((token != NULL) && !ffelex_kludge_flag_) + ffelex_token_kill (token); + while ((c = getc (finput)) != EOF && c != '\n') + ; + return c; +} +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* "Image" a character onto the card image, return incremented column number. + + Normally invoking this function as in + column = ffelex_image_char_ (c, column); + is the same as doing: + ffelex_card_image_[column++] = c; + + However, tabs and carriage returns are handled specially, to preserve + the visual "image" of the input line (in most editors) in the card + image. + + Carriage returns are ignored, as they are assumed to be followed + by newlines. + + A tab is handled by first doing: + ffelex_card_image_[column++] = ' '; + That is, it translates to at least one space. Then, as many spaces + are imaged as necessary to bring the column number to the next tab + position, where tab positions start in the ninth column and each + eighth column afterwards. ALSO, a static var named ffelex_saw_tab_ + is set to TRUE to notify the lexer that a tab was seen. + + Columns are numbered and tab stops set as illustrated below: + + 012345670123456701234567... + x y z + xx yy zz + ... + xxxxxxx yyyyyyy zzzzzzz + xxxxxxxx yyyyyyyy... */ + +static ffewhereColumnNumber +ffelex_image_char_ (int c, ffewhereColumnNumber column) +{ + ffewhereColumnNumber old_column = column; + + if (column >= ffelex_card_size_) + { + ffewhereColumnNumber newmax = ffelex_card_size_ << 1; + + if (ffelex_bad_line_) + return column; + + if ((newmax >> 1) != ffelex_card_size_) + { /* Overflowed column number. */ + overflow: /* :::::::::::::::::::: */ + + ffelex_bad_line_ = TRUE; + strcpy (&ffelex_card_image_[column - 3], "..."); + ffelex_card_length_ = column; + ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG, + ffelex_linecount_current_, column + 1); + return column; + } + + ffelex_card_image_ + = malloc_resize_ksr (malloc_pool_image (), + ffelex_card_image_, + newmax + 9, + ffelex_card_size_ + 9); + ffelex_card_size_ = newmax; + } + + switch (c) + { + case '\r': + break; + + case '\t': + ffelex_saw_tab_ = TRUE; + ffelex_card_image_[column++] = ' '; + while ((column & 7) != 0) + ffelex_card_image_[column++] = ' '; + break; + + case '\0': + if (!ffelex_bad_line_) + { + ffelex_bad_line_ = TRUE; + strcpy (&ffelex_card_image_[column], "[\\0]"); + ffelex_card_length_ = column + 4; + ffebad_start_msg_lex ("Null character at %0 -- line ignored", + FFEBAD_severityFATAL); + ffelex_bad_here_ (0, ffelex_linecount_current_, column + 1); + ffebad_finish (); + column += 4; + } + break; + + default: + ffelex_card_image_[column++] = c; + break; + } + + if (column < old_column) + { + column = old_column; + goto overflow; /* :::::::::::::::::::: */ + } + + return column; +} + +static void +ffelex_include_ () +{ + ffewhereFile include_wherefile = ffelex_include_wherefile_; + FILE *include_file = ffelex_include_file_; + /* The rest of this is to push, and after the INCLUDE file is processed, + pop, the static lexer state info that pertains to each particular + input file. */ + char *card_image; + ffewhereColumnNumber card_size = ffelex_card_size_; + ffewhereColumnNumber card_length = ffelex_card_length_; + ffewhereLine current_wl = ffelex_current_wl_; + ffewhereColumn current_wc = ffelex_current_wc_; + bool saw_tab = ffelex_saw_tab_; + ffewhereColumnNumber final_nontab_column = ffelex_final_nontab_column_; + ffewhereFile current_wf = ffelex_current_wf_; + ffewhereLineNumber linecount_current = ffelex_linecount_current_; + ffewhereLineNumber linecount_offset + = ffewhere_line_filelinenum (current_wl); +#if FFECOM_targetCURRENT == FFECOM_targetGCC + int old_lineno = lineno; + char *old_input_filename = input_filename; +#endif + + if (card_length != 0) + { + card_image = malloc_new_ks (malloc_pool_image (), + "FFELEX saved card image", + card_length); + memcpy (card_image, ffelex_card_image_, card_length); + } + else + card_image = NULL; + + ffelex_set_include_ = FALSE; + + ffelex_next_line_ (); + + ffewhere_file_set (include_wherefile, TRUE, 0); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffelex_file_push_ (old_lineno, ffewhere_file_name (include_wherefile)); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + + if (ffelex_include_free_form_) + ffelex_file_free (include_wherefile, include_file); + else + ffelex_file_fixed (include_wherefile, include_file); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffelex_file_pop_ (ffewhere_file_name (current_wf)); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + + ffewhere_file_set (current_wf, TRUE, linecount_offset); + + ffecom_close_include (include_file); + + if (card_length != 0) + { +#ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */ +#error "need to handle possible reduction of card size here!!" +#endif + assert (ffelex_card_size_ >= card_length); /* It shrunk?? */ + memcpy (ffelex_card_image_, card_image, card_length); + } + ffelex_card_image_[card_length] = '\0'; + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + input_filename = old_input_filename; + lineno = old_lineno; +#endif + ffelex_linecount_current_ = linecount_current; + ffelex_current_wf_ = current_wf; + ffelex_final_nontab_column_ = final_nontab_column; + ffelex_saw_tab_ = saw_tab; + ffelex_current_wc_ = current_wc; + ffelex_current_wl_ = current_wl; + ffelex_card_length_ = card_length; + ffelex_card_size_ = card_size; +} + +/* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation? + + ffewhereColumnNumber col; + int c; // Char at col. + if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1)) + // We have a continuation indicator. + + If there are <n> spaces starting at ffelex_card_image_[col] up through + the null character, where <n> is 0 or greater, returns TRUE. */ + +static bool +ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col) +{ + while (ffelex_card_image_[col] != '\0') + { + if (ffelex_card_image_[col++] != ' ') + return FALSE; + } + return TRUE; +} + +/* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation? + + ffewhereColumnNumber col; + int c; // Char at col. + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1)) + // We have a continuation indicator. + + If there are <n> spaces starting at ffelex_card_image_[col] up through + the null character or '!', where <n> is 0 or greater, returns TRUE. */ + +static bool +ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col) +{ + while ((ffelex_card_image_[col] != '\0') && (ffelex_card_image_[col] != '!')) + { + if (ffelex_card_image_[col++] != ' ') + return FALSE; + } + return TRUE; +} + +static void +ffelex_next_line_ () +{ + ffelex_linecount_current_ = ffelex_linecount_next_; + ++ffelex_linecount_next_; +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ++lineno; +#endif +} + +static void +ffelex_send_token_ () +{ + ++ffelex_number_of_tokens_; + + ffelex_backslash_ (EOF, 0); + + if (ffelex_token_->text == NULL) + { + if (ffelex_token_->type == FFELEX_typeCHARACTER) + { + ffelex_append_to_token_ ('\0'); + ffelex_token_->length = 0; + } + } + else + ffelex_token_->text[ffelex_token_->length] = '\0'; + + assert (ffelex_raw_mode_ == 0); + + if (ffelex_token_->type == FFELEX_typeNAMES) + { + ffewhere_line_kill (ffelex_token_->currentnames_line); + ffewhere_column_kill (ffelex_token_->currentnames_col); + } + + assert (ffelex_handler_ != NULL); + ffelex_handler_ = (ffelexHandler) (*ffelex_handler_) (ffelex_token_); + assert (ffelex_handler_ != NULL); + + ffelex_token_kill (ffelex_token_); + + ffelex_token_ = ffelex_token_new_ (); + ffelex_token_->uses = 1; + ffelex_token_->text = NULL; + if (ffelex_raw_mode_ < 0) + { + ffelex_token_->type = FFELEX_typeCHARACTER; + ffelex_token_->where_line = ffelex_raw_where_line_; + ffelex_token_->where_col = ffelex_raw_where_col_; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + } + else + { + ffelex_token_->type = FFELEX_typeNONE; + ffelex_token_->where_line = ffewhere_line_unknown (); + ffelex_token_->where_col = ffewhere_column_unknown (); + } + + if (ffelex_set_include_) + ffelex_include_ (); +} + +/* ffelex_swallow_tokens_ -- Eat all tokens delivered to me + + return ffelex_swallow_tokens_; + + Return this handler when you don't want to look at any more tokens in the + statement because you've encountered an unrecoverable error in the + statement. */ + +static ffelexHandler +ffelex_swallow_tokens_ (ffelexToken t) +{ + assert (ffelex_eos_handler_ != NULL); + + if ((ffelex_token_type (t) == FFELEX_typeEOS) + || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)) + return (ffelexHandler) (*ffelex_eos_handler_) (t); + + return (ffelexHandler) ffelex_swallow_tokens_; +} + +static ffelexToken +ffelex_token_new_ () +{ + ffelexToken t; + + ++ffelex_total_tokens_; + + t = (ffelexToken) malloc_new_ks (malloc_pool_image (), + "FFELEX token", sizeof (*t)); + t->id_ = ffelex_token_nextid_++; + return t; +} + +static char * +ffelex_type_string_ (ffelexType type) +{ + static char *types[] = { + "FFELEX_typeNONE", + "FFELEX_typeCOMMENT", + "FFELEX_typeEOS", + "FFELEX_typeEOF", + "FFELEX_typeERROR", + "FFELEX_typeRAW", + "FFELEX_typeQUOTE", + "FFELEX_typeDOLLAR", + "FFELEX_typeHASH", + "FFELEX_typePERCENT", + "FFELEX_typeAMPERSAND", + "FFELEX_typeAPOSTROPHE", + "FFELEX_typeOPEN_PAREN", + "FFELEX_typeCLOSE_PAREN", + "FFELEX_typeASTERISK", + "FFELEX_typePLUS", + "FFELEX_typeMINUS", + "FFELEX_typePERIOD", + "FFELEX_typeSLASH", + "FFELEX_typeNUMBER", + "FFELEX_typeOPEN_ANGLE", + "FFELEX_typeEQUALS", + "FFELEX_typeCLOSE_ANGLE", + "FFELEX_typeNAME", + "FFELEX_typeCOMMA", + "FFELEX_typePOWER", + "FFELEX_typeCONCAT", + "FFELEX_typeDEBUG", + "FFELEX_typeNAMES", + "FFELEX_typeHOLLERITH", + "FFELEX_typeCHARACTER", + "FFELEX_typeCOLON", + "FFELEX_typeSEMICOLON", + "FFELEX_typeUNDERSCORE", + "FFELEX_typeQUESTION", + "FFELEX_typeOPEN_ARRAY", + "FFELEX_typeCLOSE_ARRAY", + "FFELEX_typeCOLONCOLON", + "FFELEX_typeREL_LE", + "FFELEX_typeREL_NE", + "FFELEX_typeREL_EQ", + "FFELEX_typePOINTS", + "FFELEX_typeREL_GE" + }; + + if (type >= ARRAY_SIZE (types)) + return "???"; + return types[type]; +} + +void +ffelex_display_token (ffelexToken t) +{ + if (t == NULL) + t = ffelex_token_; + + fprintf (dmpout, "; Token #%lu is %s (line %" ffewhereLineNumber_f "u, col %" + ffewhereColumnNumber_f "u)", + t->id_, + ffelex_type_string_ (t->type), + ffewhere_line_number (t->where_line), + ffewhere_column_number (t->where_col)); + + if (t->text != NULL) + fprintf (dmpout, ": \"%.*s\"\n", + (int) t->length, + t->text); + else + fprintf (dmpout, ".\n"); +} + +/* ffelex_expecting_character -- Tells if next token expected to be CHARACTER + + if (ffelex_expecting_character()) + // next token delivered by lexer will be CHARACTER. + + If the most recent call to ffelex_set_expecting_hollerith since the last + token was delivered by the lexer passed a length of -1, then we return + TRUE, because the next token we deliver will be typeCHARACTER, else we + return FALSE. */ + +bool +ffelex_expecting_character () +{ + return (ffelex_raw_mode_ != 0); +} + +/* ffelex_file_fixed -- Lex a given file in fixed source form + + ffewhere wf; + FILE *f; + ffelex_file_fixed(wf,f); + + Lexes the file according to Fortran 90 ANSI + VXT specifications. */ + +ffelexHandler +ffelex_file_fixed (ffewhereFile wf, FILE *f) +{ + register int c; /* Character currently under consideration. */ + register ffewhereColumnNumber column; /* Not really; 0 means column 1... */ + bool disallow_continuation_line; + bool ignore_disallowed_continuation; + int latest_char_in_file = 0; /* For getting back into comment-skipping + code. */ + ffelexType lextype; + ffewhereColumnNumber first_label_char; /* First char of label -- + column number. */ + char label_string[6]; /* Text of label. */ + int labi; /* Length of label text. */ + bool finish_statement; /* Previous statement finished? */ + bool have_content; /* This line have content? */ + bool just_do_label; /* Nothing but label (and continuation?) on + line. */ + + /* Lex is called for a particular file, not for a particular program unit. + Yet the two events do share common characteristics. The first line in a + file or in a program unit cannot be a continuation line. No token can + be in mid-formation. No current label for the statement exists, since + there is no current statement. */ + + assert (ffelex_handler_ != NULL); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + lineno = 0; + input_filename = ffewhere_file_name (wf); +#endif + ffelex_current_wf_ = wf; + disallow_continuation_line = TRUE; + ignore_disallowed_continuation = FALSE; + ffelex_token_->type = FFELEX_typeNONE; + ffelex_number_of_tokens_ = 0; + ffelex_label_tokens_ = 0; + ffelex_current_wl_ = ffewhere_line_unknown (); + ffelex_current_wc_ = ffewhere_column_unknown (); + latest_char_in_file = '\n'; + goto first_line; /* :::::::::::::::::::: */ + + /* Come here to get a new line. */ + + beginning_of_line: /* :::::::::::::::::::: */ + + disallow_continuation_line = FALSE; + + /* Come here directly when last line didn't clarify the continuation issue. */ + + beginning_of_line_again: /* :::::::::::::::::::: */ + +#ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */ + if (ffelex_card_size_ != FFELEX_columnINITIAL_SIZE_) + { + ffelex_card_image_ + = malloc_resize_ks (malloc_pool_image (), + ffelex_card_image_, + FFELEX_columnINITIAL_SIZE_ + 9, + ffelex_card_size_ + 9); + ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_; + } +#endif + + first_line: /* :::::::::::::::::::: */ + + c = latest_char_in_file; + if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF)) + { + + end_of_file: /* :::::::::::::::::::: */ + + /* Line ending in EOF instead of \n still counts as a whole line. */ + + ffelex_finish_statement_ (); + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + return (ffelexHandler) ffelex_handler_; + } + + ffelex_next_line_ (); + + ffelex_bad_line_ = FALSE; + + /* Skip over comment (and otherwise ignored) lines as quickly as possible! */ + + while (((lextype = ffelex_first_char_[c]) == FFELEX_typeCOMMENT) + || (lextype == FFELEX_typeERROR) + || (lextype == FFELEX_typeSLASH) + || (lextype == FFELEX_typeHASH)) + { + /* Test most frequent type of line first, etc. */ + if ((lextype == FFELEX_typeCOMMENT) + || ((lextype == FFELEX_typeSLASH) + && ((c = getc (f)) == '*'))) /* NOTE SIDE-EFFECT. */ + { + /* Typical case (straight comment), just ignore rest of line. */ + comment_line: /* :::::::::::::::::::: */ + + while ((c != '\n') && (c != EOF)) + c = getc (f); + } +#if FFECOM_targetCURRENT == FFECOM_targetGCC + else if (lextype == FFELEX_typeHASH) + c = ffelex_hash_ (f); +#endif + else if (lextype == FFELEX_typeSLASH) + { + /* SIDE-EFFECT ABOVE HAS HAPPENED. */ + ffelex_card_image_[0] = '/'; + ffelex_card_image_[1] = c; + column = 2; + goto bad_first_character; /* :::::::::::::::::::: */ + } + else + /* typeERROR or unsupported typeHASH. */ + { /* Bad first character, get line and display + it with message. */ + column = ffelex_image_char_ (c, 0); + + bad_first_character: /* :::::::::::::::::::: */ + + ffelex_bad_line_ = TRUE; + while (((c = getc (f)) != '\n') && (c != EOF)) + column = ffelex_image_char_ (c, column); + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID, + ffelex_linecount_current_, 1); + } + + /* Read past last char in line. */ + + if (c == EOF) + { + ffelex_next_line_ (); + goto end_of_file; /* :::::::::::::::::::: */ + } + + c = getc (f); + + ffelex_next_line_ (); + + if (c == EOF) + goto end_of_file; /* :::::::::::::::::::: */ + + ffelex_bad_line_ = FALSE; + } /* while [c, first char, means comment] */ + + ffelex_saw_tab_ + = (c == '&') + || (ffelex_final_nontab_column_ == 0); + + if (lextype == FFELEX_typeDEBUG) + c = ' '; /* A 'D' or 'd' in column 1 with the + debug-lines option on. */ + + column = ffelex_image_char_ (c, 0); + + /* Read the entire line in as is (with whitespace processing). */ + + while (((c = getc (f)) != '\n') && (c != EOF)) + column = ffelex_image_char_ (c, column); + + if (ffelex_bad_line_) + { + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + goto comment_line; /* :::::::::::::::::::: */ + } + + /* If no tab, cut off line after column 72/132. */ + + if (!ffelex_saw_tab_ && (column > ffelex_final_nontab_column_)) + { + /* Technically, we should now fill ffelex_card_image_ up thru column + 72/132 with spaces, since character/hollerith constants must count + them in that manner. To save CPU time in several ways (avoid a loop + here that would be used only when we actually end a line in + character-constant mode; avoid writing memory unnecessarily; avoid a + loop later checking spaces when not scanning for character-constant + characters), we don't do this, and we do the appropriate thing when + we encounter end-of-line while actually processing a character + constant. */ + + column = ffelex_final_nontab_column_; + } + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + + /* Save next char in file so we can use register-based c while analyzing + line we just read. */ + + latest_char_in_file = c; /* Should be either '\n' or EOF. */ + + have_content = FALSE; + + /* Handle label, if any. */ + + labi = 0; + first_label_char = FFEWHERE_columnUNKNOWN; + for (column = 0; column < 5; ++column) + { + switch (c = ffelex_card_image_[column]) + { + case '\0': + case '!': + goto stop_looking; /* :::::::::::::::::::: */ + + case ' ': + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + label_string[labi++] = c; + if (first_label_char == FFEWHERE_columnUNKNOWN) + first_label_char = column + 1; + break; + + case '&': + if (column != 0) + { + ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC, + ffelex_linecount_current_, + column + 1); + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + if (ffe_is_pedantic ()) + ffelex_bad_1_ (FFEBAD_AMPERSAND, + ffelex_linecount_current_, 1); + finish_statement = FALSE; + just_do_label = FALSE; + goto got_a_continuation; /* :::::::::::::::::::: */ + + case '/': + if (ffelex_card_image_[column + 1] == '*') + goto stop_looking; /* :::::::::::::::::::: */ + /* Fall through. */ + default: + ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC, + ffelex_linecount_current_, column + 1); + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + } + + stop_looking: /* :::::::::::::::::::: */ + + label_string[labi] = '\0'; + + /* Find first nonblank char starting with continuation column. */ + + if (column == 5) /* In which case we didn't see end of line in + label field. */ + while ((c = ffelex_card_image_[column]) == ' ') + ++column; + + /* Now we're trying to figure out whether this is a continuation line and + whether there's anything else of substance on the line. The cases are + as follows: + + 1. If a line has an explicit continuation character (other than the digit + zero), then if it also has a label, the label is ignored and an error + message is printed. Any remaining text on the line is passed to the + parser tasks, thus even an all-blank line (possibly with an ignored + label) aside from a positive continuation character might have meaning + in the midst of a character or hollerith constant. + + 2. If a line has no explicit continuation character (that is, it has a + space in column 6 and the first non-space character past column 6 is + not a digit 0-9), then there are two possibilities: + + A. A label is present and/or a non-space (and non-comment) character + appears somewhere after column 6. Terminate processing of the previous + statement, if any, send the new label for the next statement, if any, + and start processing a new statement with this non-blank character, if + any. + + B. The line is essentially blank, except for a possible comment character. + Don't terminate processing of the previous statement and don't pass any + characters to the parser tasks, since the line is not flagged as a + continuation line. We treat it just like a completely blank line. + + 3. If a line has a continuation character of zero (0), then we terminate + processing of the previous statement, if any, send the new label for the + next statement, if any, and start processing a new statement, if any + non-blank characters are present. + + If, when checking to see if we should terminate the previous statement, it + is found that there is no previous statement but that there is an + outstanding label, substitute CONTINUE as the statement for the label + and display an error message. */ + + finish_statement = FALSE; + just_do_label = FALSE; + + switch (c) + { + case '!': /* ANSI Fortran 90 says ! in column 6 is + continuation. */ + /* VXT Fortran says ! anywhere is comment, even column 6. */ + if (ffe_is_vxt () || (column != 5)) + goto no_tokens_on_line; /* :::::::::::::::::::: */ + goto got_a_continuation; /* :::::::::::::::::::: */ + + case '/': + if (ffelex_card_image_[column + 1] != '*') + goto some_other_character; /* :::::::::::::::::::: */ + /* Fall through. */ + if (column == 5) + { + /* This seems right to do. But it is close to call, since / * starting + in column 6 will thus be interpreted as a continuation line + beginning with '*'. */ + + goto got_a_continuation;/* :::::::::::::::::::: */ + } + /* Fall through. */ + case '\0': + /* End of line. Therefore may be continued-through line, so handle + pending label as possible to-be-continued and drive end-of-statement + for any previous statement, else treat as blank line. */ + + no_tokens_on_line: /* :::::::::::::::::::: */ + + if (ffe_is_pedantic () && (c == '/')) + ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT, + ffelex_linecount_current_, column + 1); + if (first_label_char != FFEWHERE_columnUNKNOWN) + { /* Can't be a continued-through line if it + has a label. */ + finish_statement = TRUE; + have_content = TRUE; + just_do_label = TRUE; + break; + } + goto beginning_of_line_again; /* :::::::::::::::::::: */ + + case '0': + if (ffe_is_pedantic () && (column != 5)) + ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, + ffelex_linecount_current_, column + 1); + finish_statement = TRUE; + goto check_for_content; /* :::::::::::::::::::: */ + + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + + /* NOTE: This label can be reached directly from the code + that lexes the label field in columns 1-5. */ + got_a_continuation: /* :::::::::::::::::::: */ + + if (first_label_char != FFEWHERE_columnUNKNOWN) + { + ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION, + ffelex_linecount_current_, + first_label_char, + ffelex_linecount_current_, + column + 1); + first_label_char = FFEWHERE_columnUNKNOWN; + } + if (disallow_continuation_line) + { + if (!ignore_disallowed_continuation) + ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION, + ffelex_linecount_current_, column + 1); + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + if (ffe_is_pedantic () && (column != 5)) + ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, + ffelex_linecount_current_, column + 1); + if ((ffelex_raw_mode_ != 0) + && (((c = ffelex_card_image_[column + 1]) != '\0') + || !ffelex_saw_tab_)) + { + ++column; + have_content = TRUE; + break; + } + + check_for_content: /* :::::::::::::::::::: */ + + while ((c = ffelex_card_image_[++column]) == ' ') + ; + if ((c == '\0') + || (c == '!') + || ((c == '/') + && (ffelex_card_image_[column + 1] == '*'))) + { + if (ffe_is_pedantic () && (c == '/')) + ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT, + ffelex_linecount_current_, column + 1); + just_do_label = TRUE; + } + else + have_content = TRUE; + break; + + default: + + some_other_character: /* :::::::::::::::::::: */ + + if (column == 5) + goto got_a_continuation;/* :::::::::::::::::::: */ + + /* Here is the very normal case of a regular character starting in + column 7 or beyond with a blank in column 6. */ + + finish_statement = TRUE; + have_content = TRUE; + break; + } + + if (have_content + || (first_label_char != FFEWHERE_columnUNKNOWN)) + { + /* The line has content of some kind, install new end-statement + point for error messages. Note that "content" includes cases + where there's little apparent content but enough to finish + a statement. That's because finishing a statement can trigger + an impending INCLUDE, and that requires accurate line info being + maintained by the lexer. */ + + if (finish_statement) + ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */ + + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_); + ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1); + } + + /* We delay this for a combination of reasons. Mainly, it can start + INCLUDE processing, and we want to delay that until the lexer's + info on the line is coherent. And we want to delay that until we're + sure there's a reason to make that info coherent, to avoid saving + lots of useless lines. */ + + if (finish_statement) + ffelex_finish_statement_ (); + + /* If label is present, enclose it in a NUMBER token and send it along. */ + + if (first_label_char != FFEWHERE_columnUNKNOWN) + { + assert (ffelex_token_->type == FFELEX_typeNONE); + ffelex_token_->type = FFELEX_typeNUMBER; + ffelex_append_to_token_ ('\0'); /* Make room for label text. */ + strcpy (ffelex_token_->text, label_string); + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (first_label_char); + ffelex_token_->length = labi; + ffelex_send_token_ (); + ++ffelex_label_tokens_; + } + + if (just_do_label) + goto beginning_of_line; /* :::::::::::::::::::: */ + + /* Here is the main engine for parsing. c holds the character at column. + It is already known that c is not a blank, end of line, or shriek, + unless ffelex_raw_mode_ is not 0 (indicating we are in a + character/hollerith constant). A partially filled token may already + exist in ffelex_token_. One special case: if, when the end of the line + is reached, continuation_line is FALSE and the only token on the line is + END, then it is indeed the last statement. We don't look for + continuation lines during this program unit in that case. This is + according to ANSI. */ + + if (ffelex_raw_mode_ != 0) + { + + parse_raw_character: /* :::::::::::::::::::: */ + + if (c == '\0') + { + ffewhereColumnNumber i; + + if (ffelex_saw_tab_ || (column >= ffelex_final_nontab_column_)) + goto beginning_of_line; /* :::::::::::::::::::: */ + + /* Pad out line with "virtual" spaces. */ + + for (i = column; i < ffelex_final_nontab_column_; ++i) + ffelex_card_image_[i] = ' '; + ffelex_card_image_[i] = '\0'; + ffelex_card_length_ = i; + c = ' '; + } + + switch (ffelex_raw_mode_) + { + case -3: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + ffelex_append_to_token_ (c); + ffelex_raw_mode_ = -1; + break; + + case -2: + if (c == ffelex_raw_char_) + { + ffelex_raw_mode_ = -1; + ffelex_append_to_token_ (c); + } + else + { + ffelex_raw_mode_ = 0; + ffelex_backslash_reconsider_ = TRUE; + } + break; + + case -1: + if (c == ffelex_raw_char_) + ffelex_raw_mode_ = -2; + else + { + c = ffelex_backslash_ (c, column); + if (c == EOF) + { + ffelex_raw_mode_ = -3; + break; + } + + ffelex_append_to_token_ (c); + } + break; + + default: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + { + ffelex_append_to_token_ (c); + --ffelex_raw_mode_; + } + break; + } + + if (ffelex_backslash_reconsider_) + ffelex_backslash_reconsider_ = FALSE; + else + c = ffelex_card_image_[++column]; + + if (ffelex_raw_mode_ == 0) + { + ffelex_send_token_ (); + assert (ffelex_raw_mode_ == 0); + while (c == ' ') + c = ffelex_card_image_[++column]; + if ((c == '\0') + || (c == '!') + || ((c == '/') + && (ffelex_card_image_[column + 1] == '*'))) + goto beginning_of_line; /* :::::::::::::::::::: */ + goto parse_nonraw_character; /* :::::::::::::::::::: */ + } + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + parse_nonraw_character: /* :::::::::::::::::::: */ + + switch (ffelex_token_->type) + { + case FFELEX_typeNONE: + switch (c) + { + case '\"': + ffelex_token_->type = FFELEX_typeQUOTE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '$': + ffelex_token_->type = FFELEX_typeDOLLAR; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '%': + ffelex_token_->type = FFELEX_typePERCENT; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '&': + ffelex_token_->type = FFELEX_typeAMPERSAND; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '\'': + ffelex_token_->type = FFELEX_typeAPOSTROPHE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '(': + ffelex_token_->type = FFELEX_typeOPEN_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ')': + ffelex_token_->type = FFELEX_typeCLOSE_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '*': + ffelex_token_->type = FFELEX_typeASTERISK; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '+': + ffelex_token_->type = FFELEX_typePLUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case ',': + ffelex_token_->type = FFELEX_typeCOMMA; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '-': + ffelex_token_->type = FFELEX_typeMINUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '.': + ffelex_token_->type = FFELEX_typePERIOD; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '/': + ffelex_token_->type = FFELEX_typeSLASH; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_token_->type + = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_append_to_token_ (c); + break; + + case ':': + ffelex_token_->type = FFELEX_typeCOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ';': + ffelex_token_->type = FFELEX_typeSEMICOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_permit_include_ = TRUE; + ffelex_send_token_ (); + ffelex_permit_include_ = FALSE; + break; + + case '<': + ffelex_token_->type = FFELEX_typeOPEN_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '=': + ffelex_token_->type = FFELEX_typeEQUALS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '>': + ffelex_token_->type = FFELEX_typeCLOSE_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '?': + ffelex_token_->type = FFELEX_typeQUESTION; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '_': + if (1 || ffe_is_90 ()) + { + ffelex_token_->type = FFELEX_typeUNDERSCORE; + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col + = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + } + /* Fall through. */ + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + + if (ffesrc_char_match_init (c, 'H', 'h') + && ffelex_expecting_hollerith_ != 0) + { + ffelex_raw_mode_ = ffelex_expecting_hollerith_; + ffelex_token_->type = FFELEX_typeHOLLERITH; + ffelex_token_->where_line = ffelex_raw_where_line_; + ffelex_token_->where_col = ffelex_raw_where_col_; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + c = ffelex_card_image_[++column]; + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + if (ffelex_names_) + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_token_->currentnames_line + = ffewhere_line_use (ffelex_current_wl_)); + ffelex_token_->where_col + = ffewhere_column_use (ffelex_token_->currentnames_col + = ffewhere_column_new (column + 1)); + ffelex_token_->type = FFELEX_typeNAMES; + } + else + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_token_->type = FFELEX_typeNAME; + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER, + ffelex_linecount_current_, column + 1); + ffelex_finish_statement_ (); + disallow_continuation_line = TRUE; + ignore_disallowed_continuation = TRUE; + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAME: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAMES: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + if (ffelex_token_->length < FFEWHERE_indexMAX) + { + ffewhere_track (&ffelex_token_->currentnames_line, + &ffelex_token_->currentnames_col, + ffelex_token_->wheretrack, + ffelex_token_->length, + ffelex_linecount_current_, + column + 1); + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNUMBER: + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeASTERISK: + switch (c) + { + case '*': /* ** */ + ffelex_token_->type = FFELEX_typePOWER; + ffelex_send_token_ (); + break; + + default: /* * not followed by another *. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCOLON: + switch (c) + { + case ':': /* :: */ + ffelex_token_->type = FFELEX_typeCOLONCOLON; + ffelex_send_token_ (); + break; + + default: /* : not followed by another :. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeSLASH: + switch (c) + { + case '/': /* // */ + ffelex_token_->type = FFELEX_typeCONCAT; + ffelex_send_token_ (); + break; + + case ')': /* /) */ + ffelex_token_->type = FFELEX_typeCLOSE_ARRAY; + ffelex_send_token_ (); + break; + + case '=': /* /= */ + ffelex_token_->type = FFELEX_typeREL_NE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_PAREN: + switch (c) + { + case '/': /* (/ */ + ffelex_token_->type = FFELEX_typeOPEN_ARRAY; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_ANGLE: + switch (c) + { + case '=': /* <= */ + ffelex_token_->type = FFELEX_typeREL_LE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeEQUALS: + switch (c) + { + case '=': /* == */ + ffelex_token_->type = FFELEX_typeREL_EQ; + ffelex_send_token_ (); + break; + + case '>': /* => */ + ffelex_token_->type = FFELEX_typePOINTS; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCLOSE_ANGLE: + switch (c) + { + case '=': /* >= */ + ffelex_token_->type = FFELEX_typeREL_GE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + default: + assert ("Serious error!!" == NULL); + abort (); + break; + } + + c = ffelex_card_image_[++column]; + + parse_next_character: /* :::::::::::::::::::: */ + + if (ffelex_raw_mode_ != 0) + goto parse_raw_character; /* :::::::::::::::::::: */ + + while (c == ' ') + c = ffelex_card_image_[++column]; + + if ((c == '\0') + || (c == '!') + || ((c == '/') + && (ffelex_card_image_[column + 1] == '*'))) + { + if ((ffelex_number_of_tokens_ == ffelex_label_tokens_) + && (ffelex_token_->type == FFELEX_typeNAMES) + && (ffelex_token_->length == 3) + && (ffesrc_strncmp_2c (ffe_case_match (), + ffelex_token_->text, + "END", "end", "End", + 3) + == 0)) + { + ffelex_finish_statement_ (); + disallow_continuation_line = TRUE; + ignore_disallowed_continuation = FALSE; + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + goto beginning_of_line; /* :::::::::::::::::::: */ + } + goto parse_nonraw_character; /* :::::::::::::::::::: */ +} + +/* ffelex_file_free -- Lex a given file in free source form + + ffewhere wf; + FILE *f; + ffelex_file_free(wf,f); + + Lexes the file according to Fortran 90 ANSI + VXT specifications. */ + +ffelexHandler +ffelex_file_free (ffewhereFile wf, FILE *f) +{ + register int c; /* Character currently under consideration. */ + register ffewhereColumnNumber column; /* Not really; 0 means column 1... */ + bool continuation_line; + ffewhereColumnNumber continuation_column; + int latest_char_in_file; /* For getting back into comment-skipping + code. */ + + /* Lex is called for a particular file, not for a particular program unit. + Yet the two events do share common characteristics. The first line in a + file or in a program unit cannot be a continuation line. No token can + be in mid-formation. No current label for the statement exists, since + there is no current statement. */ + + assert (ffelex_handler_ != NULL); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + lineno = 0; + input_filename = ffewhere_file_name (wf); +#endif + ffelex_current_wf_ = wf; + continuation_line = FALSE; + ffelex_token_->type = FFELEX_typeNONE; + ffelex_number_of_tokens_ = 0; + ffelex_current_wl_ = ffewhere_line_unknown (); + ffelex_current_wc_ = ffewhere_column_unknown (); + latest_char_in_file = '\n'; + + /* Come here to get a new line. */ + + beginning_of_line: /* :::::::::::::::::::: */ + + c = latest_char_in_file; + if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF)) + { + + end_of_file: /* :::::::::::::::::::: */ + + /* Line ending in EOF instead of \n still counts as a whole line. */ + + ffelex_finish_statement_ (); + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + return (ffelexHandler) ffelex_handler_; + } + + ffelex_next_line_ (); + + ffelex_bad_line_ = FALSE; + + /* Skip over initial-comment and empty lines as quickly as possible! */ + + while ((c == '\n') + || (c == '!') + || (c == '#')) + { + if (c == '#') + { +#if FFECOM_targetCURRENT == FFECOM_targetGCC + c = ffelex_hash_ (f); +#else + /* Don't skip over # line after all. */ + break; +#endif + } + + comment_line: /* :::::::::::::::::::: */ + + while ((c != '\n') && (c != EOF)) + c = getc (f); + + if (c == EOF) + { + ffelex_next_line_ (); + goto end_of_file; /* :::::::::::::::::::: */ + } + + c = getc (f); + + ffelex_next_line_ (); + + if (c == EOF) + goto end_of_file; /* :::::::::::::::::::: */ + } + + ffelex_saw_tab_ = FALSE; + + column = ffelex_image_char_ (c, 0); + + /* Read the entire line in as is (with whitespace processing). */ + + while (((c = getc (f)) != '\n') && (c != EOF)) + column = ffelex_image_char_ (c, column); + + if (ffelex_bad_line_) + { + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + goto comment_line; /* :::::::::::::::::::: */ + } + + /* If no tab, cut off line after column 132. */ + + if (!ffelex_saw_tab_ && (column > FFELEX_FREE_MAX_COLUMNS_)) + column = FFELEX_FREE_MAX_COLUMNS_; + + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + + /* Save next char in file so we can use register-based c while analyzing + line we just read. */ + + latest_char_in_file = c; /* Should be either '\n' or EOF. */ + + column = 0; + continuation_column = 0; + + /* Skip over initial spaces to see if the first nonblank character + is exclamation point, newline, or EOF (line is therefore a comment) or + ampersand (line is therefore a continuation line). */ + + while ((c = ffelex_card_image_[column]) == ' ') + ++column; + + switch (c) + { + case '!': + case '\0': + goto beginning_of_line; /* :::::::::::::::::::: */ + + case '&': + continuation_column = column + 1; + break; + + default: + break; + } + + /* The line definitely has content of some kind, install new end-statement + point for error messages. */ + + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_); + ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1); + + /* Figure out which column to start parsing at. */ + + if (continuation_line) + { + if (continuation_column == 0) + { + if (ffelex_raw_mode_ != 0) + { + ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE, + ffelex_linecount_current_, column + 1); + } + else if (ffelex_token_->type != FFELEX_typeNONE) + { + ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE, + ffelex_linecount_current_, column + 1); + } + } + else if (ffelex_is_free_char_ctx_contin_ (continuation_column)) + { /* Line contains only a single "&" as only + nonblank character. */ + ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE, + ffelex_linecount_current_, continuation_column); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + column = continuation_column; + } + else + column = 0; + + c = ffelex_card_image_[column]; + continuation_line = FALSE; + + /* Here is the main engine for parsing. c holds the character at column. + It is already known that c is not a blank, end of line, or shriek, + unless ffelex_raw_mode_ is not 0 (indicating we are in a + character/hollerith constant). A partially filled token may already + exist in ffelex_token_. */ + + if (ffelex_raw_mode_ != 0) + { + + parse_raw_character: /* :::::::::::::::::::: */ + + switch (c) + { + case '&': + if (ffelex_is_free_char_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + break; + + case '\0': + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + + default: + break; + } + + switch (ffelex_raw_mode_) + { + case -3: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + ffelex_append_to_token_ (c); + ffelex_raw_mode_ = -1; + break; + + case -2: + if (c == ffelex_raw_char_) + { + ffelex_raw_mode_ = -1; + ffelex_append_to_token_ (c); + } + else + { + ffelex_raw_mode_ = 0; + ffelex_backslash_reconsider_ = TRUE; + } + break; + + case -1: + if (c == ffelex_raw_char_) + ffelex_raw_mode_ = -2; + else + { + c = ffelex_backslash_ (c, column); + if (c == EOF) + { + ffelex_raw_mode_ = -3; + break; + } + + ffelex_append_to_token_ (c); + } + break; + + default: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + { + ffelex_append_to_token_ (c); + --ffelex_raw_mode_; + } + break; + } + + if (ffelex_backslash_reconsider_) + ffelex_backslash_reconsider_ = FALSE; + else + c = ffelex_card_image_[++column]; + + if (ffelex_raw_mode_ == 0) + { + ffelex_send_token_ (); + assert (ffelex_raw_mode_ == 0); + while (c == ' ') + c = ffelex_card_image_[++column]; + if ((c == '\0') || (c == '!')) + { + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + goto parse_nonraw_character_noncontin; /* :::::::::::::::::::: */ + } + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + parse_nonraw_character: /* :::::::::::::::::::: */ + + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + + parse_nonraw_character_noncontin: /* :::::::::::::::::::: */ + + switch (ffelex_token_->type) + { + case FFELEX_typeNONE: + if (c == ' ') + { /* Otherwise + finish-statement/continue-statement + already checked. */ + while (c == ' ') + c = ffelex_card_image_[++column]; + if ((c == '\0') || (c == '!')) + { + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + } + + switch (c) + { + case '\"': + ffelex_token_->type = FFELEX_typeQUOTE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '$': + ffelex_token_->type = FFELEX_typeDOLLAR; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '%': + ffelex_token_->type = FFELEX_typePERCENT; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '&': + ffelex_token_->type = FFELEX_typeAMPERSAND; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '\'': + ffelex_token_->type = FFELEX_typeAPOSTROPHE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '(': + ffelex_token_->type = FFELEX_typeOPEN_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ')': + ffelex_token_->type = FFELEX_typeCLOSE_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '*': + ffelex_token_->type = FFELEX_typeASTERISK; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '+': + ffelex_token_->type = FFELEX_typePLUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case ',': + ffelex_token_->type = FFELEX_typeCOMMA; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '-': + ffelex_token_->type = FFELEX_typeMINUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '.': + ffelex_token_->type = FFELEX_typePERIOD; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '/': + ffelex_token_->type = FFELEX_typeSLASH; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_token_->type + = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_append_to_token_ (c); + break; + + case ':': + ffelex_token_->type = FFELEX_typeCOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ';': + ffelex_token_->type = FFELEX_typeSEMICOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_permit_include_ = TRUE; + ffelex_send_token_ (); + ffelex_permit_include_ = FALSE; + break; + + case '<': + ffelex_token_->type = FFELEX_typeOPEN_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '=': + ffelex_token_->type = FFELEX_typeEQUALS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '>': + ffelex_token_->type = FFELEX_typeCLOSE_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '?': + ffelex_token_->type = FFELEX_typeQUESTION; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '_': + if (1 || ffe_is_90 ()) + { + ffelex_token_->type = FFELEX_typeUNDERSCORE; + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col + = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + } + /* Fall through. */ + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + + if (ffesrc_char_match_init (c, 'H', 'h') + && ffelex_expecting_hollerith_ != 0) + { + ffelex_raw_mode_ = ffelex_expecting_hollerith_; + ffelex_token_->type = FFELEX_typeHOLLERITH; + ffelex_token_->where_line = ffelex_raw_where_line_; + ffelex_token_->where_col = ffelex_raw_where_col_; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + c = ffelex_card_image_[++column]; + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + if (ffelex_names_pure_) + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_token_->currentnames_line + = ffewhere_line_use (ffelex_current_wl_)); + ffelex_token_->where_col + = ffewhere_column_use (ffelex_token_->currentnames_col + = ffewhere_column_new (column + 1)); + ffelex_token_->type = FFELEX_typeNAMES; + } + else + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_token_->type = FFELEX_typeNAME; + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER, + ffelex_linecount_current_, column + 1); + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAME: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAMES: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + if (ffelex_token_->length < FFEWHERE_indexMAX) + { + ffewhere_track (&ffelex_token_->currentnames_line, + &ffelex_token_->currentnames_col, + ffelex_token_->wheretrack, + ffelex_token_->length, + ffelex_linecount_current_, + column + 1); + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNUMBER: + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeASTERISK: + switch (c) + { + case '*': /* ** */ + ffelex_token_->type = FFELEX_typePOWER; + ffelex_send_token_ (); + break; + + default: /* * not followed by another *. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCOLON: + switch (c) + { + case ':': /* :: */ + ffelex_token_->type = FFELEX_typeCOLONCOLON; + ffelex_send_token_ (); + break; + + default: /* : not followed by another :. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeSLASH: + switch (c) + { + case '/': /* // */ + ffelex_token_->type = FFELEX_typeCONCAT; + ffelex_send_token_ (); + break; + + case ')': /* /) */ + ffelex_token_->type = FFELEX_typeCLOSE_ARRAY; + ffelex_send_token_ (); + break; + + case '=': /* /= */ + ffelex_token_->type = FFELEX_typeREL_NE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_PAREN: + switch (c) + { + case '/': /* (/ */ + ffelex_token_->type = FFELEX_typeOPEN_ARRAY; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_ANGLE: + switch (c) + { + case '=': /* <= */ + ffelex_token_->type = FFELEX_typeREL_LE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeEQUALS: + switch (c) + { + case '=': /* == */ + ffelex_token_->type = FFELEX_typeREL_EQ; + ffelex_send_token_ (); + break; + + case '>': /* => */ + ffelex_token_->type = FFELEX_typePOINTS; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCLOSE_ANGLE: + switch (c) + { + case '=': /* >= */ + ffelex_token_->type = FFELEX_typeREL_GE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + default: + assert ("Serious error!" == NULL); + abort (); + break; + } + + c = ffelex_card_image_[++column]; + + parse_next_character: /* :::::::::::::::::::: */ + + if (ffelex_raw_mode_ != 0) + goto parse_raw_character; /* :::::::::::::::::::: */ + + if ((c == '\0') || (c == '!')) + { + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + goto parse_nonraw_character; /* :::::::::::::::::::: */ +} + +/* See the code in com.c that calls this to understand why. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffelex_hash_kludge (FILE *finput) +{ + /* If you change this constant string, you have to change whatever + code might thus be affected by it in terms of having to use + ffelex_getc_() instead of getc() in the lexers and _hash_. */ + static char match[] = "# 1 \""; + static int kludge[ARRAY_SIZE (match) + 1]; + int c; + char *p; + int *q; + + /* Read chars as long as they match the target string. + Copy them into an array that will serve as a record + of what we read (essentially a multi-char ungetc(), + for code that uses ffelex_getc_ instead of getc() elsewhere + in the lexer. */ + for (p = &match[0], q = &kludge[0], c = getc (finput); + (c == *p) && (*p != '\0') && (c != EOF); + ++p, ++q, c = getc (finput)) + *q = c; + + *q = c; /* Might be EOF, which requires int. */ + *++q = 0; + + ffelex_kludge_chars_ = &kludge[0]; + + if (*p == 0) + { + ffelex_kludge_flag_ = TRUE; + ++ffelex_kludge_chars_; + ffelex_hash_ (finput); /* Handle it NOW rather than later. */ + ffelex_kludge_flag_ = FALSE; + } +} + +#endif +void +ffelex_init_1 () +{ + unsigned int i; + + ffelex_final_nontab_column_ = ffe_fixed_line_length (); + ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_; + ffelex_card_image_ = malloc_new_ksr (malloc_pool_image (), + "FFELEX card image", + FFELEX_columnINITIAL_SIZE_ + 9); + ffelex_card_image_[0] = '\0'; + + for (i = 0; i < 256; ++i) + ffelex_first_char_[i] = FFELEX_typeERROR; + + ffelex_first_char_['\t'] = FFELEX_typeRAW; + ffelex_first_char_['\n'] = FFELEX_typeCOMMENT; + ffelex_first_char_['\v'] = FFELEX_typeCOMMENT; + ffelex_first_char_['\f'] = FFELEX_typeCOMMENT; + ffelex_first_char_['\r'] = FFELEX_typeRAW; + ffelex_first_char_[' '] = FFELEX_typeRAW; + ffelex_first_char_['!'] = FFELEX_typeCOMMENT; + ffelex_first_char_['*'] = FFELEX_typeCOMMENT; + ffelex_first_char_['/'] = FFELEX_typeSLASH; + ffelex_first_char_['&'] = FFELEX_typeRAW; + ffelex_first_char_['#'] = FFELEX_typeHASH; + + for (i = '0'; i <= '9'; ++i) + ffelex_first_char_[i] = FFELEX_typeRAW; + + if ((ffe_case_match () == FFE_caseNONE) + || ((ffe_case_match () == FFE_caseUPPER) + && (ffe_case_source () != FFE_caseLOWER)) /* Idiot! :-) */ + || ((ffe_case_match () == FFE_caseLOWER) + && (ffe_case_source () == FFE_caseLOWER))) + { + ffelex_first_char_['C'] = FFELEX_typeCOMMENT; + ffelex_first_char_['D'] = FFELEX_typeCOMMENT; + } + if ((ffe_case_match () == FFE_caseNONE) + || ((ffe_case_match () == FFE_caseLOWER) + && (ffe_case_source () != FFE_caseUPPER)) /* Idiot! :-) */ + || ((ffe_case_match () == FFE_caseUPPER) + && (ffe_case_source () == FFE_caseUPPER))) + { + ffelex_first_char_['c'] = FFELEX_typeCOMMENT; + ffelex_first_char_['d'] = FFELEX_typeCOMMENT; + } + + ffelex_linecount_current_ = 0; + ffelex_linecount_next_ = 1; + ffelex_raw_mode_ = 0; + ffelex_set_include_ = FALSE; + ffelex_permit_include_ = FALSE; + ffelex_names_ = TRUE; /* First token in program is a names. */ + ffelex_names_pure_ = FALSE; /* Free-form lexer does NAMES only for + FORMAT. */ + ffelex_hexnum_ = FALSE; + ffelex_expecting_hollerith_ = 0; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + + ffelex_token_ = ffelex_token_new_ (); + ffelex_token_->type = FFELEX_typeNONE; + ffelex_token_->uses = 1; + ffelex_token_->where_line = ffewhere_line_unknown (); + ffelex_token_->where_col = ffewhere_column_unknown (); + ffelex_token_->text = NULL; + + ffelex_handler_ = NULL; +} + +/* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME? + + if (ffelex_is_names_expected()) + // Deliver NAMES token + else + // Deliver NAME token + + Must be called while lexer is active, obviously. */ + +bool +ffelex_is_names_expected () +{ + return ffelex_names_; +} + +/* Current card image, which has the master linecount number + ffelex_linecount_current_. */ + +char * +ffelex_line () +{ + return ffelex_card_image_; +} + +/* ffelex_line_length -- Return length of current lexer line + + printf("Length is %lu\n",ffelex_line_length()); + + Must be called while lexer is active, obviously. */ + +ffewhereColumnNumber +ffelex_line_length () +{ + return ffelex_card_length_; +} + +/* Master line count of current card image, or 0 if no card image + is current. */ + +ffewhereLineNumber +ffelex_line_number () +{ + return ffelex_linecount_current_; +} + +/* ffelex_set_expecting_hollerith -- Set hollerith expectation status + + ffelex_set_expecting_hollerith(0); + + Lex initially assumes no hollerith constant is about to show up. If + syntactic analysis expects one, it should call this function with the + number of characters expected in the constant immediately after recognizing + the decimal number preceding the "H" and the constant itself. Then, if + the next character is indeed H, the lexer will interpret it as beginning + a hollerith constant and ship the token formed by reading the specified + number of characters (interpreting blanks and otherwise-comments too) + from the input file. It is up to syntactic analysis to call this routine + again with 0 to turn hollerith detection off immediately upon receiving + the token that might or might not be HOLLERITH. + + Also call this after seeing an APOSTROPHE or QUOTE token that begins a + character constant. Pass the expected termination character (apostrophe + or quote). + + Pass for length either the length of the hollerith (must be > 0), -1 + meaning expecting a character constant, or 0 to cancel expectation of + a hollerith only after calling it with a length of > 0 and receiving the + next token (which may or may not have been a HOLLERITH token). + + Pass for which either an apostrophe or quote when passing length of -1. + Else which is a don't-care. + + Pass for line and column the line/column info for the token beginning the + character or hollerith constant, for use in error messages, when passing + a length of -1 -- this function will invoke ffewhere_line/column_use to + make its own copies. Else line and column are don't-cares (when length + is 0) and the outstanding copies of the previous line/column info, if + still around, are killed. + + 21-Feb-90 JCB 3.1 + When called with length of 0, also zero ffelex_raw_mode_. This is + so ffest_save_ can undo the effects of replaying tokens like + APOSTROPHE and QUOTE. + 25-Jan-90 JCB 3.0 + New line, column arguments allow error messages to point to the true + beginning of a character/hollerith constant, rather than the beginning + of the content part, which makes them more consistent and helpful. + 05-Nov-89 JCB 2.0 + New "which" argument allows caller to specify termination character, + which should be apostrophe or double-quote, to support Fortran 90. */ + +void +ffelex_set_expecting_hollerith (long length, char which, + ffewhereLine line, ffewhereColumn column) +{ + + /* First kill the pending line/col info, if any (should only be pending + when this call has length==0, the previous call had length>0, and a + non-HOLLERITH token was sent in between the calls, but play it safe). */ + + ffewhere_line_kill (ffelex_raw_where_line_); + ffewhere_column_kill (ffelex_raw_where_col_); + + /* Now handle the length function. */ + switch (length) + { + case 0: + ffelex_expecting_hollerith_ = 0; + ffelex_raw_mode_ = 0; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + return; /* Don't set new line/column info from args. */ + + case -1: + ffelex_raw_mode_ = -1; + ffelex_raw_char_ = which; + break; + + default: /* length > 0 */ + ffelex_expecting_hollerith_ = length; + break; + } + + /* Now set new line/column information from passed args. */ + + ffelex_raw_where_line_ = ffewhere_line_use (line); + ffelex_raw_where_col_ = ffewhere_column_use (column); +} + +/* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free + + ffelex_set_handler((ffelexHandler) my_first_handler); + + Must be called before calling ffelex_file_fixed or ffelex_file_free or + after they return, but not while they are active. */ + +void +ffelex_set_handler (ffelexHandler first) +{ + ffelex_handler_ = first; +} + +/* ffelex_set_hexnum -- Set hexnum flag + + ffelex_set_hexnum(TRUE); + + Lex normally interprets a token starting with [0-9] as a NUMBER token, + so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves + the character as the first of the next token. But when parsing a + hexadecimal number, by calling this function with TRUE before starting + the parse of the token itself, lex will interpret [0-9] as the start + of a NAME token. */ + +void +ffelex_set_hexnum (bool f) +{ + ffelex_hexnum_ = f; +} + +/* ffelex_set_include -- Set INCLUDE file to be processed next + + ffewhereFile wf; // The ffewhereFile object for the file. + bool free_form; // TRUE means read free-form file, FALSE fixed-form. + FILE *fi; // The file to INCLUDE. + ffelex_set_include(wf,free_form,fi); + + Must be called only after receiving the EOS token following a valid + INCLUDE statement specifying a file that has already been successfully + opened. */ + +void +ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi) +{ + assert (ffelex_permit_include_); + assert (!ffelex_set_include_); + ffelex_set_include_ = TRUE; + ffelex_include_free_form_ = free_form; + ffelex_include_file_ = fi; + ffelex_include_wherefile_ = wf; +} + +/* ffelex_set_names -- Set names/name flag, names = TRUE + + ffelex_set_names(FALSE); + + Lex initially assumes multiple names should be formed. If this function is + called with FALSE, then single names are formed instead. The differences + are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME) + and in whether full source-location tracking is performed (it is for + multiple names, not for single names), which is more expensive in terms of + CPU time. */ + +void +ffelex_set_names (bool f) +{ + ffelex_names_ = f; + if (!f) + ffelex_names_pure_ = FALSE; +} + +/* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE + + ffelex_set_names_pure(FALSE); + + Like ffelex_set_names, except affects both lexers. Normally, the + free-form lexer need not generate NAMES tokens because adjacent NAME + tokens must be separated by spaces which causes the lexer to generate + separate tokens for analysis (whereas in fixed-form the spaces are + ignored resulting in one long token). But in FORMAT statements, for + some reason, the Fortran 90 standard specifies that spaces can occur + anywhere within a format-item-list with no effect on the format spec + (except of course within character string edit descriptors), which means + that "1PE14.2" and "1 P E 1 4 . 2" are equivalent. For the FORMAT + statement handling, the existence of spaces makes it hard to deal with, + because each token is seen distinctly (i.e. seven tokens in the latter + example). But when no spaces are provided, as in the former example, + then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD, + NUMBER ("2"). By generating a NAMES instead of NAME, three things happen: + One, ffest_kw_format_ does a substring rather than full-string match, + and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions + may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token; + and three, error reporting can point to the actual character rather than + at or prior to it. The first two things could be resolved by providing + alternate functions fairly easy, thus allowing FORMAT handling to expect + both lexers to generate NAME tokens instead of NAMES (with otherwise minor + changes to FORMAT parsing), but the third, error reporting, would suffer, + and when one makes mistakes in a FORMAT, believe me, one wants a pointer + to exactly where the compilers thinks the problem is, to even begin to get + a handle on it. So there. */ + +void +ffelex_set_names_pure (bool f) +{ + ffelex_names_pure_ = f; + ffelex_names_ = f; +} + +/* ffelex_splice_tokens -- Splice off and send tokens from a NAMES + + return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token, + start_char_index); + + Returns first_handler if start_char_index chars into master_token (which + must be a NAMES token) is '\0'. Else, creates a subtoken from that + char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar), + an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign) + and sends it to first_handler. If anything other than NAME is sent, the + character at the end of it in the master token is examined to see if it + begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so, + the handler returned by first_handler is invoked with that token, and + this process is repeated until the end of the master token or a NAME + token is reached. */ + +ffelexHandler +ffelex_splice_tokens (ffelexHandler first, ffelexToken master, + ffeTokenLength start) +{ + char *p; + ffeTokenLength i; + ffelexToken t; + + p = ffelex_token_text (master) + (i = start); + + while (*p != '\0') + { + if (isdigit (*p)) + { + t = ffelex_token_number_from_names (master, i); + p += ffelex_token_length (t); + i += ffelex_token_length (t); + } + else if (ffesrc_is_name_init (*p)) + { + t = ffelex_token_name_from_names (master, i, 0); + p += ffelex_token_length (t); + i += ffelex_token_length (t); + } + else if (*p == '$') + { + t = ffelex_token_dollar_from_names (master, i); + ++p; + ++i; + } + else if (*p == '_') + { + t = ffelex_token_uscore_from_names (master, i); + ++p; + ++i; + } + else + { + assert ("not a valid NAMES character" == NULL); + t = NULL; + } + assert (first != NULL); + first = (ffelexHandler) (*first) (t); + ffelex_token_kill (t); + } + + return first; +} + +/* ffelex_swallow_tokens -- Eat all tokens delivered to me + + return ffelex_swallow_tokens; + + Return this handler when you don't want to look at any more tokens in the + statement because you've encountered an unrecoverable error in the + statement. */ + +ffelexHandler +ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler) +{ + assert (handler != NULL); + + if ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeEOS) + || (ffelex_token_type (t) == FFELEX_typeSEMICOLON))) + return (ffelexHandler) (*handler) (t); + + ffelex_eos_handler_ = handler; + return (ffelexHandler) ffelex_swallow_tokens_; +} + +/* ffelex_token_dollar_from_names -- Return a dollar from within a names token + + ffelexToken t; + t = ffelex_token_dollar_from_names(t,6); + + It's as if you made a new token of dollar type having the dollar + at, in the example above, the sixth character of the NAMES token. */ + +ffelexToken +ffelex_token_dollar_from_names (ffelexToken t, ffeTokenLength start) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + assert (t->text[start] == '$'); + + /* Now make the token. */ + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeDOLLAR; + nt->length = 0; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = NULL; + return nt; +} + +/* ffelex_token_kill -- Decrement use count for token, kill if no uses left + + ffelexToken t; + ffelex_token_kill(t); + + Complements a call to ffelex_token_use or ffelex_token_new_.... */ + +void +ffelex_token_kill (ffelexToken t) +{ + assert (t != NULL); + + assert (t->uses > 0); + + if (--t->uses != 0) + return; + + --ffelex_total_tokens_; + + if (t->type == FFELEX_typeNAMES) + ffewhere_track_kill (t->where_line, t->where_col, + t->wheretrack, t->length); + ffewhere_line_kill (t->where_line); + ffewhere_column_kill (t->where_col); + if (t->text != NULL) + malloc_kill_ksr (malloc_pool_image (), t->text, t->size + 1); + malloc_kill_ks (malloc_pool_image (), t, sizeof (*t)); +} + +/* Make a new NAME token that is a substring of a NAMES token. */ + +ffelexToken +ffelex_token_name_from_names (ffelexToken t, ffeTokenLength start, + ffeTokenLength len) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + if (len == 0) + len = t->length - start; + else + { + assert (len > 0); + assert ((start + len) <= t->length); + } + assert (ffelex_is_firstnamechar (t->text[start])); + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeNAME; + nt->size = len; /* Assume nobody's gonna fiddle with token + text. */ + nt->length = len; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (nt->text, t->text + start, len); + nt->text[len] = '\0'; + return nt; +} + +/* Make a new NAMES token that is a substring of another NAMES token. */ + +ffelexToken +ffelex_token_names_from_names (ffelexToken t, ffeTokenLength start, + ffeTokenLength len) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + if (len == 0) + len = t->length - start; + else + { + assert (len > 0); + assert ((start + len) <= t->length); + } + assert (ffelex_is_firstnamechar (t->text[start])); + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeNAMES; + nt->size = len; /* Assume nobody's gonna fiddle with token + text. */ + nt->length = len; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + ffewhere_track_copy (nt->wheretrack, t->wheretrack, start, len); + nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (nt->text, t->text + start, len); + nt->text[len] = '\0'; + return nt; +} + +/* Make a new CHARACTER token. */ + +ffelexToken +ffelex_token_new_character (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + t = ffelex_token_new_ (); + t->type = FFELEX_typeCHARACTER; + t->length = t->size = strlen (s); /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + t->size + 1); + strcpy (t->text, s); + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new EOF token right after end of file. */ + +ffelexToken +ffelex_token_new_eof () +{ + ffelexToken t; + + t = ffelex_token_new_ (); + t->type = FFELEX_typeEOF; + t->uses = 1; + t->text = NULL; + t->where_line = ffewhere_line_new (ffelex_linecount_current_); + t->where_col = ffewhere_column_new (1); + return t; +} + +/* Make a new NAME token. */ + +ffelexToken +ffelex_token_new_name (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + assert (ffelex_is_firstnamechar (*s)); + + t = ffelex_token_new_ (); + t->type = FFELEX_typeNAME; + t->length = t->size = strlen (s); /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + t->size + 1); + strcpy (t->text, s); + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new NAMES token. */ + +ffelexToken +ffelex_token_new_names (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + assert (ffelex_is_firstnamechar (*s)); + + t = ffelex_token_new_ (); + t->type = FFELEX_typeNAMES; + t->length = t->size = strlen (s); /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + t->size + 1); + strcpy (t->text, s); + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + ffewhere_track_clear (t->wheretrack, t->length); /* Assume contiguous + names. */ + return t; +} + +/* Make a new NUMBER token. + + The first character of the string must be a digit, and only the digits + are copied into the new number. So this may be used to easily extract + a NUMBER token from within any text string. Then the length of the + resulting token may be used to calculate where the digits stopped + in the original string. */ + +ffelexToken +ffelex_token_new_number (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + ffeTokenLength len; + + /* How long is the string of decimal digits at s? */ + + len = strspn (s, "0123456789"); + + /* Make sure there is at least one digit. */ + + assert (len != 0); + + /* Now make the token. */ + + t = ffelex_token_new_ (); + t->type = FFELEX_typeNUMBER; + t->length = t->size = len; /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (t->text, s, len); + t->text[len] = '\0'; + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new token of any type that doesn't contain text. A private + function that is used by public macros in the interface file. */ + +ffelexToken +ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + t = ffelex_token_new_ (); + t->type = type; + t->uses = 1; + t->text = NULL; + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new NUMBER token from an existing NAMES token. + + Like ffelex_token_new_number, this function calculates the length + of the digit string itself. */ + +ffelexToken +ffelex_token_number_from_names (ffelexToken t, ffeTokenLength start) +{ + ffelexToken nt; + ffeTokenLength len; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + + /* How long is the string of decimal digits at s? */ + + len = strspn (t->text + start, "0123456789"); + + /* Make sure there is at least one digit. */ + + assert (len != 0); + + /* Now make the token. */ + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeNUMBER; + nt->size = len; /* Assume nobody's gonna fiddle with token + text. */ + nt->length = len; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (nt->text, t->text + start, len); + nt->text[len] = '\0'; + return nt; +} + +/* Make a new UNDERSCORE token from a NAMES token. */ + +ffelexToken +ffelex_token_uscore_from_names (ffelexToken t, ffeTokenLength start) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + assert (t->text[start] == '_'); + + /* Now make the token. */ + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeUNDERSCORE; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = NULL; + return nt; +} + +/* ffelex_token_use -- Return another instance of a token + + ffelexToken t; + t = ffelex_token_use(t); + + In a sense, the new token is a copy of the old, though it might be the + same with just a new use count. + + We use the use count method (easy). */ + +ffelexToken +ffelex_token_use (ffelexToken t) +{ + if (t == NULL) + assert ("_token_use: null token" == NULL); + t->uses++; + return t; +} |