| /* stc.c -- Implementation File (module.c template V1.0) |
| Copyright (C) 1995, 1996, 1997, 2003 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; |
| }; /* 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); |
| 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); |
| static ffestcOrder_ ffestc_order_data_ (void); |
| static ffestcOrder_ ffestc_order_data77_ (void); |
| 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); |
| static ffestcOrder_ ffestc_order_parameter_ (void); |
| static ffestcOrder_ ffestc_order_program_ (void); |
| static ffestcOrder_ ffestc_order_progspec_ (void); |
| static ffestcOrder_ ffestc_order_selectcase_ (void); |
| static ffestcOrder_ ffestc_order_sfunc_ (void); |
| static ffestcOrder_ ffestc_order_subroutine_ (void); |
| static ffestcOrder_ ffestc_order_typedecl_ (void); |
| static ffestcOrder_ ffestc_order_unit_ (void); |
| 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); |
| static void ffestc_shriek_blockdata_ (bool ok); |
| static void ffestc_shriek_do_ (bool ok); |
| static void ffestc_shriek_end_program_ (bool ok); |
| static void ffestc_shriek_function_ (bool ok); |
| static void ffestc_shriek_if_ (bool ok); |
| static void ffestc_shriek_ifthen_ (bool ok); |
| static void ffestc_shriek_select_ (bool ok); |
| static void ffestc_shriek_subroutine_ (bool ok); |
| static int ffestc_subr_binsrch_ (const char *const *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_() |
| #define ffestc_shriek_if_lost_ ffestc_shriek_if_ |
| |
| /* 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 (void) |
| { |
| 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 (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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_actiondo_ -- Check ordering on <actiondo> statement |
| |
| if (ffestc_order_actiondo_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_actiondo_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| return FFESTC_orderOK_; |
| |
| case FFESTV_stateIF: |
| ffestc_shriek_after1_ = ffestc_shriek_if_; |
| return FFESTC_orderOK_; |
| |
| case FFESTV_stateUSE: |
| 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_ (void) |
| { |
| 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: |
| return; |
| |
| case FFESTV_stateIF: |
| ffestc_shriek_after1_ = ffestc_shriek_if_; |
| return; |
| |
| case FFESTV_stateUSE: |
| 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_ (void) |
| { |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_data_ -- Check ordering on DATA statement |
| |
| if (ffestc_order_data_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_data_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_do_ -- Check ordering on <do> statement |
| |
| if (ffestc_order_do_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_do_ (void) |
| { |
| switch (ffestw_state (ffestw_stack_top ())) |
| { |
| case FFESTV_stateDO: |
| return FFESTC_orderOK_; |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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_ (); |
| 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_ (void) |
| { |
| switch (ffestw_state (ffestw_stack_top ())) |
| { |
| case FFESTV_stateIFTHEN: |
| return FFESTC_orderOK_; |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_parameter_ -- Check ordering on <parameter> statement |
| |
| if (ffestc_order_parameter_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_parameter_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_selectcase_ -- Check ordering on <selectcase> statement |
| |
| if (ffestc_order_selectcase_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_selectcase_ (void) |
| { |
| switch (ffestw_state (ffestw_stack_top ())) |
| { |
| case FFESTV_stateSELECT0: |
| case FFESTV_stateSELECT1: |
| return FFESTC_orderOK_; |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_subroutine_ -- Check ordering on <subroutine> statement |
| |
| if (ffestc_order_subroutine_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_subroutine_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_typedecl_ -- Check ordering on <typedecl> statement |
| |
| if (ffestc_order_typedecl_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_typedecl_ (void) |
| { |
| 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: |
| goto recurse; /* :::::::::::::::::::: */ |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| 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_unit_ -- Check ordering on <unit> statement |
| |
| if (ffestc_order_unit_() != FFESTC_orderOK_) |
| return; */ |
| |
| static ffestcOrder_ |
| ffestc_order_unit_ (void) |
| { |
| switch (ffestw_state (ffestw_stack_top ())) |
| { |
| case FFESTV_stateNIL: |
| return FFESTC_orderOK_; |
| |
| case FFESTV_stateWHERE: |
| ffestc_order_bad_ (); |
| return FFESTC_orderBAD_; |
| |
| case FFESTV_stateIF: |
| ffestc_order_bad_ (); |
| ffestc_shriek_if_ (FALSE); |
| return FFESTC_orderBAD_; |
| |
| default: |
| ffestc_order_bad_ (); |
| return FFESTC_orderBAD_; |
| } |
| } |
| /* 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 stat
|
