diff options
Diffstat (limited to 'gnu/usr.bin/gcc/f/sta.c')
| -rw-r--r-- | gnu/usr.bin/gcc/f/sta.c | 1815 |
1 files changed, 1815 insertions, 0 deletions
diff --git a/gnu/usr.bin/gcc/f/sta.c b/gnu/usr.bin/gcc/f/sta.c new file mode 100644 index 00000000000..79073f205f4 --- /dev/null +++ b/gnu/usr.bin/gcc/f/sta.c @@ -0,0 +1,1815 @@ +/* sta.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 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. + + Related Modules: + None + + Description: + Analyzes the first two tokens, figures out what statements are + possible, tries parsing the possible statements by calling on + the ffestb functions. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "sta.h" +#include "bad.h" +#include "implic.h" +#include "lex.h" +#include "malloc.h" +#include "stb.h" +#include "stc.h" +#include "std.h" +#include "str.h" +#include "storag.h" +#include "symbol.h" + +/* Externals defined here. */ + +ffelexToken ffesta_tokens[FFESTA_tokensMAX]; /* For use by a possible. */ +ffestrFirst ffesta_first_kw; /* First NAME(S) looked up. */ +ffestrSecond ffesta_second_kw; /* Second NAME(S) looked up. */ +mallocPool ffesta_output_pool; /* Pool for results of stmt handling. */ +mallocPool ffesta_scratch_pool; /* Pool for stmt scratch handling. */ +ffelexToken ffesta_construct_name; +ffelexToken ffesta_label_token; /* Pending label stuff. */ +bool ffesta_seen_first_exec; +bool ffesta_is_entry_valid = FALSE; /* TRUE only in SUBROUTINE/FUNCTION. */ +bool ffesta_line_has_semicolons = FALSE; + +/* Simple definitions and enumerations. */ + +#define FFESTA_ABORT_ON_CONFIRM_ 1 /* 0=slow, tested way; 1=faster way + that might not always work. Here's + the old description of what used + to not work with ==1: (try + "CONTINUE\10 + FORMAT('hi',I11)\END"). Problem + is that the "topology" of the + confirmed stmt's tokens with + regard to CHARACTER, HOLLERITH, + NAME/NAMES/NUMBER tokens (like hex + numbers), isn't traced if we abort + early, then other stmts might get + their grubby hands on those + unprocessed tokens and commit them + improperly. Ideal fix is to rerun + the confirmed stmt and forget the + rest. */ + +#define FFESTA_maxPOSSIBLES_ 100/* Never more than this # of possibles. */ + +/* Internal typedefs. */ + +typedef struct _ffesta_possible_ *ffestaPossible_; + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffesta_possible_ + { + ffestaPossible_ next; + ffestaPossible_ previous; + ffelexHandler handler; + }; + +struct _ffesta_possible_root_ + { + ffestaPossible_ first; + ffestaPossible_ last; + ffelexHandler nil; + }; + +/* Static objects accessed by functions in this module. */ + +static bool ffesta_is_inhibited_ = FALSE; +static ffelexToken ffesta_token_0_; /* For use by ffest possibility + handling. */ +static ffestaPossible_ ffesta_possibles_[FFESTA_maxPOSSIBLES_]; +static int ffesta_num_possibles_ = 0; /* Next possibility to use. */ +static struct _ffesta_possible_root_ ffesta_possible_nonexecs_; +static struct _ffesta_possible_root_ ffesta_possible_execs_; +static ffestaPossible_ ffesta_current_possible_; +static ffelexHandler ffesta_current_handler_; +static bool ffesta_confirmed_current_ = FALSE; +static bool ffesta_confirmed_other_ = FALSE; +static ffestaPossible_ ffesta_confirmed_possible_; +static bool ffesta_current_shutdown_ = FALSE; +#if !FFESTA_ABORT_ON_CONFIRM_ +static bool ffesta_is_two_into_statement_ = FALSE; /* For IF, WHERE stmts. */ +static ffelexToken ffesta_twotokens_1_; /* For IF, WHERE stmts. */ +static ffelexToken ffesta_twotokens_2_; /* For IF, WHERE stmts. */ +#endif +static ffestaPooldisp ffesta_outpooldisp_; /* After statement dealt + with. */ +static bool ffesta_inhibit_confirmation_ = FALSE; + +/* Static functions (internal). */ + +static void ffesta_add_possible_exec_ (ffelexHandler fn); +static void ffesta_add_possible_nonexec_ (ffelexHandler fn); +static bool ffesta_inhibited_exec_transition_ (void); +static void ffesta_reset_possibles_ (void); +static ffelexHandler ffesta_save_ (ffelexToken t); +static ffelexHandler ffesta_second_ (ffelexToken t); +#if !FFESTA_ABORT_ON_CONFIRM_ +static ffelexHandler ffesta_send_two_ (ffelexToken t); +#endif + +/* Internal macros. */ + + +/* ffesta_add_possible_exec_ -- Add possible executable statement to list + + ffelexHandler ffestb_some_executable_stmt_handler_; + ffesta_add_possible_exec_(ffestb_some_executable_stmt_handler_); + + Adds a possible statement to the list of executable statements, with the + specified statement handler as the recipient of the first token in the + statement. */ + +static void +ffesta_add_possible_exec_ (ffelexHandler fn) +{ + ffestaPossible_ p; + + assert (ffesta_num_possibles_ < FFESTA_maxPOSSIBLES_); + + p = ffesta_possibles_[ffesta_num_possibles_++]; + + p->next = (ffestaPossible_) &ffesta_possible_execs_.first; + p->previous = ffesta_possible_execs_.last; + p->next->previous = p; + p->previous->next = p; + + p->handler = fn; +} + +/* ffesta_add_possible_nonexec_ -- Add possible nonexecutable statement to list + + ffelexHandler ffestb_some_nonexecutable_stmt_handler_; + ffesta_add_possible_nonexec_(ffestb_some_nonexecutable_stmt_handler_); + + Adds a possible statement to the list of nonexecutable statements, with the + specified statement handler as the recipient of the first token in the + statement. */ + +static void +ffesta_add_possible_nonexec_ (ffelexHandler fn) +{ + ffestaPossible_ p; + + assert (ffesta_num_possibles_ < FFESTA_maxPOSSIBLES_); + + p = ffesta_possibles_[ffesta_num_possibles_++]; + + p->next = (ffestaPossible_) &ffesta_possible_nonexecs_.first; + p->previous = ffesta_possible_nonexecs_.last; + p->next->previous = p; + p->previous->next = p; + + p->handler = fn; +} + +/* ffesta_inhibited_exec_transition_ -- Do exec transition while inhibited + + if (!ffesta_inhibited_exec_transition_()) // couldn't transition... + + Invokes ffestc_exec_transition, but first enables ffebad and ffesta and + afterwards disables them again. Then returns the result of the + invocation of ffestc_exec_transition. */ + +static bool +ffesta_inhibited_exec_transition_ () +{ + bool result; + + assert (ffebad_inhibit ()); + assert (ffesta_is_inhibited_); + + ffebad_set_inhibit (FALSE); + ffesta_is_inhibited_ = FALSE; + + result = ffestc_exec_transition (); + + ffebad_set_inhibit (TRUE); + ffesta_is_inhibited_ = TRUE; + + return result; +} + +/* ffesta_reset_possibles_ -- Reset (clear) lists of possible statements + + ffesta_reset_possibles_(); + + Clears the lists of executable and nonexecutable statements. */ + +static void +ffesta_reset_possibles_ () +{ + ffesta_num_possibles_ = 0; + + ffesta_possible_execs_.first = ffesta_possible_execs_.last + = (ffestaPossible_) &ffesta_possible_execs_.first; + ffesta_possible_nonexecs_.first = ffesta_possible_nonexecs_.last + = (ffestaPossible_) &ffesta_possible_nonexecs_.first; +} + +/* ffesta_save_ -- Save token on list, pass thru to current handler + + return ffesta_save_; // to lexer. + + Receives a token from the lexer. Saves it in the list of tokens. Calls + the current handler with the token. + + If no shutdown error occurred (via + ffest_ffebad_start), then if the token was EOS or SEMICOLON, mark the + current possible as successful and confirmed but try the next possible + anyway until ambiguities in the form handling are ironed out. */ + +static ffelexHandler +ffesta_save_ (ffelexToken t) +{ + static ffelexToken *saved_tokens = NULL; /* A variable-sized array. */ + static unsigned int num_saved_tokens = 0; /* Number currently saved. */ + static unsigned int max_saved_tokens = 0; /* Maximum to be saved. */ + unsigned int toknum; /* Index into saved_tokens array. */ + ffelexToken eos; /* EOS created on-the-fly for shutdown + purposes. */ + ffelexToken t2; /* Another temporary token (no intersect with + eos, btw). */ + + /* Save the current token. */ + + if (saved_tokens == NULL) + { + saved_tokens + = (ffelexToken *) malloc_new_ksr (malloc_pool_image (), + "FFEST Saved Tokens", + (max_saved_tokens = 8) * sizeof (ffelexToken)); + /* Start off with 8. */ + } + else if (num_saved_tokens >= max_saved_tokens) + { + toknum = max_saved_tokens; + max_saved_tokens <<= 1; /* Multiply by two. */ + assert (max_saved_tokens > toknum); + saved_tokens + = (ffelexToken *) malloc_resize_ksr (malloc_pool_image (), + saved_tokens, + max_saved_tokens * sizeof (ffelexToken), + toknum * sizeof (ffelexToken)); + } + + *(saved_tokens + num_saved_tokens++) = ffelex_token_use (t); + + /* Transmit the current token to the current handler. */ + + ffesta_current_handler_ = (ffelexHandler) (*ffesta_current_handler_) (t); + + /* See if this possible has been shut down, or confirmed in which case we + might as well shut it down anyway to save time. */ + + if ((ffesta_current_shutdown_ || (FFESTA_ABORT_ON_CONFIRM_ + && ffesta_confirmed_current_)) + && !ffelex_expecting_character ()) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + eos = ffelex_token_new_eos (ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffesta_inhibit_confirmation_ = ffesta_current_shutdown_; + (*ffesta_current_handler_) (eos); + ffesta_inhibit_confirmation_ = FALSE; + ffelex_token_kill (eos); + break; + } + } + else + { + + /* If this is an EOS or SEMICOLON token, switch to next handler, else + return self as next handler for lexer. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + return (ffelexHandler) ffesta_save_; + } + } + + next_handler: /* :::::::::::::::::::: */ + + /* Note that a shutdown also happens after seeing the first two tokens + after "IF (expr)" or "WHERE (expr)" where a statement follows, even + though there is no error. This causes the IF or WHERE form to be + implemented first before ffest_first is called for the first token in + the following statement. */ + + if (ffesta_current_shutdown_) + ffesta_current_shutdown_ = FALSE; /* Only after sending EOS! */ + else + assert (ffesta_confirmed_current_); + + if (ffesta_confirmed_current_) + { + ffesta_confirmed_current_ = FALSE; + ffesta_confirmed_other_ = TRUE; + } + + /* Pick next handler. */ + + ffesta_current_possible_ = ffesta_current_possible_->next; + ffesta_current_handler_ = ffesta_current_possible_->handler; + if (ffesta_current_handler_ == NULL) + { /* No handler in this list, try exec list if + not tried yet. */ + if (ffesta_current_possible_ + == (ffestaPossible_) &ffesta_possible_nonexecs_) + { + ffesta_current_possible_ = ffesta_possible_execs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + } + if ((ffesta_current_handler_ == NULL) + || (!ffesta_seen_first_exec + && ((ffesta_confirmed_possible_ != NULL) + || !ffesta_inhibited_exec_transition_ ()))) + /* Don't run execs if: (decoding the "if" ^^^ up here ^^^) - we + have no exec handler available, or - we haven't seen the first + executable statement yet, and - we've confirmed a nonexec + (otherwise even a nonexec would cause a transition), or - a + nonexec-to-exec transition can't be made at the statement context + level (as in an executable statement in the middle of a STRUCTURE + definition); if it can be made, ffestc_exec_transition makes the + corresponding transition at the statement state level so + specification statements are no longer accepted following an + unrecognized statement. (Note: it is valid for f_e_t_ to decide + to always return TRUE by "shrieking" away the statement state + stack until a transitionable state is reached. Or it can leave + the stack as is and return FALSE.) + + If we decide not to run execs, enter this block to rerun the + confirmed statement, if any. */ + { /* At end of both lists! Pick confirmed or + first possible. */ + ffebad_set_inhibit (FALSE); + ffesta_is_inhibited_ = FALSE; + ffesta_confirmed_other_ = FALSE; + ffesta_tokens[0] = ffesta_token_0_; + if (ffesta_confirmed_possible_ == NULL) + { /* No confirmed success, just use first + possible. */ + ffesta_current_possible_ = ffesta_possible_nonexecs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + if (ffesta_current_handler_ == NULL) + { + ffesta_current_possible_ = ffesta_possible_execs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + assert (ffesta_current_handler_ != NULL); + } + } + else + { /* Confirmed success, use it. */ + ffesta_current_possible_ = ffesta_confirmed_possible_; + ffesta_current_handler_ = ffesta_confirmed_possible_->handler; + } + ffesta_reset_possibles_ (); + } + else + { /* Switching from [empty?] list of nonexecs + to nonempty list of execs at this point. */ + ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_); + ffesymbol_set_retractable (ffesta_scratch_pool); + } + } + else + { + ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_); + ffesymbol_set_retractable (ffesta_scratch_pool); + } + + /* Send saved tokens to current handler until either shut down or all + tokens sent. */ + + for (toknum = 0; toknum < num_saved_tokens; ++toknum) + { + t = *(saved_tokens + toknum); + switch (ffelex_token_type (t)) + { + case FFELEX_typeCHARACTER: + ffelex_set_expecting_hollerith (0, '\0', + ffewhere_line_unknown (), + ffewhere_column_unknown ()); + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t); + break; + + case FFELEX_typeNAMES: + if (ffelex_is_names_expected ()) + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t); + else + { + t2 = ffelex_token_name_from_names (t, 0, 0); + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t2); + ffelex_token_kill (t2); + } + break; + + default: + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t); + break; + } + + if (!ffesta_is_inhibited_) + ffelex_token_kill (t); /* Won't need this any more. */ + + /* See if this possible has been shut down. */ + + else if ((ffesta_current_shutdown_ || (FFESTA_ABORT_ON_CONFIRM_ + && ffesta_confirmed_current_)) + && !ffelex_expecting_character ()) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + eos = ffelex_token_new_eos (ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffesta_inhibit_confirmation_ = ffesta_current_shutdown_; + (*ffesta_current_handler_) (eos); + ffesta_inhibit_confirmation_ = FALSE; + ffelex_token_kill (eos); + break; + } + goto next_handler; /* :::::::::::::::::::: */ + } + } + + /* Finished sending all the tokens so far. If still trying possibilities, + then if we've just sent an EOS or SEMICOLON token through, go to the + next handler. Otherwise, return self so we can gather and process more + tokens. */ + + if (ffesta_is_inhibited_) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + goto next_handler; /* :::::::::::::::::::: */ + + default: +#if FFESTA_ABORT_ON_CONFIRM_ + assert (!ffesta_confirmed_other_); /* Catch ambiguities. */ +#endif + return (ffelexHandler) ffesta_save_; + } + } + + /* This was the one final possibility, uninhibited, so send the final + handler it sent. */ + + num_saved_tokens = 0; +#if !FFESTA_ABORT_ON_CONFIRM_ + if (ffesta_is_two_into_statement_) + { /* End of the line for the previous two + tokens, resurrect them. */ + ffelexHandler next; + + ffesta_is_two_into_statement_ = FALSE; + next = (ffelexHandler) ffesta_first (ffesta_twotokens_1_); + ffelex_token_kill (ffesta_twotokens_1_); + next = (ffelexHandler) (*next) (ffesta_twotokens_2_); + ffelex_token_kill (ffesta_twotokens_2_); + return (ffelexHandler) next; + } +#endif + + assert (ffesta_current_handler_ != NULL); + return (ffelexHandler) ffesta_current_handler_; +} + +/* ffesta_second_ -- Parse the token after a NAME/NAMES in a statement + + return ffesta_second_; // to lexer. + + The second token cannot be a NAMES, since the first token is a NAME or + NAMES. If the second token is a NAME, look up its name in the list of + second names for use by whoever needs it. + + Then make a list of all the possible statements this could be, based on + looking at the first two tokens. Two lists of possible statements are + created, one consisting of nonexecutable statements, the other consisting + of executable statements. + + If the total number of possibilities is one, just fire up that + possibility by calling its handler function, passing the first two + tokens through it and so on. + + Otherwise, start up a process whereby tokens are passed to the first + possibility on the list until EOS or SEMICOLON is reached or an error + is detected. But inhibit any actual reporting of errors; just record + their existence in the list. If EOS or SEMICOLON is reached with no + errors (other than non-form errors happening downstream, such as an + overflowing value for an integer or a GOTO statement identifying a label + on a FORMAT statement), then that is the only possible statement. Rerun + the statement with error-reporting turned on if any non-form errors were + generated, otherwise just use its results, then erase the list of tokens + memorized during the search process. If a form error occurs, immediately + cancel that possibility by sending EOS as the next token, remember the + error code for that possibility, and try the next possibility on the list, + first sending it the list of tokens memorized while handling the first + possibility, then continuing on as before. + + Ultimately, either the end of the list of possibilities will be reached + without any successful forms being detected, in which case we pick one + based on hueristics (usually the first possibility) and rerun it with + error reporting turned on using the list of memorized tokens so the user + sees the error, or one of the possibilities will effectively succeed. */ + +static ffelexHandler +ffesta_second_ (ffelexToken t) +{ + ffelexHandler next; + bool include_only = FALSE; /* Initially valid INCLUDE form when TRUE. */ + ffesymbol s; + + assert (ffelex_token_type (t) != FFELEX_typeNAMES); + + if (ffelex_token_type (t) == FFELEX_typeNAME) + ffesta_second_kw = ffestr_second (t); + + /* Here we use switch on the first keyword name and handle each possible + recognizable name by looking at the second token, and building the list + of possible names accordingly. For now, just put every possible + statement on the list for ambiguity checking. */ + + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstALLOCATABLE: + ffestb_args.dimlist.len = FFESTR_firstlALLOCATABLE; + ffestb_args.dimlist.badname = "ALLOCATABLE"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstALLOCATE: + ffestb_args.heap.len = FFESTR_firstlALLOCATE; + ffestb_args.heap.badname = "ALLOCATE"; + ffestb_args.heap.ctx = FFEEXPR_contextALLOCATE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_heap); + break; +#endif + + case FFESTR_firstBACKSPACE: + ffestb_args.beru.len = FFESTR_firstlBACKSPACE; + ffestb_args.beru.badname = "BACKSPACE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; + + case FFESTR_firstCMPLX: + ffestb_args.decl.len = FFESTR_firstlCMPLX; + ffestb_args.decl.type = FFESTP_typeCOMPLEX; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_F90 + case FFESTR_firstDEALLOCATE: + ffestb_args.heap.len = FFESTR_firstlDEALLOCATE; + ffestb_args.heap.badname = "DEALLOCATE"; + ffestb_args.heap.ctx = FFEEXPR_contextDEALLOCATE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_heap); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstDECODE: + ffestb_args.vxtcode.len = FFESTR_firstlDECODE; + ffestb_args.vxtcode.badname = "DECODE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_vxtcode); + break; +#endif + + case FFESTR_firstDIMENSION: + ffestb_args.R524.len = FFESTR_firstlDIMENSION; + ffestb_args.R524.badname = "DIMENSION"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R524); + break; + + case FFESTR_firstDBLCMPLX: + ffestb_args.decl.len = FFESTR_firstlDBLCMPLX; + ffestb_args.decl.type = FFESTP_typeDBLCMPLX; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_dbltype); + break; + + case FFESTR_firstDBLPRCSN: + ffestb_args.decl.len = FFESTR_firstlDBLPRCSN; + ffestb_args.decl.type = FFESTP_typeDBLPRCSN; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_dbltype); + break; + + case FFESTR_firstELSEIF: + ffestb_args.elsexyz.second = FFESTR_secondIF; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz); + break; + +#if FFESTR_F90 + case FFESTR_firstELSEWHERE: + ffestb_args.elsexyz.second = FFESTR_secondWHERE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstENCODE: + ffestb_args.vxtcode.len = FFESTR_firstlENCODE; + ffestb_args.vxtcode.badname = "ENCODE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_vxtcode); + break; +#endif + + case FFESTR_firstEND: + if ((ffelex_token_type (ffesta_token_0_) == FFELEX_typeNAMES) + || (ffelex_token_type (t) != FFELEX_typeNAME)) + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end); + else + { + switch (ffesta_second_kw) + { + case FFESTR_secondBLOCK: + case FFESTR_secondBLOCKDATA: + case FFESTR_secondDO: + case FFESTR_secondFILE: + case FFESTR_secondFUNCTION: + case FFESTR_secondIF: +#if FFESTR_F90 + case FFESTR_secondMODULE: +#endif + case FFESTR_secondPROGRAM: + case FFESTR_secondSELECT: + case FFESTR_secondSUBROUTINE: +#if FFESTR_F90 + case FFESTR_secondWHERE: +#endif + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end); + break; + + default: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_end); + break; + } + } + break; + + case FFESTR_firstENDBLOCK: + ffestb_args.endxyz.len = FFESTR_firstlENDBLOCK; + ffestb_args.endxyz.second = FFESTR_secondBLOCK; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDBLOCKDATA: + ffestb_args.endxyz.len = FFESTR_firstlENDBLOCKDATA; + ffestb_args.endxyz.second = FFESTR_secondBLOCKDATA; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDDO: + ffestb_args.endxyz.len = FFESTR_firstlENDDO; + ffestb_args.endxyz.second = FFESTR_secondDO; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDFILE: + ffestb_args.beru.len = FFESTR_firstlENDFILE; + ffestb_args.beru.badname = "ENDFILE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; + + case FFESTR_firstENDFUNCTION: + ffestb_args.endxyz.len = FFESTR_firstlENDFUNCTION; + ffestb_args.endxyz.second = FFESTR_secondFUNCTION; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDIF: + ffestb_args.endxyz.len = FFESTR_firstlENDIF; + ffestb_args.endxyz.second = FFESTR_secondIF; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + +#if FFESTR_F90 + case FFESTR_firstENDINTERFACE: + ffestb_args.endxyz.len = FFESTR_firstlENDINTERFACE; + ffestb_args.endxyz.second = FFESTR_secondINTERFACE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstENDMAP: + ffestb_args.endxyz.len = FFESTR_firstlENDMAP; + ffestb_args.endxyz.second = FFESTR_secondMAP; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstENDMODULE: + ffestb_args.endxyz.len = FFESTR_firstlENDMODULE; + ffestb_args.endxyz.second = FFESTR_secondMODULE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + + case FFESTR_firstENDPROGRAM: + ffestb_args.endxyz.len = FFESTR_firstlENDPROGRAM; + ffestb_args.endxyz.second = FFESTR_secondPROGRAM; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDSELECT: + ffestb_args.endxyz.len = FFESTR_firstlENDSELECT; + ffestb_args.endxyz.second = FFESTR_secondSELECT; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + +#if FFESTR_VXT + case FFESTR_firstENDSTRUCTURE: + ffestb_args.endxyz.len = FFESTR_firstlENDSTRUCTURE; + ffestb_args.endxyz.second = FFESTR_secondSTRUCTURE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + + case FFESTR_firstENDSUBROUTINE: + ffestb_args.endxyz.len = FFESTR_firstlENDSUBROUTINE; + ffestb_args.endxyz.second = FFESTR_secondSUBROUTINE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + +#if FFESTR_F90 + case FFESTR_firstENDTYPE: + ffestb_args.endxyz.len = FFESTR_firstlENDTYPE; + ffestb_args.endxyz.second = FFESTR_secondTYPE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstENDUNION: + ffestb_args.endxyz.len = FFESTR_firstlENDUNION; + ffestb_args.endxyz.second = FFESTR_secondUNION; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstENDWHERE: + ffestb_args.endxyz.len = FFESTR_firstlENDWHERE; + ffestb_args.endxyz.second = FFESTR_secondWHERE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + + case FFESTR_firstENTRY: + ffestb_args.dummy.len = FFESTR_firstlENTRY; + ffestb_args.dummy.badname = "ENTRY"; + ffestb_args.dummy.is_subr = ffestc_is_entry_in_subr (); + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); + break; + + case FFESTR_firstEXTERNAL: + ffestb_args.varlist.len = FFESTR_firstlEXTERNAL; + ffestb_args.varlist.badname = "EXTERNAL"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; + + /* WARNING: don't put anything that might cause an item to precede + FORMAT in the list of possible statements (it's added below) without + making sure FORMAT still is first. It has to run with + ffelex_set_names_pure(TRUE), to make sure the lexer delivers NAMES + tokens. */ + + case FFESTR_firstFORMAT: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1001); + break; + + case FFESTR_firstFUNCTION: + ffestb_args.dummy.len = FFESTR_firstlFUNCTION; + ffestb_args.dummy.badname = "FUNCTION"; + ffestb_args.dummy.is_subr = FALSE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); + break; + + case FFESTR_firstINCLUDE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_S3P4); + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + case FFELEX_typeNAME: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + include_only = TRUE; + break; + + default: + break; + } + break; + + case FFESTR_firstINTGR: + ffestb_args.decl.len = FFESTR_firstlINTGR; + ffestb_args.decl.type = FFESTP_typeINTEGER; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + + case FFESTR_firstBYTE: + ffestb_args.decl.len = FFESTR_firstlBYTE; + ffestb_args.decl.type = FFESTP_typeBYTE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + + case FFESTR_firstWORD: + ffestb_args.decl.len = FFESTR_firstlWORD; + ffestb_args.decl.type = FFESTP_typeWORD; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffestb_args.varlist.len = FFESTR_firstlINTENT; + ffestb_args.varlist.badname = "INTENT"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + + case FFESTR_firstINTRINSIC: + ffestb_args.varlist.len = FFESTR_firstlINTRINSIC; + ffestb_args.varlist.badname = "INTRINSIC"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; + + case FFESTR_firstLGCL: + ffestb_args.decl.len = FFESTR_firstlLGCL; + ffestb_args.decl.type = FFESTP_typeLOGICAL; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestb_args.varlist.len = FFESTR_firstlOPTIONAL; + ffestb_args.varlist.badname = "OPTIONAL"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + + case FFESTR_firstPAUSE: + ffestb_args.halt.len = FFESTR_firstlPAUSE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); + break; + +#if FFESTR_F90 + case FFESTR_firstPOINTER: + ffestb_args.dimlist.len = FFESTR_firstlPOINTER; + ffestb_args.dimlist.badname = "POINTER"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); + break; +#endif + +#if HARD_F90 + case FFESTR_firstPRIVATE: + ffestb_args.varlist.len = FFESTR_firstlPRIVATE; + ffestb_args.varlist.badname = "ACCESS"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; + + case FFESTR_firstPUBLIC: + ffestb_args.varlist.len = FFESTR_firstlPUBLIC; + ffestb_args.varlist.badname = "ACCESS"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + + case FFESTR_firstREAL: + ffestb_args.decl.len = FFESTR_firstlREAL; + ffestb_args.decl.type = FFESTP_typeREAL; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + + case FFESTR_firstREWIND: + ffestb_args.beru.len = FFESTR_firstlREWIND; + ffestb_args.beru.badname = "REWIND"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; + + case FFESTR_firstSTOP: + ffestb_args.halt.len = FFESTR_firstlSTOP; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); + break; + + case FFESTR_firstSUBROUTINE: + ffestb_args.dummy.len = FFESTR_firstlSUBROUTINE; + ffestb_args.dummy.badname = "SUBROUTINE"; + ffestb_args.dummy.is_subr = TRUE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); + break; + +#if FFESTR_F90 + case FFESTR_firstTARGET: + ffestb_args.dimlist.len = FFESTR_firstlTARGET; + ffestb_args.dimlist.badname = "TARGET"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstUNLOCK: + ffestb_args.beru.len = FFESTR_firstlUNLOCK; + ffestb_args.beru.badname = "UNLOCK"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; +#endif + + case FFESTR_firstVIRTUAL: + ffestb_args.R524.len = FFESTR_firstlVIRTUAL; + ffestb_args.R524.badname = "VIRTUAL"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R524); + break; + + default: + + /* For now, a decent error message for an unconfirmed stmt, rather than + just whatever is at the top of the list. */ + + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_unimplemented); + break; + } + + if (!include_only) + { + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_block); /* BLOCK. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_blockdata); /* BLOCKDATA. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_chartype); /* CHARACTER. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_do); /* DO. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_double); /* DOUBLE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_dowhile); /* DOWHILE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_else); /* ELSE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto); /* GOTO. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_if); /* IF. */ +#if FFESTR_F90 + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_module); /* MODULE. */ +#endif +#if FFESTR_F90 + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_recursive); /* RECURSIVE. */ +#endif +#if FFESTR_F90 + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_type); /* TYPE. */ +#endif +#if HARD_F90 + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_typetype); /* TYPE(). */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_where); /* WHERE. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R423B); /* SEQUENCE. */ +#endif + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R522); /* SAVE. */ + if (ffe_is_pedantic_not_90 ()) + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R528); /* DATA. */ + else + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R528); /* DATA. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R537); /* PARAMETER. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_R539); /* IMPLICIT. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R542); /* NAMELIST. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R544); /* EQUIVALENCE. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R547); /* COMMON. */ +#if FFESTR_F90 + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R624); /* NULLIFY. */ +#endif + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R809); /* SELECTCASE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R810); /* CASE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R834); /* CYCLE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R835); /* EXIT. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R838); /* ASSIGN. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R840); /* Arithmetic IF. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R841); /* CONTINUE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R904); /* OPEN. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R907); /* CLOSE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R909); /* READ. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R910); /* WRITE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R911); /* PRINT. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R923); /* INQUIRE. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1102); /* PROGRAM. */ +#if FFESTR_F90 + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1107); /* USE. */ +#endif +#if FFESTR_F90 + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1202); /* INTERFACE. */ +#endif + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1212); /* CALL. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1227); /* RETURN. */ +#if FFESTR_F90 + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1228); /* CONTAINS. */ +#endif +#if FFESTR_VXT + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V003); /* STRUCTURE. */ +#endif +#if FFESTR_VXT + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V009); /* UNION. */ +#endif +#if FFESTR_VXT + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V012); /* MAP. */ +#endif + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V014); /* VOLATILE. */ +#if FFESTR_VXT + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V016); /* RECORD. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V018); /* REWRITE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V019); /* ACCEPT. */ +#endif + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V020); /* TYPE. */ +#if FFESTR_VXT + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V021); /* DELETE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V025); /* DEFINEFILE. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V026); /* FIND. */ +#endif + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V027); /* VXT PARAMETER. */ + } + else + include_only = FALSE; + + /* Now check the default cases, which are always "live" (meaning that no + other possibility can override them). These are where the second token + is OPEN_PAREN, PERCENT, EQUALS, POINTS, or COLON. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + s = ffesymbol_lookup_local (ffesta_token_0_); + if (((s == NULL) || (ffesymbol_dims (s) == NULL)) + && !ffesta_seen_first_exec) + { /* Not known as array; may be stmt function. */ + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1229); + + /* If the symbol is (or will be due to implicit typing) of + CHARACTER type, then the statement might be an assignment + statement. If so, since it can't be a function invocation nor + an array element reference, the open paren following the symbol + name must be followed by an expression and a colon. Without the + colon (which cannot appear in a stmt function definition), the + let stmt rejects. So CHARACTER_NAME(...)=expr, unlike any other + type, is not ambiguous alone. */ + + if (ffeimplic_peek_symbol_type (s, + ffelex_token_text (ffesta_token_0_)) + == FFEINFO_basictypeCHARACTER) + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_let); + } + else /* Not statement function if known as an + array. */ + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_let); + break; + +#if FFESTR_F90 + case FFELEX_typePERCENT: +#endif + case FFELEX_typeEQUALS: +#if FFESTR_F90 + case FFELEX_typePOINTS: +#endif + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_let); + break; + + case FFELEX_typeCOLON: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_construct); + break; + + default: + ; + } + + /* Now see how many possibilities are on the list. */ + + switch (ffesta_num_possibles_) + { + case 0: /* None, so invalid statement. */ + no_stmts: /* :::::::::::::::::::: */ + ffesta_tokens[0] = ffesta_token_0_; + ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_token_0_, t); + next = (ffelexHandler) ffelex_swallow_tokens (NULL, + (ffelexHandler) ffesta_zero); + break; + + case 1: /* One, so just do it! */ + ffesta_tokens[0] = ffesta_token_0_; + next = ffesta_possible_execs_.first->handler; + if (next == NULL) + { /* Have a nonexec stmt. */ + next = ffesta_possible_nonexecs_.first->handler; + assert (next != NULL); + } + else if (ffesta_seen_first_exec) + ; /* Have an exec stmt after exec transition. */ + else if (!ffestc_exec_transition ()) + /* 1 exec stmt only, but not valid in context, so pretend as though + statement is unrecognized. */ + goto no_stmts; /* :::::::::::::::::::: */ + break; + + default: /* More than one, so try them in order. */ + ffesta_confirmed_possible_ = NULL; + ffesta_current_possible_ = ffesta_possible_nonexecs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + if (ffesta_current_handler_ == NULL) + { + ffesta_current_possible_ = ffesta_possible_execs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + assert (ffesta_current_handler_ != NULL); + if (!ffesta_seen_first_exec) + { /* Need to do exec transition now. */ + if (!ffestc_exec_transition ()) + goto no_stmts; /* :::::::::::::::::::: */ + } + } + ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_); + next = (ffelexHandler) ffesta_save_; + ffebad_set_inhibit (TRUE); + ffesta_is_inhibited_ = TRUE; + break; + } + + ffesta_output_pool + = malloc_pool_new ("Statement Output", ffe_pool_program_unit (), 1024); + ffesta_scratch_pool + = malloc_pool_new ("Statement Scratch", ffe_pool_program_unit (), 1024); + ffesta_outpooldisp_ = FFESTA_pooldispDISCARD; + + if (ffesta_is_inhibited_) + ffesymbol_set_retractable (ffesta_scratch_pool); + + ffelex_set_names (FALSE); /* Most handlers will want this. If not, + they have to set it TRUE again (its value + at the beginning of a statement). */ + + return (ffelexHandler) (*next) (t); +} + +/* ffesta_send_two_ -- Send the two tokens saved by ffesta_two after all + + return ffesta_send_two_; // to lexer. + + Currently, if this function gets called, it means that the two tokens + saved by ffesta_two did not have their handlers derailed by + ffesta_save_, which probably means they weren't sent by ffesta_save_ + but directly by the lexer, which probably means the original statement + (which should be IF (expr) or WHERE (expr)) somehow evaluated to only + one possibility in ffesta_second_ or somebody optimized FFEST to + immediately revert to one possibility upon confirmation but forgot to + change this function (and thus perhaps the entire resubmission + mechanism). */ + +#if !FFESTA_ABORT_ON_CONFIRM_ +static ffelexHandler +ffesta_send_two_ (ffelexToken t) +{ + assert ("what am I doing here?" == NULL); + return NULL; +} + +#endif +/* ffesta_confirmed -- Confirm current possibility as only one + + ffesta_confirmed(); + + Sets the confirmation flag. During debugging for ambiguous constructs, + asserts that the confirmation flag for a previous possibility has not + yet been set. */ + +void +ffesta_confirmed () +{ + if (ffesta_inhibit_confirmation_) + return; + ffesta_confirmed_current_ = TRUE; + assert (!ffesta_confirmed_other_ + || (ffesta_confirmed_possible_ == ffesta_current_possible_)); + ffesta_confirmed_possible_ = ffesta_current_possible_; +} + +/* ffesta_eof -- End of (non-INCLUDEd) source file + + ffesta_eof(); + + Call after piping tokens through ffest_first, where the most recent + token sent through must be EOS. + + 20-Feb-91 JCB 1.1 + Put new EOF token in ffesta_tokens[0], not NULL, because too much + code expects something there for error reporting and the like. Also, + do basically the same things ffest_second and ffesta_zero do for + processing a statement (make and destroy pools, et cetera). */ + +void +ffesta_eof () +{ + ffesta_tokens[0] = ffelex_token_new_eof (); + + ffesta_output_pool + = malloc_pool_new ("Statement Output", ffe_pool_program_unit (), 1024); + ffesta_scratch_pool + = malloc_pool_new ("Statement Scratch", ffe_pool_program_unit (), 1024); + ffesta_outpooldisp_ = FFESTA_pooldispDISCARD; + + ffestc_eof (); + + if (ffesta_tokens[0] != NULL) + ffelex_token_kill (ffesta_tokens[0]); + + if (ffesta_output_pool != NULL) + { + if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD) + malloc_pool_kill (ffesta_output_pool); + ffesta_output_pool = NULL; + } + + if (ffesta_scratch_pool != NULL) + { + malloc_pool_kill (ffesta_scratch_pool); + ffesta_scratch_pool = NULL; + } + + if (ffesta_label_token != NULL) + { + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; + } + + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } +} + +/* ffesta_ffebad_here_current_stmt -- ffebad_here with ptr to current stmt + + ffesta_ffebad_here_current_stmt(0); + + Outsiders can call this fn if they have no more convenient place to + point to (via a token or pair of ffewhere objects) and they know a + current, useful statement is being evaluted by ffest (i.e. they are + being called from ffestb, ffestc, ffestd, ... functions). */ + +void +ffesta_ffebad_here_current_stmt (ffebadIndex i) +{ + assert (ffesta_tokens[0] != NULL); + ffebad_here (i, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); +} + +/* ffesta_ffebad_start -- Start a possibly inhibited error report + + if (ffesta_ffebad_start(FFEBAD_SOME_ERROR)) + { + ffebad_here, ffebad_string ...; + ffebad_finish(); + } + + Call if the error might indicate that ffest is evaluating the wrong + statement form, instead of calling ffebad_start directly. If ffest + is choosing between forms, it will return FALSE, send an EOS/SEMICOLON + token through as the next token (if the current one isn't already one + of those), and try another possible form. Otherwise, ffebad_start is + called with the argument and TRUE returned. */ + +bool +ffesta_ffebad_start (ffebad errnum) +{ + if (!ffesta_is_inhibited_) + { + ffebad_start (errnum); + return TRUE; + } + + if (!ffesta_confirmed_current_) + ffesta_current_shutdown_ = TRUE; + + return FALSE; +} + +/* ffesta_first -- Parse the first token in a statement + + return ffesta_first; // to lexer. */ + +ffelexHandler +ffesta_first (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSEMICOLON: + case FFELEX_typeEOS: + ffesta_tokens[0] = ffelex_token_use (t); + if (ffesta_label_token != NULL) + { + ffebad_start (FFEBAD_LABEL_WITHOUT_STMT); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_string (ffelex_token_text (ffesta_label_token)); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffesta_token_0_ = ffelex_token_use (t); + ffesta_first_kw = ffestr_first (t); + return (ffelexHandler) ffesta_second_; + + case FFELEX_typeNUMBER: + if (ffesta_line_has_semicolons + && !ffe_is_free_form () + && ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_LABEL_WRONG_PLACE); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffelex_token_text (t)); + ffebad_finish (); + } + if (ffesta_label_token == NULL) + { + ffesta_label_token = ffelex_token_use (t); + return (ffelexHandler) ffesta_first; + } + else + { + ffebad_start (FFEBAD_EXTRA_LABEL_DEF); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffelex_token_text (t)); + ffebad_here (1, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_string (ffelex_token_text (ffesta_label_token)); + ffebad_finish (); + + return (ffelexHandler) ffesta_first; + } + + default: /* Invalid first token. */ + ffesta_tokens[0] = ffelex_token_use (t); + ffebad_start (FFEBAD_STMT_BEGINS_BAD); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffesta_init_0 -- Initialize for entire image invocation + + ffesta_init_0(); + + Call just once per invocation of the compiler (not once per invocation + of the front end). + + Gets memory for the list of possibles once and for all, since this + list never gets larger than a certain size (FFESTA_maxPOSSIBLES_) + and is not particularly large. Initializes the array of pointers to + this list. Initializes the executable and nonexecutable lists. */ + +void +ffesta_init_0 () +{ + ffestaPossible_ ptr; + int i; + + ptr = (ffestaPossible_) malloc_new_kp (malloc_pool_image (), + "FFEST possibles", + FFESTA_maxPOSSIBLES_ + * sizeof (*ptr)); + + for (i = 0; i < FFESTA_maxPOSSIBLES_; ++i) + ffesta_possibles_[i] = ptr++; + + ffesta_possible_execs_.first = ffesta_possible_execs_.last + = (ffestaPossible_) &ffesta_possible_execs_.first; + ffesta_possible_nonexecs_.first = ffesta_possible_nonexecs_.last + = (ffestaPossible_) &ffesta_possible_nonexecs_.first; + ffesta_possible_execs_.nil = ffesta_possible_nonexecs_.nil = NULL; +} + +/* ffesta_init_3 -- Initialize for any program unit + + ffesta_init_3(); */ + +void +ffesta_init_3 () +{ + ffesta_output_pool = NULL; /* May be doing this just before reaching */ + ffesta_scratch_pool = NULL; /* ffesta_zero or ffesta_two. */ + /* NOTE: we let the ffe_terminate_2 action of killing the program_unit pool + handle the killing of the output and scratch pools for us, which is why + we don't have a terminate_3 action to do so. */ + ffesta_construct_name = NULL; + ffesta_label_token = NULL; + ffesta_seen_first_exec = FALSE; +} + +/* ffesta_is_inhibited -- Test whether the current possibility is inhibited + + if (!ffesta_is_inhibited()) + // implement the statement. + + Just make sure the current possibility has been confirmed. If anyone + really needs to test whether the current possibility is inhibited prior + to confirming it, that indicates a need to begin statement processing + before it is certain that the given possibility is indeed the statement + to be processed. As of this writing, there does not appear to be such + a need. If there is, then when confirming a statement would normally + immediately disable the inhibition (whereas currently we leave the + confirmed statement disabled until we've tried the other possibilities, + to check for ambiguities), we must check to see if the possibility has + already tested for inhibition prior to confirmation and, if so, maintain + inhibition until the end of the statement (which may be forced right + away) and then rerun the entire statement from the beginning. Otherwise, + initial calls to ffestb functions won't have been made, but subsequent + calls (after confirmation) will, which is wrong. Of course, this all + applies only to those statements implemented via multiple calls to + ffestb, although if a statement requiring only a single ffestb call + tested for inhibition prior to confirmation, it would likely mean that + the ffestb call would be completely dropped without this mechanism. */ + +bool +ffesta_is_inhibited () +{ + assert (ffesta_confirmed_current_ || ffesta_inhibit_confirmation_); + return ffesta_is_inhibited_; +} + +/* ffesta_ffebad_1p -- Issue diagnostic with one source character + + ffelexToken names_token; + ffeTokenLength index; + ffelexToken next_token; + ffesta_ffebad_1p(FFEBAD_SOME_ERROR,names_token,index,next_token); + + Equivalent to "if (ffest_ffebad_start(FFEBAD_SOME_ERROR))" followed by + sending one argument, the location of index with names_token, if TRUE is + returned. If index is equal to the length of names_token, meaning it + points to the end of the token, then uses the location in next_token + (which should be the token sent by the lexer after it sent names_token) + instead. */ + +void +ffesta_ffebad_1p (ffebad errnum, ffelexToken names_token, ffeTokenLength index, + ffelexToken next_token) +{ + ffewhereLine line; + ffewhereColumn col; + + assert (index <= ffelex_token_length (names_token)); + + if (ffesta_ffebad_start (errnum)) + { + if (index == ffelex_token_length (names_token)) + { + assert (next_token != NULL); + line = ffelex_token_where_line (next_token); + col = ffelex_token_where_column (next_token); + ffebad_here (0, line, col); + } + else + { + ffewhere_set_from_track (&line, &col, + ffelex_token_where_line (names_token), + ffelex_token_where_column (names_token), + ffelex_token_wheretrack (names_token), + index); + ffebad_here (0, line, col); + ffewhere_line_kill (line); + ffewhere_column_kill (col); + } + ffebad_finish (); + } +} + +void +ffesta_ffebad_1sp (ffebad errnum, char *s, ffelexToken names_token, + ffeTokenLength index, ffelexToken next_token) +{ + ffewhereLine line; + ffewhereColumn col; + + assert (index <= ffelex_token_length (names_token)); + + if (ffesta_ffebad_start (errnum)) + { + ffebad_string (s); + if (index == ffelex_token_length (names_token)) + { + assert (next_token != NULL); + line = ffelex_token_where_line (next_token); + col = ffelex_token_where_column (next_token); + ffebad_here (0, line, col); + } + else + { + ffewhere_set_from_track (&line, &col, + ffelex_token_where_line (names_token), + ffelex_token_where_column (names_token), + ffelex_token_wheretrack (names_token), + index); + ffebad_here (0, line, col); + ffewhere_line_kill (line); + ffewhere_column_kill (col); + } + ffebad_finish (); + } +} + +void +ffesta_ffebad_1st (ffebad errnum, char *s, ffelexToken t) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_string (s); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } +} + +/* ffesta_ffebad_1t -- Issue diagnostic with one source token + + ffelexToken t; + ffesta_ffebad_1t(FFEBAD_SOME_ERROR,t); + + Equivalent to "if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))" followed by + sending one argument, the location of the token t, if TRUE is returned. */ + +void +ffesta_ffebad_1t (ffebad errnum, ffelexToken t) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } +} + +void +ffesta_ffebad_2st (ffebad errnum, char *s, ffelexToken t1, ffelexToken t2) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_string (s); + ffebad_here (0, ffelex_token_where_line (t1), ffelex_token_where_column (t1)); + ffebad_here (1, ffelex_token_where_line (t2), ffelex_token_where_column (t2)); + ffebad_finish (); + } +} + +/* ffesta_ffebad_2t -- Issue diagnostic with two source tokens + + ffelexToken t1, t2; + ffesta_ffebad_2t(FFEBAD_SOME_ERROR,t1,t2); + + Equivalent to "if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))" followed by + sending two argument, the locations of the tokens t1 and t2, if TRUE is + returned. */ + +void +ffesta_ffebad_2t (ffebad errnum, ffelexToken t1, ffelexToken t2) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_here (0, ffelex_token_where_line (t1), ffelex_token_where_column (t1)); + ffebad_here (1, ffelex_token_where_line (t2), ffelex_token_where_column (t2)); + ffebad_finish (); + } +} + +/* ffesta_set_outpooldisp -- Set disposition of statement output pool + + ffesta_set_outpooldisp(FFESTA_pooldispPRESERVE); */ + +void +ffesta_set_outpooldisp (ffestaPooldisp d) +{ + ffesta_outpooldisp_ = d; +} + +/* ffesta_two -- Deal with the first two tokens after a swallowed statement + + return ffesta_two(first_token,second_token); // to lexer. + + Like ffesta_zero, except instead of expecting an EOS or SEMICOLON, it + expects the first two tokens of a statement that is part of another + statement: the first two tokens of statement in "IF (expr) statement" or + "WHERE (expr) statement", in particular. The first token must be a NAME + or NAMES, the second can be basically anything. The statement type MUST + be confirmed by now. + + If we're not inhibited, just handle things as if we were ffesta_zero + and saw an EOS just before the two tokens. + + If we're inhibited, set ffesta_current_shutdown_ to shut down the current + statement and continue with other possibilities, then (presumably) come + back to this one for real when not inhibited. */ + +ffelexHandler +ffesta_two (ffelexToken first, ffelexToken second) +{ +#if FFESTA_ABORT_ON_CONFIRM_ + ffelexHandler next; +#endif + + assert ((ffelex_token_type (first) == FFELEX_typeNAME) + || (ffelex_token_type (first) == FFELEX_typeNAMES)); + assert (ffesta_tokens[0] != NULL); + + if (ffesta_is_inhibited_) /* Oh, not really done with statement. */ + { + ffesta_current_shutdown_ = TRUE; + /* To catch the EOS on shutdown. */ + return (ffelexHandler) ffelex_swallow_tokens (second, + (ffelexHandler) ffesta_zero); + } + + ffestw_display_state (); + + ffelex_token_kill (ffesta_tokens[0]); + + if (ffesta_output_pool != NULL) + { + if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD) + malloc_pool_kill (ffesta_output_pool); + ffesta_output_pool = NULL; + } + + if (ffesta_scratch_pool != NULL) + { + malloc_pool_kill (ffesta_scratch_pool); + ffesta_scratch_pool = NULL; + } + + ffesta_reset_possibles_ (); + ffesta_confirmed_current_ = FALSE; + + /* What happens here is somewhat interesting. We effectively derail the + line of handlers for these two tokens, the first two in a statement, by + setting a flag to TRUE. This flag tells ffesta_save_ (or, conceivably, + the lexer via ffesta_second_'s case 1:, where it has only one possible + kind of statement -- someday this will be more likely, i.e. after + confirmation causes an immediate switch to only the one context rather + than just setting a flag and running through the remaining possibles to + look for ambiguities) that the last two tokens it sent did not reach the + truly desired targets (ffest_first and ffesta_second_) since that would + otherwise attempt to recursively invoke ffesta_save_ in most cases, + while the existing ffesta_save_ was still alive and making use of static + (nonrecursive) variables. Instead, ffesta_save_, upon seeing this flag + set TRUE, sets it to FALSE and resubmits the two tokens copied here to + ffest_first and, presumably, ffesta_second_, kills them, and returns the + handler returned by the handler for the second token. Thus, even though + ffesta_save_ is still (likely to be) recursively invoked, the former + invocation is past the use of any static variables possibly changed + during the first-two-token invocation of the latter invocation. */ + +#if FFESTA_ABORT_ON_CONFIRM_ + /* Shouldn't be in ffesta_save_ at all here. */ + + next = (ffelexHandler) ffesta_first (first); + return (ffelexHandler) (*next) (second); +#else + ffesta_twotokens_1_ = ffelex_token_use (first); + ffesta_twotokens_2_ = ffelex_token_use (second); + + ffesta_is_two_into_statement_ = TRUE; + return (ffelexHandler) ffesta_send_two_; /* Shouldn't get called. */ +#endif +} + +/* ffesta_zero -- Deal with the end of a swallowed statement + + return ffesta_zero; // to lexer. + + NOTICE that this code is COPIED, largely, into a + similar function named ffesta_two that gets invoked in place of + _zero_ when the end of the statement happens before EOS or SEMICOLON and + to tokens into the next statement have been read (as is the case with the + logical-IF and WHERE-stmt statements). So any changes made here should + probably be made in _two_ at the same time. */ + +ffelexHandler +ffesta_zero (ffelexToken t) +{ + assert ((ffelex_token_type (t) == FFELEX_typeEOS) + || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)); + assert (ffesta_tokens[0] != NULL); + + if (ffesta_is_inhibited_) + ffesymbol_retract (TRUE); + else + ffestw_display_state (); + + /* Do CONTINUE if nothing else. This is done specifically so that "IF + (...) BLAH" causes the same things to happen as if "IF (...) CONTINUE" + was done, so that tracking of labels and such works. (Try a small + program like "DO 10 ...", "IF (...) BLAH", "10 CONTINUE", "END".) + + But it turns out that just testing "!ffesta_confirmed_current_" + isn't enough, because then typing "GOTO" instead of "BLAH" above + doesn't work -- the statement is confirmed (we know the user + attempted a GOTO) but ffestc hasn't seen it. So, instead, just + always tell ffestc to do "any" statement it needs to to reset. */ + + if (!ffesta_is_inhibited_ + && ffesta_seen_first_exec) + { + ffestc_any (); + } + + ffelex_token_kill (ffesta_tokens[0]); + + if (ffesta_is_inhibited_) /* Oh, not really done with statement. */ + return (ffelexHandler) ffesta_zero; /* Call me again when done! */ + + if (ffesta_output_pool != NULL) + { + if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD) + malloc_pool_kill (ffesta_output_pool); + ffesta_output_pool = NULL; + } + + if (ffesta_scratch_pool != NULL) + { + malloc_pool_kill (ffesta_scratch_pool); + ffesta_scratch_pool = NULL; + } + + ffesta_reset_possibles_ (); + ffesta_confirmed_current_ = FALSE; + + if (ffelex_token_type (t) == FFELEX_typeSEMICOLON) + { + ffesta_line_has_semicolons = TRUE; + if (ffe_is_pedantic_not_90 ()) + { + ffebad_start (FFEBAD_SEMICOLON); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + } + else + ffesta_line_has_semicolons = FALSE; + + if (ffesta_label_token != NULL) + { + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; + } + + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } + + ffelex_set_names (TRUE); + return (ffelexHandler) ffesta_first; +} |