/* stc.c -- Implementation File (module.c template V1.0) Copyright (C) 1995-1997 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. GNU Fortran is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Fortran is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Fortran; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Related Modules: st.c Description: Verifies the proper semantics for statements, checking expressions already semantically analyzed individually, collectively, checking label defs and refs, and so on. Uses ffebad to indicate errors in semantics. In many cases, both a token and a keyword (ffestrFirst, ffestrSecond, or ffestrOther) is provided. ONLY USE THE TOKEN as a pointer to the source-code location for an error message or similar; use the keyword as the semantic matching for the token, since the token's text might not match the keyword's code. For example, INTENT(IN OUT) A in free source form passes to ffestc_R519_start the token "IN" but the keyword FFESTR_otherINOUT, and the latter is correct. Generally, either a single ffestc function handles an entire statement, in which case its name is ffestc_xyz_, or more than one function is needed, in which case its names are ffestc_xyz_start_, ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_. The caller must call _start_ before calling any _item_ functions, and must call _finish_ afterwards. If it is clearly a syntactic matter as to restrictions on the number and variety of _item_ calls, then the caller should report any errors and ffestc_ should presume it has been taken care of and handle any semantic problems with grace and no error messages. If the permitted number and variety of _item_ calls has some basis in semantics, then the caller should not generate any messages and ffestc should do all the checking. A few ffestc functions have names rather than grammar numbers, like ffestc_elsewhere and ffestc_end. These are cases where the actual statement depends on its context rather than just its form; ELSE WHERE may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE). The actual ffestc functions do exist and do work, but may or may not be invoked by ffestb depending on whether some form of resolution is possible. For example, ffestc_R1103 end-program-stmt is reachable directly when END PROGRAM [name] is specified, or via ffestc_end when END is specified and the context is a main program. So ffestc_xyz_ should make a quick determination of the context and pick the appropriate ffestc_Nxyz_ function to invoke, without a lot of ceremony. Modifications: */ /* Include files. */ #include "proj.h" #include "stc.h" #include "bad.h" #include "bld.h" #include "data.h" #include "expr.h" #include "global.h" #include "implic.h" #include "lex.h" #include "malloc.h" #include "src.h" #include "sta.h" #include "std.h" #include "stp.h" #include "str.h" #include "stt.h" #include "stw.h" /* Externals defined here. */ ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST; /* Valid only from READ/WRITE start to finish. */ /* Simple definitions and enumerations. */ typedef enum { FFESTC_orderOK_, /* Statement ok in this context, process. */ FFESTC_orderBAD_, /* Statement not ok in this context, don't process. */ FFESTC_orderBADOK_, /* Don't process but push block if applicable. */ FFESTC } ffestcOrder_; typedef enum { FFESTC_stateletSIMPLE_, /* Expecting simple/start. */ FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */ FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ FFESTC_ } ffestcStatelet_; /* Internal typedefs. */ /* Private include files. */ /* Internal structure definitions. */ union ffestc_local_u_ { struct { ffebld initlist; /* For list of one sym in INTEGER I/3/ case. */ ffetargetCharacterSize stmt_size; ffetargetCharacterSize size; ffeinfoBasictype basic_type; ffeinfoKindtype stmt_kind_type; ffeinfoKindtype kind_type; bool per_var_kind_ok; char is_R426; /* 1=R426, 2=R501. */ } decl; struct { ffebld objlist; /* For list of target objects. */ ffebldListBottom list_bottom; /* For building lists. */ } data; struct { ffebldListBottom list_bottom; /* For building lists. */ int entry_num; } dummy; struct { ffesymbol symbol; /* NML symbol. */ } namelist; struct { ffelexToken t; /* First token in list. */ ffeequiv eq; /* Current equivalence being built up. */ ffebld list; /* List of expressions in equivalence. */ ffebldListBottom bottom; bool ok; /* TRUE while current list still being processed. */ bool save; /* TRUE if any var in list is SAVEd. */ } equiv; struct { ffesymbol symbol; /* BCB/NCB symbol. */ } common; struct { ffesymbol symbol; /* SFN symbol. */ } sfunc; #if FFESTR_VXT struct { char list_state; /* 0=>no field names allowed, 1=>error reported already, 2=>field names req'd, 3=>have a field name. */ } V003; #endif }; /* Merge with the one in ffestc later. */ /* Static objects accessed by functions in this module. */ static bool ffestc_ok_; /* _start_ fn's send this to _xyz_ fn's. */ static bool ffestc_parent_ok_; /* Parent sym for baby sym fn's ok. */ static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */ static union ffestc_local_u_ ffestc_local_; static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_; static ffestwShriek ffestc_shriek_after1_ = NULL; static unsigned long ffestc_blocknum_ = 0; /* Next block# to assign. */ static int ffestc_entry_num_; static int ffestc_sfdummy_argno_; static int ffestc_saved_entry_num_; static ffelab ffestc_label_; /* Static functions (internal). */ static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t); static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent); static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent); static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last); static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val); static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val); static void ffestc_labeldef_any_ (void); static bool ffestc_labeldef_begin_ (void); static void ffestc_labeldef_branch_begin_ (void); static void ffestc_labeldef_branch_end_ (void); static void ffestc_labeldef_endif_ (void); static void ffestc_labeldef_format_ (void); static void ffestc_labeldef_invalid_ (void); static void ffestc_labeldef_notloop_ (void); static void ffestc_labeldef_notloop_begin_ (void); static void ffestc_labeldef_useless_ (void); static bool ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *label); static bool ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *label); static bool ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *label); static bool ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *label); #if FFESTR_F90 static ffestcOrder_ ffestc_order_access_ (void); #endif static ffestcOrder_ ffestc_order_actiondo_ (void); static ffestcOrder_ ffestc_order_actionif_ (void); static ffestcOrder_ ffestc_order_actionwhere_ (void); static void ffestc_order_any_ (void); static void ffestc_order_bad_ (void); static ffestcOrder_ ffestc_order_blockdata_ (void); static ffestcOrder_ ffestc_order_blockspec_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_component_ (void); #endif #if FFESTR_F90 static ffestcOrder_ ffestc_order_contains_ (void); #endif static ffestcOrder_ ffestc_order_data_ (void); static ffestcOrder_ ffestc_order_data77_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_derivedtype_ (void); #endif static ffestcOrder_ ffestc_order_do_ (void); static ffestcOrder_ ffestc_order_entry_ (void); static ffestcOrder_ ffestc_order_exec_ (void); static ffestcOrder_ ffestc_order_format_ (void); static ffestcOrder_ ffestc_order_function_ (void); static ffestcOrder_ ffestc_order_iface_ (void); static ffestcOrder_ ffestc_order_ifthen_ (void); static ffestcOrder_ ffestc_order_implicit_ (void); static ffestcOrder_ ffestc_order_implicitnone_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_interface_ (void); #endif #if FFESTR_F90 static ffestcOrder_ ffestc_order_map_ (void); #endif #if FFESTR_F90 static ffestcOrder_ ffestc_order_module_ (void); #endif static ffestcOrder_ ffestc_order_parameter_ (void); static ffestcOrder_ ffestc_order_program_ (void); static ffestcOrder_ ffestc_order_progspec_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_record_ (void); #endif static ffestcOrder_ ffestc_order_selectcase_ (void); static ffestcOrder_ ffestc_order_sfunc_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_spec_ (void); #endif #if FFESTR_VXT static ffestcOrder_ ffestc_order_structure_ (void); #endif static ffestcOrder_ ffestc_order_subroutine_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_type_ (void); #endif static ffestcOrder_ ffestc_order_typedecl_ (void); #if FFESTR_VXT static ffestcOrder_ ffestc_order_union_ (void); #endif static ffestcOrder_ ffestc_order_unit_ (void); #if FFESTR_F90 static ffestcOrder_ ffestc_order_use_ (void); #endif #if FFESTR_VXT static ffestcOrder_ ffestc_order_vxtstructure_ (void); #endif #if FFESTR_F90 static ffestcOrder_ ffestc_order_where_ (void); #endif static void ffestc_promote_dummy_ (ffelexToken t); static void ffestc_promote_execdummy_ (ffelexToken t); static void ffestc_promote_sfdummy_ (ffelexToken t); static void ffestc_shriek_begin_program_ (void); #if FFESTR_F90 static void ffestc_shriek_begin_uses_ (void); #endif static void ffestc_shriek_blockdata_ (bool ok); static void ffestc_shriek_do_ (bool ok); static void ffestc_shriek_end_program_ (bool ok); #if FFESTR_F90 static void ffestc_shriek_end_uses_ (bool ok); #endif static void ffestc_shriek_function_ (bool ok); static void ffestc_shriek_if_ (bool ok); static void ffestc_shriek_ifthen_ (bool ok); #if FFESTR_F90 static void ffestc_shriek_interface_ (bool ok); #endif #if FFESTR_F90 static void ffestc_shriek_map_ (bool ok); #endif #if FFESTR_F90 static void ffestc_shriek_module_ (bool ok); #endif static void ffestc_shriek_select_ (bool ok); #if FFESTR_VXT static void ffestc_shriek_structure_ (bool ok); #endif static void ffestc_shriek_subroutine_ (bool ok); #if FFESTR_F90 static void ffestc_shriek_type_ (bool ok); #endif #if FFESTR_VXT static void ffestc_shriek_union_ (bool ok); #endif #if FFESTR_F90 static void ffestc_shriek_where_ (bool ok); #endif #if FFESTR_F90 static void ffestc_shriek_wherethen_ (bool ok); #endif static int ffestc_subr_binsrch_ (const char **list, int size, ffestpFile *spec, const char *whine); static ffestvFormat ffestc_subr_format_ (ffestpFile *spec); static bool ffestc_subr_is_branch_ (ffestpFile *spec); static bool ffestc_subr_is_format_ (ffestpFile *spec); static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec); static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target, int *length); static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec); static void ffestc_try_shriek_do_ (void); /* Internal macros. */ #define ffestc_check_simple_() \ assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_) #define ffestc_check_start_() \ assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \ ffestc_statelet_ = FFESTC_stateletATTRIB_ #define ffestc_check_attrib_() \ assert(ffestc_statelet_ == FFESTC_stateletATTRIB_) #define ffestc_check_item_() \ assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ || ffestc_statelet_ == FFESTC_stateletITEM_); \ ffestc_statelet_ = FFESTC_stateletITEM_ #define ffestc_check_item_startvals_() \ assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ || ffestc_statelet_ == FFESTC_stateletITEM_); \ ffestc_statelet_ = FFESTC_stateletITEMVALS_ #define ffestc_check_item_value_() \ assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_) #define ffestc_check_item_endvals_() \ assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \ ffestc_statelet_ = FFESTC_stateletITEM_ #define ffestc_check_finish_() \ assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ || ffestc_statelet_ == FFESTC_stateletITEM_); \ ffestc_statelet_ = FFESTC_stateletSIMPLE_ #define ffestc_order_action_() ffestc_order_exec_() #if FFESTR_F90 #define ffestc_order_interfacespec_() ffestc_order_derivedtype_() #endif #define ffestc_shriek_if_lost_ ffestc_shriek_if_ #if FFESTR_F90 #define ffestc_shriek_where_lost_ ffestc_shriek_where_ #endif /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity ffestc_establish_declinfo_(kind,kind_token,len,len_token); Must be called after _declstmt_ called to establish base type. */ static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent) { ffeinfoBasictype bt = ffestc_local_.decl.basic_type; ffeinfoKindtype kt; ffetargetCharacterSize val; if (kindt == NULL) kt = ffestc_local_.decl.stmt_kind_type; else if (!ffestc_local_.decl.per_var_kind_ok) { ffebad_start (FFEBAD_KINDTYPE); ffebad_here (0, ffelex_token_where_line (kindt), ffelex_token_where_column (kindt)); ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), ffelex_token_where_column (ffesta_tokens[0])); ffebad_finish (); kt = ffestc_local_.decl.stmt_kind_type; } else { if (kind == NULL) { assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); val = atol (ffelex_token_text (kindt)); kt = ffestc_kindtype_star_ (bt, val); } else if (ffebld_op (kind) == FFEBLD_opANY) kt = ffestc_local_.decl.stmt_kind_type; else { assert (ffebld_op (kind) == FFEBLD_opCONTER); assert (ffeinfo_basictype (ffebld_info (kind)) == FFEINFO_basictypeINTEGER); assert (ffeinfo_kindtype (ffebld_info (kind)) == FFEINFO_kindtypeINTEGERDEFAULT); val = ffebld_constant_integerdefault (ffebld_conter (kind)); kt = ffestc_kindtype_kind_ (bt, val); } if (kt == FFEINFO_kindtypeNONE) { /* Not valid kind type. */ ffebad_start (FFEBAD_KINDTYPE); ffebad_here (0, ffelex_token_where_line (kindt), ffelex_token_where_column (kindt)); ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), ffelex_token_where_column (ffesta_tokens[0])); ffebad_finish (); kt = ffestc_local_.decl.stmt_kind_type; } } ffestc_local_.decl.kind_type = kt; /* Now check length specification for CHARACTER data type. */ if (((len == NULL) && (lent == NULL)) || (bt != FFEINFO_basictypeCHARACTER)) val = ffestc_local_.decl.stmt_size; else { if (len == NULL) { assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); val = atol (ffelex_token_text (lent)); } else if (ffebld_op (len) == FFEBLD_opSTAR) val = FFETARGET_charactersizeNONE; else if (ffebld_op (len) == FFEBLD_opANY) val = FFETARGET_charactersizeNONE; else { assert (ffebld_op (len) == FFEBLD_opCONTER); assert (ffeinfo_basictype (ffebld_info (len)) == FFEINFO_basictypeINTEGER); assert (ffeinfo_kindtype (ffebld_info (len)) == FFEINFO_kindtypeINTEGERDEFAULT); val = ffebld_constant_integerdefault (ffebld_conter (len)); } } if ((val == 0) && !(0 && ffe_is_90 ())) { val = 1; ffebad_start (FFEBAD_ZERO_SIZE); ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); ffebad_finish (); } ffestc_local_.decl.size = val; } /* ffestc_establish_declstmt_ -- Establish host-specific type/params info ffestc_establish_declstmt_(type,type_token,kind,kind_token,len, len_token); */ static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind, ffelexToken kindt, ffebld len, ffelexToken lent) { ffeinfoBasictype bt; ffeinfoKindtype ktd; /* Default kindtype. */ ffeinfoKindtype kt; ffetargetCharacterSize val; bool per_var_kind_ok = TRUE; /* Determine basictype and default kindtype. */ switch (type) { case FFESTP_typeINTEGER: bt = FFEINFO_basictypeINTEGER; ktd = FFEINFO_kindtypeINTEGERDEFAULT; break; case FFESTP_typeBYTE: bt = FFEINFO_basictypeINTEGER; ktd = FFEINFO_kindtypeINTEGER2; break; case FFESTP_typeWORD: bt = FFEINFO_basictypeINTEGER; ktd = FFEINFO_kindtypeINTEGER3; break; case FFESTP_typeREAL: bt = FFEINFO_basictypeREAL; ktd = FFEINFO_kindtypeREALDEFAULT; break; case FFESTP_typeCOMPLEX: bt = FFEINFO_basictypeCOMPLEX; ktd = FFEINFO_kindtypeREALDEFAULT; break; case FFESTP_typeLOGICAL: bt = FFEINFO_basictypeLOGICAL; ktd = FFEINFO_kindtypeLOGICALDEFAULT; break; case FFESTP_typeCHARACTER: bt = FFEINFO_basictypeCHARACTER; ktd = FFEINFO_kindtypeCHARACTERDEFAULT; break; case FFESTP_typeDBLPRCSN: bt = FFEINFO_basictypeREAL; ktd = FFEINFO_kindtypeREALDOUBLE; per_var_kind_ok = FALSE; break; case FFESTP_typeDBLCMPLX: bt = FFEINFO_basictypeCOMPLEX; #if FFETARGET_okCOMPLEX2 ktd = FFEINFO_kindtypeREALDOUBLE; #else ktd = FFEINFO_kindtypeREALDEFAULT; ffebad_start (FFEBAD_BAD_DBLCMPLX); ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), ffelex_token_where_column (ffesta_tokens[0])); ffebad_finish (); #endif per_var_kind_ok = FALSE; break; default: assert ("Unexpected type (F90 TYPE?)!" == NULL); bt = FFEINFO_basictypeNONE; ktd = FFEINFO_kindtypeNONE; break; } if (kindt == NULL) kt = ktd; else { /* Not necessarily default kind type. */ if (kind == NULL) { /* Shouldn't happen for CHARACTER. */ assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); val = atol (ffelex_token_text (kindt)); kt = ffestc_kindtype_star_ (bt, val); } else if (ffebld_op (kind) == FFEBLD_opANY) kt = ktd; else { assert (ffebld_op (kind) == FFEBLD_opCONTER); assert (ffeinfo_basictype (ffebld_info (kind)) == FFEINFO_basictypeINTEGER); assert (ffeinfo_kindtype (ffebld_info (kind)) == FFEINFO_kindtypeINTEGERDEFAULT); val = ffebld_constant_integerdefault (ffebld_conter (kind)); kt = ffestc_kindtype_kind_ (bt, val); } if (kt == FFEINFO_kindtypeNONE) { /* Not valid kind type. */ ffebad_start (FFEBAD_KINDTYPE); ffebad_here (0, ffelex_token_where_line (kindt), ffelex_token_where_column (kindt)); ffebad_here (1, ffelex_token_where_line (typet), ffelex_token_where_column (typet)); ffebad_finish (); kt = ktd; } } ffestc_local_.decl.basic_type = bt; ffestc_local_.decl.stmt_kind_type = kt; ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok; /* Now check length specification for CHARACTER data type. */ if (((len == NULL) && (lent == NULL)) || (type != FFESTP_typeCHARACTER)) val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE; else { if (len == NULL) { assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); val = atol (ffelex_token_text (lent)); } else if (ffebld_op (len) == FFEBLD_opSTAR) val = FFETARGET_charactersizeNONE; else if (ffebld_op (len) == FFEBLD_opANY) val = FFETARGET_charactersizeNONE; else { assert (ffebld_op (len) == FFEBLD_opCONTER); assert (ffeinfo_basictype (ffebld_info (len)) == FFEINFO_basictypeINTEGER); assert (ffeinfo_kindtype (ffebld_info (len)) == FFEINFO_kindtypeINTEGERDEFAULT); val = ffebld_constant_integerdefault (ffebld_conter (len)); } } if ((val == 0) && !(0 && ffe_is_90 ())) { val = 1; ffebad_start (FFEBAD_ZERO_SIZE); ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); ffebad_finish (); } ffestc_local_.decl.stmt_size = val; } /* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s) ffestc_establish_impletter_(first_letter_token,last_letter_token); */ static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last) { bool ok = FALSE; /* Stays FALSE if first letter > last. */ char c; if (last == NULL) ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)), ffestc_local_.decl.basic_type, ffestc_local_.decl.kind_type, ffestc_local_.decl.size); else { for (c = *(ffelex_token_text (first)); c <= *(ffelex_token_text (last)); c++) { ok = ffeimplic_establish_initial (c, ffestc_local_.decl.basic_type, ffestc_local_.decl.kind_type, ffestc_local_.decl.size); if (!ok) break; } } if (!ok) { char cs[2]; cs[0] = c; cs[1] = '\0'; ffebad_start (FFEBAD_BAD_IMPLICIT); ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first)); ffebad_string (cs); ffebad_finish (); } } /* ffestc_init_3 -- Initialize ffestc for new program unit ffestc_init_3(); */ void ffestc_init_3 () { ffestv_save_state_ = FFESTV_savestateNONE; ffestc_entry_num_ = 0; ffestv_num_label_defines_ = 0; } /* ffestc_init_4 -- Initialize ffestc for new scoping unit ffestc_init_4(); For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE- defs, and statement function defs. */ void ffestc_init_4 () { ffestc_saved_entry_num_ = ffestc_entry_num_; ffestc_entry_num_ = 0; } /* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value ffeinfoKindtype kt; ffeinfoBasictype bt; ffetargetCharacterSize val; kt = ffestc_kindtype_kind_(bt,val); if (kt == FFEINFO_kindtypeNONE) // unsupported/invalid KIND= value for type */ static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val) { ffetype type; ffetype base_type; ffeinfoKindtype kt; base_type = ffeinfo_type (bt, 1); /* ~~ */ assert (base_type != NULL); type = ffetype_lookup_kind (base_type, (int) val); if (type == NULL) return FFEINFO_kindtypeNONE; for (kt = 1; kt < FFEINFO_kindtype; ++kt) if (ffeinfo_type (bt, kt) == type) return kt; return FFEINFO_kindtypeNONE; } /* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value ffeinfoKindtype kt; ffeinfoBasictype bt; ffetargetCharacterSize val; kt = ffestc_kindtype_star_(bt,val); if (kt == FFEINFO_kindtypeNONE) // unsupported/invalid * value for type */ static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val) { ffetype type; ffetype base_type; ffeinfoKindtype kt; base_type = ffeinfo_type (bt, 1); /* ~~ */ assert (base_type != NULL); type = ffetype_lookup_star (base_type, (int) val); if (type == NULL) return FFEINFO_kindtypeNONE; for (kt = 1; kt < FFEINFO_kindtype; ++kt) if (ffeinfo_type (bt, kt) == type) return kt; return FFEINFO_kindtypeNONE; } /* Define label as usable for anything without complaint. */ static void ffestc_labeldef_any_ () { if ((ffesta_label_token == NULL) || !ffestc_labeldef_begin_ ()) return; ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffestc_labeldef_branch_end_ (); } /* ffestc_labeldef_begin_ -- Define label as unknown, initially ffestc_labeldef_begin_(); */ static bool ffestc_labeldef_begin_ () { ffelabValue label_value; ffelab label; label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token)); if ((label_value == 0) || (label_value > FFELAB_valueMAX)) { ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); } label = ffelab_find (label_value); if (label == NULL) { label = ffestc_label_ = ffelab_new (label_value); ffestv_num_label_defines_++; ffelab_set_definition_line (label, ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); ffelab_set_definition_column (label, ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); return TRUE; } if (ffewhere_line_is_unknown (ffelab_definition_line (label))) { ffestv_num_label_defines_++; ffestc_label_ = label; ffelab_set_definition_line (label, ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); ffelab_set_definition_column (label, ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); return TRUE; } ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_definition_line (label), ffelab_definition_column (label)); ffebad_string (ffelex_token_text (ffesta_label_token)); ffebad_finish (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; return FALSE; } /* ffestc_labeldef_branch_begin_ -- Define label as a branch target one ffestc_labeldef_branch_begin_(); */ static void ffestc_labeldef_branch_begin_ () { if ((ffesta_label_token == NULL) || (ffestc_shriek_after1_ != NULL) || !ffestc_labeldef_begin_ ()) return; switch (ffelab_type (ffestc_label_)) { case FFELAB_typeUNKNOWN: case FFELAB_typeASSIGNABLE: ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_stack_top ())); ffestd_labeldef_branch (ffestc_label_); break; case FFELAB_typeNOTLOOP: if (ffelab_blocknum (ffestc_label_) < ffestw_blocknum (ffestw_stack_top ())) { ffebad_start (FFEBAD_LABEL_BLOCK); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); } ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_stack_top ())); ffestd_labeldef_branch (ffestc_label_); break; case FFELAB_typeLOOPEND: if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) { /* Unterminated block. */ ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); ffebad_here (0, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); ffebad_here (2, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); break; } ffestd_labeldef_branch (ffestc_label_); /* Leave something around for _branch_end_() to handle. */ return; case FFELAB_typeFORMAT: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); break; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* Define possible end of labeled-DO-loop. Call only after calling ffestc_labeldef_branch_begin_, or when other branch_* functions recognize that a label might also be serving as a branch end (in which case they must issue a diagnostic). */ static void ffestc_labeldef_branch_end_ () { if (ffesta_label_token == NULL) return; assert (ffestc_label_ != NULL); assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND) || (ffelab_type (ffestc_label_) == FFELAB_typeANY)); while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO) && (ffestw_label (ffestw_stack_top ()) == ffestc_label_)) ffestc_shriek_do_ (TRUE); ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* ffestc_labeldef_endif_ -- Define label as an END IF one ffestc_labeldef_endif_(); */ static void ffestc_labeldef_endif_ () { if ((ffesta_label_token == NULL) || (ffestc_shriek_after1_ != NULL) || !ffestc_labeldef_begin_ ()) return; switch (ffelab_type (ffestc_label_)) { case FFELAB_typeUNKNOWN: case FFELAB_typeASSIGNABLE: ffelab_set_type (ffestc_label_, FFELAB_typeENDIF); ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); ffestd_labeldef_endif (ffestc_label_); break; case FFELAB_typeNOTLOOP: if (ffelab_blocknum (ffestc_label_) < ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))) { ffebad_start (FFEBAD_LABEL_BLOCK); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); } ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); ffestd_labeldef_endif (ffestc_label_); break; case FFELAB_typeLOOPEND: if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) { /* Unterminated block. */ ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); ffebad_here (0, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); ffebad_here (2, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); break; } ffestd_labeldef_endif (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_finish (); ffestc_labeldef_branch_end_ (); return; case FFELAB_typeFORMAT: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); break; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* ffestc_labeldef_format_ -- Define label as a FORMAT one ffestc_labeldef_format_(); */ static void ffestc_labeldef_format_ () { if ((ffesta_label_token == NULL) || (ffestc_shriek_after1_ != NULL)) { ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), ffelex_token_where_column (ffesta_tokens[0])); ffebad_finish (); return; } if (!ffestc_labeldef_begin_ ()) return; switch (ffelab_type (ffestc_label_)) { case FFELAB_typeUNKNOWN: case FFELAB_typeASSIGNABLE: ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT); ffestd_labeldef_format (ffestc_label_); break; case FFELAB_typeFORMAT: ffestd_labeldef_format (ffestc_label_); break; case FFELAB_typeLOOPEND: if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) { /* Unterminated block. */ ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); ffebad_here (0, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); ffebad_here (2, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); break; } ffestd_labeldef_format (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_finish (); ffestc_labeldef_branch_end_ (); return; case FFELAB_typeNOTLOOP: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); break; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present ffestc_labeldef_invalid_(); */ static void ffestc_labeldef_invalid_ () { if ((ffesta_label_token == NULL) || (ffestc_shriek_after1_ != NULL) || !ffestc_labeldef_begin_ ()) return; ffebad_start (FFEBAD_INVALID_LABEL_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* Define label as a non-loop-ending one on a statement that can't be in the "then" part of a logical IF, such as a block-IF statement. */ static void ffestc_labeldef_notloop_ () { if (ffesta_label_token == NULL) return; assert (ffestc_shriek_after1_ == NULL); if (!ffestc_labeldef_begin_ ()) return; switch (ffelab_type (ffestc_label_)) { case FFELAB_typeUNKNOWN: case FFELAB_typeASSIGNABLE: ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_stack_top ())); ffestd_labeldef_notloop (ffestc_label_); break; case FFELAB_typeNOTLOOP: if (ffelab_blocknum (ffestc_label_) < ffestw_blocknum (ffestw_stack_top ())) { ffebad_start (FFEBAD_LABEL_BLOCK); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); } ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_stack_top ())); ffestd_labeldef_notloop (ffestc_label_); break; case FFELAB_typeLOOPEND: if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) { /* Unterminated block. */ ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); ffebad_here (0, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); ffebad_here (2, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); break; } ffestd_labeldef_notloop (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_finish (); ffestc_labeldef_branch_end_ (); return; case FFELAB_typeFORMAT: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); break; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* Define label as a non-loop-ending one. Use this when it is possible that the pending label is inhibited because we're in the midst of a logical-IF, and thus _branch_end_ is going to be called after the current statement to resolve a potential loop-ending label. */ static void ffestc_labeldef_notloop_begin_ () { if ((ffesta_label_token == NULL) || (ffestc_shriek_after1_ != NULL) || !ffestc_labeldef_begin_ ()) return; switch (ffelab_type (ffestc_label_)) { case FFELAB_typeUNKNOWN: case FFELAB_typeASSIGNABLE: ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_stack_top ())); ffestd_labeldef_notloop (ffestc_label_); break; case FFELAB_typeNOTLOOP: if (ffelab_blocknum (ffestc_label_) < ffestw_blocknum (ffestw_stack_top ())) { ffebad_start (FFEBAD_LABEL_BLOCK); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); } ffelab_set_blocknum (ffestc_label_, ffestw_blocknum (ffestw_stack_top ())); ffestd_labeldef_notloop (ffestc_label_); break; case FFELAB_typeLOOPEND: if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) { /* Unterminated block. */ ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); ffebad_here (0, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); ffebad_here (2, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); break; } ffestd_labeldef_branch (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_finish (); return; case FFELAB_typeFORMAT: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); break; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* ffestc_labeldef_useless_ -- Define label as a useless one ffestc_labeldef_useless_(); */ static void ffestc_labeldef_useless_ () { if ((ffesta_label_token == NULL) || (ffestc_shriek_after1_ != NULL) || !ffestc_labeldef_begin_ ()) return; switch (ffelab_type (ffestc_label_)) { case FFELAB_typeUNKNOWN: ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS); ffestd_labeldef_useless (ffestc_label_); break; case FFELAB_typeLOOPEND: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) { /* Unterminated block. */ ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); ffebad_here (0, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); ffebad_here (2, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_finish (); break; } ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_doref_line (ffestc_label_), ffelab_doref_column (ffestc_label_)); ffebad_finish (); ffestc_labeldef_branch_end_ (); return; case FFELAB_typeASSIGNABLE: case FFELAB_typeFORMAT: case FFELAB_typeNOTLOOP: ffelab_set_type (ffestc_label_, FFELAB_typeANY); ffestd_labeldef_any (ffestc_label_); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelex_token_where_line (ffesta_label_token), ffelex_token_where_column (ffesta_label_token)); ffebad_here (1, ffelab_firstref_line (ffestc_label_), ffelab_firstref_column (ffestc_label_)); ffebad_finish (); break; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } ffestc_try_shriek_do_ (); ffelex_token_kill (ffesta_label_token); ffesta_label_token = NULL; } /* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt if (ffestc_labelref_is_assignable_(label_token,&label)) // label ref is ok, label is filled in with ffelab object */ static bool ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label) { ffelab label; ffelabValue label_value; label_value = (ffelabValue) atol (ffelex_token_text (label_token)); if ((label_value == 0) || (label_value > FFELAB_valueMAX)) { ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); ffebad_here (0, ffelex_token_where_line (label_token), ffelex_token_where_column (label_token)); ffebad_finish (); return FALSE; } label = ffelab_find (label_value); if (label == NULL) { label = ffelab_new (label_value); ffelab_set_firstref_line (label, ffewhere_line_use (ffelex_token_where_line (label_token))); ffelab_set_firstref_column (label, ffewhere_column_use (ffelex_token_where_column (label_token))); } switch (ffelab_type (label)) { case FFELAB_typeUNKNOWN: ffelab_set_type (label, FFELAB_typeASSIGNABLE); break; case FFELAB_typeASSIGNABLE: case FFELAB_typeLOOPEND: case FFELAB_typeFORMAT: case FFELAB_typeNOTLOOP: case FFELAB_typeENDIF: break; case FFELAB_typeUSELESS: ffelab_set_type (label, FFELAB_typeANY); ffestd_labeldef_any (label); ffebad_start (FFEBAD_LABEL_USE_DEF); ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); ffebad_here (1, ffelex_token_where_line (label_token), ffelex_token_where_column (label_token)); ffebad_finish (); ffestc_try_shriek_do_ (); return FALSE; default: assert ("bad label" == NULL); /* Fall through. */ case FFELAB_typeANY: break; } *x_label = label; return TRUE; } /* ffestc_labelref_is_branch_ -- Reference to label in branch stmt if (ffestc_labelref_is_branch_(label_token,&label)) // label ref is ok, label is filled in with ffelab object */ static bool ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label) { ffelab label; ffelabValue label_value; ffestw block; unsigned long blocknum; label_value = (ffelabValue) atol (ffelex_token_text (label_token)); if ((label_value == 0) || (label_value > FFELAB_valueMAX)) { ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); ffebad_here (0, ffelex_token_where_line (label_token), ffelex_token_where_column (label_token)); ffebad_finish (); return FALSE; } label = ffelab_find (label_value); if (label == NULL) { label = ffelab_new (label_value); ffelab_set_firstref_line (label, ffewhere_line_use (ffelex_token_where_line (label_token))); ffelab_set_firstref_column (label, ffewhere_column_use (ffelex_token_where_column (label_token))); } switch (ffelab_type (label)) { case FFELAB_typeUNKNOWN: case FFELAB_typeASSIGNABLE: ffelab_set_type (label, FFELAB_typeNOTLOOP); ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ())); break; case FFELAB_typeLOOPEND: if (ffelab_blocknum (label) != 0) break; /* Already taken care of. */ for (block = ffestw_top_do (ffestw_stack_top ()); (block != NULL) && (ffestw_label (block) != label); block = ffestw_top_do (ffestw_previous (block))) ; /* Find most recent DO