X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Ff%2Fstc.c;fp=gcc%2Ff%2Fstc.c;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=1f17766d9ac09c5ac155100e8686915d76cd65f0;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/f/stc.c b/gcc/f/stc.c deleted file mode 100644 index 1f17766d..00000000 --- a/gcc/f/stc.c +++ /dev/null @@ -1,13890 +0,0 @@ -/* stc.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 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 *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_() -#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