diff options
Diffstat (limited to 'gcc/f/stc.c')
| -rw-r--r-- | gcc/f/stc.c | 13895 |
1 files changed, 13895 insertions, 0 deletions
diff --git a/gcc/f/stc.c b/gcc/f/stc.c new file mode 100644 index 00000000000..ef91d7188dd --- /dev/null +++ b/gcc/f/stc.c @@ -0,0 +1,13895 @@ +/* stc.c -- Implementation File (module.c template V1.0) + 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. + + Related Modules: + st.c + + Description: + Verifies the proper semantics for statements, checking expressions already + semantically analyzed individually, collectively, checking label defs and + refs, and so on. Uses ffebad to indicate errors in semantics. + + In many cases, both a token and a keyword (ffestrFirst, ffestrSecond, + or ffestrOther) is provided. ONLY USE THE TOKEN as a pointer to the + source-code location for an error message or similar; use the keyword + as the semantic matching for the token, since the token's text might + not match the keyword's code. For example, INTENT(IN OUT) A in free + source form passes to ffestc_R519_start the token "IN" but the keyword + FFESTR_otherINOUT, and the latter is correct. + + Generally, either a single ffestc function handles an entire statement, + in which case its name is ffestc_xyz_, or more than one function is + needed, in which case its names are ffestc_xyz_start_, + ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_. + The caller must call _start_ before calling any _item_ functions, and + must call _finish_ afterwards. If it is clearly a syntactic matter as + to restrictions on the number and variety of _item_ calls, then the caller + should report any errors and ffestc_ should presume it has been taken + care of and handle any semantic problems with grace and no error messages. + If the permitted number and variety of _item_ calls has some basis in + semantics, then the caller should not generate any messages and ffestc + should do all the checking. + + A few ffestc functions have names rather than grammar numbers, like + ffestc_elsewhere and ffestc_end. These are cases where the actual + statement depends on its context rather than just its form; ELSE WHERE + may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little + more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE). The actual + ffestc functions do exist and do work, but may or may not be invoked + by ffestb depending on whether some form of resolution is possible. + For example, ffestc_R1103 end-program-stmt is reachable directly when + END PROGRAM [name] is specified, or via ffestc_end when END is specified + and the context is a main program. So ffestc_xyz_ should make a quick + determination of the context and pick the appropriate ffestc_Nxyz_ + function to invoke, without a lot of ceremony. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "stc.h" +#include "bad.h" +#include "bld.h" +#include "data.h" +#include "expr.h" +#include "global.h" +#include "implic.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#include "sta.h" +#include "std.h" +#include "stp.h" +#include "str.h" +#include "stt.h" +#include "stw.h" + +/* Externals defined here. */ + +ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST; +/* Valid only from READ/WRITE start to finish. */ + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFESTC_orderOK_, /* Statement ok in this context, process. */ + FFESTC_orderBAD_, /* Statement not ok in this context, don't + process. */ + FFESTC_orderBADOK_, /* Don't process but push block if + applicable. */ + FFESTC + } ffestcOrder_; + +typedef enum + { + FFESTC_stateletSIMPLE_, /* Expecting simple/start. */ + FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ + FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */ + FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ + FFESTC_ + } ffestcStatelet_; + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + +union ffestc_local_u_ + { + struct + { + ffebld initlist; /* For list of one sym in INTEGER I/3/ case. */ + ffetargetCharacterSize stmt_size; + ffetargetCharacterSize size; + ffeinfoBasictype basic_type; + ffeinfoKindtype stmt_kind_type; + ffeinfoKindtype kind_type; + bool per_var_kind_ok; + char is_R426; /* 1=R426, 2=R501. */ + } + decl; + struct + { + ffebld objlist; /* For list of target objects. */ + ffebldListBottom list_bottom; /* For building lists. */ + } + data; + struct + { + ffebldListBottom list_bottom; /* For building lists. */ + int entry_num; + } + dummy; + struct + { + ffesymbol symbol; /* NML symbol. */ + } + namelist; + struct + { + ffelexToken t; /* First token in list. */ + ffeequiv eq; /* Current equivalence being built up. */ + ffebld list; /* List of expressions in equivalence. */ + ffebldListBottom bottom; + bool ok; /* TRUE while current list still being + processed. */ + bool save; /* TRUE if any var in list is SAVEd. */ + } + equiv; + struct + { + ffesymbol symbol; /* BCB/NCB symbol. */ + } + common; + struct + { + ffesymbol symbol; /* SFN symbol. */ + } + sfunc; +#if FFESTR_VXT + struct + { + char list_state; /* 0=>no field names allowed, 1=>error + reported already, 2=>field names req'd, + 3=>have a field name. */ + } + V003; +#endif + }; /* Merge with the one in ffestc later. */ + +/* Static objects accessed by functions in this module. */ + +static bool ffestc_ok_; /* _start_ fn's send this to _xyz_ fn's. */ +static bool ffestc_parent_ok_; /* Parent sym for baby sym fn's ok. */ +static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */ +static union ffestc_local_u_ ffestc_local_; +static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_; +static ffestwShriek ffestc_shriek_after1_ = NULL; +static unsigned long ffestc_blocknum_ = 0; /* Next block# to assign. */ +static int ffestc_entry_num_; +static int ffestc_sfdummy_argno_; +static int ffestc_saved_entry_num_; +static ffelab ffestc_label_; + +/* Static functions (internal). */ + +static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t); +static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, + ffebld len, ffelexToken lent); +static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, + ffebld kind, ffelexToken kindt, + ffebld len, ffelexToken lent); +static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last); +static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt, + ffetargetCharacterSize val); +static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt, + ffetargetCharacterSize val); +static void ffestc_labeldef_any_ (void); +static bool ffestc_labeldef_begin_ (void); +static void ffestc_labeldef_branch_begin_ (void); +static void ffestc_labeldef_branch_end_ (void); +static void ffestc_labeldef_endif_ (void); +static void ffestc_labeldef_format_ (void); +static void ffestc_labeldef_invalid_ (void); +static void ffestc_labeldef_notloop_ (void); +static void ffestc_labeldef_notloop_begin_ (void); +static void ffestc_labeldef_useless_ (void); +static bool ffestc_labelref_is_assignable_ (ffelexToken label_token, + ffelab *label); +static bool ffestc_labelref_is_branch_ (ffelexToken label_token, + ffelab *label); +static bool ffestc_labelref_is_format_ (ffelexToken label_token, + ffelab *label); +static bool ffestc_labelref_is_loopend_ (ffelexToken label_token, + ffelab *label); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_access_ (void); +#endif +static ffestcOrder_ ffestc_order_actiondo_ (void); +static ffestcOrder_ ffestc_order_actionif_ (void); +static ffestcOrder_ ffestc_order_actionwhere_ (void); +static void ffestc_order_any_ (void); +static void ffestc_order_bad_ (void); +static ffestcOrder_ ffestc_order_blockdata_ (void); +static ffestcOrder_ ffestc_order_blockspec_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_component_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_contains_ (void); +#endif +static ffestcOrder_ ffestc_order_data_ (void); +static ffestcOrder_ ffestc_order_data77_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_derivedtype_ (void); +#endif +static ffestcOrder_ ffestc_order_do_ (void); +static ffestcOrder_ ffestc_order_entry_ (void); +static ffestcOrder_ ffestc_order_exec_ (void); +static ffestcOrder_ ffestc_order_format_ (void); +static ffestcOrder_ ffestc_order_function_ (void); +static ffestcOrder_ ffestc_order_iface_ (void); +static ffestcOrder_ ffestc_order_ifthen_ (void); +static ffestcOrder_ ffestc_order_implicit_ (void); +static ffestcOrder_ ffestc_order_implicitnone_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_interface_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_map_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_module_ (void); +#endif +static ffestcOrder_ ffestc_order_parameter_ (void); +static ffestcOrder_ ffestc_order_program_ (void); +static ffestcOrder_ ffestc_order_progspec_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_record_ (void); +#endif +static ffestcOrder_ ffestc_order_selectcase_ (void); +static ffestcOrder_ ffestc_order_sfunc_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_spec_ (void); +#endif +#if FFESTR_VXT +static ffestcOrder_ ffestc_order_structure_ (void); +#endif +static ffestcOrder_ ffestc_order_subroutine_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_type_ (void); +#endif +static ffestcOrder_ ffestc_order_typedecl_ (void); +#if FFESTR_VXT +static ffestcOrder_ ffestc_order_union_ (void); +#endif +static ffestcOrder_ ffestc_order_unit_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_use_ (void); +#endif +#if FFESTR_VXT +static ffestcOrder_ ffestc_order_vxtstructure_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_where_ (void); +#endif +static void ffestc_promote_dummy_ (ffelexToken t); +static void ffestc_promote_execdummy_ (ffelexToken t); +static void ffestc_promote_sfdummy_ (ffelexToken t); +static void ffestc_shriek_begin_program_ (void); +#if FFESTR_F90 +static void ffestc_shriek_begin_uses_ (void); +#endif +static void ffestc_shriek_blockdata_ (bool ok); +static void ffestc_shriek_do_ (bool ok); +static void ffestc_shriek_end_program_ (bool ok); +#if FFESTR_F90 +static void ffestc_shriek_end_uses_ (bool ok); +#endif +static void ffestc_shriek_function_ (bool ok); +static void ffestc_shriek_if_ (bool ok); +static void ffestc_shriek_ifthen_ (bool ok); +#if FFESTR_F90 +static void ffestc_shriek_interface_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_map_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_module_ (bool ok); +#endif +static void ffestc_shriek_select_ (bool ok); +#if FFESTR_VXT +static void ffestc_shriek_structure_ (bool ok); +#endif +static void ffestc_shriek_subroutine_ (bool ok); +#if FFESTR_F90 +static void ffestc_shriek_type_ (bool ok); +#endif +#if FFESTR_VXT +static void ffestc_shriek_union_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_where_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_wherethen_ (bool ok); +#endif +static int ffestc_subr_binsrch_ (char **list, int size, ffestpFile *spec, + char *whine); +static ffestvFormat ffestc_subr_format_ (ffestpFile *spec); +static bool ffestc_subr_is_branch_ (ffestpFile *spec); +static bool ffestc_subr_is_format_ (ffestpFile *spec); +static bool ffestc_subr_is_present_ (char *name, ffestpFile *spec); +static int ffestc_subr_speccmp_ (char *string, ffestpFile *spec, + char **target, int *length); +static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec); +static void ffestc_try_shriek_do_ (void); + +/* Internal macros. */ + +#define ffestc_check_simple_() \ + assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_) +#define ffestc_check_start_() \ + assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \ + ffestc_statelet_ = FFESTC_stateletATTRIB_ +#define ffestc_check_attrib_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_) +#define ffestc_check_item_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ + || ffestc_statelet_ == FFESTC_stateletITEM_); \ + ffestc_statelet_ = FFESTC_stateletITEM_ +#define ffestc_check_item_startvals_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ + || ffestc_statelet_ == FFESTC_stateletITEM_); \ + ffestc_statelet_ = FFESTC_stateletITEMVALS_ +#define ffestc_check_item_value_() \ + assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_) +#define ffestc_check_item_endvals_() \ + assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \ + ffestc_statelet_ = FFESTC_stateletITEM_ +#define ffestc_check_finish_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ + || ffestc_statelet_ == FFESTC_stateletITEM_); \ + ffestc_statelet_ = FFESTC_stateletSIMPLE_ +#define ffestc_order_action_() ffestc_order_exec_() +#if FFESTR_F90 +#define ffestc_order_interfacespec_() ffestc_order_derivedtype_() +#endif +#define ffestc_shriek_if_lost_ ffestc_shriek_if_ +#if FFESTR_F90 +#define ffestc_shriek_where_lost_ ffestc_shriek_where_ +#endif + +/* ffestc_establish_declinfo_ -- Determine specific type/params info for entity + + ffestc_establish_declinfo_(kind,kind_token,len,len_token); + + Must be called after _declstmt_ called to establish base type. */ + +static void +ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len, + ffelexToken lent) +{ + ffeinfoBasictype bt = ffestc_local_.decl.basic_type; + ffeinfoKindtype kt; + ffetargetCharacterSize val; + + if (kindt == NULL) + kt = ffestc_local_.decl.stmt_kind_type; + else if (!ffestc_local_.decl.per_var_kind_ok) + { + ffebad_start (FFEBAD_KINDTYPE); + ffebad_here (0, ffelex_token_where_line (kindt), + ffelex_token_where_column (kindt)); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + kt = ffestc_local_.decl.stmt_kind_type; + } + else + { + if (kind == NULL) + { + assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (kindt)); + kt = ffestc_kindtype_star_ (bt, val); + } + else if (ffebld_op (kind) == FFEBLD_opANY) + kt = ffestc_local_.decl.stmt_kind_type; + else + { + assert (ffebld_op (kind) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (kind)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (kind)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (kind)); + kt = ffestc_kindtype_kind_ (bt, val); + } + + if (kt == FFEINFO_kindtypeNONE) + { /* Not valid kind type. */ + ffebad_start (FFEBAD_KINDTYPE); + ffebad_here (0, ffelex_token_where_line (kindt), + ffelex_token_where_column (kindt)); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + kt = ffestc_local_.decl.stmt_kind_type; + } + } + + ffestc_local_.decl.kind_type = kt; + + /* Now check length specification for CHARACTER data type. */ + + if (((len == NULL) && (lent == NULL)) + || (bt != FFEINFO_basictypeCHARACTER)) + val = ffestc_local_.decl.stmt_size; + else + { + if (len == NULL) + { + assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (lent)); + } + else if (ffebld_op (len) == FFEBLD_opSTAR) + val = FFETARGET_charactersizeNONE; + else if (ffebld_op (len) == FFEBLD_opANY) + val = FFETARGET_charactersizeNONE; + else + { + assert (ffebld_op (len) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (len)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (len)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (len)); + } + } + + if ((val == 0) && !(0 && ffe_is_90 ())) + { + val = 1; + ffebad_start (FFEBAD_ZERO_SIZE); + ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); + ffebad_finish (); + } + ffestc_local_.decl.size = val; +} + +/* ffestc_establish_declstmt_ -- Establish host-specific type/params info + + ffestc_establish_declstmt_(type,type_token,kind,kind_token,len, + len_token); */ + +static void +ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind, + ffelexToken kindt, ffebld len, ffelexToken lent) +{ + ffeinfoBasictype bt; + ffeinfoKindtype ktd; /* Default kindtype. */ + ffeinfoKindtype kt; + ffetargetCharacterSize val; + bool per_var_kind_ok = TRUE; + + /* Determine basictype and default kindtype. */ + + switch (type) + { + case FFESTP_typeINTEGER: + bt = FFEINFO_basictypeINTEGER; + ktd = FFEINFO_kindtypeINTEGERDEFAULT; + break; + + case FFESTP_typeBYTE: + bt = FFEINFO_basictypeINTEGER; + ktd = FFEINFO_kindtypeINTEGER2; + break; + + case FFESTP_typeWORD: + bt = FFEINFO_basictypeINTEGER; + ktd = FFEINFO_kindtypeINTEGER3; + break; + + case FFESTP_typeREAL: + bt = FFEINFO_basictypeREAL; + ktd = FFEINFO_kindtypeREALDEFAULT; + break; + + case FFESTP_typeCOMPLEX: + bt = FFEINFO_basictypeCOMPLEX; + ktd = FFEINFO_kindtypeREALDEFAULT; + break; + + case FFESTP_typeLOGICAL: + bt = FFEINFO_basictypeLOGICAL; + ktd = FFEINFO_kindtypeLOGICALDEFAULT; + break; + + case FFESTP_typeCHARACTER: + bt = FFEINFO_basictypeCHARACTER; + ktd = FFEINFO_kindtypeCHARACTERDEFAULT; + break; + + case FFESTP_typeDBLPRCSN: + bt = FFEINFO_basictypeREAL; + ktd = FFEINFO_kindtypeREALDOUBLE; + per_var_kind_ok = FALSE; + break; + + case FFESTP_typeDBLCMPLX: + bt = FFEINFO_basictypeCOMPLEX; +#if FFETARGET_okCOMPLEX2 + ktd = FFEINFO_kindtypeREALDOUBLE; +#else + ktd = FFEINFO_kindtypeREALDEFAULT; + ffebad_start (FFEBAD_BAD_DBLCMPLX); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); +#endif + per_var_kind_ok = FALSE; + break; + + default: + assert ("Unexpected type (F90 TYPE?)!" == NULL); + bt = FFEINFO_basictypeNONE; + ktd = FFEINFO_kindtypeNONE; + break; + } + + if (kindt == NULL) + kt = ktd; + else + { /* Not necessarily default kind type. */ + if (kind == NULL) + { /* Shouldn't happen for CHARACTER. */ + assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (kindt)); + kt = ffestc_kindtype_star_ (bt, val); + } + else if (ffebld_op (kind) == FFEBLD_opANY) + kt = ktd; + else + { + assert (ffebld_op (kind) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (kind)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (kind)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (kind)); + kt = ffestc_kindtype_kind_ (bt, val); + } + + if (kt == FFEINFO_kindtypeNONE) + { /* Not valid kind type. */ + ffebad_start (FFEBAD_KINDTYPE); + ffebad_here (0, ffelex_token_where_line (kindt), + ffelex_token_where_column (kindt)); + ffebad_here (1, ffelex_token_where_line (typet), + ffelex_token_where_column (typet)); + ffebad_finish (); + kt = ktd; + } + } + + ffestc_local_.decl.basic_type = bt; + ffestc_local_.decl.stmt_kind_type = kt; + ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok; + + /* Now check length specification for CHARACTER data type. */ + + if (((len == NULL) && (lent == NULL)) + || (type != FFESTP_typeCHARACTER)) + val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE; + else + { + if (len == NULL) + { + assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (lent)); + } + else if (ffebld_op (len) == FFEBLD_opSTAR) + val = FFETARGET_charactersizeNONE; + else if (ffebld_op (len) == FFEBLD_opANY) + val = FFETARGET_charactersizeNONE; + else + { + assert (ffebld_op (len) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (len)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (len)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (len)); + } + } + + if ((val == 0) && !(0 && ffe_is_90 ())) + { + val = 1; + ffebad_start (FFEBAD_ZERO_SIZE); + ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); + ffebad_finish (); + } + ffestc_local_.decl.stmt_size = val; +} + +/* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s) + + ffestc_establish_impletter_(first_letter_token,last_letter_token); */ + +static void +ffestc_establish_impletter_ (ffelexToken first, ffelexToken last) +{ + bool ok = FALSE; /* Stays FALSE if first letter > last. */ + char c; + + if (last == NULL) + ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)), + ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + ffestc_local_.decl.size); + else + { + for (c = *(ffelex_token_text (first)); + c <= *(ffelex_token_text (last)); + c++) + { + ok = ffeimplic_establish_initial (c, + ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + ffestc_local_.decl.size); + if (!ok) + break; + } + } + + if (!ok) + { + char cs[2]; + + cs[0] = c; + cs[1] = '\0'; + + ffebad_start (FFEBAD_BAD_IMPLICIT); + ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first)); + ffebad_string (cs); + ffebad_finish (); + } +} + +/* ffestc_init_3 -- Initialize ffestc for new program unit + + ffestc_init_3(); */ + +void +ffestc_init_3 () +{ + ffestv_save_state_ = FFESTV_savestateNONE; + ffestc_entry_num_ = 0; + ffestv_num_label_defines_ = 0; +} + +/* ffestc_init_4 -- Initialize ffestc for new scoping unit + + ffestc_init_4(); + + For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE- + defs, and statement function defs. */ + +void +ffestc_init_4 () +{ + ffestc_saved_entry_num_ = ffestc_entry_num_; + ffestc_entry_num_ = 0; +} + +/* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value + + ffeinfoKindtype kt; + ffeinfoBasictype bt; + ffetargetCharacterSize val; + kt = ffestc_kindtype_kind_(bt,val); + if (kt == FFEINFO_kindtypeNONE) + // unsupported/invalid KIND= value for type */ + +static ffeinfoKindtype +ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val) +{ + ffetype type; + ffetype base_type; + ffeinfoKindtype kt; + + base_type = ffeinfo_type (bt, 1); /* ~~ */ + assert (base_type != NULL); + + type = ffetype_lookup_kind (base_type, (int) val); + if (type == NULL) + return FFEINFO_kindtypeNONE; + + for (kt = 1; kt < FFEINFO_kindtype; ++kt) + if (ffeinfo_type (bt, kt) == type) + return kt; + + return FFEINFO_kindtypeNONE; +} + +/* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value + + ffeinfoKindtype kt; + ffeinfoBasictype bt; + ffetargetCharacterSize val; + kt = ffestc_kindtype_star_(bt,val); + if (kt == FFEINFO_kindtypeNONE) + // unsupported/invalid * value for type */ + +static ffeinfoKindtype +ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val) +{ + ffetype type; + ffetype base_type; + ffeinfoKindtype kt; + + base_type = ffeinfo_type (bt, 1); /* ~~ */ + assert (base_type != NULL); + + type = ffetype_lookup_star (base_type, (int) val); + if (type == NULL) + return FFEINFO_kindtypeNONE; + + for (kt = 1; kt < FFEINFO_kindtype; ++kt) + if (ffeinfo_type (bt, kt) == type) + return kt; + + return FFEINFO_kindtypeNONE; +} + +/* Define label as usable for anything without complaint. */ + +static void +ffestc_labeldef_any_ () +{ + if ((ffesta_label_token == NULL) + || !ffestc_labeldef_begin_ ()) + return; + + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_labeldef_begin_ -- Define label as unknown, initially + + ffestc_labeldef_begin_(); */ + +static bool +ffestc_labeldef_begin_ () +{ + ffelabValue label_value; + ffelab label; + + label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffestc_label_ = ffelab_new (label_value); + ffestv_num_label_defines_++; + ffelab_set_definition_line (label, + ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); + ffelab_set_definition_column (label, + ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); + + return TRUE; + } + + if (ffewhere_line_is_unknown (ffelab_definition_line (label))) + { + ffestv_num_label_defines_++; + ffestc_label_ = label; + ffelab_set_definition_line (label, + ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); + ffelab_set_definition_column (label, + ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); + + return TRUE; + } + + ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_definition_line (label), + ffelab_definition_column (label)); + ffebad_string (ffelex_token_text (ffesta_label_token)); + ffebad_finish (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; + return FALSE; +} + +/* ffestc_labeldef_branch_begin_ -- Define label as a branch target one + + ffestc_labeldef_branch_begin_(); */ + +static void +ffestc_labeldef_branch_begin_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_branch (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_stack_top ())) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_branch (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_branch (ffestc_label_); + /* Leave something around for _branch_end_() to handle. */ + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* Define possible end of labeled-DO-loop. Call only after calling + ffestc_labeldef_branch_begin_, or when other branch_* functions + recognize that a label might also be serving as a branch end (in + which case they must issue a diagnostic). */ + +static void +ffestc_labeldef_branch_end_ () +{ + if (ffesta_label_token == NULL) + return; + + assert (ffestc_label_ != NULL); + assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND) + || (ffelab_type (ffestc_label_) == FFELAB_typeANY)); + + while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO) + && (ffestw_label (ffestw_stack_top ()) == ffestc_label_)) + ffestc_shriek_do_ (TRUE); + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_endif_ -- Define label as an END IF one + + ffestc_labeldef_endif_(); */ + +static void +ffestc_labeldef_endif_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeENDIF); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); + ffestd_labeldef_endif (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); + ffestd_labeldef_endif (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_endif (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_format_ -- Define label as a FORMAT one + + ffestc_labeldef_format_(); */ + +static void +ffestc_labeldef_format_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL)) + { + ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + return; + } + + if (!ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT); + ffestd_labeldef_format (ffestc_label_); + break; + + case FFELAB_typeFORMAT: + ffestd_labeldef_format (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_format (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeNOTLOOP: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present + + ffestc_labeldef_invalid_(); */ + +static void +ffestc_labeldef_invalid_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + ffebad_start (FFEBAD_INVALID_LABEL_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* Define label as a non-loop-ending one on a statement that can't + be in the "then" part of a logical IF, such as a block-IF statement. */ + +static void +ffestc_labeldef_notloop_ () +{ + if (ffesta_label_token == NULL) + return; + + assert (ffestc_shriek_after1_ == NULL); + + if (!ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_stack_top ())) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_notloop (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* Define label as a non-loop-ending one. Use this when it is + possible that the pending label is inhibited because we're in + the midst of a logical-IF, and thus _branch_end_ is going to + be called after the current statement to resolve a potential + loop-ending label. */ + +static void +ffestc_labeldef_notloop_begin_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_stack_top ())) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_branch (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_useless_ -- Define label as a useless one + + ffestc_labeldef_useless_(); */ + +static void +ffestc_labeldef_useless_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS); + ffestd_labeldef_useless (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeASSIGNABLE: + case FFELAB_typeFORMAT: + case FFELAB_typeNOTLOOP: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt + + if (ffestc_labelref_is_assignable_(label_token,&label)) + // label ref is ok, label is filled in with ffelab object */ + +static bool +ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label) +{ + ffelab label; + ffelabValue label_value; + + label_value = (ffelabValue) atol (ffelex_token_text (label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + return FALSE; + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffelab_new (label_value); + ffelab_set_firstref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_firstref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + } + + switch (ffelab_type (label)) + { + case FFELAB_typeUNKNOWN: + ffelab_set_type (label, FFELAB_typeASSIGNABLE); + break; + + case FFELAB_typeASSIGNABLE: + case FFELAB_typeLOOPEND: + case FFELAB_typeFORMAT: + case FFELAB_typeNOTLOOP: + case FFELAB_typeENDIF: + break; + + case FFELAB_typeUSELESS: + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + *x_label = label; + return TRUE; +} + +/* ffestc_labelref_is_branch_ -- Reference to label in branch stmt + + if (ffestc_labelref_is_branch_(label_token,&label)) + // label ref is ok, label is filled in with ffelab object */ + +static bool +ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label) +{ + ffelab label; + ffelabValue label_value; + ffestw block; + unsigned long blocknum; + + label_value = (ffelabValue) atol (ffelex_token_text (label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + return FALSE; + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffelab_new (label_value); + ffelab_set_firstref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_firstref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + } + + switch (ffelab_type (label)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (label, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ())); + break; + + case FFELAB_typeLOOPEND: + if (ffelab_blocknum (label) != 0) + break; /* Already taken care of. */ + for (block = ffestw_top_do (ffestw_stack_top ()); + (block != NULL) && (ffestw_label (block) != label); + block = ffestw_top_do (ffestw_previous (block))) + ; /* Find most recent DO <label> ancestor. */ + if (block == NULL) + { /* Reference to within a (dead) block. */ + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelab_definition_line (label), + ffelab_definition_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + break; + } + ffelab_set_blocknum (label, ffestw_blocknum (block)); + ffelab_set_firstref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_firstref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + break; + + case FFELAB_typeNOTLOOP: + case FFELAB_typeENDIF: + if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ())) + break; + blocknum = ffelab_blocknum (label); + for (block = ffestw_stack_top (); + ffestw_blocknum (block) > blocknum; + block = ffestw_previous (block)) + ; /* Find most recent common ancestor. */ + if (ffelab_blocknum (label) == ffestw_blocknum (block)) + break; /* Check again. */ + if (!ffewhere_line_is_unknown (ffelab_definition_line (label))) + { /* Reference to within a (dead) block. */ + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelab_definition_line (label), + ffelab_definition_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + break; + } + ffelab_set_blocknum (label, ffestw_blocknum (block)); + break; + + case FFELAB_typeFORMAT: + if (ffewhere_line_is_unknown (ffelab_definition_line (label))) + { + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_USE); + ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + } + /* Fall through. */ + case FFELAB_typeUSELESS: + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + *x_label = label; + return TRUE; +} + +/* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification + + if (ffestc_labelref_is_format_(label_token,&label)) + // label ref is ok, label is filled in with ffelab object */ + +static bool +ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label) +{ + ffelab label; + ffelabValue label_value; + + label_value = (ffelabValue) atol (ffelex_token_text (label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + return FALSE; + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffelab_new (label_value); + ffelab_set_firstref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_firstref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + } + + switch (ffelab_type (label)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (label, FFELAB_typeFORMAT); + break; + + case FFELAB_typeFORMAT: + break; + + case FFELAB_typeLOOPEND: + case FFELAB_typeNOTLOOP: + if (ffewhere_line_is_unknown (ffelab_definition_line (label))) + { + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_USE); + ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + } + /* Fall through. */ + case FFELAB_typeUSELESS: + case FFELAB_typeENDIF: + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + *x_label = label; + return TRUE; +} + +/* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt + + if (ffestc_labelref_is_loopend_(label_token,&label)) + // label ref is ok, label is filled in with ffelab object */ + +static bool +ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label) +{ + ffelab label; + ffelabValue label_value; + + label_value = (ffelabValue) atol (ffelex_token_text (label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + return FALSE; + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffelab_new (label_value); + ffelab_set_doref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_doref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + } + + switch (ffelab_type (label)) + { + case FFELAB_typeASSIGNABLE: + ffelab_set_doref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_doref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + ffewhere_line_kill (ffelab_firstref_line (label)); + ffelab_set_firstref_line (label, ffewhere_line_unknown ()); + ffewhere_column_kill (ffelab_firstref_column (label)); + ffelab_set_firstref_column (label, ffewhere_column_unknown ()); + /* Fall through. */ + case FFELAB_typeUNKNOWN: + ffelab_set_type (label, FFELAB_typeLOOPEND); + ffelab_set_blocknum (label, 0); + break; + + case FFELAB_typeLOOPEND: + if (!ffewhere_line_is_unknown (ffelab_definition_line (label))) + { /* Def must follow all refs. */ + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_DEF_DO); + ffebad_here (0, ffelab_definition_line (label), + ffelab_definition_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + } + if (ffelab_blocknum (label) != 0) + { /* Had a branch ref earlier, can't go inside + this new block! */ + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_USE); + ffebad_here (0, ffelab_firstref_line (label), + ffelab_firstref_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + } + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != label)) + { /* Top of stack interrupts flow between two + DOs specifying label. */ + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO); + ffebad_here (0, ffelab_doref_line (label), + ffelab_doref_column (label)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + } + break; + + case FFELAB_typeNOTLOOP: + case FFELAB_typeFORMAT: + if (ffewhere_line_is_unknown (ffelab_definition_line (label))) + { + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_USE); + ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + } + /* Fall through. */ + case FFELAB_typeUSELESS: + case FFELAB_typeENDIF: + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + *x_label = label; + return TRUE; +} + +/* ffestc_order_access_ -- Check ordering on <access> statement + + if (ffestc_order_access_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_access_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE3: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement + + if (ffestc_order_actiondo_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_actiondo_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateDO: + return FFESTC_orderOK_; + + case FFESTV_stateIFTHEN: + case FFESTV_stateSELECT1: + if (ffestw_top_do (ffestw_stack_top ()) == NULL) + break; + return FFESTC_orderOK_; + + case FFESTV_stateIF: + if (ffestw_top_do (ffestw_stack_top ()) == NULL) + break; + ffestc_shriek_after1_ = ffestc_shriek_if_; + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + default: + break; + } + ffestc_order_bad_ (); + return FFESTC_orderBAD_; +} + +/* ffestc_order_actionif_ -- Check ordering on <actionif> statement + + if (ffestc_order_actionif_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_actionif_ () +{ + bool update; + +recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); + update = TRUE; + break; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); + update = TRUE; + break; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); + update = TRUE; + break; + + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + update = FALSE; + break; + + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateIF: + ffestc_shriek_after1_ = ffestc_shriek_if_; + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } + + switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) + { + case FFESTV_stateINTERFACE0: + ffestc_order_bad_ (); + if (update) + ffestw_update (NULL); + return FFESTC_orderBAD_; + + default: + if (update) + ffestw_update (NULL); + return FFESTC_orderOK_; + } +} + +/* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement + + if (ffestc_order_actionwhere_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_actionwhere_ () +{ + bool update; + +recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); + update = TRUE; + break; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); + update = TRUE; + break; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); + update = TRUE; + break; + + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + update = FALSE; + break; + + case FFESTV_stateWHERETHEN: + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: +#if FFESTR_F90 + ffestc_shriek_after1_ = ffestc_shriek_where_; +#endif + return FFESTC_orderOK_; + + case FFESTV_stateIF: + ffestc_shriek_after1_ = ffestc_shriek_if_; + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } + + switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) + { + case FFESTV_stateINTERFACE0: + ffestc_order_bad_ (); + if (update) + ffestw_update (NULL); + return FFESTC_orderBAD_; + + default: + if (update) + ffestw_update (NULL); + return FFESTC_orderOK_; + } +} + +/* Check ordering on "any" statement. Like _actionwhere_, but + doesn't produce any diagnostics. */ + +static void +ffestc_order_any_ () +{ + bool update; + +recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); + update = TRUE; + break; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); + update = TRUE; + break; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); + update = TRUE; + break; + + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + update = FALSE; + break; + + case FFESTV_stateWHERETHEN: + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT1: + return; + + case FFESTV_stateWHERE: +#if FFESTR_F90 + ffestc_shriek_after1_ = ffestc_shriek_where_; +#endif + return; + + case FFESTV_stateIF: + ffestc_shriek_after1_ = ffestc_shriek_if_; + return; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + default: + return; + } + + switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) + { + case FFESTV_stateINTERFACE0: + if (update) + ffestw_update (NULL); + return; + + default: + if (update) + ffestw_update (NULL); + return; + } +} + +/* ffestc_order_bad_ -- Whine about statement ordering violation + + ffestc_order_bad_(); + + Uses current ffesta_tokens[0] and, if available, info on where current + state started to produce generic message. Someday we should do + fancier things than this, but this just gets things creaking along for + now. */ + +static void +ffestc_order_bad_ () +{ + if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ()))) + { + ffebad_start (FFEBAD_ORDER_1); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + else + { + ffebad_start (FFEBAD_ORDER_2); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + ffestc_labeldef_useless_ (); /* Any label definition is useless. */ +} + +/* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement + + if (ffestc_order_blockdata_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_blockdata_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + case FFESTV_stateBLOCKDATA3: + case FFESTV_stateBLOCKDATA4: + case FFESTV_stateBLOCKDATA5: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement + + if (ffestc_order_blockspec_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_blockspec_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + case FFESTV_stateBLOCKDATA3: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_component_ -- Check ordering on <component-decl> statement + + if (ffestc_order_component_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_component_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateTYPE: + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_contains_ -- Check ordering on CONTAINS statement + + if (ffestc_order_contains_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_contains_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + case FFESTV_statePROGRAM4: + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5); + break; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateSUBROUTINE4: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5); + break; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + case FFESTV_stateFUNCTION4: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5); + break; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + case FFESTV_stateMODULE3: + case FFESTV_stateMODULE4: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5); + break; + + case FFESTV_stateUSE: + ffestc_shriek_end_uses_ (TRUE); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } + + switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) + { + case FFESTV_stateNIL: + ffestw_update (NULL); + return FFESTC_orderOK_; + + default: + ffestc_order_bad_ (); + ffestw_update (NULL); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_data_ -- Check ordering on DATA statement + + if (ffestc_order_data_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_data_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM2: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION2: + case FFESTV_stateBLOCKDATA2: + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateBLOCKDATA3: + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + case FFESTV_stateBLOCKDATA4: + case FFESTV_stateWHERETHEN: + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT0: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement + + if (ffestc_order_data77_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_data77_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + case FFESTV_stateBLOCKDATA3: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + case FFESTV_stateBLOCKDATA4: + return FFESTC_orderOK_; + + case FFESTV_stateWHERETHEN: + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT0: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement + + if (ffestc_order_derivedtype_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_derivedtype_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: + ffestc_shriek_end_uses_ (TRUE); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_do_ -- Check ordering on <do> statement + + if (ffestc_order_do_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_do_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateDO: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_entry_ -- Check ordering on ENTRY statement + + if (ffestc_order_entry_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_entry_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateSUBROUTINE0: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1); + break; + + case FFESTV_stateFUNCTION0: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1); + break; + + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + break; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } + + switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) + { + case FFESTV_stateNIL: + case FFESTV_stateMODULE5: + ffestw_update (NULL); + return FFESTC_orderOK_; + + default: + ffestc_order_bad_ (); + ffestw_update (NULL); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_exec_ -- Check ordering on <exec> statement + + if (ffestc_order_exec_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_exec_ () +{ + bool update; + +recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4); + update = TRUE; + break; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4); + update = TRUE; + break; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4); + update = TRUE; + break; + + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + update = FALSE; + break; + + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } + + switch (ffestw_state (ffestw_previous (ffestw_stack_top ()))) + { + case FFESTV_stateINTERFACE0: + ffestc_order_bad_ (); + if (update) + ffestw_update (NULL); + return FFESTC_orderBAD_; + + default: + if (update) + ffestw_update (NULL); + return FFESTC_orderOK_; + } +} + +/* ffestc_order_format_ -- Check ordering on FORMAT statement + + if (ffestc_order_format_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_format_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + case FFESTV_stateWHERETHEN: + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT0: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_function_ -- Check ordering on <function> statement + + if (ffestc_order_function_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_function_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + case FFESTV_stateFUNCTION4: + case FFESTV_stateFUNCTION5: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_iface_ -- Check ordering on <iface> statement + + if (ffestc_order_iface_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_iface_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + case FFESTV_statePROGRAM5: + case FFESTV_stateSUBROUTINE5: + case FFESTV_stateFUNCTION5: + case FFESTV_stateMODULE5: + case FFESTV_stateINTERFACE0: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement + + if (ffestc_order_ifthen_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_ifthen_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateIFTHEN: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement + + if (ffestc_order_implicit_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_implicit_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM2: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION2: + case FFESTV_stateMODULE2: + case FFESTV_stateBLOCKDATA2: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement + + if (ffestc_order_implicitnone_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_implicitnone_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_interface_ -- Check ordering on <interface> statement + + if (ffestc_order_interface_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_interface_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateINTERFACE0: + case FFESTV_stateINTERFACE1: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_map_ -- Check ordering on <map> statement + + if (ffestc_order_map_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_VXT +static ffestcOrder_ +ffestc_order_map_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateMAP: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_module_ -- Check ordering on <module> statement + + if (ffestc_order_module_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_module_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + case FFESTV_stateMODULE3: + case FFESTV_stateMODULE4: + case FFESTV_stateMODULE5: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: + ffestc_shriek_end_uses_ (TRUE); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_parameter_ -- Check ordering on <parameter> statement + + if (ffestc_order_parameter_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_parameter_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM2: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION2: + case FFESTV_stateMODULE2: + case FFESTV_stateBLOCKDATA2: + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + case FFESTV_stateBLOCKDATA3: + case FFESTV_stateTYPE: /* GNU extension here! */ + case FFESTV_stateSTRUCTURE: + case FFESTV_stateUNION: + case FFESTV_stateMAP: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_program_ -- Check ordering on <program> statement + + if (ffestc_order_program_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_program_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + case FFESTV_statePROGRAM3: + case FFESTV_statePROGRAM4: + case FFESTV_statePROGRAM5: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_progspec_ -- Check ordering on <progspec> statement + + if (ffestc_order_progspec_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_progspec_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2); + if (ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_BLOCKDATA_STMT); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_record_ -- Check ordering on RECORD statement + + if (ffestc_order_record_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_VXT +static ffestcOrder_ +ffestc_order_record_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + case FFESTV_stateBLOCKDATA3: + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement + + if (ffestc_order_selectcase_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_selectcase_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateSELECT0: + case FFESTV_stateSELECT1: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_sfunc_ -- Check ordering on statement-function definition + + if (ffestc_order_sfunc_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_sfunc_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_spec_ -- Check ordering on <spec> statement + + if (ffestc_order_spec_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_spec_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_structure_ -- Check ordering on <structure> statement + + if (ffestc_order_structure_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_VXT +static ffestcOrder_ +ffestc_order_structure_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateSTRUCTURE: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement + + if (ffestc_order_subroutine_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_subroutine_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateSUBROUTINE5: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_type_ -- Check ordering on <type> statement + + if (ffestc_order_type_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_type_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateTYPE: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement + + if (ffestc_order_typedecl_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_typedecl_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + case FFESTV_stateBLOCKDATA3: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_union_ -- Check ordering on <union> statement + + if (ffestc_order_union_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_VXT +static ffestcOrder_ +ffestc_order_union_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateUNION: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_unit_ -- Check ordering on <unit> statement + + if (ffestc_order_unit_() != FFESTC_orderOK_) + return; */ + +static ffestcOrder_ +ffestc_order_unit_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +/* ffestc_order_use_ -- Check ordering on USE statement + + if (ffestc_order_use_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_use_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1); + ffestc_shriek_begin_uses_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateSUBROUTINE0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1); + ffestc_shriek_begin_uses_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateFUNCTION0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1); + ffestc_shriek_begin_uses_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateMODULE0: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1); + ffestc_shriek_begin_uses_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateUSE: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement + + if (ffestc_order_vxtstructure_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_VXT +static ffestcOrder_ +ffestc_order_vxtstructure_ () +{ + recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_statePROGRAM1: + case FFESTV_statePROGRAM2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3); + return FFESTC_orderOK_; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3); + return FFESTC_orderOK_; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3); + return FFESTC_orderOK_; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3); + return FFESTC_orderOK_; + + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + ffestw_update (NULL); + ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3); + return FFESTC_orderOK_; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + case FFESTV_stateBLOCKDATA3: + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + return FFESTC_orderOK_; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); +#if FFESTR_F90 + ffestc_shriek_where_ (FALSE); +#endif + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* ffestc_order_where_ -- Check ordering on <where> statement + + if (ffestc_order_where_() != FFESTC_orderOK_) + return; */ + +#if FFESTR_F90 +static ffestcOrder_ +ffestc_order_where_ () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateWHERETHEN: + return FFESTC_orderOK_; + + case FFESTV_stateWHERE: + ffestc_order_bad_ (); + ffestc_shriek_where_ (FALSE); + return FFESTC_orderBAD_; + + case FFESTV_stateIF: + ffestc_order_bad_ (); + ffestc_shriek_if_ (FALSE); + return FFESTC_orderBAD_; + + default: + ffestc_order_bad_ (); + return FFESTC_orderBAD_; + } +} + +#endif +/* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and + ENTRY (prior to the first executable statement). */ + +static void +ffestc_promote_dummy_ (ffelexToken t) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffebld e; + bool sfref_ok; + + assert (t != NULL); + + if (ffelex_token_type (t) == FFELEX_typeASTERISK) + { + ffebld_append_item (&ffestc_local_.dummy.list_bottom, + ffebld_new_star ()); + return; /* Don't bother with alternate returns! */ + } + + s = ffesymbol_declare_local (t, FALSE); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + sfref_ok = FALSE; + + if (sa & FFESYMBOL_attrsANY) + na = sa; + else if (sa & FFESYMBOL_attrsDUMMY) + { + if (ffestc_entry_num_ == ffesymbol_maxentrynum (s)) + { /* Seen this one twice in this list! */ + na = FFESYMBOL_attrsetNONE; + } + else + na = sa; + sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef + previously, since already declared as a + dummy arg. */ + } + else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsANY + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsANYSIZE + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsDUMMY; + else + na = FFESYMBOL_attrsetNONE; + + if (!ffesymbol_is_specable (s) + && (!sfref_ok + || (ffesymbol_where (s) != FFEINFO_whereDUMMY))) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_maxentrynum (s, ffestc_entry_num_); + ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1); + e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (e, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE)); + ffebld_append_item (&ffestc_local_.dummy.list_bottom, e); + ffesymbol_signal_unreported (s); + } +} + +/* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context + + ffestc_promote_execdummy_(t); + + Invoked for each token in dummy arg list of ENTRY when the statement + follows the first executable statement. */ + +static void +ffestc_promote_execdummy_ (ffelexToken t) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffesymbolState ss; + ffesymbolState ns; + ffeinfoKind kind; + ffeinfoWhere where; + ffebld e; + + assert (t != NULL); + + if (ffelex_token_type (t) == FFELEX_typeASTERISK) + { + ffebld_append_item (&ffestc_local_.dummy.list_bottom, + ffebld_new_star ()); + return; /* Don't bother with alternate returns! */ + } + + s = ffesymbol_declare_local (t, FALSE); + na = sa = ffesymbol_attrs (s); + ss = ffesymbol_state (s); + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + if (ffestc_entry_num_ == ffesymbol_maxentrynum (s)) + { /* Seen this one twice in this list! */ + na = FFESYMBOL_attrsetNONE; + } + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */ + + switch (kind) + { + case FFEINFO_kindENTITY: + case FFEINFO_kindFUNCTION: + case FFEINFO_kindSUBROUTINE: + break; /* These are fine, as far as we know. */ + + case FFEINFO_kindNONE: + if (sa & FFESYMBOL_attrsDUMMY) + ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */ + else if (sa & FFESYMBOL_attrsANYLEN) + { + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereDUMMY; + } + else if (sa & FFESYMBOL_attrsACTUALARG) + na = FFESYMBOL_attrsetNONE; + else + { + na = sa | FFESYMBOL_attrsDUMMY; + ns = FFESYMBOL_stateUNCERTAIN; + } + break; + + default: + na = FFESYMBOL_attrsetNONE; /* Error. */ + break; + } + + switch (where) + { + case FFEINFO_whereDUMMY: + break; /* This is fine. */ + + case FFEINFO_whereNONE: + where = FFEINFO_whereDUMMY; + break; + + default: + na = FFESYMBOL_attrsetNONE; /* Error. */ + break; + } + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, ns); + ffesymbol_set_maxentrynum (s, ffestc_entry_num_); + ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1); + if ((ns == FFESYMBOL_stateUNDERSTOOD) + && (kind != FFEINFO_kindSUBROUTINE) + && !ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return; + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, + where, + ffesymbol_size (s))); + e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s))); + ffebld_append_item (&ffestc_local_.dummy.list_bottom, e); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); + } +} + +/* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable + + ffestc_promote_sfdummy_(t); + + Invoked for each token in dummy arg list of statement function. + + 22-Oct-91 JCB 1.1 + Reject arg if CHARACTER*(*). */ + +static void +ffestc_promote_sfdummy_ (ffelexToken t) +{ + ffesymbol s; + ffesymbol sp; /* Parent symbol. */ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffebld e; + + assert (t != NULL); + + s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj; + also sets sfa_dummy_parent to + parent symbol. */ + if (ffesymbol_state (s) != FFESYMBOL_stateNONE) + { + ffesymbol_error (s, t); /* Dummy already in list. */ + return; + } + + sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used + for dummy. */ + sa = ffesymbol_attrs (sp); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (sp) + && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY) + || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL) + && (ffesymbol_where (sp) != FFEINFO_whereCOMMON) + && (ffesymbol_where (sp) != FFEINFO_whereDUMMY) + && (ffesymbol_where (sp) != FFEINFO_whereNONE)))) + na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */ + else if (sa & FFESYMBOL_attrsANY) + na = sa; + else if (!(sa & ~(FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsRESULT + | FFESYMBOL_attrsSAVE + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsSFARG; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + { + ffesymbol_error (sp, t); + ffesymbol_set_info (s, ffeinfo_new_any ()); + } + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); + ffesymbol_set_attrs (sp, na); + if (!ffeimplic_establish_symbol (sp) + || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER) + && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE))) + ffesymbol_error (sp, t); + else + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (sp), + ffesymbol_kindtype (sp), + 0, + FFEINFO_kindENTITY, + FFEINFO_whereDUMMY, + ffesymbol_size (sp))); + + ffesymbol_signal_unreported (sp); + } + + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++); + ffesymbol_signal_unreported (s); + e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s))); + ffebld_append_item (&ffestc_local_.dummy.list_bottom, e); +} + +/* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement + + ffestc_shriek_begin_program_(); + + Invoked only when a PROGRAM statement is NOT present at the beginning + of a main program unit. */ + +static void +ffestc_shriek_begin_program_ () +{ + ffestw b; + ffesymbol s; + + ffestc_blocknum_ = 0; + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_statePROGRAM0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_end_program_); + ffestw_set_name (b, NULL); + + s = ffesymbol_declare_programunit (NULL, + ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + + /* Special case: this is one symbol that won't go through + ffestu_exec_transition_ when the first statement in a main program is + executable, because the transition happens in ffest before ffestc is + reached and triggers the implicit generation of a main program. So we + do the exec transition for the implicit main program right here, just + for cleanliness' sake (at the very least). */ + + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindPROGRAM, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + + ffesymbol_signal_unreported (s); + + ffestd_R1102 (s, NULL); +} + +/* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements + + ffestc_shriek_begin_uses_(); + + Invoked before handling the first USE statement in a block of one or + more USE statements. _end_uses_(bool ok) is invoked before handling + the first statement after the block (there are no BEGIN USE and END USE + statements, but the semantics of USE statements effectively requires + handling them as a single block rather than one statement at a time). */ + +#if FFESTR_F90 +static void +ffestc_shriek_begin_uses_ () +{ + ffestw b; + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateUSE); + ffestw_set_blocknum (b, 0); + ffestw_set_shriek (b, ffestc_shriek_end_uses_); + + ffestd_begin_uses (); +} + +#endif +/* ffestc_shriek_blockdata_ -- End a BLOCK DATA + + ffestc_shriek_blockdata_(TRUE); */ + +static void +ffestc_shriek_blockdata_ (bool ok) +{ + if (!ffesta_seen_first_exec) + { + ffesta_seen_first_exec = TRUE; + ffestd_exec_begin (); + } + + ffestd_R1112 (ok); + + ffestd_exec_end (); + + if (ffestw_name (ffestw_stack_top ()) != NULL) + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + + ffe_terminate_2 (); + ffe_init_2 (); +} + +/* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc + + ffestc_shriek_do_(TRUE); + + Also invoked by _labeldef_branch_end_ (or, in cases + of errors, other _labeldef_ functions) when the label definition is + for a DO-target (LOOPEND) label, once per matching/outstanding DO + block on the stack. These cases invoke this function with ok==TRUE, so + only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE. */ + +static void +ffestc_shriek_do_ (bool ok) +{ + ffelab l; + + if (((l = ffestw_label (ffestw_stack_top ())) != NULL) + && (ffewhere_line_is_unknown (ffelab_definition_line (l)))) + { /* DO target is label that is still + undefined. */ + assert ((ffelab_type (l) == FFELAB_typeLOOPEND) + || (ffelab_type (l) == FFELAB_typeANY)); + if (ffelab_type (l) != FFELAB_typeANY) + { + ffelab_set_definition_line (l, + ffewhere_line_use (ffelab_doref_line (l))); + ffelab_set_definition_column (l, + ffewhere_column_use (ffelab_doref_column (l))); + ffestv_num_label_defines_++; + } + ffestd_labeldef_branch (l); + } + + ffestd_do (ok); + + if (ffestw_name (ffestw_stack_top ()) != NULL) + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL) + ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ())); + if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL) + ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE); + ffestw_kill (ffestw_pop ()); +} + +/* ffestc_shriek_end_program_ -- End a PROGRAM + + ffestc_shriek_end_program_(); */ + +static void +ffestc_shriek_end_program_ (bool ok) +{ + if (!ffesta_seen_first_exec) + { + ffesta_seen_first_exec = TRUE; + ffestd_exec_begin (); + } + + ffestd_R1103 (ok); + + ffestd_exec_end (); + + if (ffestw_name (ffestw_stack_top ()) != NULL) + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + + ffe_terminate_2 (); + ffe_init_2 (); +} + +/* ffestc_shriek_end_uses_ -- End a bunch of USE statements + + ffestc_shriek_end_uses_(TRUE); + + ok==TRUE means simply not popping due to ffestc_eof() + being called, because there is no formal END USES statement in Fortran. */ + +#if FFESTR_F90 +static void +ffestc_shriek_end_uses_ (bool ok) +{ + ffestd_end_uses (ok); + + ffestw_kill (ffestw_pop ()); +} + +#endif +/* ffestc_shriek_function_ -- End a FUNCTION + + ffestc_shriek_function_(TRUE); */ + +static void +ffestc_shriek_function_ (bool ok) +{ + if (!ffesta_seen_first_exec) + { + ffesta_seen_first_exec = TRUE; + ffestd_exec_begin (); + } + + ffestd_R1221 (ok); + + ffestd_exec_end (); + + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + ffesta_is_entry_valid = FALSE; + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffe_terminate_2 (); + ffe_init_2 (); + break; + + default: + ffe_terminate_3 (); + ffe_init_3 (); + break; + + case FFESTV_stateINTERFACE0: + ffe_terminate_4 (); + ffe_init_4 (); + break; + } +} + +/* ffestc_shriek_if_ -- End of statement following logical IF + + ffestc_shriek_if_(TRUE); + + Applies ONLY to logical IF, not to IF-THEN. For example, does not + ffelex_token_kill the construct name for an IF-THEN block (the name + field is invalid for logical IF). ok==TRUE iff statement following + logical IF (substatement) is valid; else, statement is invalid or + stack forcibly popped due to ffestc_eof(). */ + +static void +ffestc_shriek_if_ (bool ok) +{ + ffestd_end_R807 (ok); + + ffestw_kill (ffestw_pop ()); + ffestc_shriek_after1_ = NULL; + + ffestc_try_shriek_do_ (); +} + +/* ffestc_shriek_ifthen_ -- End an IF-THEN + + ffestc_shriek_ifthen_(TRUE); */ + +static void +ffestc_shriek_ifthen_ (bool ok) +{ + ffestd_R806 (ok); + + if (ffestw_name (ffestw_stack_top ()) != NULL) + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +/* ffestc_shriek_interface_ -- End an INTERFACE + + ffestc_shriek_interface_(TRUE); */ + +#if FFESTR_F90 +static void +ffestc_shriek_interface_ (bool ok) +{ + ffestd_R1203 (ok); + + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_shriek_map_ -- End a MAP + + ffestc_shriek_map_(TRUE); */ + +#if FFESTR_VXT +static void +ffestc_shriek_map_ (bool ok) +{ + ffestd_V013 (ok); + + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_shriek_module_ -- End a MODULE + + ffestc_shriek_module_(TRUE); */ + +#if FFESTR_F90 +static void +ffestc_shriek_module_ (bool ok) +{ + if (!ffesta_seen_first_exec) + { + ffesta_seen_first_exec = TRUE; + ffestd_exec_begin (); + } + + ffestd_R1106 (ok); + + ffestd_exec_end (); + + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + + ffe_terminate_2 (); + ffe_init_2 (); +} + +#endif +/* ffestc_shriek_select_ -- End a SELECT + + ffestc_shriek_select_(TRUE); */ + +static void +ffestc_shriek_select_ (bool ok) +{ + ffestwSelect s; + ffestwCase c; + + ffestd_R811 (ok); + + if (ffestw_name (ffestw_stack_top ()) != NULL) + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + s = ffestw_select (ffestw_stack_top ()); + ffelex_token_kill (s->t); + for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel) + ffelex_token_kill (c->t); + malloc_pool_kill (s->pool); + + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +/* ffestc_shriek_structure_ -- End a STRUCTURE + + ffestc_shriek_structure_(TRUE); */ + +#if FFESTR_VXT +static void +ffestc_shriek_structure_ (bool ok) +{ + ffestd_V004 (ok); + + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_shriek_subroutine_ -- End a SUBROUTINE + + ffestc_shriek_subroutine_(TRUE); */ + +static void +ffestc_shriek_subroutine_ (bool ok) +{ + if (!ffesta_seen_first_exec) + { + ffesta_seen_first_exec = TRUE; + ffestd_exec_begin (); + } + + ffestd_R1225 (ok); + + ffestd_exec_end (); + + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + ffesta_is_entry_valid = FALSE; + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffe_terminate_2 (); + ffe_init_2 (); + break; + + default: + ffe_terminate_3 (); + ffe_init_3 (); + break; + + case FFESTV_stateINTERFACE0: + ffe_terminate_4 (); + ffe_init_4 (); + break; + } +} + +/* ffestc_shriek_type_ -- End a TYPE + + ffestc_shriek_type_(TRUE); */ + +#if FFESTR_F90 +static void +ffestc_shriek_type_ (bool ok) +{ + ffestd_R425 (ok); + + ffe_terminate_4 (); + + ffelex_token_kill (ffestw_name (ffestw_stack_top ())); + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_shriek_union_ -- End a UNION + + ffestc_shriek_union_(TRUE); */ + +#if FFESTR_VXT +static void +ffestc_shriek_union_ (bool ok) +{ + ffestd_V010 (ok); + + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_shriek_where_ -- Implicit END WHERE statement + + ffestc_shriek_where_(TRUE); + + Implement the end of the current WHERE "block". ok==TRUE iff statement + following WHERE (substatement) is valid; else, statement is invalid + or stack forcibly popped due to ffestc_eof(). */ + +#if FFESTR_F90 +static void +ffestc_shriek_where_ (bool ok) +{ + ffestd_R745 (ok); + + ffestw_kill (ffestw_pop ()); + ffestc_shriek_after1_ = NULL; + if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF) + ffestc_shriek_if_ (TRUE); /* "IF (x) WHERE (y) stmt" is only valid + case. */ + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_shriek_wherethen_ -- End a WHERE(-THEN) + + ffestc_shriek_wherethen_(TRUE); */ + +#if FFESTR_F90 +static void +ffestc_shriek_wherethen_ (bool ok) +{ + ffestd_end_R740 (ok); + + ffestw_kill (ffestw_pop ()); + + ffestc_try_shriek_do_ (); +} + +#endif +/* ffestc_subr_binsrch_ -- Binary search of char const in list of strings + + i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc"); + + search_list contains search_list_size char *'s, spec is checked to see + if it is a char constant and, if so, is binary-searched against the list. + 0 is returned if not found, else the "classic" index (beginning with 1) + is returned. Before returning 0 where the search was performed but + fruitless, if "etc" is a non-NULL char *, an error message is displayed + using "etc" as the pick-one-of-these string. */ + +static int +ffestc_subr_binsrch_ (char **list, int size, ffestpFile *spec, char *whine) +{ + int lowest_tested; + int highest_tested; + int halfway; + int offset; + int c; + char *str; + int len; + + if (size == 0) + return 0; /* Nobody should pass size == 0, but for + elegance.... */ + + lowest_tested = -1; + highest_tested = size; + halfway = size >> 1; + + list += halfway; + + c = ffestc_subr_speccmp_ (*list, spec, &str, &len); + if (c == 2) + return 0; + c = -c; /* Sigh. */ + +next: /* :::::::::::::::::::: */ + switch (c) + { + case -1: + offset = (halfway - lowest_tested) >> 1; + if (offset == 0) + goto nope; /* :::::::::::::::::::: */ + highest_tested = halfway; + list -= offset; + halfway -= offset; + c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list); + goto next; /* :::::::::::::::::::: */ + + case 0: + return halfway + 1; + + case 1: + offset = (highest_tested - halfway) >> 1; + if (offset == 0) + goto nope; /* :::::::::::::::::::: */ + lowest_tested = halfway; + list += offset; + halfway += offset; + c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list); + goto next; /* :::::::::::::::::::: */ + + default: + assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL); + break; + } + +nope: /* :::::::::::::::::::: */ + ffebad_start (FFEBAD_SPEC_VALUE); + ffebad_here (0, ffelex_token_where_line (spec->value), + ffelex_token_where_column (spec->value)); + ffebad_string (whine); + ffebad_finish (); + return 0; +} + +/* ffestc_subr_format_ -- Return summary of format specifier + + ffestc_subr_format_(&specifier); */ + +static ffestvFormat +ffestc_subr_format_ (ffestpFile *spec) +{ + if (!spec->kw_or_val_present) + return FFESTV_formatNONE; + assert (spec->value_present); + if (spec->value_is_label) + return FFESTV_formatLABEL; /* Ok if not a label. */ + + assert (spec->value != NULL); + if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR) + return FFESTV_formatASTERISK; + + if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST) + return FFESTV_formatNAMELIST; + + if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0) + return FFESTV_formatCHAREXPR; /* F77 C5. */ + + switch (ffeinfo_basictype (ffebld_info (spec->u.expr))) + { + case FFEINFO_basictypeINTEGER: + return FFESTV_formatINTEXPR; + + case FFEINFO_basictypeCHARACTER: + return FFESTV_formatCHAREXPR; + + case FFEINFO_basictypeANY: + return FFESTV_formatASTERISK; + + default: + assert ("bad basictype" == NULL); + return FFESTV_formatINTEXPR; + } +} + +/* ffestc_subr_is_branch_ -- Handle specifier as branch target label + + ffestc_subr_is_branch_(&specifier); */ + +static bool +ffestc_subr_is_branch_ (ffestpFile *spec) +{ + if (!spec->kw_or_val_present) + return TRUE; + assert (spec->value_present); + assert (spec->value_is_label); + spec->value_is_label++; /* For checking purposes only; 1=>2. */ + return ffestc_labelref_is_branch_ (spec->value, &spec->u.label); +} + +/* ffestc_subr_is_format_ -- Handle specifier as format target label + + ffestc_subr_is_format_(&specifier); */ + +static bool +ffestc_subr_is_format_ (ffestpFile *spec) +{ + if (!spec->kw_or_val_present) + return TRUE; + assert (spec->value_present); + if (!spec->value_is_label) + return TRUE; /* Ok if not a label. */ + + spec->value_is_label++; /* For checking purposes only; 1=>2. */ + return ffestc_labelref_is_format_ (spec->value, &spec->u.label); +} + +/* ffestc_subr_is_present_ -- Ensure specifier is present, else error + + ffestc_subr_is_present_("SPECIFIER",&specifier); */ + +static bool +ffestc_subr_is_present_ (char *name, ffestpFile *spec) +{ + if (spec->kw_or_val_present) + { + assert (spec->value_present); + return TRUE; + } + + ffebad_start (FFEBAD_MISSING_SPECIFIER); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_string (name); + ffebad_finish (); + return FALSE; +} + +/* ffestc_subr_speccmp_ -- Compare string to constant expression, if present + + if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0) + // specifier value is present and is a char constant "CONSTANT" + + Like strcmp, except the return values are defined as: -1 returned in place + of strcmp's generic negative value, 1 in place of it's generic positive + value, and 2 when there is no character constant string to compare. Also, + a case-insensitive comparison is performed, where string is assumed to + already be in InitialCaps form. + + If a non-NULL pointer is provided as the char **target, then *target is + written with NULL if 2 is returned, a pointer to the constant string + value of the specifier otherwise. Similarly, length is written with + 0 if 2 is returned, the length of the constant string value otherwise. */ + +static int +ffestc_subr_speccmp_ (char *string, ffestpFile *spec, char **target, + int *length) +{ + ffebldConstant c; + int i; + + if (!spec->kw_or_val_present || !spec->value_present + || (spec->u.expr == NULL) + || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER)) + { + if (target != NULL) + *target = NULL; + if (length != NULL) + *length = 0; + return 2; + } + + if (ffebld_constant_type (c = ffebld_conter (spec->u.expr)) + != FFEBLD_constCHARACTERDEFAULT) + { + if (target != NULL) + *target = NULL; + if (length != NULL) + *length = 0; + return 2; + } + + if (target != NULL) + *target = ffebld_constant_characterdefault (c).text; + if (length != NULL) + *length = ffebld_constant_characterdefault (c).length; + + i = ffesrc_strcmp_1ns2i (ffe_case_match (), + ffebld_constant_characterdefault (c).text, + ffebld_constant_characterdefault (c).length, + string); + if (i == 0) + return 0; + if (i > 0) + return -1; /* Yes indeed, we reverse the strings to + _strcmpin_. */ + return 1; +} + +/* ffestc_subr_unit_ -- Return summary of unit specifier + + ffestc_subr_unit_(&specifier); */ + +static ffestvUnit +ffestc_subr_unit_ (ffestpFile *spec) +{ + if (!spec->kw_or_val_present) + return FFESTV_unitNONE; + assert (spec->value_present); + assert (spec->value != NULL); + + if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR) + return FFESTV_unitASTERISK; + + switch (ffeinfo_basictype (ffebld_info (spec->u.expr))) + { + case FFEINFO_basictypeINTEGER: + return FFESTV_unitINTEXPR; + + case FFEINFO_basictypeCHARACTER: + return FFESTV_unitCHAREXPR; + + case FFEINFO_basictypeANY: + return FFESTV_unitASTERISK; + + default: + assert ("bad basictype" == NULL); + return FFESTV_unitINTEXPR; + } +} + +/* Call this function whenever it's possible that one or more top + stack items are label-targeting DO blocks that have had their + labels defined, but at a time when they weren't at the top of the + stack. This prevents uninformative diagnostics for programs + like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END". */ + +static void +ffestc_try_shriek_do_ () +{ + ffelab lab; + ffelabType ty; + + while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO) + && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL) + && (((ty = (ffelab_type (lab))) + == FFELAB_typeANY) + || (ty == FFELAB_typeUSELESS) + || (ty == FFELAB_typeFORMAT) + || (ty == FFELAB_typeNOTLOOP) + || (ty == FFELAB_typeENDIF))) + ffestc_shriek_do_ (FALSE); +} + +/* ffestc_decl_start -- R426 or R501 + + ffestc_decl_start(...); + + Verify that R426 component-def-stmt or R501 type-declaration-stmt are + valid here, figure out which one, and implement. */ + +void +ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind, + ffelexToken kindt, ffebld len, ffelexToken lent) +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + case FFESTV_statePROGRAM0: + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateFUNCTION0: + case FFESTV_stateMODULE0: + case FFESTV_stateBLOCKDATA0: + case FFESTV_statePROGRAM1: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateFUNCTION1: + case FFESTV_stateMODULE1: + case FFESTV_stateBLOCKDATA1: + case FFESTV_statePROGRAM2: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION2: + case FFESTV_stateMODULE2: + case FFESTV_stateBLOCKDATA2: + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateMODULE3: + case FFESTV_stateBLOCKDATA3: + case FFESTV_stateUSE: + ffestc_local_.decl.is_R426 = 2; + break; + + case FFESTV_stateTYPE: + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + ffestc_local_.decl.is_R426 = 1; + break; + + default: + ffestc_order_bad_ (); + ffestc_labeldef_useless_ (); + ffestc_local_.decl.is_R426 = 0; + return; + } + + switch (ffestc_local_.decl.is_R426) + { +#if FFESTR_F90 + case 1: + ffestc_R426_start (type, typet, kind, kindt, len, lent); + break; +#endif + + case 2: + ffestc_R501_start (type, typet, kind, kindt, len, lent); + break; + + default: + ffestc_labeldef_useless_ (); + break; + } +} + +/* ffestc_decl_attrib -- R426 or R501 type attribute + + ffestc_decl_attrib(...); + + Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute + is valid here and implement. */ + +void +ffestc_decl_attrib (ffestpAttrib attrib UNUSED, + ffelexToken attribt UNUSED, + ffestrOther intent_kw UNUSED, + ffesttDimList dims UNUSED) +{ +#if FFESTR_F90 + switch (ffestc_local_.decl.is_R426) + { + case 1: + ffestc_R426_attrib (attrib, attribt, intent_kw, dims); + break; + + case 2: + ffestc_R501_attrib (attrib, attribt, intent_kw, dims); + break; + + default: + break; + } +#else + ffebad_start (FFEBAD_F90); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + return; +#endif +} + +/* ffestc_decl_item -- R426 or R501 + + ffestc_decl_item(...); + + Establish type for a particular object. */ + +void +ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt, + ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init, + ffelexToken initt, bool clist) +{ + switch (ffestc_local_.decl.is_R426) + { +#if FFESTR_F90 + case 1: + ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt, + clist); + break; +#endif + + case 2: + ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt, + clist); + break; + + default: + break; + } +} + +/* ffestc_decl_itemstartvals -- R426 or R501 start list of values + + ffestc_decl_itemstartvals(); + + Gonna specify values for the object now. */ + +void +ffestc_decl_itemstartvals () +{ + switch (ffestc_local_.decl.is_R426) + { +#if FFESTR_F90 + case 1: + ffestc_R426_itemstartvals (); + break; +#endif + + case 2: + ffestc_R501_itemstartvals (); + break; + + default: + break; + } +} + +/* ffestc_decl_itemvalue -- R426 or R501 source value + + ffestc_decl_itemvalue(repeat,repeat_token,value,value_token); + + Make sure repeat and value are valid for the object being initialized. */ + +void +ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token, + ffebld value, ffelexToken value_token) +{ + switch (ffestc_local_.decl.is_R426) + { +#if FFESTR_F90 + case 1: + ffestc_R426_itemvalue (repeat, repeat_token, value, value_token); + break; +#endif + + case 2: + ffestc_R501_itemvalue (repeat, repeat_token, value, value_token); + break; + + default: + break; + } +} + +/* ffestc_decl_itemendvals -- R426 or R501 end list of values + + ffelexToken t; // the SLASH token that ends the list. + ffestc_decl_itemendvals(t); + + No more values, might specify more objects now. */ + +void +ffestc_decl_itemendvals (ffelexToken t) +{ + switch (ffestc_local_.decl.is_R426) + { +#if FFESTR_F90 + case 1: + ffestc_R426_itemendvals (t); + break; +#endif + + case 2: + ffestc_R501_itemendvals (t); + break; + + default: + break; + } +} + +/* ffestc_decl_finish -- R426 or R501 + + ffestc_decl_finish(); + + Just wrap up any local activities. */ + +void +ffestc_decl_finish () +{ + switch (ffestc_local_.decl.is_R426) + { +#if FFESTR_F90 + case 1: + ffestc_R426_finish (); + break; +#endif + + case 2: + ffestc_R501_finish (); + break; + + default: + break; + } +} + +/* ffestc_elsewhere -- Generic ELSE WHERE statement + + ffestc_end(); + + Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */ + +void +ffestc_elsewhere (ffelexToken where) +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateIFTHEN: + ffestc_R805 (where); + break; + + default: +#if FFESTR_F90 + ffestc_R744 (); +#endif + break; + } +} + +/* ffestc_end -- Generic END statement + + ffestc_end(); + + Make sure a generic END is valid in the current context, and implement + it. */ + +void +ffestc_end () +{ + ffestw b; + + b = ffestw_stack_top (); + +recurse: + + switch (ffestw_state (b)) + { + case FFESTV_stateBLOCKDATA0: + case FFESTV_stateBLOCKDATA1: + case FFESTV_stateBLOCKDATA2: + case FFESTV_stateBLOCKDATA3: + case FFESTV_stateBLOCKDATA4: + case FFESTV_stateBLOCKDATA5: + ffestc_R1112 (NULL); + break; + + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + case FFESTV_stateFUNCTION4: + case FFESTV_stateFUNCTION5: + if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL) + && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0)) + { + ffebad_start (FFEBAD_END_WO); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b))); + ffebad_string ("FUNCTION"); + ffebad_finish (); + } + ffestc_R1221 (NULL); + break; + + case FFESTV_stateMODULE0: + case FFESTV_stateMODULE1: + case FFESTV_stateMODULE2: + case FFESTV_stateMODULE3: + case FFESTV_stateMODULE4: + case FFESTV_stateMODULE5: +#if FFESTR_F90 + ffestc_R1106 (NULL); +#endif + break; + + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateSUBROUTINE5: + if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL) + && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0)) + { + ffebad_start (FFEBAD_END_WO); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b))); + ffebad_string ("SUBROUTINE"); + ffebad_finish (); + } + ffestc_R1225 (NULL); + break; + + case FFESTV_stateUSE: + b = ffestw_previous (ffestw_stack_top ()); + goto recurse; /* :::::::::::::::::::: */ + + default: + ffestc_R1103 (NULL); + break; + } +} + +/* ffestc_eof -- Generic EOF + + ffestc_eof(); + + Make sure we're at state NIL, or issue an error message and use each + block's shriek function to clean up to state NIL. */ + +void +ffestc_eof () +{ + if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL) + { + ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END); + ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + do + (*ffestw_shriek (ffestw_stack_top ()))(FALSE); + while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL); + } +} + +/* ffestc_exec_transition -- Check if ok and move stmt state to executable + + if (ffestc_exec_transition()) + // Transition successful (kind of like a CONTINUE stmt was seen). + + If the current statement state is a non-nested specification state in + which, say, a CONTINUE statement would be valid, then enter the state + we'd be in after seeing CONTINUE (without, of course, generating any + CONTINUE code), call ffestd_exec_begin, and return TRUE. Otherwise + return FALSE. + + This function cannot be invoked once the first executable statement + is seen. This function may choose to always return TRUE by shrieking + away any interceding state stack entries to reach the base level of + specification state, but right now it doesn't, and it is (or should + be) purely an issue of how one wishes errors to be handled (for example, + an unrecognized statement in the middle of a STRUCTURE construct: after + the error message, should subsequent statements still be interpreted as + being within the construct, or should the construct be terminated upon + seeing the unrecognized statement? we do the former at the moment). */ + +bool +ffestc_exec_transition () +{ + bool update; + +recurse: + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + ffestc_shriek_begin_program_ (); + goto recurse; /* :::::::::::::::::::: */ + + case FFESTV_statePROGRAM0: + case FFESTV_stateSUBROUTINE0: + case FFESTV_stateFUNCTION0: + case FFESTV_stateBLOCKDATA0: + ffestw_state (ffestw_stack_top ()) += 4; /* To state UNIT4. */ + update = TRUE; + break; + + case FFESTV_statePROGRAM1: + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateFUNCTION1: + case FFESTV_stateBLOCKDATA1: + ffestw_state (ffestw_stack_top ()) += 3; /* To state UNIT4. */ + update = TRUE; + break; + + case FFESTV_statePROGRAM2: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateFUNCTION2: + case FFESTV_stateBLOCKDATA2: + ffestw_state (ffestw_stack_top ()) += 2; /* To state UNIT4. */ + update = TRUE; + break; + + case FFESTV_statePROGRAM3: + case FFESTV_stateSUBROUTINE3: + case FFESTV_stateFUNCTION3: + case FFESTV_stateBLOCKDATA3: + ffestw_state (ffestw_stack_top ()) += 1; /* To state UNIT4. */ + update = TRUE; + break; + + case FFESTV_stateUSE: +#if FFESTR_F90 + ffestc_shriek_end_uses_ (TRUE); +#endif + goto recurse; /* :::::::::::::::::::: */ + + default: + return FALSE; + } + + if (update) + ffestw_update (NULL); /* Update state line/col info. */ + + ffesta_seen_first_exec = TRUE; + ffestd_exec_begin (); + + return TRUE; +} + +/* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var + + ffesymbol s; + // call ffebad_start first, of course. + ffestc_ffebad_here_doiter(0,s); + // call ffebad_finish afterwards, naturally. + + Searches the stack of blocks backwards for a DO loop that has s + as its iteration variable, then calls ffebad_here with pointers to + that particular reference to the variable. Crashes if the DO loop + can't be found. */ + +void +ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s) +{ + ffestw block; + + for (block = ffestw_top_do (ffestw_stack_top ()); + (block != NULL) && (ffestw_blocknum (block) != 0); + block = ffestw_top_do (ffestw_previous (block))) + { + if (ffestw_do_iter_var (block) == s) + { + ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)), + ffelex_token_where_column (ffestw_do_iter_var_t (block))); + return; + } + } + assert ("no do block found" == NULL); +} + +/* ffestc_is_decl_not_R1219 -- Context information for FFESTB + + if (ffestc_is_decl_not_R1219()) ... + + When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)" + is seen, call this function. It returns TRUE if the statement's context + is such that it is a declaration of an object named + "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE + if the statement's context is such that it begins the definition of a + function named "name" havin the dummy argument list "name-list" (this + is the R1219 function-stmt case). */ + +bool +ffestc_is_decl_not_R1219 () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateNIL: + case FFESTV_statePROGRAM5: + case FFESTV_stateSUBROUTINE5: + case FFESTV_stateFUNCTION5: + case FFESTV_stateMODULE5: + case FFESTV_stateINTERFACE0: + return FALSE; + + default: + return TRUE; + } +} + +/* ffestc_is_entry_in_subr -- Context information for FFESTB + + if (ffestc_is_entry_in_subr()) ... + + When a statement with the form "ENTRY name(name-list)" + is seen, call this function. It returns TRUE if the statement's context + is such that it may have "*", meaning alternate return, in place of + names in the name list (i.e. if the ENTRY is in a subroutine context). + It also returns TRUE if the ENTRY is not in a function context (invalid + but prevents extra complaints about "*", if present). It returns FALSE + if the ENTRY is in a function context. */ + +bool +ffestc_is_entry_in_subr () +{ + ffestvState s; + + s = ffestw_state (ffestw_stack_top ()); + +recurse: + + switch (s) + { + case FFESTV_stateFUNCTION0: + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + case FFESTV_stateFUNCTION4: + return FALSE; + + case FFESTV_stateUSE: + s = ffestw_state (ffestw_previous (ffestw_stack_top ())); + goto recurse; /* :::::::::::::::::::: */ + + default: + return TRUE; + } +} + +/* ffestc_is_let_not_V027 -- Context information for FFESTB + + if (ffestc_is_let_not_V027()) ... + + When a statement with the form "PARAMETERname=expr" + is seen, call this function. It returns TRUE if the statement's context + is such that it is an assignment to an object named "PARAMETERname", FALSE + if the statement's context is such that it is a V-extension PARAMETER + statement that is like a PARAMETER(name=expr) statement except that the + type of name is determined by the type of expr, not the implicit or + explicit typing of name. */ + +bool +ffestc_is_let_not_V027 () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + case FFESTV_stateWHERETHEN: + case FFESTV_stateIFTHEN: + case FFESTV_stateDO: + case FFESTV_stateSELECT0: + case FFESTV_stateSELECT1: + case FFESTV_stateWHERE: + case FFESTV_stateIF: + return TRUE; + + default: + return FALSE; + } +} + +/* ffestc_module -- MODULE or MODULE PROCEDURE statement + + ffestc_module(module_name_token,procedure_name_token); + + Decide which is intended, and implement it by calling _R1105_ or + _R1205_. */ + +#if FFESTR_F90 +void +ffestc_module (ffelexToken module, ffelexToken procedure) +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateINTERFACE0: + case FFESTV_stateINTERFACE1: + ffestc_R1205_start (); + ffestc_R1205_item (procedure); + ffestc_R1205_finish (); + break; + + default: + ffestc_R1105 (module); + break; + } +} + +#endif +/* ffestc_private -- Generic PRIVATE statement + + ffestc_end(); + + This is either a PRIVATE within R422 derived-type statement or an + R521 PRIVATE statement. Figure it out based on context and implement + it, or produce an error. */ + +#if FFESTR_F90 +void +ffestc_private () +{ + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateTYPE: + ffestc_R423A (); + break; + + default: + ffestc_R521B (); + break; + } +} + +#endif +/* ffestc_terminate_4 -- Terminate ffestc after scoping unit + + ffestc_terminate_4(); + + For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE- + defs, and statement function defs. */ + +void +ffestc_terminate_4 () +{ + ffestc_entry_num_ = ffestc_saved_entry_num_; +} + +/* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement) + + ffestc_R423A(); */ + +#if FFESTR_F90 +void +ffestc_R423A () +{ + ffestc_check_simple_ (); + if (ffestc_order_type_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 0) + { + ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + return; + } + + if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3) + { + ffebad_start (FFEBAD_DERIVTYP_ACCESS); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + return; + } + + ffestw_set_substate (ffestw_stack_top (), 1); /* Seen + private-sequence-stmt. */ + + ffestd_R423A (); +} + +/* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt) + + ffestc_R423B(); */ + +void +ffestc_R423B () +{ + ffestc_check_simple_ (); + if (ffestc_order_type_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 0) + { + ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + return; + } + + ffestw_set_substate (ffestw_stack_top (), 1); /* Seen + private-sequence-stmt. */ + + ffestd_R423B (); +} + +/* ffestc_R424 -- derived-TYPE-def statement + + ffestc_R424(access_token,access_kw,name_token); + + Handle a derived-type definition. */ + +void +ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name) +{ + ffestw b; + + assert (name != NULL); + + ffestc_check_simple_ (); + if (ffestc_order_derivedtype_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if ((access != NULL) + && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3)) + { + ffebad_start (FFEBAD_DERIVTYP_ACCESS); + ffebad_here (0, ffelex_token_where_line (access), + ffelex_token_where_column (access)); + ffebad_finish (); + access = NULL; + } + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateTYPE); + ffestw_set_blocknum (b, 0); + ffestw_set_shriek (b, ffestc_shriek_type_); + ffestw_set_name (b, ffelex_token_use (name)); + ffestw_set_substate (b, 0); /* Awaiting private-sequence-stmt and one + component-def-stmt. */ + + ffestd_R424 (access, access_kw, name); + + ffe_init_4 (); +} + +/* ffestc_R425 -- END TYPE statement + + ffestc_R425(name_token); + + Make sure ffestc_kind_ identifies a TYPE definition. If not + NULL, make sure name_token gives the correct name. Implement the end + of the type definition. */ + +void +ffestc_R425 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_type_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 2) + { + ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + if ((name != NULL) + && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) + { + ffebad_start (FFEBAD_TYPE_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + + ffestc_shriek_type_ (TRUE); +} + +/* ffestc_R426_start -- component-declaration-stmt + + ffestc_R426_start(...); + + Verify that R426 component-declaration-stmt is + valid here and implement. */ + +void +ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind, + ffelexToken kindt, ffebld len, ffelexToken lent) +{ + ffestc_check_start_ (); + if (ffestc_order_component_ () != FFESTC_orderOK_) + { + ffestc_local_.decl.is_R426 = 0; + return; + } + ffestc_labeldef_useless_ (); + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one + member. */ + break; + + case FFESTV_stateTYPE: + ffestw_set_substate (ffestw_stack_top (), 2); + break; + + default: + assert ("Component parent state invalid" == NULL); + break; + } +} + +/* ffestc_R426_attrib -- type attribute + + ffestc_R426_attrib(...); + + Verify that R426 component-declaration-stmt attribute + is valid here and implement. */ + +void +ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt, + ffestrOther intent_kw, ffesttDimList dims) +{ + ffestc_check_attrib_ (); +} + +/* ffestc_R426_item -- declared object + + ffestc_R426_item(...); + + Establish type for a particular object. */ + +void +ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt, + ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init, + ffelexToken initt, bool clist) +{ + ffestc_check_item_ (); + assert (name != NULL); + assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */ + assert (kind == NULL); /* No way an expression should get here. */ + + if ((dims != NULL) || (init != NULL) || clist) + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); +} + +/* ffestc_R426_itemstartvals -- Start list of values + + ffestc_R426_itemstartvals(); + + Gonna specify values for the object now. */ + +void +ffestc_R426_itemstartvals () +{ + ffestc_check_item_startvals_ (); +} + +/* ffestc_R426_itemvalue -- Source value + + ffestc_R426_itemvalue(repeat,repeat_token,value,value_token); + + Make sure repeat and value are valid for the object being initialized. */ + +void +ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token, + ffebld value, ffelexToken value_token) +{ + ffestc_check_item_value_ (); +} + +/* ffestc_R426_itemendvals -- End list of values + + ffelexToken t; // the SLASH token that ends the list. + ffestc_R426_itemendvals(t); + + No more values, might specify more objects now. */ + +void +ffestc_R426_itemendvals (ffelexToken t) +{ + ffestc_check_item_endvals_ (); +} + +/* ffestc_R426_finish -- Done + + ffestc_R426_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R426_finish () +{ + ffestc_check_finish_ (); +} + +#endif +/* ffestc_R501_start -- type-declaration-stmt + + ffestc_R501_start(...); + + Verify that R501 type-declaration-stmt is + valid here and implement. */ + +void +ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind, + ffelexToken kindt, ffebld len, ffelexToken lent) +{ + ffestc_check_start_ (); + if (ffestc_order_typedecl_ () != FFESTC_orderOK_) + { + ffestc_local_.decl.is_R426 = 0; + return; + } + ffestc_labeldef_useless_ (); + + ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent); +} + +/* ffestc_R501_attrib -- type attribute + + ffestc_R501_attrib(...); + + Verify that R501 type-declaration-stmt attribute + is valid here and implement. */ + +void +ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt, + ffestrOther intent_kw UNUSED, + ffesttDimList dims UNUSED) +{ + ffestc_check_attrib_ (); + + switch (attrib) + { +#if FFESTR_F90 + case FFESTP_attribALLOCATABLE: + break; +#endif + + case FFESTP_attribDIMENSION: + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + break; + + case FFESTP_attribEXTERNAL: + break; + +#if FFESTR_F90 + case FFESTP_attribINTENT: + break; +#endif + + case FFESTP_attribINTRINSIC: + break; + +#if FFESTR_F90 + case FFESTP_attribOPTIONAL: + break; +#endif + + case FFESTP_attribPARAMETER: + break; + +#if FFESTR_F90 + case FFESTP_attribPOINTER: + break; +#endif + +#if FFESTR_F90 + case FFESTP_attribPRIVATE: + break; + + case FFESTP_attribPUBLIC: + break; +#endif + + case FFESTP_attribSAVE: + switch (ffestv_save_state_) + { + case FFESTV_savestateNONE: + ffestv_save_state_ = FFESTV_savestateSPECIFIC; + ffestv_save_line_ + = ffewhere_line_use (ffelex_token_where_line (attribt)); + ffestv_save_col_ + = ffewhere_column_use (ffelex_token_where_column (attribt)); + break; + + case FFESTV_savestateSPECIFIC: + case FFESTV_savestateANY: + break; + + case FFESTV_savestateALL: + if (ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_CONFLICTING_SAVES); + ffebad_here (0, ffestv_save_line_, ffestv_save_col_); + ffebad_here (1, ffelex_token_where_line (attribt), + ffelex_token_where_column (attribt)); + ffebad_finish (); + } + ffestv_save_state_ = FFESTV_savestateANY; + break; + + default: + assert ("unexpected save state" == NULL); + break; + } + break; + +#if FFESTR_F90 + case FFESTP_attribTARGET: + break; +#endif + + default: + assert ("unexpected attribute" == NULL); + break; + } +} + +/* ffestc_R501_item -- declared object + + ffestc_R501_item(...); + + Establish type for a particular object. */ + +void +ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt, + ffesttDimList dims, ffebld len, ffelexToken lent, + ffebld init, ffelexToken initt, bool clist) +{ + ffesymbol s; + ffesymbol sfn; /* FUNCTION symbol. */ + ffebld array_size; + ffebld extents; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffestpDimtype nd; + bool is_init = (init != NULL) || clist; + bool is_assumed; + bool is_ugly_assumed; + ffeinfoRank rank; + + ffestc_check_item_ (); + assert (name != NULL); + assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */ + assert (kind == NULL); /* No way an expression should get here. */ + + ffestc_establish_declinfo_ (kind, kindt, len, lent); + + is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER) + && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE); + + if ((dims != NULL) || is_init) + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + s = ffesymbol_declare_local (name, TRUE); + sa = ffesymbol_attrs (s); + + /* First figure out what kind of object this is based solely on the current + object situation (type params, dimension list, and initialization). */ + + na = FFESYMBOL_attrsTYPE; + + if (is_assumed) + na |= FFESYMBOL_attrsANYLEN; + + is_ugly_assumed = (ffe_is_ugly_assumed () + && ((sa & FFESYMBOL_attrsDUMMY) + || (ffesymbol_where (s) == FFEINFO_whereDUMMY))); + + nd = ffestt_dimlist_type (dims, is_ugly_assumed); + switch (nd) + { + case FFESTP_dimtypeNONE: + break; + + case FFESTP_dimtypeKNOWN: + na |= FFESYMBOL_attrsARRAY; + break; + + case FFESTP_dimtypeADJUSTABLE: + na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE; + break; + + case FFESTP_dimtypeASSUMED: + na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE; + break; + + case FFESTP_dimtypeADJUSTABLEASSUMED: + na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYSIZE; + break; + + default: + assert ("unexpected dimtype" == NULL); + na = FFESYMBOL_attrsetNONE; + break; + } + + if (!ffesta_is_entry_valid + && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY)) + == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY)))) + na = FFESYMBOL_attrsetNONE; + + if (is_init) + { + if (na == FFESYMBOL_attrsetNONE) + ; + else if (na & (FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYSIZE)) + na = FFESYMBOL_attrsetNONE; + else + na |= FFESYMBOL_attrsINIT; + } + + /* Now figure out what kind of object we've got based on previous + declarations of or references to the object. */ + + if (na == FFESYMBOL_attrsetNONE) + ; + else if (!ffesymbol_is_specable (s) + && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT) + && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)) + || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT)))) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't + dimension/init UNDERSTOODs. */ + else if (sa & FFESYMBOL_attrsANY) + na = sa; + else if ((sa & na) + || ((sa & (FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsADJUSTS)) + && (na & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsANYLEN))) + || ((sa & FFESYMBOL_attrsRESULT) + && (na & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsINIT))) + || ((sa & (FFESYMBOL_attrsSFUNC + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsINTRINSIC + | FFESYMBOL_attrsINIT)) + && (na & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsINIT))) + || ((sa & FFESYMBOL_attrsARRAY) + && !ffesta_is_entry_valid + && (na & FFESYMBOL_attrsANYLEN)) + || ((sa & (FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsANYSIZE + | FFESYMBOL_attrsDUMMY)) + && (na & FFESYMBOL_attrsINIT)) + || ((sa & (FFESYMBOL_attrsSAVE + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsEQUIV)) + && (na & (FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsANYSIZE)))) + na = FFESYMBOL_attrsetNONE; + else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY) + && (ffesymbol_where (s) == FFEINFO_whereCONSTANT) + && (na & FFESYMBOL_attrsANYLEN)) + { /* If CHARACTER*(*) FOO after PARAMETER FOO. */ + na |= FFESYMBOL_attrsTYPE; + ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s)); + } + else + na |= sa; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + { + ffesymbol_error (s, name); + ffestc_parent_ok_ = FALSE; + } + else if (na & FFESYMBOL_attrsANY) + ffestc_parent_ok_ = FALSE; + else + { + ffesymbol_set_attrs (s, na); + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + rank = ffesymbol_rank (s); + if (dims != NULL) + { + ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank, + &array_size, + &extents, + is_ugly_assumed)); + ffesymbol_set_arraysize (s, array_size); + ffesymbol_set_extents (s, extents); + if (!(0 && ffe_is_90 ()) + && (ffebld_op (array_size) == FFEBLD_opCONTER) + && (ffebld_constant_integerdefault (ffebld_conter (array_size)) + == 0)) + { + ffebad_start (FFEBAD_ZERO_ARRAY); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_finish (); + } + } + if (init != NULL) + { + ffesymbol_set_init (s, + ffeexpr_convert (init, initt, name, + ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + rank, + ffestc_local_.decl.size, + FFEEXPR_contextDATA)); + ffecom_notify_init_symbol (s); + ffesymbol_update_init (s); +#if FFEGLOBAL_ENABLED + if (ffesymbol_common (s) != NULL) + ffeglobal_init_common (ffesymbol_common (s), initt); +#endif + } + else if (clist) + { + ffebld symter; + + symter = ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + + ffebld_set_info (symter, + ffeinfo_new (ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + rank, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + ffestc_local_.decl.size)); + ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL); + } + if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE) + { + ffesymbol_set_info (s, + ffeinfo_new (ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + rank, + ffesymbol_kind (s), + ffesymbol_where (s), + ffestc_local_.decl.size)); + if ((na & FFESYMBOL_attrsRESULT) + && ((sfn = ffesymbol_funcresult (s)) != NULL)) + { + ffesymbol_set_info (sfn, + ffeinfo_new (ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + rank, + ffesymbol_kind (sfn), + ffesymbol_where (sfn), + ffestc_local_.decl.size)); + ffesymbol_signal_unreported (sfn); + } + } + else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s)) + || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s)) + || ((ffestc_local_.decl.basic_type + == FFEINFO_basictypeCHARACTER) + && (ffestc_local_.decl.size != ffesymbol_size (s)))) + { /* Explicit type disagrees with established + implicit type. */ + ffesymbol_error (s, name); + } + + if ((na & FFESYMBOL_attrsADJUSTS) + && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER) + || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1))) + ffesymbol_error (s, name); + + ffesymbol_signal_unreported (s); + ffestc_parent_ok_ = TRUE; + } +} + +/* ffestc_R501_itemstartvals -- Start list of values + + ffestc_R501_itemstartvals(); + + Gonna specify values for the object now. */ + +void +ffestc_R501_itemstartvals () +{ + ffestc_check_item_startvals_ (); + + if (ffestc_parent_ok_) + ffedata_begin (ffestc_local_.decl.initlist); +} + +/* ffestc_R501_itemvalue -- Source value + + ffestc_R501_itemvalue(repeat,repeat_token,value,value_token); + + Make sure repeat and value are valid for the object being initialized. */ + +void +ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token, + ffebld value, ffelexToken value_token) +{ + ffetargetIntegerDefault rpt; + + ffestc_check_item_value_ (); + + if (!ffestc_parent_ok_) + return; + + if (repeat == NULL) + rpt = 1; + else if (ffebld_op (repeat) == FFEBLD_opCONTER) + rpt = ffebld_constant_integerdefault (ffebld_conter (repeat)); + else + { + ffestc_parent_ok_ = FALSE; + ffedata_end (TRUE, NULL); + return; + } + + if (!(ffestc_parent_ok_ = ffedata_value (rpt, value, + (repeat_token == NULL) ? value_token : repeat_token))) + ffedata_end (TRUE, NULL); +} + +/* ffestc_R501_itemendvals -- End list of values + + ffelexToken t; // the SLASH token that ends the list. + ffestc_R501_itemendvals(t); + + No more values, might specify more objects now. */ + +void +ffestc_R501_itemendvals (ffelexToken t) +{ + ffestc_check_item_endvals_ (); + + if (ffestc_parent_ok_) + ffestc_parent_ok_ = ffedata_end (FALSE, t); + + if (ffestc_parent_ok_) + ffesymbol_signal_unreported (ffebld_symter (ffebld_head + (ffestc_local_.decl.initlist))); +} + +/* ffestc_R501_finish -- Done + + ffestc_R501_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R501_finish () +{ + ffestc_check_finish_ (); +} + +/* ffestc_R519_start -- INTENT statement list begin + + ffestc_R519_start(); + + Verify that INTENT is valid here, and begin accepting items in the list. */ + +#if FFESTR_F90 +void +ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw) +{ + ffestc_check_start_ (); + if (ffestc_order_spec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R519_start (intent_kw); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R519_item -- INTENT statement for name + + ffestc_R519_item(name_token); + + Make sure name_token identifies a valid object to be INTENTed. */ + +void +ffestc_R519_item (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_R519_item (name); +} + +/* ffestc_R519_finish -- INTENT statement list complete + + ffestc_R519_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R519_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R519_finish (); +} + +/* ffestc_R520_start -- OPTIONAL statement list begin + + ffestc_R520_start(); + + Verify that OPTIONAL is valid here, and begin accepting items in the list. */ + +void +ffestc_R520_start () +{ + ffestc_check_start_ (); + if (ffestc_order_spec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R520_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R520_item -- OPTIONAL statement for name + + ffestc_R520_item(name_token); + + Make sure name_token identifies a valid object to be OPTIONALed. */ + +void +ffestc_R520_item (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_R520_item (name); +} + +/* ffestc_R520_finish -- OPTIONAL statement list complete + + ffestc_R520_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R520_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R520_finish (); +} + +/* ffestc_R521A -- PUBLIC statement + + ffestc_R521A(); + + Verify that PUBLIC is valid here. */ + +void +ffestc_R521A () +{ + ffestc_check_simple_ (); + if (ffestc_order_access_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + switch (ffestv_access_state_) + { + case FFESTV_accessstateNONE: + ffestv_access_state_ = FFESTV_accessstatePUBLIC; + ffestv_access_line_ + = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); + ffestv_access_col_ + = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); + break; + + case FFESTV_accessstateANY: + break; + + case FFESTV_accessstatePUBLIC: + case FFESTV_accessstatePRIVATE: + ffebad_start (FFEBAD_CONFLICTING_ACCESSES); + ffebad_here (0, ffestv_access_line_, ffestv_access_col_); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + ffestv_access_state_ = FFESTV_accessstateANY; + break; + + default: + assert ("unexpected access state" == NULL); + break; + } + + ffestd_R521A (); +} + +/* ffestc_R521Astart -- PUBLIC statement list begin + + ffestc_R521Astart(); + + Verify that PUBLIC is valid here, and begin accepting items in the list. */ + +void +ffestc_R521Astart () +{ + ffestc_check_start_ (); + if (ffestc_order_access_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R521Astart (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R521Aitem -- PUBLIC statement for name + + ffestc_R521Aitem(name_token); + + Make sure name_token identifies a valid object to be PUBLICed. */ + +void +ffestc_R521Aitem (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_R521Aitem (name); +} + +/* ffestc_R521Afinish -- PUBLIC statement list complete + + ffestc_R521Afinish(); + + Just wrap up any local activities. */ + +void +ffestc_R521Afinish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R521Afinish (); +} + +/* ffestc_R521B -- PRIVATE statement + + ffestc_R521B(); + + Verify that PRIVATE is valid here (outside a derived-type statement). */ + +void +ffestc_R521B () +{ + ffestc_check_simple_ (); + if (ffestc_order_access_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + switch (ffestv_access_state_) + { + case FFESTV_accessstateNONE: + ffestv_access_state_ = FFESTV_accessstatePRIVATE; + ffestv_access_line_ + = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); + ffestv_access_col_ + = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); + break; + + case FFESTV_accessstateANY: + break; + + case FFESTV_accessstatePUBLIC: + case FFESTV_accessstatePRIVATE: + ffebad_start (FFEBAD_CONFLICTING_ACCESSES); + ffebad_here (0, ffestv_access_line_, ffestv_access_col_); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + ffestv_access_state_ = FFESTV_accessstateANY; + break; + + default: + assert ("unexpected access state" == NULL); + break; + } + + ffestd_R521B (); +} + +/* ffestc_R521Bstart -- PRIVATE statement list begin + + ffestc_R521Bstart(); + + Verify that PRIVATE is valid here, and begin accepting items in the list. */ + +void +ffestc_R521Bstart () +{ + ffestc_check_start_ (); + if (ffestc_order_access_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R521Bstart (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R521Bitem -- PRIVATE statement for name + + ffestc_R521Bitem(name_token); + + Make sure name_token identifies a valid object to be PRIVATEed. */ + +void +ffestc_R521Bitem (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_R521Bitem (name); +} + +/* ffestc_R521Bfinish -- PRIVATE statement list complete + + ffestc_R521Bfinish(); + + Just wrap up any local activities. */ + +void +ffestc_R521Bfinish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R521Bfinish (); +} + +#endif +/* ffestc_R522 -- SAVE statement with no list + + ffestc_R522(); + + Verify that SAVE is valid here, and flag everything as SAVEd. */ + +void +ffestc_R522 () +{ + ffestc_check_simple_ (); + if (ffestc_order_blockspec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + switch (ffestv_save_state_) + { + case FFESTV_savestateNONE: + ffestv_save_state_ = FFESTV_savestateALL; + ffestv_save_line_ + = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); + ffestv_save_col_ + = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); + break; + + case FFESTV_savestateANY: + break; + + case FFESTV_savestateSPECIFIC: + case FFESTV_savestateALL: + if (ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_CONFLICTING_SAVES); + ffebad_here (0, ffestv_save_line_, ffestv_save_col_); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + ffestv_save_state_ = FFESTV_savestateALL; + break; + + default: + assert ("unexpected save state" == NULL); + break; + } + + ffe_set_is_saveall (TRUE); + + ffestd_R522 (); +} + +/* ffestc_R522start -- SAVE statement list begin + + ffestc_R522start(); + + Verify that SAVE is valid here, and begin accepting items in the list. */ + +void +ffestc_R522start () +{ + ffestc_check_start_ (); + if (ffestc_order_blockspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + switch (ffestv_save_state_) + { + case FFESTV_savestateNONE: + ffestv_save_state_ = FFESTV_savestateSPECIFIC; + ffestv_save_line_ + = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0])); + ffestv_save_col_ + = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0])); + break; + + case FFESTV_savestateSPECIFIC: + case FFESTV_savestateANY: + break; + + case FFESTV_savestateALL: + if (ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_CONFLICTING_SAVES); + ffebad_here (0, ffestv_save_line_, ffestv_save_col_); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + ffestv_save_state_ = FFESTV_savestateANY; + break; + + default: + assert ("unexpected save state" == NULL); + break; + } + + ffestd_R522start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R522item_object -- SAVE statement for object-name + + ffestc_R522item_object(name_token); + + Make sure name_token identifies a valid object to be SAVEd. */ + +void +ffestc_R522item_object (ffelexToken name) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + s = ffesymbol_declare_local (name, FALSE); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s) + && ((ffesymbol_kind (s) != FFEINFO_kindENTITY) + || (ffesymbol_where (s) != FFEINFO_whereLOCAL))) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + else if (sa & FFESYMBOL_attrsANY) + na = sa; + else if (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsSAVE; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, name); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_update_save (s); + ffesymbol_signal_unreported (s); + } + + ffestd_R522item_object (name); +} + +/* ffestc_R522item_cblock -- SAVE statement for common-block-name + + ffestc_R522item_cblock(name_token); + + Make sure name_token identifies a valid common block to be SAVEd. */ + +void +ffestc_R522item_cblock (ffelexToken name) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; + else if (sa & FFESYMBOL_attrsANY) + na = sa; /* Already have an error here, say nothing. */ + else if (!(sa & ~(FFESYMBOL_attrsCBLOCK))) + na = sa | FFESYMBOL_attrsSAVECBLOCK; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_update_save (s); + ffesymbol_signal_unreported (s); + } + + ffestd_R522item_cblock (name); +} + +/* ffestc_R522finish -- SAVE statement list complete + + ffestc_R522finish(); + + Just wrap up any local activities. */ + +void +ffestc_R522finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R522finish (); +} + +/* ffestc_R524_start -- DIMENSION statement list begin + + ffestc_R524_start(bool virtual); + + Verify that DIMENSION is valid here, and begin accepting items in the + list. */ + +void +ffestc_R524_start (bool virtual) +{ + ffestc_check_start_ (); + if (ffestc_order_blockspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R524_start (virtual); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R524_item -- DIMENSION statement for object-name + + ffestc_R524_item(name_token,dim_list); + + Make sure name_token identifies a valid object to be DIMENSIONd. */ + +void +ffestc_R524_item (ffelexToken name, ffesttDimList dims) +{ + ffesymbol s; + ffebld array_size; + ffebld extents; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffestpDimtype nd; + ffeinfoRank rank; + bool is_ugly_assumed; + + ffestc_check_item_ (); + assert (name != NULL); + assert (dims != NULL); + if (!ffestc_ok_) + return; + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + s = ffesymbol_declare_local (name, FALSE); + sa = ffesymbol_attrs (s); + + /* First figure out what kind of object this is based solely on the current + object situation (dimension list). */ + + is_ugly_assumed = (ffe_is_ugly_assumed () + && ((sa & FFESYMBOL_attrsDUMMY) + || (ffesymbol_where (s) == FFEINFO_whereDUMMY))); + + nd = ffestt_dimlist_type (dims, is_ugly_assumed); + switch (nd) + { + case FFESTP_dimtypeKNOWN: + na = FFESYMBOL_attrsARRAY; + break; + + case FFESTP_dimtypeADJUSTABLE: + na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE; + break; + + case FFESTP_dimtypeASSUMED: + na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE; + break; + + case FFESTP_dimtypeADJUSTABLEASSUMED: + na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYSIZE; + break; + + default: + assert ("Unexpected dims type" == NULL); + na = FFESYMBOL_attrsetNONE; + break; + } + + /* Now figure out what kind of object we've got based on previous + declarations of or references to the object. */ + + if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if (!ffesta_is_entry_valid + && (sa & FFESYMBOL_attrsANYLEN)) + na = FFESYMBOL_attrsetNONE; + else if ((sa & FFESYMBOL_attrsARRAY) + || ((sa & (FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSAVE)) + && (na & (FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYSIZE)))) + na = FFESYMBOL_attrsetNONE; + else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsANYSIZE + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSAVE + | FFESYMBOL_attrsTYPE))) + na |= sa; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, name); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank, + &array_size, + &extents, + is_ugly_assumed)); + ffesymbol_set_arraysize (s, array_size); + ffesymbol_set_extents (s, extents); + if (!(0 && ffe_is_90 ()) + && (ffebld_op (array_size) == FFEBLD_opCONTER) + && (ffebld_constant_integerdefault (ffebld_conter (array_size)) + == 0)) + { + ffebad_start (FFEBAD_ZERO_ARRAY); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_finish (); + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + rank, + ffesymbol_kind (s), + ffesymbol_where (s), + ffesymbol_size (s))); + } + + ffesymbol_signal_unreported (s); + + ffestd_R524_item (name, dims); +} + +/* ffestc_R524_finish -- DIMENSION statement list complete + + ffestc_R524_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R524_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R524_finish (); +} + +/* ffestc_R525_start -- ALLOCATABLE statement list begin + + ffestc_R525_start(); + + Verify that ALLOCATABLE is valid here, and begin accepting items in the + list. */ + +#if FFESTR_F90 +void +ffestc_R525_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R525_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R525_item -- ALLOCATABLE statement for object-name + + ffestc_R525_item(name_token,dim_list); + + Make sure name_token identifies a valid object to be ALLOCATABLEd. */ + +void +ffestc_R525_item (ffelexToken name, ffesttDimList dims) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestd_R525_item (name, dims); +} + +/* ffestc_R525_finish -- ALLOCATABLE statement list complete + + ffestc_R525_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R525_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R525_finish (); +} + +/* ffestc_R526_start -- POINTER statement list begin + + ffestc_R526_start(); + + Verify that POINTER is valid here, and begin accepting items in the + list. */ + +void +ffestc_R526_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R526_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R526_item -- POINTER statement for object-name + + ffestc_R526_item(name_token,dim_list); + + Make sure name_token identifies a valid object to be POINTERd. */ + +void +ffestc_R526_item (ffelexToken name, ffesttDimList dims) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestd_R526_item (name, dims); +} + +/* ffestc_R526_finish -- POINTER statement list complete + + ffestc_R526_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R526_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R526_finish (); +} + +/* ffestc_R527_start -- TARGET statement list begin + + ffestc_R527_start(); + + Verify that TARGET is valid here, and begin accepting items in the + list. */ + +void +ffestc_R527_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R527_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R527_item -- TARGET statement for object-name + + ffestc_R527_item(name_token,dim_list); + + Make sure name_token identifies a valid object to be TARGETd. */ + +void +ffestc_R527_item (ffelexToken name, ffesttDimList dims) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestd_R527_item (name, dims); +} + +/* ffestc_R527_finish -- TARGET statement list complete + + ffestc_R527_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R527_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R527_finish (); +} + +#endif +/* ffestc_R528_start -- DATA statement list begin + + ffestc_R528_start(); + + Verify that DATA is valid here, and begin accepting items in the list. */ + +void +ffestc_R528_start () +{ + ffestcOrder_ order; + + ffestc_check_start_ (); + if (ffe_is_pedantic_not_90 ()) + order = ffestc_order_data77_ (); + else + order = ffestc_order_data_ (); + if (order != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + +#if 1 + ffestc_local_.data.objlist = NULL; +#else + ffestd_R528_start_ (); +#endif + + ffestc_ok_ = TRUE; +} + +/* ffestc_R528_item_object -- DATA statement target object + + ffestc_R528_item_object(object,object_token); + + Make sure object is valid to be DATAd. */ + +void +ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + +#if 1 + if (ffestc_local_.data.objlist == NULL) + ffebld_init_list (&ffestc_local_.data.objlist, + &ffestc_local_.data.list_bottom); + + ffebld_append_item (&ffestc_local_.data.list_bottom, expr); +#else + ffestd_R528_item_object_ (expr, expr_token); +#endif +} + +/* ffestc_R528_item_startvals -- DATA statement start list of values + + ffestc_R528_item_startvals(); + + No more objects, gonna specify values for the list of objects now. */ + +void +ffestc_R528_item_startvals () +{ + ffestc_check_item_startvals_ (); + if (!ffestc_ok_) + return; + +#if 1 + assert (ffestc_local_.data.objlist != NULL); + ffebld_end_list (&ffestc_local_.data.list_bottom); + ffedata_begin (ffestc_local_.data.objlist); +#else + ffestd_R528_item_startvals_ (); +#endif +} + +/* ffestc_R528_item_value -- DATA statement source value + + ffestc_R528_item_value(repeat,repeat_token,value,value_token); + + Make sure repeat and value are valid for the objects being initialized. */ + +void +ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token, + ffebld value, ffelexToken value_token) +{ + ffetargetIntegerDefault rpt; + + ffestc_check_item_value_ (); + if (!ffestc_ok_) + return; + +#if 1 + if (repeat == NULL) + rpt = 1; + else if (ffebld_op (repeat) == FFEBLD_opCONTER) + rpt = ffebld_constant_integerdefault (ffebld_conter (repeat)); + else + { + ffestc_ok_ = FALSE; + ffedata_end (TRUE, NULL); + return; + } + + if (!(ffestc_ok_ = ffedata_value (rpt, value, + (repeat_token == NULL) + ? value_token + : repeat_token))) + ffedata_end (TRUE, NULL); + +#else + ffestd_R528_item_value_ (repeat, value); +#endif +} + +/* ffestc_R528_item_endvals -- DATA statement start list of values + + ffelexToken t; // the SLASH token that ends the list. + ffestc_R528_item_endvals(t); + + No more values, might specify more objects now. */ + +void +ffestc_R528_item_endvals (ffelexToken t) +{ + ffestc_check_item_endvals_ (); + if (!ffestc_ok_) + return; + +#if 1 + ffedata_end (!ffestc_ok_, t); + ffestc_local_.data.objlist = NULL; +#else + ffestd_R528_item_endvals_ (t); +#endif +} + +/* ffestc_R528_finish -- DATA statement list complete + + ffestc_R528_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R528_finish () +{ + ffestc_check_finish_ (); + +#if 1 +#else + ffestd_R528_finish_ (); +#endif +} + +/* ffestc_R537_start -- PARAMETER statement list begin + + ffestc_R537_start(); + + Verify that PARAMETER is valid here, and begin accepting items in the + list. */ + +void +ffestc_R537_start () +{ + ffestc_check_start_ (); + if (ffestc_order_parameter_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestd_R537_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R537_item -- PARAMETER statement assignment + + ffestc_R537_item(dest,dest_token,source,source_token); + + Make sure the source is a valid source for the destination; make the + assignment. */ + +void +ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source, + ffelexToken source_token) +{ + ffesymbol s; + + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if ((ffebld_op (dest) == FFEBLD_opANY) + || (ffebld_op (source) == FFEBLD_opANY)) + { + if (ffebld_op (dest) == FFEBLD_opSYMTER) + { + s = ffebld_symter (dest); + ffesymbol_set_init (s, ffebld_new_any ()); + ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ()); + ffesymbol_signal_unreported (s); + } + ffestd_R537_item (dest, source); + return; + } + + assert (ffebld_op (dest) == FFEBLD_opSYMTER); + assert (ffebld_op (source) == FFEBLD_opCONTER); + + s = ffebld_symter (dest); + if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) + && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)) + { /* Destination has explicit/implicit + CHARACTER*(*) type; set length. */ + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + ffesymbol_kind (s), + ffesymbol_where (s), + ffebld_size (source))); + ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s))); + } + + source = ffeexpr_convert_expr (source, source_token, dest, dest_token, + FFEEXPR_contextDATA); + + ffesymbol_set_init (s, source); + + ffesymbol_signal_unreported (s); + + ffestd_R537_item (dest, source); +} + +/* ffestc_R537_finish -- PARAMETER statement list complete + + ffestc_R537_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R537_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R537_finish (); +} + +/* ffestc_R539 -- IMPLICIT NONE statement + + ffestc_R539(); + + Verify that the IMPLICIT NONE statement is ok here and implement. */ + +void +ffestc_R539 () +{ + ffestc_check_simple_ (); + if (ffestc_order_implicitnone_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffeimplic_none (); + + ffestd_R539 (); +} + +/* ffestc_R539start -- IMPLICIT statement + + ffestc_R539start(); + + Verify that the IMPLICIT statement is ok here and implement. */ + +void +ffestc_R539start () +{ + ffestc_check_start_ (); + if (ffestc_order_implicit_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R539start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R539item -- IMPLICIT statement specification (R540) + + ffestc_R539item(...); + + Verify that the type and letter list are all ok and implement. */ + +void +ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt, + ffebld len, ffelexToken lent, ffesttImpList letters) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if ((type == FFESTP_typeCHARACTER) && (len != NULL) + && (ffebld_op (len) == FFEBLD_opSTAR)) + { /* Complain and pretend they're CHARACTER + [*1]. */ + ffebad_start (FFEBAD_IMPLICIT_ADJLEN); + ffebad_here (0, ffelex_token_where_line (lent), + ffelex_token_where_column (lent)); + ffebad_finish (); + len = NULL; + lent = NULL; + } + ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent); + ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL); + + ffestt_implist_drive (letters, ffestc_establish_impletter_); + + ffestd_R539item (type, kind, kindt, len, lent, letters); +} + +/* ffestc_R539finish -- IMPLICIT statement + + ffestc_R539finish(); + + Finish up any local activities. */ + +void +ffestc_R539finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R539finish (); +} + +/* ffestc_R542_start -- NAMELIST statement list begin + + ffestc_R542_start(); + + Verify that NAMELIST is valid here, and begin accepting items in the + list. */ + +void +ffestc_R542_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + if (ffe_is_f2c_library () + && (ffe_case_source () == FFE_caseNONE)) + { + ffebad_start (FFEBAD_NAMELIST_CASE); + ffesta_ffebad_here_current_stmt (0); + ffebad_finish (); + } + + ffestd_R542_start (); + + ffestc_local_.namelist.symbol = NULL; + + ffestc_ok_ = TRUE; +} + +/* ffestc_R542_item_nlist -- NAMELIST statement for group-name + + ffestc_R542_item_nlist(groupname_token); + + Make sure name_token identifies a valid object to be NAMELISTd. */ + +void +ffestc_R542_item_nlist (ffelexToken name) +{ + ffesymbol s; + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + if (ffestc_local_.namelist.symbol != NULL) + ffesymbol_signal_unreported (ffestc_local_.namelist.symbol); + + s = ffesymbol_declare_local (name, FALSE); + + if ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))) + { + ffestc_parent_ok_ = TRUE; + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffebld_init_list (ffesymbol_ptr_to_namelist (s), + ffesymbol_ptr_to_listbottom (s)); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindNAMELIST, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + } + } + else + { + if (ffesymbol_kind (s) != FFEINFO_kindANY) + ffesymbol_error (s, name); + ffestc_parent_ok_ = FALSE; + } + + ffestc_local_.namelist.symbol = s; + + ffestd_R542_item_nlist (name); +} + +/* ffestc_R542_item_nitem -- NAMELIST statement for variable-name + + ffestc_R542_item_nitem(name_token); + + Make sure name_token identifies a valid object to be NAMELISTd. */ + +void +ffestc_R542_item_nitem (ffelexToken name) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffebld e; + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + s = ffesymbol_declare_local (name, FALSE); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s) + && ((ffesymbol_kind (s) != FFEINFO_kindENTITY) + || ((ffesymbol_where (s) != FFEINFO_whereLOCAL) + && (ffesymbol_where (s) != FFEINFO_whereCOMMON)))) + na = FFESYMBOL_attrsetNONE; + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if (!(sa & ~(FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSAVE + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsNAMELIST; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, name); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_namelisted (s, TRUE); + ffesymbol_signal_unreported (s); +#if 0 /* No need to establish type yet! */ + if (!ffeimplic_establish_symbol (s)) + ffesymbol_error (s, name); +#endif + } + + if (ffestc_parent_ok_) + { + e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (e, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE)); + ffebld_append_item + (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e); + } + + ffestd_R542_item_nitem (name); +} + +/* ffestc_R542_finish -- NAMELIST statement list complete + + ffestc_R542_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R542_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffesymbol_signal_unreported (ffestc_local_.namelist.symbol); + + ffestd_R542_finish (); +} + +/* ffestc_R544_start -- EQUIVALENCE statement list begin + + ffestc_R544_start(); + + Verify that EQUIVALENCE is valid here, and begin accepting items in the + list. */ + +void +ffestc_R544_start () +{ + ffestc_check_start_ (); + if (ffestc_order_blockspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R544_item -- EQUIVALENCE statement assignment + + ffestc_R544_item(exprlist); + + Make sure the equivalence is valid, then implement it. */ + +void +ffestc_R544_item (ffesttExprList exprlist) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + /* First we go through the list and come up with one ffeequiv object that + will describe all items in the list. When an ffeequiv object is first + found, it is used (else we create one as a "local equiv" for the time + being). If subsequent ffeequiv objects are found, they are merged with + the first so we end up with one. However, if more than one COMMON + variable is involved, then an error condition occurs. */ + + ffestc_local_.equiv.ok = TRUE; + ffestc_local_.equiv.t = NULL; /* No token yet. */ + ffestc_local_.equiv.eq = NULL;/* No equiv yet. */ + ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */ + + ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom); + ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */ + ffebld_end_list (&ffestc_local_.equiv.bottom); + + if (!ffestc_local_.equiv.ok) + return; /* Something went wrong, stop bothering with + this stuff. */ + + if (ffestc_local_.equiv.eq == NULL) + ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */ + + /* Append this list of equivalences to list of such lists for this + equivalence. */ + + ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list, + ffestc_local_.equiv.t); + if (ffestc_local_.equiv.save) + ffeequiv_update_save (ffestc_local_.equiv.eq); +} + +/* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list + + ffebld expr; + ffelexToken t; + ffestc_R544_equiv_(expr,t); + + Record information, if any, on symbol in expr; if symbol has equivalence + object already, merge with outstanding object if present or make it + the outstanding object. */ + +static void +ffestc_R544_equiv_ (ffebld expr, ffelexToken t) +{ + ffesymbol s; + + if (!ffestc_local_.equiv.ok) + return; + + if (ffestc_local_.equiv.t == NULL) + ffestc_local_.equiv.t = t; + + switch (ffebld_op (expr)) + { + case FFEBLD_opANY: + return; /* Don't put this on the list. */ + + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opSUBSTR: + break; /* All of these are ok. */ + + default: + assert ("ffestc_R544_equiv_ bad op" == NULL); + return; + } + + ffebld_append_item (&ffestc_local_.equiv.bottom, expr); + + s = ffeequiv_symbol (expr); + + /* See if symbol has an equivalence object already. */ + + if (ffesymbol_equiv (s) != NULL) + if (ffestc_local_.equiv.eq == NULL) + ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */ + else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s)) + { + ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s), + ffestc_local_.equiv.eq, + t); + if (ffestc_local_.equiv.eq == NULL) + ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */ + } + + if (ffesymbol_is_save (s)) + ffestc_local_.equiv.save = TRUE; +} + +/* ffestc_R544_finish -- EQUIVALENCE statement list complete + + ffestc_R544_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R544_finish () +{ + ffestc_check_finish_ (); +} + +/* ffestc_R547_start -- COMMON statement list begin + + ffestc_R547_start(); + + Verify that COMMON is valid here, and begin accepting items in the list. */ + +void +ffestc_R547_start () +{ + ffestc_check_start_ (); + if (ffestc_order_blockspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestc_local_.common.symbol = NULL; /* Blank common is the default. */ + ffestc_parent_ok_ = TRUE; + + ffestd_R547_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R547_item_object -- COMMON statement for object-name + + ffestc_R547_item_object(name_token,dim_list); + + Make sure name_token identifies a valid object to be COMMONd. */ + +void +ffestc_R547_item_object (ffelexToken name, ffesttDimList dims) +{ + ffesymbol s; + ffebld array_size; + ffebld extents; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffestpDimtype nd; + ffebld e; + ffeinfoRank rank; + bool is_ugly_assumed; + + if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL)) + ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */ + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + if (dims != NULL) + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + s = ffesymbol_declare_local (name, FALSE); + sa = ffesymbol_attrs (s); + + /* First figure out what kind of object this is based solely on the current + object situation (dimension list). */ + + is_ugly_assumed = (ffe_is_ugly_assumed () + && ((sa & FFESYMBOL_attrsDUMMY) + || (ffesymbol_where (s) == FFEINFO_whereDUMMY))); + + nd = ffestt_dimlist_type (dims, is_ugly_assumed); + switch (nd) + { + case FFESTP_dimtypeNONE: + na = FFESYMBOL_attrsCOMMON; + break; + + case FFESTP_dimtypeKNOWN: + na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY; + break; + + default: + na = FFESYMBOL_attrsetNONE; + break; + } + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (na == FFESYMBOL_attrsetNONE) + ; + else if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if ((sa & (FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsSFARG)) + && (na & FFESYMBOL_attrsARRAY)) + na = FFESYMBOL_attrsetNONE; + else if (!(sa & ~(FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na |= sa; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, name); + else if ((ffesymbol_equiv (s) != NULL) + && (ffeequiv_common (ffesymbol_equiv (s)) != NULL) + && (ffeequiv_common (ffesymbol_equiv (s)) + != ffestc_local_.common.symbol)) + { + /* Oops, just COMMONed a symbol to a different area (via equiv). */ + ffebad_start (FFEBAD_EQUIV_COMMON); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_string (ffesymbol_text (ffestc_local_.common.symbol)); + ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s)))); + ffebad_finish (); + ffesymbol_set_attr (s, na | FFESYMBOL_attrANY); + ffesymbol_set_info (s, ffeinfo_new_any ()); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_signal_unreported (s); + } + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_common (s, ffestc_local_.common.symbol); +#if FFEGLOBAL_ENABLED + if (ffesymbol_is_init (s)) + ffeglobal_init_common (ffestc_local_.common.symbol, name); +#endif + if (ffesymbol_is_save (ffestc_local_.common.symbol)) + ffesymbol_update_save (s); + if (ffesymbol_equiv (s) != NULL) + { /* Is this newly COMMONed symbol involved in + an equivalence? */ + if (ffeequiv_common (ffesymbol_equiv (s)) == NULL) + ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */ + ffestc_local_.common.symbol); +#if FFEGLOBAL_ENABLED + if (ffeequiv_is_init (ffesymbol_equiv (s))) + ffeglobal_init_common (ffestc_local_.common.symbol, name); +#endif + if (ffesymbol_is_save (ffestc_local_.common.symbol)) + ffeequiv_update_save (ffesymbol_equiv (s)); + } + if (dims != NULL) + { + ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank, + &array_size, + &extents, + is_ugly_assumed)); + ffesymbol_set_arraysize (s, array_size); + ffesymbol_set_extents (s, extents); + if (!(0 && ffe_is_90 ()) + && (ffebld_op (array_size) == FFEBLD_opCONTER) + && (ffebld_constant_integerdefault (ffebld_conter (array_size)) + == 0)) + { + ffebad_start (FFEBAD_ZERO_ARRAY); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_finish (); + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + rank, + ffesymbol_kind (s), + ffesymbol_where (s), + ffesymbol_size (s))); + } + ffesymbol_signal_unreported (s); + } + + if (ffestc_parent_ok_) + { + e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (e, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE)); + ffebld_append_item + (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e); + } + + ffestd_R547_item_object (name, dims); +} + +/* ffestc_R547_item_cblock -- COMMON statement for common-block-name + + ffestc_R547_item_cblock(name_token); + + Make sure name_token identifies a valid common block to be COMMONd. */ + +void +ffestc_R547_item_cblock (ffelexToken name) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if (ffestc_local_.common.symbol != NULL) + ffesymbol_signal_unreported (ffestc_local_.common.symbol); + + s = ffesymbol_declare_cblock (name, + ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; /* Already have an error here, say nothing. */ + else if (!(sa & ~(FFESYMBOL_attrsCBLOCK + | FFESYMBOL_attrsSAVECBLOCK))) + { + if (!(sa & FFESYMBOL_attrsCBLOCK)) + ffebld_init_list (ffesymbol_ptr_to_commonlist (s), + ffesymbol_ptr_to_listbottom (s)); + na = sa | FFESYMBOL_attrsCBLOCK; + } + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + { + ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name); + ffestc_parent_ok_ = FALSE; + } + else if (na & FFESYMBOL_attrsANY) + ffestc_parent_ok_ = FALSE; + else + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + if (name == NULL) + ffesymbol_update_save (s); + ffestc_parent_ok_ = TRUE; + } + + ffestc_local_.common.symbol = s; + + ffestd_R547_item_cblock (name); +} + +/* ffestc_R547_finish -- COMMON statement list complete + + ffestc_R547_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R547_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + if (ffestc_local_.common.symbol != NULL) + ffesymbol_signal_unreported (ffestc_local_.common.symbol); + + ffestd_R547_finish (); +} + +/* ffestc_R620 -- ALLOCATE statement + + ffestc_R620(exprlist,stat,stat_token); + + Make sure the expression list is valid, then implement it. */ + +#if FFESTR_F90 +void +ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + ffestd_R620 (exprlist, stat); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R624 -- NULLIFY statement + + ffestc_R624(pointer_name_list); + + Make sure pointer_name_list identifies valid pointers for a NULLIFY. */ + +void +ffestc_R624 (ffesttExprList pointers) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + ffestd_R624 (pointers); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R625 -- DEALLOCATE statement + + ffestc_R625(exprlist,stat,stat_token); + + Make sure the equivalence is valid, then implement it. */ + +void +ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + ffestd_R625 (exprlist, stat); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +#endif +/* ffestc_let -- R1213 or R737 + + ffestc_let(...); + + Verify that R1213 defined-assignment or R737 assignment-stmt are + valid here, figure out which one, and implement. */ + +#if FFESTR_F90 +void +ffestc_let (ffebld dest, ffebld source, ffelexToken source_token) +{ + ffestc_R737 (dest, source, source_token); +} + +#endif +/* ffestc_R737 -- Assignment statement + + ffestc_R737(dest_expr,source_expr,source_token); + + Make sure the assignment is valid. */ + +void +ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token) +{ + ffestc_check_simple_ (); + + switch (ffestw_state (ffestw_stack_top ())) + { +#if FFESTR_F90 + case FFESTV_stateWHERE: + case FFESTV_stateWHERETHEN: + if (ffestc_order_actionwhere_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestd_R737B (dest, source); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + return; +#endif + + default: + break; + } + + if (ffestc_order_actionwhere_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0], + FFEEXPR_contextLET); + + ffestd_R737A (dest, source); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R738 -- Pointer assignment statement + + ffestc_R738(dest_expr,source_expr,source_token); + + Make sure the assignment is valid. */ + +#if FFESTR_F90 +void +ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + ffestd_R738 (dest, source); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R740 -- WHERE statement + + ffestc_R740(expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R740 (ffebld expr, ffelexToken expr_token) +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); + ffestw_set_state (b, FFESTV_stateWHERE); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_where_lost_); + + ffestd_R740 (expr); + + /* Leave label finishing to next statement. */ + +} + +/* ffestc_R742 -- WHERE-construct statement + + ffestc_R742(expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R742 (ffebld expr, ffelexToken expr_token) +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_probably_this_wont_work_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); + ffestw_set_state (b, FFESTV_stateWHERETHEN); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_wherethen_); + ffestw_set_substate (b, 0); /* Haven't seen ELSEWHERE yet. */ + + ffestd_R742 (expr); +} + +/* ffestc_R744 -- ELSE WHERE statement + + ffestc_R744(); + + Make sure ffestc_kind_ identifies a WHERE block. + Implement the ELSE of the current WHERE block. */ + +void +ffestc_R744 () +{ + ffestc_check_simple_ (); + if (ffestc_order_where_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 0) + { + ffebad_start (FFEBAD_SECOND_ELSE_WHERE); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */ + + ffestd_R744 (); +} + +/* ffestc_R745 -- END WHERE statement + + ffestc_R745(); + + Make sure ffestc_kind_ identifies a WHERE block. + Implement the end of the current WHERE block. */ + +void +ffestc_R745 () +{ + ffestc_check_simple_ (); + if (ffestc_order_where_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_shriek_wherethen_ (TRUE); +} + +#endif +/* ffestc_R803 -- Block IF (IF-THEN) statement + + ffestc_R803(construct_name,expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R803 (ffelexToken construct_name, ffebld expr, + ffelexToken expr_token UNUSED) +{ + ffestw b; + ffesymbol s; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); + ffestw_set_state (b, FFESTV_stateIFTHEN); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_ifthen_); + ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */ + + if (construct_name == NULL) + ffestw_set_name (b, NULL); + else + { + ffestw_set_name (b, ffelex_token_use (construct_name)); + + s = ffesymbol_declare_local (construct_name, FALSE); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindCONSTRUCT, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, construct_name); + } + + ffestd_R803 (construct_name, expr); +} + +/* ffestc_R804 -- ELSE IF statement + + ffestc_R804(expr,expr_token,name_token); + + Make sure ffestc_kind_ identifies an IF block. If not + NULL, make sure name_token gives the correct name. Implement the else + of the IF block. */ + +void +ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED, + ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_ifthen_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (name != NULL) + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, + ffestw_name (ffestw_stack_top ())) + != 0) + { + ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + if (ffestw_substate (ffestw_stack_top ()) != 0) + { + ffebad_start (FFEBAD_AFTER_ELSE); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + return; /* Don't upset back end with ELSEIF + after ELSE. */ + } + + ffestd_R804 (expr, name); +} + +/* ffestc_R805 -- ELSE statement + + ffestc_R805(name_token); + + Make sure ffestc_kind_ identifies an IF block. If not + NULL, make sure name_token gives the correct name. Implement the ELSE + of the IF block. */ + +void +ffestc_R805 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_ifthen_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (name != NULL) + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) + { + ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + if (ffestw_substate (ffestw_stack_top ()) != 0) + { + ffebad_start (FFEBAD_AFTER_ELSE); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + return; /* Tell back end about only one ELSE. */ + } + + ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */ + + ffestd_R805 (name); +} + +/* ffestc_R806 -- END IF statement + + ffestc_R806(name_token); + + Make sure ffestc_kind_ identifies an IF block. If not + NULL, make sure name_token gives the correct name. Implement the end + of the IF block. */ + +void +ffestc_R806 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_ifthen_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_endif_ (); + + if (name == NULL) + { + if (ffestw_name (ffestw_stack_top ()) != NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NAMED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + } + else + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) + { + ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + ffestc_shriek_ifthen_ (TRUE); +} + +/* ffestc_R807 -- Logical IF statement + + ffestc_R807(expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED) +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_action_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); + ffestw_set_state (b, FFESTV_stateIF); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_if_lost_); + + ffestd_R807 (expr); + + /* Do the label finishing in the next statement. */ + +} + +/* ffestc_R809 -- SELECT CASE statement + + ffestc_R809(construct_name,expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token) +{ + ffestw b; + mallocPool pool; + ffestwSelect s; + ffesymbol sym; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b))); + ffestw_set_state (b, FFESTV_stateSELECT0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_select_); + ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */ + + /* Init block to manage CASE list. */ + + pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024); + s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s)); + s->first_rel = (ffestwCase) &s->first_rel; + s->last_rel = (ffestwCase) &s->first_rel; + s->first_stmt = (ffestwCase) &s->first_rel; + s->last_stmt = (ffestwCase) &s->first_rel; + s->pool = pool; + s->cases = 1; + s->t = ffelex_token_use (expr_token); + s->type = ffeinfo_basictype (ffebld_info (expr)); + s->kindtype = ffeinfo_kindtype (ffebld_info (expr)); + ffestw_set_select (b, s); + + if (construct_name == NULL) + ffestw_set_name (b, NULL); + else + { + ffestw_set_name (b, ffelex_token_use (construct_name)); + + sym = ffesymbol_declare_local (construct_name, FALSE); + + if (ffesymbol_state (sym) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (sym, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, 0, + FFEINFO_kindCONSTRUCT, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + sym = ffecom_sym_learned (sym); + ffesymbol_signal_unreported (sym); + } + else + ffesymbol_error (sym, construct_name); + } + + ffestd_R809 (construct_name, expr); +} + +/* ffestc_R810 -- CASE statement + + ffestc_R810(case_value_range_list,name); + + If case_value_range_list is NULL, it's CASE DEFAULT. name is the case- + construct-name. Make sure no more than one CASE DEFAULT is present for + a given case-construct and that there aren't any overlapping ranges or + duplicate case values. */ + +void +ffestc_R810 (ffesttCaseList cases, ffelexToken name) +{ + ffesttCaseList caseobj; + ffestwSelect s; + ffestwCase c, nc; + ffebldConstant expr1c, expr2c; + + ffestc_check_simple_ (); + if (ffestc_order_selectcase_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + s = ffestw_select (ffestw_stack_top ()); + + if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0) + { +#if 0 /* Not sure we want to have msgs point here + instead of SELECT CASE. */ + ffestw_update (NULL); /* Update state line/col info. */ +#endif + ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1); + } + + if (name != NULL) + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, + ffestw_name (ffestw_stack_top ())) + != 0) + { + ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + if (cases == NULL) + { + if (ffestw_substate (ffestw_stack_top ()) != 0) + { + ffebad_start (FFEBAD_CASE_SECOND_DEFAULT); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */ + } + else + { /* For each case, try to fit into sorted list + of ranges. */ + for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next) + { + if ((caseobj->expr1 == NULL) + && (!caseobj->range + || (caseobj->expr2 == NULL))) + { /* "CASE (:)". */ + ffebad_start (FFEBAD_CASE_BAD_RANGE); + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_finish (); + continue; + } + + if (((caseobj->expr1 != NULL) + && ((ffeinfo_basictype (ffebld_info (caseobj->expr1)) + != s->type) + || (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) + != s->kindtype))) + || ((caseobj->range) + && (caseobj->expr2 != NULL) + && ((ffeinfo_basictype (ffebld_info (caseobj->expr2)) + != s->type) + || (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) + != s->kindtype)))) + { + ffebad_start (FFEBAD_CASE_TYPE_DISAGREE); + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_here (1, ffelex_token_where_line (s->t), + ffelex_token_where_column (s->t)); + ffebad_finish (); + continue; + } + + if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range)) + { + ffebad_start (FFEBAD_CASE_LOGICAL_RANGE); + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_finish (); + continue; + } + + if (caseobj->expr1 == NULL) + expr1c = NULL; + else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER) + continue; /* opANY. */ + else + expr1c = ffebld_conter (caseobj->expr1); + + if (!caseobj->range) + expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this + case. */ + else if (caseobj->expr2 == NULL) + expr2c = NULL; + else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER) + continue; /* opANY. */ + else + expr2c = ffebld_conter (caseobj->expr2); + + if (expr1c == NULL) + { /* "CASE (:high)", must be first in list. */ + c = s->first_rel; + if ((c != (ffestwCase) &s->first_rel) + && ((c->low == NULL) + || (ffebld_constant_cmp (expr2c, c->low) >= 0))) + { /* Other "CASE (:high)" or lowest "CASE + (low[:high])" low. */ + ffebad_start (FFEBAD_CASE_DUPLICATE); + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_here (1, ffelex_token_where_line (c->t), + ffelex_token_where_column (c->t)); + ffebad_finish (); + continue; + } + } + else if (expr2c == NULL) + { /* "CASE (low:)", must be last in list. */ + c = s->last_rel; + if ((c != (ffestwCase) &s->first_rel) + && ((c->high == NULL) + || (ffebld_constant_cmp (expr1c, c->high) <= 0))) + { /* Other "CASE (low:)" or lowest "CASE + ([low:]high)" high. */ + ffebad_start (FFEBAD_CASE_DUPLICATE); + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_here (1, ffelex_token_where_line (c->t), + ffelex_token_where_column (c->t)); + ffebad_finish (); + continue; + } + c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */ + } + else + { /* (expr1c != NULL) && (expr2c != NULL). */ + if (ffebld_constant_cmp (expr1c, expr2c) > 0) + { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */ + ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */ + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_finish (); + continue; + } + for (c = s->first_rel; + (c != (ffestwCase) &s->first_rel) + && ((c->low == NULL) + || (ffebld_constant_cmp (expr1c, c->low) > 0)); + c = c->next_rel) + ; + nc = c; /* Which one to report? */ + if (((c != (ffestwCase) &s->first_rel) + && (ffebld_constant_cmp (expr2c, c->low) >= 0)) + || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel) + && (ffebld_constant_cmp (expr1c, nc->high) <= 0))) + { /* Interference with range in case nc. */ + ffebad_start (FFEBAD_CASE_DUPLICATE); + ffebad_here (0, ffelex_token_where_line (caseobj->t), + ffelex_token_where_column (caseobj->t)); + ffebad_here (1, ffelex_token_where_line (nc->t), + ffelex_token_where_column (nc->t)); + ffebad_finish (); + continue; + } + } + + /* If we reach here for this case range/value, it's ok (sorts into + the list of ranges/values) so we give it its own case object + sorted into the list of case statements. */ + + nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc)); + nc->next_rel = c; + nc->previous_rel = c->previous_rel; + nc->next_stmt = (ffestwCase) &s->first_rel; + nc->previous_stmt = s->last_stmt; + nc->low = expr1c; + nc->high = expr2c; + nc->casenum = s->cases; + nc->t = ffelex_token_use (caseobj->t); + nc->next_rel->previous_rel = nc; + nc->previous_rel->next_rel = nc; + nc->next_stmt->previous_stmt = nc; + nc->previous_stmt->next_stmt = nc; + } + } + + ffestd_R810 ((cases == NULL) ? 0 : s->cases); + + s->cases++; /* Increment # of cases. */ +} + +/* ffestc_R811 -- END SELECT statement + + ffestc_R811(name_token); + + Make sure ffestc_kind_ identifies a SELECT block. If not + NULL, make sure name_token gives the correct name. Implement the end + of the SELECT block. */ + +void +ffestc_R811 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_selectcase_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + if (name == NULL) + { + if (ffestw_name (ffestw_stack_top ()) != NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NAMED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + } + else + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, + ffestw_name (ffestw_stack_top ())) + != 0) + { + ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + ffestc_shriek_select_ (TRUE); +} + +/* ffestc_R819A -- Iterative labeled DO statement + + ffestc_R819A(construct_name,label_token,expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var, + ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end, + ffelexToken end_token, ffebld incr, ffelexToken incr_token) +{ + ffestw b; + ffelab label; + ffesymbol s; + ffesymbol varsym; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + if (!ffestc_labelref_is_loopend_ (label_token, &label)) + return; + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, b); + ffestw_set_state (b, FFESTV_stateDO); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_do_); + ffestw_set_label (b, label); + switch (ffebld_op (var)) + { + case FFEBLD_opSYMTER: + if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL) + && ffe_is_warn_surprising ()) + { + ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ + ffebad_here (0, ffelex_token_where_line (var_token), + ffelex_token_where_column (var_token)); + ffebad_string (ffesymbol_text (ffebld_symter (var))); + ffebad_finish (); + } + if (!ffesymbol_is_doiter (varsym = ffebld_symter (var))) + { /* Presumably already complained about by + ffeexpr_lhs_. */ + ffesymbol_set_is_doiter (varsym, TRUE); + ffestw_set_do_iter_var (b, varsym); + ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token)); + break; + } + /* Fall through. */ + case FFEBLD_opANY: + ffestw_set_do_iter_var (b, NULL); + ffestw_set_do_iter_var_t (b, NULL); + break; + + default: + assert ("bad iter var" == NULL); + break; + } + + if (construct_name == NULL) + ffestw_set_name (b, NULL); + else + { + ffestw_set_name (b, ffelex_token_use (construct_name)); + + s = ffesymbol_declare_local (construct_name, FALSE); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindCONSTRUCT, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, construct_name); + } + + if (incr == NULL) + { + incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); + ffebld_set_info (incr, ffeinfo_new + (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + } + + start = ffeexpr_convert_expr (start, start_token, var, var_token, + FFEEXPR_contextLET); + end = ffeexpr_convert_expr (end, end_token, var, var_token, + FFEEXPR_contextLET); + incr = ffeexpr_convert_expr (incr, incr_token, var, var_token, + FFEEXPR_contextLET); + + ffestd_R819A (construct_name, label, var, + start, start_token, + end, end_token, + incr, incr_token); +} + +/* ffestc_R819B -- Labeled DO WHILE statement + + ffestc_R819B(construct_name,label_token,expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R819B (ffelexToken construct_name, ffelexToken label_token, + ffebld expr, ffelexToken expr_token UNUSED) +{ + ffestw b; + ffelab label; + ffesymbol s; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + if (!ffestc_labelref_is_loopend_ (label_token, &label)) + return; + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, b); + ffestw_set_state (b, FFESTV_stateDO); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_do_); + ffestw_set_label (b, label); + ffestw_set_do_iter_var (b, NULL); + ffestw_set_do_iter_var_t (b, NULL); + + if (construct_name == NULL) + ffestw_set_name (b, NULL); + else + { + ffestw_set_name (b, ffelex_token_use (construct_name)); + + s = ffesymbol_declare_local (construct_name, FALSE); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindCONSTRUCT, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, construct_name); + } + + ffestd_R819B (construct_name, label, expr); +} + +/* ffestc_R820A -- Iterative nonlabeled DO statement + + ffestc_R820A(construct_name,expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token, + ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token, + ffebld incr, ffelexToken incr_token) +{ + ffestw b; + ffesymbol s; + ffesymbol varsym; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, b); + ffestw_set_state (b, FFESTV_stateDO); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_do_); + ffestw_set_label (b, NULL); + switch (ffebld_op (var)) + { + case FFEBLD_opSYMTER: + if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL) + && ffe_is_warn_surprising ()) + { + ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ + ffebad_here (0, ffelex_token_where_line (var_token), + ffelex_token_where_column (var_token)); + ffebad_string (ffesymbol_text (ffebld_symter (var))); + ffebad_finish (); + } + if (!ffesymbol_is_doiter (varsym = ffebld_symter (var))) + { /* Presumably already complained about by + ffeexpr_lhs_. */ + ffesymbol_set_is_doiter (varsym, TRUE); + ffestw_set_do_iter_var (b, varsym); + ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token)); + break; + } + /* Fall through. */ + case FFEBLD_opANY: + ffestw_set_do_iter_var (b, NULL); + ffestw_set_do_iter_var_t (b, NULL); + break; + + default: + assert ("bad iter var" == NULL); + break; + } + + if (construct_name == NULL) + ffestw_set_name (b, NULL); + else + { + ffestw_set_name (b, ffelex_token_use (construct_name)); + + s = ffesymbol_declare_local (construct_name, FALSE); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindCONSTRUCT, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, construct_name); + } + + if (incr == NULL) + { + incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); + ffebld_set_info (incr, ffeinfo_new + (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + } + + start = ffeexpr_convert_expr (start, start_token, var, var_token, + FFEEXPR_contextLET); + end = ffeexpr_convert_expr (end, end_token, var, var_token, + FFEEXPR_contextLET); + incr = ffeexpr_convert_expr (incr, incr_token, var, var_token, + FFEEXPR_contextLET); + +#if 0 + if ((ffebld_op (incr) == FFEBLD_opCONTER) + && (ffebld_constant_is_zero (ffebld_conter (incr)))) + { + ffebad_start (FFEBAD_DO_STEP_ZERO); + ffebad_here (0, ffelex_token_where_line (incr_token), + ffelex_token_where_column (incr_token)); + ffebad_string ("Iterative DO loop"); + ffebad_finish (); + } +#endif + + ffestd_R819A (construct_name, NULL, var, + start, start_token, + end, end_token, + incr, incr_token); +} + +/* ffestc_R820B -- Nonlabeled DO WHILE statement + + ffestc_R820B(construct_name,expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R820B (ffelexToken construct_name, ffebld expr, + ffelexToken expr_token UNUSED) +{ + ffestw b; + ffesymbol s; + + ffestc_check_simple_ (); + if (ffestc_order_exec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, b); + ffestw_set_state (b, FFESTV_stateDO); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_do_); + ffestw_set_label (b, NULL); + ffestw_set_do_iter_var (b, NULL); + ffestw_set_do_iter_var_t (b, NULL); + + if (construct_name == NULL) + ffestw_set_name (b, NULL); + else + { + ffestw_set_name (b, ffelex_token_use (construct_name)); + + s = ffesymbol_declare_local (construct_name, FALSE); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindCONSTRUCT, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, construct_name); + } + + ffestd_R819B (construct_name, NULL, expr); +} + +/* ffestc_R825 -- END DO statement + + ffestc_R825(name_token); + + Make sure ffestc_kind_ identifies a DO block. If not + NULL, make sure name_token gives the correct name. Implement the end + of the DO block. */ + +void +ffestc_R825 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_do_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (name == NULL) + { + if (ffestw_name (ffestw_stack_top ()) != NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NAMED); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + } + else + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, + ffestw_name (ffestw_stack_top ())) + != 0) + { + ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + if (ffesta_label_token == NULL) + { /* If top of stack has label, its an error! */ + if (ffestw_label (ffestw_stack_top ()) != NULL) + { + ffebad_start (FFEBAD_DO_HAD_LABEL); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + ffestc_shriek_do_ (TRUE); + + ffestc_try_shriek_do_ (); + + return; + } + + ffestd_R825 (name); + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R834 -- CYCLE statement + + ffestc_R834(name_token); + + Handle a CYCLE within a loop. */ + +void +ffestc_R834 (ffelexToken name) +{ + ffestw block; + + ffestc_check_simple_ (); + if (ffestc_order_actiondo_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + if (name == NULL) + block = ffestw_top_do (ffestw_stack_top ()); + else + { /* Search for name. */ + for (block = ffestw_top_do (ffestw_stack_top ()); + (block != NULL) && (ffestw_blocknum (block) != 0); + block = ffestw_top_do (ffestw_previous (block))) + { + if ((ffestw_name (block) != NULL) + && (ffelex_token_strcmp (name, ffestw_name (block)) == 0)) + break; + } + if ((block == NULL) || (ffestw_blocknum (block) == 0)) + { + block = ffestw_top_do (ffestw_stack_top ()); + ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_finish (); + } + } + + ffestd_R834 (block); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) CYCLE". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R835 -- EXIT statement + + ffestc_R835(name_token); + + Handle a EXIT within a loop. */ + +void +ffestc_R835 (ffelexToken name) +{ + ffestw block; + + ffestc_check_simple_ (); + if (ffestc_order_actiondo_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + if (name == NULL) + block = ffestw_top_do (ffestw_stack_top ()); + else + { /* Search for name. */ + for (block = ffestw_top_do (ffestw_stack_top ()); + (block != NULL) && (ffestw_blocknum (block) != 0); + block = ffestw_top_do (ffestw_previous (block))) + { + if ((ffestw_name (block) != NULL) + && (ffelex_token_strcmp (name, ffestw_name (block)) == 0)) + break; + } + if ((block == NULL) || (ffestw_blocknum (block) == 0)) + { + block = ffestw_top_do (ffestw_stack_top ()); + ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_finish (); + } + } + + ffestd_R835 (block); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) EXIT". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R836 -- GOTO statement + + ffestc_R836(label_token); + + Make sure label_token identifies a valid label for a GOTO. Update + that label's info to indicate it is the target of a GOTO. */ + +void +ffestc_R836 (ffelexToken label_token) +{ + ffelab label; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + if (ffestc_labelref_is_branch_ (label_token, &label)) + ffestd_R836 (label); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) GOTO 100". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R837 -- Computed GOTO statement + + ffestc_R837(label_list,expr,expr_token); + + Make sure label_list identifies valid labels for a GOTO. Update + each label's info to indicate it is the target of a GOTO. */ + +void +ffestc_R837 (ffesttTokenList label_toks, ffebld expr, + ffelexToken expr_token UNUSED) +{ + ffesttTokenItem ti; + bool ok = TRUE; + int i; + ffelab *labels; + + assert (label_toks != NULL); + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels", + sizeof (*labels) + * ffestt_tokenlist_count (label_toks)); + + for (ti = label_toks->first, i = 0; + ti != (ffesttTokenItem) &label_toks->first; + ti = ti->next, ++i) + { + if (!ffestc_labelref_is_branch_ (ti->t, &labels[i])) + { + ok = FALSE; + break; + } + } + + if (ok) + ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R838 -- ASSIGN statement + + ffestc_R838(label_token,target_variable,target_token); + + Make sure label_token identifies a valid label for an assignment. Update + that label's info to indicate it is the source of an assignment. Update + target_variable's info to indicate it is the target the assignment of that + label. */ + +void +ffestc_R838 (ffelexToken label_token, ffebld target, + ffelexToken target_token UNUSED) +{ + ffelab label; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_labelref_is_assignable_ (label_token, &label)) + ffestd_R838 (label, target); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R839 -- Assigned GOTO statement + + ffestc_R839(target,target_token,label_list); + + Make sure label_list identifies valid labels for a GOTO. Update + each label's info to indicate it is the target of a GOTO. */ + +void +ffestc_R839 (ffebld target, ffelexToken target_token UNUSED, + ffesttTokenList label_toks) +{ + ffesttTokenItem ti; + bool ok = TRUE; + int i; + ffelab *labels; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + if (label_toks == NULL) + { + labels = NULL; + i = 0; + } + else + { + labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels", + sizeof (*labels) * ffestt_tokenlist_count (label_toks)); + + for (ti = label_toks->first, i = 0; + ti != (ffesttTokenItem) &label_toks->first; + ti = ti->next, ++i) + { + if (!ffestc_labelref_is_branch_ (ti->t, &labels[i])) + { + ok = FALSE; + break; + } + } + } + + if (ok) + ffestd_R839 (target, labels, i); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) GOTO I". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R840 -- Arithmetic IF statement + + ffestc_R840(expr,expr_token,neg,zero,pos); + + Make sure the labels are valid; implement. */ + +void +ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED, + ffelexToken neg_token, ffelexToken zero_token, + ffelexToken pos_token) +{ + ffelab neg; + ffelab zero; + ffelab pos; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + if (ffestc_labelref_is_branch_ (neg_token, &neg) + && ffestc_labelref_is_branch_ (zero_token, &zero) + && ffestc_labelref_is_branch_ (pos_token, &pos)) + ffestd_R840 (expr, neg, zero, pos); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) GOTO (100,200,300), I". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R841 -- CONTINUE statement + + ffestc_R841(); */ + +void +ffestc_R841 () +{ + ffestc_check_simple_ (); + + if (ffestc_order_actionwhere_ () != FFESTC_orderOK_) + return; + + switch (ffestw_state (ffestw_stack_top ())) + { +#if FFESTR_F90 + case FFESTV_stateWHERE: + case FFESTV_stateWHERETHEN: + ffestc_labeldef_useless_ (); + + ffestd_R841 (TRUE); + + /* It's okay that we call ffestc_labeldef_branch_end_ () below, + since that will be a no-op after calling _useless_ () above. */ + break; +#endif + + default: + ffestc_labeldef_branch_begin_ (); + + ffestd_R841 (FALSE); + + break; + } + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R842 -- STOP statement + + ffestc_R842(expr,expr_token); + + Make sure statement is valid here; implement. expr and expr_token are + both NULL if there was no expression. */ + +void +ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + ffestd_R842 (expr); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) STOP". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R843 -- PAUSE statement + + ffestc_R843(expr,expr_token); + + Make sure statement is valid here; implement. expr and expr_token are + both NULL if there was no expression. */ + +void +ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + ffestd_R843 (expr); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R904 -- OPEN statement + + ffestc_R904(); + + Make sure an OPEN is valid in the current context, and implement it. */ + +void +ffestc_R904 () +{ + int i; + int expect_file; + char *status_strs[] + = + { + "New", + "Old", + "Replace", + "Scratch", + "Unknown" + }; + char *access_strs[] + = + { + "Append", + "Direct", + "Keyed", + "Sequential" + }; + char *blank_strs[] + = + { + "Null", + "Zero" + }; + char *carriagecontrol_strs[] + = + { + "Fortran", + "List", + "None" + }; + char *dispose_strs[] + = + { + "Delete", + "Keep", + "Print", + "Print/Delete", + "Save", + "Submit", + "Submit/Delete" + }; + char *form_strs[] + = + { + "Formatted", + "Unformatted" + }; + char *organization_strs[] + = + { + "Indexed", + "Relative", + "Sequential" + }; + char *position_strs[] + = + { + "Append", + "AsIs", + "Rewind" + }; + char *action_strs[] + = + { + "Read", + "ReadWrite", + "Write" + }; + char *delim_strs[] + = + { + "Apostrophe", + "None", + "Quote" + }; + char *recordtype_strs[] + = + { + "Fixed", + "Segmented", + "Stream", + "Stream_CR", + "Stream_LF", + "Variable" + }; + char *pad_strs[] + = + { + "No", + "Yes" + }; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.open.open_spec[FFESTP_openixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.open.open_spec[FFESTP_openixUNIT])) + { + i = ffestc_subr_binsrch_ (status_strs, + ARRAY_SIZE (status_strs), + &ffestp_file.open.open_spec[FFESTP_openixSTATUS], + "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN"); + switch (i) + { + case 0: /* Unknown. */ + case 5: /* UNKNOWN. */ + expect_file = 2; /* Unknown, don't care about FILE=. */ + break; + + case 1: /* NEW. */ + case 2: /* OLD. */ + if (ffe_is_pedantic ()) + expect_file = 1; /* Yes, need FILE=. */ + else + expect_file = 2; /* f2clib doesn't care about FILE=. */ + break; + + case 3: /* REPLACE. */ + expect_file = 1; /* Yes, need FILE=. */ + break; + + case 4: /* SCRATCH. */ + expect_file = 0; /* No, disallow FILE=. */ + break; + + default: + assert ("invalid _binsrch_ result" == NULL); + expect_file = 0; + break; + } + if ((expect_file == 0) + && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present) + { + ffebad_start (FFEBAD_CONFLICTING_SPECS); + assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present); + if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present) + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.open.open_spec[FFESTP_openixFILE].kw), + ffelex_token_where_column + (ffestp_file.open.open_spec[FFESTP_openixFILE].kw)); + } + else + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.open.open_spec[FFESTP_openixFILE].value), + ffelex_token_where_column + (ffestp_file.open.open_spec[FFESTP_openixFILE].value)); + } + assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present); + if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present) + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw), + ffelex_token_where_column + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw)); + } + else + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value), + ffelex_token_where_column + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value)); + } + ffebad_finish (); + } + else if ((expect_file == 1) + && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present) + { + ffebad_start (FFEBAD_MISSING_SPECIFIER); + assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present); + if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present) + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw), + ffelex_token_where_column + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw)); + } + else + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value), + ffelex_token_where_column + (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value)); + } + ffebad_string ("FILE="); + ffebad_finish (); + } + + ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs), + &ffestp_file.open.open_spec[FFESTP_openixACCESS], + "APPEND, DIRECT, KEYED, or SEQUENTIAL"); + + ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs), + &ffestp_file.open.open_spec[FFESTP_openixBLANK], + "NULL or ZERO"); + + ffestc_subr_binsrch_ (carriagecontrol_strs, + ARRAY_SIZE (carriagecontrol_strs), + &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL], + "FORTRAN, LIST, or NONE"); + + ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs), + &ffestp_file.open.open_spec[FFESTP_openixDISPOSE], + "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE"); + + ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs), + &ffestp_file.open.open_spec[FFESTP_openixFORM], + "FORMATTED or UNFORMATTED"); + + ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs), + &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION], + "INDEXED, RELATIVE, or SEQUENTIAL"); + + ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs), + &ffestp_file.open.open_spec[FFESTP_openixPOSITION], + "APPEND, ASIS, or REWIND"); + + ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs), + &ffestp_file.open.open_spec[FFESTP_openixACTION], + "READ, READWRITE, or WRITE"); + + ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs), + &ffestp_file.open.open_spec[FFESTP_openixDELIM], + "APOSTROPHE, NONE, or QUOTE"); + + ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs), + &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE], + "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE"); + + ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs), + &ffestp_file.open.open_spec[FFESTP_openixPAD], + "NO or YES"); + + ffestd_R904 (); + } + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R907 -- CLOSE statement + + ffestc_R907(); + + Make sure a CLOSE is valid in the current context, and implement it. */ + +void +ffestc_R907 () +{ + char *status_strs[] + = + { + "Delete", + "Keep", + "Print", + "Print/Delete", + "Save", + "Submit", + "Submit/Delete" + }; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.close.close_spec[FFESTP_closeixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.close.close_spec[FFESTP_closeixUNIT])) + { + ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs), + &ffestp_file.close.close_spec[FFESTP_closeixSTATUS], + "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE"); + + ffestd_R907 (); + } + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R909_start -- READ(...) statement list begin + + ffestc_R909_start(FALSE); + + Verify that READ is valid here, and begin accepting items in the + list. */ + +void +ffestc_R909_start (bool only_format) +{ + ffestvUnit unit; + ffestvFormat format; + bool rec; + bool key; + ffestpReadIx keyn; + ffestpReadIx spec1; + ffestpReadIx spec2; + + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_format_ + (&ffestp_file.read.read_spec[FFESTP_readixFORMAT])) + { + ffestc_ok_ = FALSE; + return; + } + + format = ffestc_subr_format_ + (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]); + ffestc_namelist_ = (format == FFESTV_formatNAMELIST); + + if (only_format) + { + ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE); + + ffestc_ok_ = TRUE; + return; + } + + if (!ffestc_subr_is_branch_ + (&ffestp_file.read.read_spec[FFESTP_readixEOR]) + || !ffestc_subr_is_branch_ + (&ffestp_file.read.read_spec[FFESTP_readixERR]) + || !ffestc_subr_is_branch_ + (&ffestp_file.read.read_spec[FFESTP_readixEND])) + { + ffestc_ok_ = FALSE; + return; + } + + unit = ffestc_subr_unit_ + (&ffestp_file.read.read_spec[FFESTP_readixUNIT]); + if (unit == FFESTV_unitNONE) + { + ffebad_start (FFEBAD_NO_UNIT_SPEC); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + ffestc_ok_ = FALSE; + return; + } + + rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present; + + if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present) + { + key = TRUE; + keyn = spec1 = FFESTP_readixKEYEQ; + } + else + { + key = FALSE; + keyn = spec1 = FFESTP_readix; + } + + if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present) + { + if (key) + { + spec2 = FFESTP_readixKEYGT; + whine: /* :::::::::::::::::::: */ + ffebad_start (FFEBAD_CONFLICTING_SPECS); + assert (ffestp_file.read.read_spec[spec1].kw_or_val_present); + if (ffestp_file.read.read_spec[spec1].kw_present) + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.read.read_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec1].kw)); + } + else + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.read.read_spec[spec1].value), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec1].value)); + } + assert (ffestp_file.read.read_spec[spec2].kw_or_val_present); + if (ffestp_file.read.read_spec[spec2].kw_present) + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.read.read_spec[spec2].kw), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec2].kw)); + } + else + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.read.read_spec[spec2].value), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec2].value)); + } + ffebad_finish (); + ffestc_ok_ = FALSE; + return; + } + key = TRUE; + keyn = spec1 = FFESTP_readixKEYGT; + } + + if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present) + { + if (key) + { + spec2 = FFESTP_readixKEYGT; + goto whine; /* :::::::::::::::::::: */ + } + key = TRUE; + keyn = FFESTP_readixKEYGT; + } + + if (rec) + { + spec1 = FFESTP_readixREC; + if (key) + { + spec2 = keyn; + goto whine; /* :::::::::::::::::::: */ + } + if (unit == FFESTV_unitCHAREXPR) + { + spec2 = FFESTP_readixUNIT; + goto whine; /* :::::::::::::::::::: */ + } + if ((format == FFESTV_formatASTERISK) + || (format == FFESTV_formatNAMELIST)) + { + spec2 = FFESTP_readixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) + { + spec2 = FFESTP_readixADVANCE; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present) + { + spec2 = FFESTP_readixEND; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present) + { + spec2 = FFESTP_readixNULLS; + goto whine; /* :::::::::::::::::::: */ + } + } + else if (key) + { + spec1 = keyn; + if (unit == FFESTV_unitCHAREXPR) + { + spec2 = FFESTP_readixUNIT; + goto whine; /* :::::::::::::::::::: */ + } + if ((format == FFESTV_formatASTERISK) + || (format == FFESTV_formatNAMELIST)) + { + spec2 = FFESTP_readixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) + { + spec2 = FFESTP_readixADVANCE; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present) + { + spec2 = FFESTP_readixEND; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present) + { + spec2 = FFESTP_readixEOR; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present) + { + spec2 = FFESTP_readixNULLS; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present) + { + spec2 = FFESTP_readixREC; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present) + { + spec2 = FFESTP_readixSIZE; + goto whine; /* :::::::::::::::::::: */ + } + } + else + { /* Sequential/Internal. */ + if (unit == FFESTV_unitCHAREXPR) + { /* Internal file. */ + spec1 = FFESTP_readixUNIT; + if (format == FFESTV_formatNAMELIST) + { + spec2 = FFESTP_readixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) + { + spec2 = FFESTP_readixADVANCE; + goto whine; /* :::::::::::::::::::: */ + } + } + if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present) + { /* ADVANCE= specified. */ + spec1 = FFESTP_readixADVANCE; + if (format == FFESTV_formatNONE) + { + ffebad_start (FFEBAD_MISSING_FORMAT_SPEC); + ffebad_here (0, ffelex_token_where_line + (ffestp_file.read.read_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec1].kw)); + ffebad_finish (); + + ffestc_ok_ = FALSE; + return; + } + if (format == FFESTV_formatNAMELIST) + { + spec2 = FFESTP_readixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + } + if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present) + { /* EOR= specified. */ + spec1 = FFESTP_readixEOR; + if (ffestc_subr_speccmp_ ("No", + &ffestp_file.read.read_spec[FFESTP_readixADVANCE], + NULL, NULL) != 0) + { + goto whine_advance; /* :::::::::::::::::::: */ + } + } + if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present) + { /* NULLS= specified. */ + spec1 = FFESTP_readixNULLS; + if (format != FFESTV_formatASTERISK) + { + spec2 = FFESTP_readixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + } + if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present) + { /* SIZE= specified. */ + spec1 = FFESTP_readixSIZE; + if (ffestc_subr_speccmp_ ("No", + &ffestp_file.read.read_spec[FFESTP_readixADVANCE], + NULL, NULL) != 0) + { + whine_advance: /* :::::::::::::::::::: */ + if (ffestp_file.read.read_spec[FFESTP_readixADVANCE] + .kw_or_val_present) + { + ffebad_start (FFEBAD_CONFLICTING_SPECS); + ffebad_here (0, ffelex_token_where_line + (ffestp_file.read.read_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec1].kw)); + ffebad_here (1, ffelex_token_where_line + (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw), + ffelex_token_where_column + (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw)); + ffebad_finish (); + } + else + { + ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC); + ffebad_here (0, ffelex_token_where_line + (ffestp_file.read.read_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.read.read_spec[spec1].kw)); + ffebad_finish (); + } + + ffestc_ok_ = FALSE; + return; + } + } + } + + if (unit == FFESTV_unitCHAREXPR) + ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF; + else + ffestc_iolist_context_ = FFEEXPR_contextIOLIST; + + ffestd_R909_start (FALSE, unit, format, rec, key); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R909_item -- READ statement i/o item + + ffestc_R909_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_R909_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if (ffestc_namelist_ != 0) + { + if (ffestc_namelist_ == 1) + { + ffestc_namelist_ = 2; + ffebad_start (FFEBAD_NAMELIST_ITEMS); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + } + return; + } + + ffestd_R909_item (expr, expr_token); +} + +/* ffestc_R909_finish -- READ statement list complete + + ffestc_R909_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R909_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R909_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R910_start -- WRITE(...) statement list begin + + ffestc_R910_start(); + + Verify that WRITE is valid here, and begin accepting items in the + list. */ + +void +ffestc_R910_start () +{ + ffestvUnit unit; + ffestvFormat format; + bool rec; + ffestpWriteIx spec1; + ffestpWriteIx spec2; + + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_branch_ + (&ffestp_file.write.write_spec[FFESTP_writeixEOR]) + || !ffestc_subr_is_branch_ + (&ffestp_file.write.write_spec[FFESTP_writeixERR]) + || !ffestc_subr_is_format_ + (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT])) + { + ffestc_ok_ = FALSE; + return; + } + + format = ffestc_subr_format_ + (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]); + ffestc_namelist_ = (format == FFESTV_formatNAMELIST); + + unit = ffestc_subr_unit_ + (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]); + if (unit == FFESTV_unitNONE) + { + ffebad_start (FFEBAD_NO_UNIT_SPEC); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + ffestc_ok_ = FALSE; + return; + } + + rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present; + + if (rec) + { + spec1 = FFESTP_writeixREC; + if (unit == FFESTV_unitCHAREXPR) + { + spec2 = FFESTP_writeixUNIT; + whine: /* :::::::::::::::::::: */ + ffebad_start (FFEBAD_CONFLICTING_SPECS); + assert (ffestp_file.write.write_spec[spec1].kw_or_val_present); + if (ffestp_file.write.write_spec[spec1].kw_present) + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.write.write_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec1].kw)); + } + else + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.write.write_spec[spec1].value), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec1].value)); + } + assert (ffestp_file.write.write_spec[spec2].kw_or_val_present); + if (ffestp_file.write.write_spec[spec2].kw_present) + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.write.write_spec[spec2].kw), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec2].kw)); + } + else + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.write.write_spec[spec2].value), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec2].value)); + } + ffebad_finish (); + ffestc_ok_ = FALSE; + return; + } + if ((format == FFESTV_formatASTERISK) + || (format == FFESTV_formatNAMELIST)) + { + spec2 = FFESTP_writeixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present) + { + spec2 = FFESTP_writeixADVANCE; + goto whine; /* :::::::::::::::::::: */ + } + } + else + { /* Sequential/Indexed/Internal. */ + if (unit == FFESTV_unitCHAREXPR) + { /* Internal file. */ + spec1 = FFESTP_writeixUNIT; + if (format == FFESTV_formatNAMELIST) + { + spec2 = FFESTP_writeixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present) + { + spec2 = FFESTP_writeixADVANCE; + goto whine; /* :::::::::::::::::::: */ + } + } + if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present) + { /* ADVANCE= specified. */ + spec1 = FFESTP_writeixADVANCE; + if (format == FFESTV_formatNONE) + { + ffebad_start (FFEBAD_MISSING_FORMAT_SPEC); + ffebad_here (0, ffelex_token_where_line + (ffestp_file.write.write_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec1].kw)); + ffebad_finish (); + + ffestc_ok_ = FALSE; + return; + } + if (format == FFESTV_formatNAMELIST) + { + spec2 = FFESTP_writeixFORMAT; + goto whine; /* :::::::::::::::::::: */ + } + } + if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present) + { /* EOR= specified. */ + spec1 = FFESTP_writeixEOR; + if (ffestc_subr_speccmp_ ("No", + &ffestp_file.write.write_spec[FFESTP_writeixADVANCE], + NULL, NULL) != 0) + { + if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE] + .kw_or_val_present) + { + ffebad_start (FFEBAD_CONFLICTING_SPECS); + ffebad_here (0, ffelex_token_where_line + (ffestp_file.write.write_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec1].kw)); + ffebad_here (1, ffelex_token_where_line + (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw), + ffelex_token_where_column + (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw)); + ffebad_finish (); + } + else + { + ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC); + ffebad_here (0, ffelex_token_where_line + (ffestp_file.write.write_spec[spec1].kw), + ffelex_token_where_column + (ffestp_file.write.write_spec[spec1].kw)); + ffebad_finish (); + } + + ffestc_ok_ = FALSE; + return; + } + } + } + + if (unit == FFESTV_unitCHAREXPR) + ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF; + else + ffestc_iolist_context_ = FFEEXPR_contextIOLIST; + + ffestd_R910_start (unit, format, rec); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R910_item -- WRITE statement i/o item + + ffestc_R910_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_R910_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if (ffestc_namelist_ != 0) + { + if (ffestc_namelist_ == 1) + { + ffestc_namelist_ = 2; + ffebad_start (FFEBAD_NAMELIST_ITEMS); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + } + return; + } + + ffestd_R910_item (expr, expr_token); +} + +/* ffestc_R910_finish -- WRITE statement list complete + + ffestc_R910_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R910_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R910_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R911_start -- PRINT(...) statement list begin + + ffestc_R911_start(); + + Verify that PRINT is valid here, and begin accepting items in the + list. */ + +void +ffestc_R911_start () +{ + ffestvFormat format; + + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_format_ + (&ffestp_file.print.print_spec[FFESTP_printixFORMAT])) + { + ffestc_ok_ = FALSE; + return; + } + + format = ffestc_subr_format_ + (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]); + ffestc_namelist_ = (format == FFESTV_formatNAMELIST); + + ffestd_R911_start (format); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R911_item -- PRINT statement i/o item + + ffestc_R911_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_R911_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if (ffestc_namelist_ != 0) + { + if (ffestc_namelist_ == 1) + { + ffestc_namelist_ = 2; + ffebad_start (FFEBAD_NAMELIST_ITEMS); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + } + return; + } + + ffestd_R911_item (expr, expr_token); +} + +/* ffestc_R911_finish -- PRINT statement list complete + + ffestc_R911_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R911_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R911_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R919 -- BACKSPACE statement + + ffestc_R919(); + + Make sure a BACKSPACE is valid in the current context, and implement it. */ + +void +ffestc_R919 () +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) + ffestd_R919 (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R920 -- ENDFILE statement + + ffestc_R920(); + + Make sure a ENDFILE is valid in the current context, and implement it. */ + +void +ffestc_R920 () +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) + ffestd_R920 (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R921 -- REWIND statement + + ffestc_R921(); + + Make sure a REWIND is valid in the current context, and implement it. */ + +void +ffestc_R921 () +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) + ffestd_R921 (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version) + + ffestc_R923A(); + + Make sure an INQUIRE is valid in the current context, and implement it. */ + +void +ffestc_R923A () +{ + bool by_file; + bool by_unit; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR])) + { + by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE] + .kw_or_val_present; + by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT] + .kw_or_val_present; + if (by_file && by_unit) + { + ffebad_start (FFEBAD_CONFLICTING_SPECS); + assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present); + if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present) + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw), + ffelex_token_where_column + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw)); + } + else + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value), + ffelex_token_where_column + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value)); + } + assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present); + if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present) + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw), + ffelex_token_where_column + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw)); + } + else + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value), + ffelex_token_where_column + (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value)); + } + ffebad_finish (); + } + else if (!by_file && !by_unit) + { + ffebad_start (FFEBAD_MISSING_SPECIFIER); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_string ("UNIT= or FILE="); + ffebad_finish (); + } + else + ffestd_R923A (by_file); + } + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin + + ffestc_R923B_start(); + + Verify that INQUIRE is valid here, and begin accepting items in the + list. */ + +void +ffestc_R923B_start () +{ + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + ffestd_R923B_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R923B_item -- INQUIRE statement i/o item + + ffestc_R923B_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + ffestd_R923B_item (expr); +} + +/* ffestc_R923B_finish -- INQUIRE statement list complete + + ffestc_R923B_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R923B_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R923B_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R1001 -- FORMAT statement + + ffestc_R1001(format_list); + + Make sure format_list is valid. Update label's info to indicate it is a + FORMAT label, and (perhaps) warn if there is no label! */ + +void +ffestc_R1001 (ffesttFormatList f) +{ + ffestc_check_simple_ (); + if (ffestc_order_format_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_format_ (); + + ffestd_R1001 (f); +} + +/* ffestc_R1102 -- PROGRAM statement + + ffestc_R1102(name_token); + + Make sure ffestc_kind_ identifies an empty block. Make sure name_token + gives a valid name. Implement the beginning of a main program. */ + +void +ffestc_R1102 (ffelexToken name) +{ + ffestw b; + ffesymbol s; + + assert (name != NULL); + + ffestc_check_simple_ (); + if (ffestc_order_unit_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_blocknum_ = 0; + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_statePROGRAM0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_end_program_); + + ffestw_set_name (b, ffelex_token_use (name)); + + s = ffesymbol_declare_programunit (name, + ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindPROGRAM, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, name); + + ffestd_R1102 (s, name); +} + +/* ffestc_R1103 -- END PROGRAM statement + + ffestc_R1103(name_token); + + Make sure ffestc_kind_ identifies the current kind of program unit. If not + NULL, make sure name_token gives the correct name. Implement the end + of the current program unit. */ + +void +ffestc_R1103 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_program_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + if (name != NULL) + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_PROGRAM_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) + { + ffebad_start (FFEBAD_UNIT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + ffestc_shriek_end_program_ (TRUE); +} + +/* ffestc_R1105 -- MODULE statement + + ffestc_R1105(name_token); + + Make sure ffestc_kind_ identifies an empty block. Make sure name_token + gives a valid name. Implement the beginning of a module. */ + +#if FFESTR_F90 +void +ffestc_R1105 (ffelexToken name) +{ + ffestw b; + + assert (name != NULL); + + ffestc_check_simple_ (); + if (ffestc_order_unit_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_blocknum_ = 0; + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateMODULE0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_module_); + ffestw_set_name (b, ffelex_token_use (name)); + + ffestd_R1105 (name); +} + +/* ffestc_R1106 -- END MODULE statement + + ffestc_R1106(name_token); + + Make sure ffestc_kind_ identifies the current kind of program unit. If not + NULL, make sure name_token gives the correct name. Implement the end + of the current program unit. */ + +void +ffestc_R1106 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_module_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if ((name != NULL) + && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) + { + ffebad_start (FFEBAD_UNIT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + + ffestc_shriek_module_ (TRUE); +} + +/* ffestc_R1107_start -- USE statement list begin + + ffestc_R1107_start(); + + Verify that USE is valid here, and begin accepting items in the list. */ + +void +ffestc_R1107_start (ffelexToken name, bool only) +{ + ffestc_check_start_ (); + if (ffestc_order_use_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R1107_start (name, only); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R1107_item -- USE statement for name + + ffestc_R1107_item(local_token,use_token); + + Make sure name_token identifies a valid object to be USEed. local_token + may be NULL if _start_ was called with only==TRUE. */ + +void +ffestc_R1107_item (ffelexToken local, ffelexToken use) +{ + ffestc_check_item_ (); + assert (use != NULL); + if (!ffestc_ok_) + return; + + ffestd_R1107_item (local, use); +} + +/* ffestc_R1107_finish -- USE statement list complete + + ffestc_R1107_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R1107_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R1107_finish (); +} + +#endif +/* ffestc_R1111 -- BLOCK DATA statement + + ffestc_R1111(name_token); + + Make sure ffestc_kind_ identifies no current program unit. If not + NULL, make sure name_token gives a valid name. Implement the beginning + of a block data program unit. */ + +void +ffestc_R1111 (ffelexToken name) +{ + ffestw b; + ffesymbol s; + + ffestc_check_simple_ (); + if (ffestc_order_unit_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_blocknum_ = 0; + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateBLOCKDATA0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_blockdata_); + + if (name == NULL) + ffestw_set_name (b, NULL); + else + ffestw_set_name (b, ffelex_token_use (name)); + + s = ffesymbol_declare_blockdataunit (name, + ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindBLOCKDATA, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, name); + + ffestd_R1111 (s, name); +} + +/* ffestc_R1112 -- END BLOCK DATA statement + + ffestc_R1112(name_token); + + Make sure ffestc_kind_ identifies the current kind of program unit. If not + NULL, make sure name_token gives the correct name. Implement the end + of the current program unit. */ + +void +ffestc_R1112 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_blockdata_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (name != NULL) + { + if (ffestw_name (ffestw_stack_top ()) == NULL) + { + ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0) + { + ffebad_start (FFEBAD_UNIT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + } + + ffestc_shriek_blockdata_ (TRUE); +} + +/* ffestc_R1202 -- INTERFACE statement + + ffestc_R1202(operator,defined_name); + + Make sure ffestc_kind_ identifies an INTERFACE block. + Implement the end of the current interface. + + 15-May-90 JCB 1.1 + Allow no operator or name to mean INTERFACE by itself; missed this + valid form when originally doing syntactic analysis code. */ + +#if FFESTR_F90 +void +ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name) +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_interfacespec_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateINTERFACE0); + ffestw_set_blocknum (b, 0); + ffestw_set_shriek (b, ffestc_shriek_interface_); + + if ((operator == FFESTP_definedoperatorNone) && (name == NULL)) + ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE + PROCEDURE. */ + else + ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */ + + ffestd_R1202 (operator, name); + + ffe_init_4 (); +} + +/* ffestc_R1203 -- END INTERFACE statement + + ffestc_R1203(); + + Make sure ffestc_kind_ identifies an INTERFACE block. + Implement the end of the current interface. */ + +void +ffestc_R1203 () +{ + ffestc_check_simple_ (); + if (ffestc_order_interface_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_shriek_interface_ (TRUE); + + ffe_terminate_4 (); +} + +/* ffestc_R1205_start -- MODULE PROCEDURE statement list begin + + ffestc_R1205_start(); + + Verify that MODULE PROCEDURE is valid here, and begin accepting items in + the list. */ + +void +ffestc_R1205_start () +{ + ffestc_check_start_ (); + if (ffestc_order_interface_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) == 0) + { + ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + ffestc_ok_ = FALSE; + return; + } + + if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0) + { + ffestw_update (NULL); /* Update state line/col info. */ + ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1); + } + + ffestd_R1205_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R1205_item -- MODULE PROCEDURE statement for name + + ffestc_R1205_item(name_token); + + Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */ + +void +ffestc_R1205_item (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_R1205_item (name); +} + +/* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete + + ffestc_R1205_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R1205_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R1205_finish (); +} + +#endif +/* ffestc_R1207_start -- EXTERNAL statement list begin + + ffestc_R1207_start(); + + Verify that EXTERNAL is valid here, and begin accepting items in the list. */ + +void +ffestc_R1207_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R1207_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R1207_item -- EXTERNAL statement for name + + ffestc_R1207_item(name_token); + + Make sure name_token identifies a valid object to be EXTERNALd. */ + +void +ffestc_R1207_item (ffelexToken name) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + s = ffesymbol_declare_local (name, FALSE); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsEXTERNAL; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, name); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_explicitwhere (s, TRUE); + ffesymbol_reference (s, name, FALSE); + ffesymbol_signal_unreported (s); + } + + ffestd_R1207_item (name); +} + +/* ffestc_R1207_finish -- EXTERNAL statement list complete + + ffestc_R1207_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R1207_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R1207_finish (); +} + +/* ffestc_R1208_start -- INTRINSIC statement list begin + + ffestc_R1208_start(); + + Verify that INTRINSIC is valid here, and begin accepting items in the list. */ + +void +ffestc_R1208_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_R1208_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R1208_item -- INTRINSIC statement for name + + ffestc_R1208_item(name_token); + + Make sure name_token identifies a valid object to be INTRINSICd. */ + +void +ffestc_R1208_item (ffelexToken name) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeintrinGen gen; + ffeintrinSpec spec; + ffeintrinImp imp; + + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + s = ffesymbol_declare_local (name, TRUE); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + else if (sa & FFESYMBOL_attrsANY) + na = sa; + else if (!(sa & ~FFESYMBOL_attrsTYPE)) + { + if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE, + &gen, &spec, &imp) + && ((imp == FFEINTRIN_impNONE) +#if 0 /* Don't bother with this for now. */ + || ((ffeintrin_basictype (spec) + == ffesymbol_basictype (s)) + && (ffeintrin_kindtype (spec) + == ffesymbol_kindtype (s))) +#else + || 1 +#endif + || !(sa & FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsINTRINSIC; + else + na = FFESYMBOL_attrsetNONE; + } + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, name); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_generic (s, gen); + ffesymbol_set_specific (s, spec); + ffesymbol_set_implementation (s, imp); + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + FFEINFO_kindNONE, + FFEINFO_whereINTRINSIC, + ffesymbol_size (s))); + ffesymbol_set_explicitwhere (s, TRUE); + ffesymbol_reference (s, name, TRUE); + } + + ffesymbol_signal_unreported (s); + + ffestd_R1208_item (name); +} + +/* ffestc_R1208_finish -- INTRINSIC statement list complete + + ffestc_R1208_finish(); + + Just wrap up any local activities. */ + +void +ffestc_R1208_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_R1208_finish (); +} + +/* ffestc_R1212 -- CALL statement + + ffestc_R1212(expr,expr_token); + + Make sure statement is valid here; implement. */ + +void +ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED) +{ + ffebld item; /* ITEM. */ + ffebld labexpr; /* LABTOK=>LABTER. */ + ffelab label; + bool ok; /* TRUE if all LABTOKs were ok. */ + bool ok1; /* TRUE if a particular LABTOK is ok. */ + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffebld_op (expr) != FFEBLD_opSUBRREF) + ffestd_R841 (FALSE); /* CONTINUE. */ + else + { + ok = TRUE; + + for (item = ffebld_right (expr); + item != NULL; + item = ffebld_trail (item)) + { + if (((labexpr = ffebld_head (item)) != NULL) + && (ffebld_op (labexpr) == FFEBLD_opLABTOK)) + { + ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr), + &label); + ffelex_token_kill (ffebld_labtok (labexpr)); + if (!ok1) + { + label = NULL; + ok = FALSE; + } + ffebld_set_op (labexpr, FFEBLD_opLABTER); + ffebld_set_labter (labexpr, label); + } + } + + if (ok) + ffestd_R1212 (expr); + } + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R1213 -- Defined assignment statement + + ffestc_R1213(dest_expr,source_expr,source_token); + + Make sure the assignment is valid. */ + +#if FFESTR_F90 +void +ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token) +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + ffestd_R1213 (dest, source); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +#endif +/* ffestc_R1219 -- FUNCTION statement + + ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent, + recursive); + + Make sure statement is valid here, register arguments for the + function name, and so on. + + 06-Apr-90 JCB 2.0 + Added the kind, len, and recursive arguments. */ + +void +ffestc_R1219 (ffelexToken funcname, ffesttTokenList args, + ffelexToken final UNUSED, ffestpType type, ffebld kind, + ffelexToken kindt, ffebld len, ffelexToken lent, + ffelexToken recursive, ffelexToken result) +{ + ffestw b; + ffesymbol s; + ffesymbol fs; /* FUNCTION symbol when dealing with RESULT + symbol. */ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffelexToken res; + bool separate_result; + + assert ((funcname != NULL) + && (ffelex_token_type (funcname) == FFELEX_typeNAME)); + + ffestc_check_simple_ (); + if (ffestc_order_iface_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_blocknum_ = 0; + ffesta_is_entry_valid = + (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL); + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateFUNCTION0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_function_); + ffestw_set_name (b, ffelex_token_use (funcname)); + + if (type == FFESTP_typeNone) + { + ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE; + ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE; + ffestc_local_.decl.size = FFETARGET_charactersizeNONE; + } + else + { + ffestc_establish_declstmt_ (type, ffesta_tokens[0], + kind, kindt, len, lent); + ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL); + } + + separate_result = (result != NULL) + && (ffelex_token_strcmp (funcname, result) != 0); + + if (separate_result) + fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */ + else + fs = ffesymbol_declare_funcunit (funcname); /* Global only. */ + + if (ffesymbol_state (fs) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_signal_unreported (fs); + + /* Note that .basic_type and .kind_type might be NONE here. */ + + ffesymbol_set_info (fs, + ffeinfo_new (ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + 0, + FFEINFO_kindFUNCTION, + FFEINFO_whereLOCAL, + ffestc_local_.decl.size)); + + /* Check whether the type info fits the filewide expectations; + set ok flag accordingly. */ + + ffesymbol_reference (fs, funcname, FALSE); + if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY) + ffestc_parent_ok_ = FALSE; + else + ffestc_parent_ok_ = TRUE; + } + else + { + if (ffesymbol_kind (fs) != FFEINFO_kindANY) + ffesymbol_error (fs, funcname); + ffestc_parent_ok_ = FALSE; + } + + if (ffestc_parent_ok_) + { + ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom); + ffestt_tokenlist_drive (args, ffestc_promote_dummy_); + ffebld_end_list (&ffestc_local_.dummy.list_bottom); + } + + if (result == NULL) + res = funcname; + else + res = result; + + s = ffesymbol_declare_funcresult (res); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if (ffesymbol_state (s) != FFESYMBOL_stateNONE) + na = FFESYMBOL_attrsetNONE; + else + { + na = FFESYMBOL_attrsRESULT; + if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE) + { + na |= FFESYMBOL_attrsTYPE; + if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER) + && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE)) + na |= FFESYMBOL_attrsANYLEN; + } + } + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE) + { + if (!(na & FFESYMBOL_attrsANY)) + ffesymbol_error (s, res); + ffesymbol_set_funcresult (fs, NULL); + ffesymbol_set_funcresult (s, NULL); + ffestc_parent_ok_ = FALSE; + } + else + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_funcresult (fs, s); + ffesymbol_set_funcresult (s, fs); + if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE) + { + ffesymbol_set_info (s, + ffeinfo_new (ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + ffestc_local_.decl.size)); + } + } + + ffesymbol_signal_unreported (fs); + + ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent, + (recursive != NULL), result, separate_result); +} + +/* ffestc_R1221 -- END FUNCTION statement + + ffestc_R1221(name_token); + + Make sure ffestc_kind_ identifies the current kind of program unit. If + not NULL, make sure name_token gives the correct name. Implement the end + of the current program unit. */ + +void +ffestc_R1221 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_function_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + if ((name != NULL) + && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) + { + ffebad_start (FFEBAD_UNIT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + + ffestc_shriek_function_ (TRUE); +} + +/* ffestc_R1223 -- SUBROUTINE statement + + ffestc_R1223(subrname,arglist,ending_token,recursive_token); + + Make sure statement is valid here, register arguments for the + subroutine name, and so on. + + 06-Apr-90 JCB 2.0 + Added the recursive argument. */ + +void +ffestc_R1223 (ffelexToken subrname, ffesttTokenList args, + ffelexToken final, ffelexToken recursive) +{ + ffestw b; + ffesymbol s; + + assert ((subrname != NULL) + && (ffelex_token_type (subrname) == FFELEX_typeNAME)); + + ffestc_check_simple_ (); + if (ffestc_order_iface_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestc_blocknum_ = 0; + ffesta_is_entry_valid + = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL); + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateSUBROUTINE0); + ffestw_set_blocknum (b, ffestc_blocknum_++); + ffestw_set_shriek (b, ffestc_shriek_subroutine_); + ffestw_set_name (b, ffelex_token_use (subrname)); + + s = ffesymbol_declare_subrunit (subrname); + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindSUBROUTINE, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + ffestc_parent_ok_ = TRUE; + } + else + { + if (ffesymbol_kind (s) != FFEINFO_kindANY) + ffesymbol_error (s, subrname); + ffestc_parent_ok_ = FALSE; + } + + if (ffestc_parent_ok_) + { + ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom); + ffestt_tokenlist_drive (args, ffestc_promote_dummy_); + ffebld_end_list (&ffestc_local_.dummy.list_bottom); + } + + ffesymbol_signal_unreported (s); + + ffestd_R1223 (s, subrname, args, final, (recursive != NULL)); +} + +/* ffestc_R1225 -- END SUBROUTINE statement + + ffestc_R1225(name_token); + + Make sure ffestc_kind_ identifies the current kind of program unit. If + not NULL, make sure name_token gives the correct name. Implement the end + of the current program unit. */ + +void +ffestc_R1225 (ffelexToken name) +{ + ffestc_check_simple_ (); + if (ffestc_order_subroutine_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_ (); + + if ((name != NULL) + && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)) + { + ffebad_start (FFEBAD_UNIT_WRONG_NAME); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())), + ffelex_token_where_column (ffestw_name (ffestw_stack_top ()))); + ffebad_finish (); + } + + ffestc_shriek_subroutine_ (TRUE); +} + +/* ffestc_R1226 -- ENTRY statement + + ffestc_R1226(entryname,arglist,ending_token); + + Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the + entry point name, and so on. */ + +void +ffestc_R1226 (ffelexToken entryname, ffesttTokenList args, + ffelexToken final UNUSED) +{ + ffesymbol s; + ffesymbol fs; + ffesymbolAttrs sa; + ffesymbolAttrs na; + bool in_spec; /* TRUE if further specification statements + may follow, FALSE if executable stmts. */ + bool in_func; /* TRUE if ENTRY is a FUNCTION, not + SUBROUTINE. */ + + assert ((entryname != NULL) + && (ffelex_token_type (entryname) == FFELEX_typeNAME)); + + ffestc_check_simple_ (); + if (ffestc_order_entry_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateFUNCTION1: + case FFESTV_stateFUNCTION2: + case FFESTV_stateFUNCTION3: + in_func = TRUE; + in_spec = TRUE; + break; + + case FFESTV_stateFUNCTION4: + in_func = TRUE; + in_spec = FALSE; + break; + + case FFESTV_stateSUBROUTINE1: + case FFESTV_stateSUBROUTINE2: + case FFESTV_stateSUBROUTINE3: + in_func = FALSE; + in_spec = TRUE; + break; + + case FFESTV_stateSUBROUTINE4: + in_func = FALSE; + in_spec = FALSE; + break; + + default: + assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL); + in_func = FALSE; + in_spec = FALSE; + break; + } + + if (in_func) + fs = ffesymbol_declare_funcunit (entryname); + else + fs = ffesymbol_declare_subrunit (entryname); + + if (ffesymbol_state (fs) == FFESYMBOL_stateNONE) + ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD); + else + { + if (ffesymbol_kind (fs) != FFEINFO_kindANY) + ffesymbol_error (fs, entryname); + } + + ++ffestc_entry_num_; + + ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom); + if (in_spec) + ffestt_tokenlist_drive (args, ffestc_promote_dummy_); + else + ffestt_tokenlist_drive (args, ffestc_promote_execdummy_); + ffebld_end_list (&ffestc_local_.dummy.list_bottom); + + if (in_func) + { + s = ffesymbol_declare_funcresult (entryname); + ffesymbol_set_funcresult (fs, s); + ffesymbol_set_funcresult (s, fs); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous + declarations of or references to the object. */ + + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + na = FFESYMBOL_attrsetNONE; + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if (!(sa & ~(FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsRESULT; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error + cropped up; ANY means an old error to be ignored; otherwise, + everything's ok, update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + { + ffesymbol_error (s, entryname); + ffestc_parent_ok_ = FALSE; + } + else if (na & FFESYMBOL_attrsANY) + { + ffestc_parent_ok_ = FALSE; + } + else + { + ffesymbol_set_attrs (s, na); + if (ffesymbol_state (s) == FFESYMBOL_stateNONE) + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN) + { + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + FFEINFO_kindENTITY, + FFEINFO_whereRESULT, + ffesymbol_size (s))); + ffesymbol_resolve_intrin (s); + ffestorag_exec_layout (s); + } + } + + /* Since ENTRY might appear after executable stmts, do what would have + been done if it hadn't -- give symbol implicit type and + exec-transition it. */ + + if (!in_spec && ffesymbol_is_specable (s)) + { + if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */ + ffesymbol_error (s, entryname); + s = ffecom_sym_exec_transition (s); + } + + /* Use whatever type info is available for ENTRY to set up type for its + global-name-space function symbol relative. */ + + ffesymbol_set_info (fs, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + FFEINFO_kindFUNCTION, + FFEINFO_whereLOCAL, + ffesymbol_size (s))); + + + /* Check whether the type info fits the filewide expectations; + set ok flag accordingly. */ + + ffesymbol_reference (fs, entryname, FALSE); + + /* ~~Question??: + When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be + if FOO and IBAR would normally end up with different types? I think + the answer is that FOO is always given whatever type would be chosen + for IBAR, rather than the other way around, and I think it ends up + working that way for FUNCTION FOO() RESULT(IBAR), but this should be + checked out in all its different combos. Related question is, is + there any way that FOO in either case ends up without type info + filled in? Does anyone care? */ + + ffesymbol_signal_unreported (s); + } + else + { + ffesymbol_set_info (fs, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindSUBROUTINE, + FFEINFO_whereLOCAL, + FFETARGET_charactersizeNONE)); + } + + if (!in_spec) + fs = ffecom_sym_exec_transition (fs); + + ffesymbol_signal_unreported (fs); + + ffestd_R1226 (fs); +} + +/* ffestc_R1227 -- RETURN statement + + ffestc_R1227(expr,expr_token); + + Make sure statement is valid here; implement. expr and expr_token are + both NULL if there was no expression. */ + +void +ffestc_R1227 (ffebld expr, ffelexToken expr_token) +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_notloop_begin_ (); + + for (b = ffestw_stack_top (); ; b = ffestw_previous (b)) + { + switch (ffestw_state (b)) + { + case FFESTV_statePROGRAM4: + case FFESTV_stateSUBROUTINE4: + case FFESTV_stateFUNCTION4: + goto base; /* :::::::::::::::::::: */ + + case FFESTV_stateNIL: + assert ("bad state" == NULL); + break; + + default: + break; + } + } + + base: + switch (ffestw_state (b)) + { + case FFESTV_statePROGRAM4: + if (ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_RETURN_IN_MAIN); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + if (expr != NULL) + { + ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + expr = NULL; + } + break; + + case FFESTV_stateSUBROUTINE4: + break; + + case FFESTV_stateFUNCTION4: + if (expr != NULL) + { + ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + expr = NULL; + } + break; + + default: + assert ("bad state #2" == NULL); + break; + } + + ffestd_R1227 (expr); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + + /* notloop's that are actionif's can be the target of a loop-end + statement if they're in the "then" part of a logical IF, as + in "DO 10", "10 IF (...) RETURN". */ + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_R1228 -- CONTAINS statement + + ffestc_R1228(); */ + +#if FFESTR_F90 +void +ffestc_R1228 () +{ + ffestc_check_simple_ (); + if (ffestc_order_contains_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestd_R1228 (); + + ffe_terminate_3 (); + ffe_init_3 (); +} + +#endif +/* ffestc_R1229_start -- STMTFUNCTION statement begin + + ffestc_R1229_start(func_name,func_arg_list,close_paren); + + Verify that STMTFUNCTION is valid here, establish func_arg_list in a new + "live" scope within the current scope, and expect the actual expression + (or NULL) in ffestc_R1229_finish. The reason there are two ffestc + functions to handle this is so the scope can be established, allowing + ffeexpr to assign proper characteristics to references to the dummy + arguments. */ + +void +ffestc_R1229_start (ffelexToken name, ffesttTokenList args, + ffelexToken final UNUSED) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + + ffestc_check_start_ (); + if (ffestc_order_sfunc_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + assert (name != NULL); + assert (args != NULL); + + s = ffesymbol_declare_local (name, FALSE); + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!ffesymbol_is_specable (s)) + na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */ + else if (sa & FFESYMBOL_attrsANY) + na = FFESYMBOL_attrsANY; + else if (!(sa & ~FFESYMBOL_attrsTYPE)) + na = sa | FFESYMBOL_attrsSFUNC; + else + na = FFESYMBOL_attrsetNONE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + { + ffesymbol_error (s, name); + ffestc_parent_ok_ = FALSE; + } + else if (na & FFESYMBOL_attrsANY) + ffestc_parent_ok_ = FALSE; + else + { + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + if (!ffeimplic_establish_symbol (s) + || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) + && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))) + { + ffesymbol_error (s, ffesta_tokens[0]); + ffestc_parent_ok_ = FALSE; + } + else + { + /* Tell ffeexpr that sfunc def is in progress. */ + ffesymbol_set_sfexpr (s, ffebld_new_any ()); + ffestc_parent_ok_ = TRUE; + } + } + + ffe_init_4 (); + + if (ffestc_parent_ok_) + { + ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom); + ffestc_sfdummy_argno_ = 0; + ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_); + ffebld_end_list (&ffestc_local_.dummy.list_bottom); + } + + ffestc_local_.sfunc.symbol = s; + + ffestd_R1229_start (name, args); + + ffestc_ok_ = TRUE; +} + +/* ffestc_R1229_finish -- STMTFUNCTION statement list complete + + ffestc_R1229_finish(expr,expr_token); + + If expr is NULL, an error occurred parsing the expansion expression, so + just cancel the effects of ffestc_R1229_start and pretend nothing + happened. Otherwise, install the expression as the expansion for the + statement function named in _start_, then clean up. */ + +void +ffestc_R1229_finish (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + if (ffestc_parent_ok_ && (expr != NULL)) + ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol, + ffeexpr_convert_to_sym (expr, + expr_token, + ffestc_local_.sfunc.symbol, + ffesta_tokens[0])); + + ffestd_R1229_finish (ffestc_local_.sfunc.symbol); + + ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol); + + ffe_terminate_4 (); +} + +/* ffestc_S3P4 -- INCLUDE line + + ffestc_S3P4(filename,filename_token); + + Make sure INCLUDE not preceded by any semicolons or a label def; implement. */ + +void +ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED) +{ + ffestc_check_simple_ (); + ffestc_labeldef_invalid_ (); + + ffestd_S3P4 (filename); +} + +/* ffestc_V003_start -- STRUCTURE statement list begin + + ffestc_V003_start(structure_name); + + Verify that STRUCTURE is valid here, and begin accepting items in the list. */ + +#if FFESTR_VXT +void +ffestc_V003_start (ffelexToken structure_name) +{ + ffestw b; + + ffestc_check_start_ (); + if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + ffestc_local_.V003.list_state = 2; /* Require at least one field + name. */ + ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one + member. */ + break; + + default: + ffestc_local_.V003.list_state = 0; /* No field names required. */ + if (structure_name == NULL) + { + ffebad_start (FFEBAD_STRUCT_MISSING_NAME); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + break; + } + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateSTRUCTURE); + ffestw_set_blocknum (b, 0); + ffestw_set_shriek (b, ffestc_shriek_structure_); + ffestw_set_substate (b, 0); /* No field-declarations seen yet. */ + + ffestd_V003_start (structure_name); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V003_item -- STRUCTURE statement for object-name + + ffestc_V003_item(name_token,dim_list); + + Make sure name_token identifies a valid object to be STRUCTUREd. */ + +void +ffestc_V003_item (ffelexToken name, ffesttDimList dims) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + if (ffestc_local_.V003.list_state < 2) + { + if (ffestc_local_.V003.list_state == 0) + { + ffestc_local_.V003.list_state = 1; + ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD); + ffebad_here (0, ffelex_token_where_line (name), + ffelex_token_where_column (name)); + ffebad_finish (); + } + return; + } + ffestc_local_.V003.list_state = 3; /* Have at least one field name. */ + + if (dims != NULL) + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestd_V003_item (name, dims); +} + +/* ffestc_V003_finish -- STRUCTURE statement list complete + + ffestc_V003_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V003_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + if (ffestc_local_.V003.list_state == 2) + { + ffebad_start (FFEBAD_STRUCT_MISSING_FIELD); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())), + ffestw_col (ffestw_previous (ffestw_stack_top ()))); + ffebad_finish (); + } + + ffestd_V003_finish (); +} + +/* ffestc_V004 -- END STRUCTURE statement + + ffestc_V004(); + + Make sure ffestc_kind_ identifies a STRUCTURE block. + Implement the end of the current STRUCTURE block. */ + +void +ffestc_V004 () +{ + ffestc_check_simple_ (); + if (ffestc_order_structure_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 1) + { + ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + ffestc_shriek_structure_ (TRUE); +} + +/* ffestc_V009 -- UNION statement + + ffestc_V009(); */ + +void +ffestc_V009 () +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_structure_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */ + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateUNION); + ffestw_set_blocknum (b, 0); + ffestw_set_shriek (b, ffestc_shriek_union_); + ffestw_set_substate (b, 0); /* No map decls seen yet. */ + + ffestd_V009 (); +} + +/* ffestc_V010 -- END UNION statement + + ffestc_V010(); + + Make sure ffestc_kind_ identifies a UNION block. + Implement the end of the current UNION block. */ + +void +ffestc_V010 () +{ + ffestc_check_simple_ (); + if (ffestc_order_union_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 2) + { + ffebad_start (FFEBAD_UNION_NO_TWO_MAPS); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + ffestc_shriek_union_ (TRUE); +} + +/* ffestc_V012 -- MAP statement + + ffestc_V012(); */ + +void +ffestc_V012 () +{ + ffestw b; + + ffestc_check_simple_ (); + if (ffestc_order_union_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 2) + ffestw_substate (ffestw_stack_top ())++; /* 0=>1, 1=>2. */ + + b = ffestw_update (ffestw_push (NULL)); + ffestw_set_top_do (b, NULL); + ffestw_set_state (b, FFESTV_stateMAP); + ffestw_set_blocknum (b, 0); + ffestw_set_shriek (b, ffestc_shriek_map_); + ffestw_set_substate (b, 0); /* No field-declarations seen yet. */ + + ffestd_V012 (); +} + +/* ffestc_V013 -- END MAP statement + + ffestc_V013(); + + Make sure ffestc_kind_ identifies a MAP block. + Implement the end of the current MAP block. */ + +void +ffestc_V013 () +{ + ffestc_check_simple_ (); + if (ffestc_order_map_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_useless_ (); + + if (ffestw_substate (ffestw_stack_top ()) != 1) + { + ffebad_start (FFEBAD_MAP_NO_COMPONENTS); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_finish (); + } + + ffestc_shriek_map_ (TRUE); +} + +#endif +/* ffestc_V014_start -- VOLATILE statement list begin + + ffestc_V014_start(); + + Verify that VOLATILE is valid here, and begin accepting items in the + list. */ + +void +ffestc_V014_start () +{ + ffestc_check_start_ (); + if (ffestc_order_progspec_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_V014_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V014_item_object -- VOLATILE statement for object-name + + ffestc_V014_item_object(name_token); + + Make sure name_token identifies a valid object to be VOLATILEd. */ + +void +ffestc_V014_item_object (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_V014_item_object (name); +} + +/* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name + + ffestc_V014_item_cblock(name_token); + + Make sure name_token identifies a valid common block to be VOLATILEd. */ + +void +ffestc_V014_item_cblock (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_V014_item_cblock (name); +} + +/* ffestc_V014_finish -- VOLATILE statement list complete + + ffestc_V014_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V014_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V014_finish (); +} + +/* ffestc_V016_start -- RECORD statement list begin + + ffestc_V016_start(); + + Verify that RECORD is valid here, and begin accepting items in the list. */ + +#if FFESTR_VXT +void +ffestc_V016_start () +{ + ffestc_check_start_ (); + if (ffestc_order_record_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + switch (ffestw_state (ffestw_stack_top ())) + { + case FFESTV_stateSTRUCTURE: + case FFESTV_stateMAP: + ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one + member. */ + break; + + default: + break; + } + + ffestd_V016_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V016_item_structure -- RECORD statement for common-block-name + + ffestc_V016_item_structure(name_token); + + Make sure name_token identifies a valid structure to be RECORDed. */ + +void +ffestc_V016_item_structure (ffelexToken name) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + ffestd_V016_item_structure (name); +} + +/* ffestc_V016_item_object -- RECORD statement for object-name + + ffestc_V016_item_object(name_token,dim_list); + + Make sure name_token identifies a valid object to be RECORDd. */ + +void +ffestc_V016_item_object (ffelexToken name, ffesttDimList dims) +{ + ffestc_check_item_ (); + assert (name != NULL); + if (!ffestc_ok_) + return; + + if (dims != NULL) + ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE); + + ffestd_V016_item_object (name, dims); +} + +/* ffestc_V016_finish -- RECORD statement list complete + + ffestc_V016_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V016_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V016_finish (); +} + +/* ffestc_V018_start -- REWRITE(...) statement list begin + + ffestc_V018_start(); + + Verify that REWRITE is valid here, and begin accepting items in the + list. */ + +void +ffestc_V018_start () +{ + ffestvFormat format; + + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_branch_ + (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR]) + || !ffestc_subr_is_format_ + (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]) + || !ffestc_subr_is_present_ ("UNIT", + &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT])) + { + ffestc_ok_ = FALSE; + return; + } + + format = ffestc_subr_format_ + (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]); + switch (format) + { + case FFESTV_formatNAMELIST: + case FFESTV_formatASTERISK: + ffebad_start (FFEBAD_CONFLICTING_SPECS); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present); + if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present) + { + ffebad_here (0, ffelex_token_where_line + (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw), + ffelex_token_where_column + (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw)); + } + else + { + ffebad_here (1, ffelex_token_where_line + (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value), + ffelex_token_where_column + (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value)); + } + ffebad_finish (); + ffestc_ok_ = FALSE; + return; + + default: + break; + } + + ffestd_V018_start (format); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V018_item -- REWRITE statement i/o item + + ffestc_V018_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_V018_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + ffestd_V018_item (expr); +} + +/* ffestc_V018_finish -- REWRITE statement list complete + + ffestc_V018_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V018_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V018_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V019_start -- ACCEPT statement list begin + + ffestc_V019_start(); + + Verify that ACCEPT is valid here, and begin accepting items in the + list. */ + +void +ffestc_V019_start () +{ + ffestvFormat format; + + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_format_ + (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT])) + { + ffestc_ok_ = FALSE; + return; + } + + format = ffestc_subr_format_ + (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]); + ffestc_namelist_ = (format == FFESTV_formatNAMELIST); + + ffestd_V019_start (format); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V019_item -- ACCEPT statement i/o item + + ffestc_V019_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_V019_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if (ffestc_namelist_ != 0) + { + if (ffestc_namelist_ == 1) + { + ffestc_namelist_ = 2; + ffebad_start (FFEBAD_NAMELIST_ITEMS); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + } + return; + } + + ffestd_V019_item (expr); +} + +/* ffestc_V019_finish -- ACCEPT statement list complete + + ffestc_V019_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V019_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V019_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +#endif +/* ffestc_V020_start -- TYPE statement list begin + + ffestc_V020_start(); + + Verify that TYPE is valid here, and begin accepting items in the + list. */ + +void +ffestc_V020_start () +{ + ffestvFormat format; + + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_format_ + (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT])) + { + ffestc_ok_ = FALSE; + return; + } + + format = ffestc_subr_format_ + (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]); + ffestc_namelist_ = (format == FFESTV_formatNAMELIST); + + ffestd_V020_start (format); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V020_item -- TYPE statement i/o item + + ffestc_V020_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_V020_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + if (ffestc_namelist_ != 0) + { + if (ffestc_namelist_ == 1) + { + ffestc_namelist_ = 2; + ffebad_start (FFEBAD_NAMELIST_ITEMS); + ffebad_here (0, ffelex_token_where_line (expr_token), + ffelex_token_where_column (expr_token)); + ffebad_finish (); + } + return; + } + + ffestd_V020_item (expr); +} + +/* ffestc_V020_finish -- TYPE statement list complete + + ffestc_V020_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V020_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V020_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V021 -- DELETE statement + + ffestc_V021(); + + Make sure a DELETE is valid in the current context, and implement it. */ + +#if FFESTR_VXT +void +ffestc_V021 () +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT])) + ffestd_V021 (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V022 -- UNLOCK statement + + ffestc_V022(); + + Make sure a UNLOCK is valid in the current context, and implement it. */ + +void +ffestc_V022 () +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.beru.beru_spec[FFESTP_beruixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT])) + ffestd_V022 (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V023_start -- ENCODE(...) statement list begin + + ffestc_V023_start(); + + Verify that ENCODE is valid here, and begin accepting items in the + list. */ + +void +ffestc_V023_start () +{ + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_branch_ + (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR])) + { + ffestc_ok_ = FALSE; + return; + } + + ffestd_V023_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V023_item -- ENCODE statement i/o item + + ffestc_V023_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_V023_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + ffestd_V023_item (expr); +} + +/* ffestc_V023_finish -- ENCODE statement list complete + + ffestc_V023_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V023_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V023_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V024_start -- DECODE(...) statement list begin + + ffestc_V024_start(); + + Verify that DECODE is valid here, and begin accepting items in the + list. */ + +void +ffestc_V024_start () +{ + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + if (!ffestc_subr_is_branch_ + (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR])) + { + ffestc_ok_ = FALSE; + return; + } + + ffestd_V024_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V024_item -- DECODE statement i/o item + + ffestc_V024_item(expr,expr_token); + + Implement output-list expression. */ + +void +ffestc_V024_item (ffebld expr, ffelexToken expr_token) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + ffestd_V024_item (expr); +} + +/* ffestc_V024_finish -- DECODE statement list complete + + ffestc_V024_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V024_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V024_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V025_start -- DEFINEFILE statement list begin + + ffestc_V025_start(); + + Verify that DEFINEFILE is valid here, and begin accepting items in the + list. */ + +void +ffestc_V025_start () +{ + ffestc_check_start_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_branch_begin_ (); + + ffestd_V025_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V025_item -- DEFINE FILE statement item + + ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt); + + Implement item. */ + +void +ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt, + ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + ffestd_V025_item (u, m, n, asv); +} + +/* ffestc_V025_finish -- DEFINE FILE statement list complete + + ffestc_V025_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V025_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V025_finish (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_V026 -- FIND statement + + ffestc_V026(); + + Make sure a FIND is valid in the current context, and implement it. */ + +void +ffestc_V026 () +{ + ffestc_check_simple_ (); + if (ffestc_order_actionif_ () != FFESTC_orderOK_) + return; + ffestc_labeldef_branch_begin_ (); + + if (ffestc_subr_is_branch_ + (&ffestp_file.find.find_spec[FFESTP_findixERR]) + && ffestc_subr_is_present_ ("UNIT", + &ffestp_file.find.find_spec[FFESTP_findixUNIT]) + && ffestc_subr_is_present_ ("REC", + &ffestp_file.find.find_spec[FFESTP_findixREC])) + ffestd_V026 (); + + if (ffestc_shriek_after1_ != NULL) + (*ffestc_shriek_after1_) (TRUE); + ffestc_labeldef_branch_end_ (); +} + +#endif +/* ffestc_V027_start -- VXT PARAMETER statement list begin + + ffestc_V027_start(); + + Verify that PARAMETER is valid here, and begin accepting items in the list. */ + +void +ffestc_V027_start () +{ + ffestc_check_start_ (); + if (ffestc_order_parameter_ () != FFESTC_orderOK_) + { + ffestc_ok_ = FALSE; + return; + } + ffestc_labeldef_useless_ (); + + ffestd_V027_start (); + + ffestc_ok_ = TRUE; +} + +/* ffestc_V027_item -- VXT PARAMETER statement assignment + + ffestc_V027_item(dest,dest_token,source,source_token); + + Make sure the source is a valid source for the destination; make the + assignment. */ + +void +ffestc_V027_item (ffelexToken dest_token, ffebld source, + ffelexToken source_token UNUSED) +{ + ffestc_check_item_ (); + if (!ffestc_ok_) + return; + + ffestd_V027_item (dest_token, source); +} + +/* ffestc_V027_finish -- VXT PARAMETER statement list complete + + ffestc_V027_finish(); + + Just wrap up any local activities. */ + +void +ffestc_V027_finish () +{ + ffestc_check_finish_ (); + if (!ffestc_ok_) + return; + + ffestd_V027_finish (); +} + +/* Any executable statement. Mainly make sure that one-shot things + like the statement for a logical IF are reset. */ + +void +ffestc_any () +{ + ffestc_check_simple_ (); + + ffestc_order_any_ (); + + ffestc_labeldef_any_ (); + + if (ffestc_shriek_after1_ == NULL) + return; + + ffestd_any (); + + (*ffestc_shriek_after1_) (TRUE); +} |