diff options
Diffstat (limited to 'contrib/gcc/f/stc.c')
| -rw-r--r-- | contrib/gcc/f/stc.c | 13902 |
1 files changed, 0 insertions, 13902 deletions
diff --git a/contrib/gcc/f/stc.c b/contrib/gcc/f/stc.c deleted file mode 100644 index b89b7472d57d..000000000000 --- a/contrib/gcc/f/stc.c +++ /dev/null @@ -1,13902 +0,0 @@ -/* stc.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995-1997 Free Software Foundation, Inc. - Contributed by James Craig Burley. - -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_ (const char **list, int size, ffestpFile *spec, - const 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_ (const char *name, ffestpFile *spec); -static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, - const 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_ (const char **list, int size, ffestpFile *spec, const char *whine) -{ - int lowest_tested; - int highest_tested; - int halfway; - int offset; - int c; - const 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_ (const 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_ (const char *string, ffestpFile *spec, const 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_ (); - - /* Mark target symbol as target of an ASSIGN. */ - if (ffebld_op (target) == FFEBLD_opSYMTER) - ffesymbol_set_assigned (ffebld_symter (target), TRUE); - - 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; - const char *status_strs[] - = - { - "New", - "Old", - "Replace", - "Scratch", - "Unknown" - }; - const char *access_strs[] - = - { - "Append", - "Direct", - "Keyed", - "Sequential" - }; - const char *blank_strs[] - = - { - "Null", - "Zero" - }; - const char *carriagecontrol_strs[] - = - { - "Fortran", - "List", - "None" - }; - const char *dispose_strs[] - = - { - "Delete", - "Keep", - "Print", - "Print/Delete", - "Save", - "Submit", - "Submit/Delete" - }; - const char *form_strs[] - = - { - "Formatted", - "Unformatted" - }; - const char *organization_strs[] - = - { - "Indexed", - "Relative", - "Sequential" - }; - const char *position_strs[] - = - { - "Append", - "AsIs", - "Rewind" - }; - const char *action_strs[] - = - { - "Read", - "ReadWrite", - "Write" - }; - const char *delim_strs[] - = - { - "Apostrophe", - "None", - "Quote" - }; - const char *recordtype_strs[] - = - { - "Fixed", - "Segmented", - "Stream", - "Stream_CR", - "Stream_LF", - "Variable" - }; - const 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 () -{ - const 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 ()); - ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_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); -} |