blob: b9602c20a469cdadd4c88ce1c647cab7a05db6c5 [file] [log] [blame]
/* 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;
#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 <label> ancestor. */
if (block == NULL)
{ /* Reference to within a (dead) block. */
ffebad_start (FFEBAD_LABEL_BLOCK);
ffebad_here (0, ffelab_definition_line (label),
ffelab_definition_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
break;
}
ffelab_set_blocknum (label, ffestw_blocknum (block));
ffelab_set_firstref_line (label,
ffewhere_line_use (ffelex_token_where_line (label_token)));
ffelab_set_firstref_column (label,
ffewhere_column_use (ffelex_token_where_column (label_token)));
break;
case FFELAB_typeNOTLOOP:
case FFELAB_typeENDIF:
if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
break;
blocknum = ffelab_blocknum (label);
for (block = ffestw_stack_top ();
ffestw_blocknum (block) > blocknum;
block = ffestw_previous (block))
; /* Find most recent common ancestor. */
if (ffelab_blocknum (label) == ffestw_blocknum (block))
break; /* Check again. */
if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
{ /* Reference to within a (dead) block. */
ffebad_start (FFEBAD_LABEL_BLOCK);
ffebad_here (0, ffelab_definition_line (label),
ffelab_definition_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
break;
}
ffelab_set_blocknum (label, ffestw_blocknum (block));
break;
case FFELAB_typeFORMAT:
if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
{
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_USE);
ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
}
/* Fall through. */
case FFELAB_typeUSELESS:
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_DEF);
ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
default:
assert ("bad label" == NULL);
/* Fall through. */
case FFELAB_typeANY:
break;
}
*x_label = label;
return TRUE;
}
/* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
if (ffestc_labelref_is_format_(label_token,&label))
// label ref is ok, label is filled in with ffelab object */
static bool
ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
{
ffelab label;
ffelabValue label_value;
label_value = (ffelabValue) atol (ffelex_token_text (label_token));
if ((label_value == 0) || (label_value > FFELAB_valueMAX))
{
ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
ffebad_here (0, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
return FALSE;
}
label = ffelab_find (label_value);
if (label == NULL)
{
label = ffelab_new (label_value);
ffelab_set_firstref_line (label,
ffewhere_line_use (ffelex_token_where_line (label_token)));
ffelab_set_firstref_column (label,
ffewhere_column_use (ffelex_token_where_column (label_token)));
}
switch (ffelab_type (label))
{
case FFELAB_typeUNKNOWN:
case FFELAB_typeASSIGNABLE:
ffelab_set_type (label, FFELAB_typeFORMAT);
break;
case FFELAB_typeFORMAT:
break;
case FFELAB_typeLOOPEND:
case FFELAB_typeNOTLOOP:
if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
{
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_USE);
ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
}
/* Fall through. */
case FFELAB_typeUSELESS:
case FFELAB_typeENDIF:
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_DEF);
ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
default:
assert ("bad label" == NULL);
/* Fall through. */
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
*x_label = label;
return TRUE;
}
/* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
if (ffestc_labelref_is_loopend_(label_token,&label))
// label ref is ok, label is filled in with ffelab object */
static bool
ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
{
ffelab label;
ffelabValue label_value;
label_value = (ffelabValue) atol (ffelex_token_text (label_token));
if ((label_value == 0) || (label_value > FFELAB_valueMAX))
{
ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
ffebad_here (0, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
return FALSE;
}
label = ffelab_find (label_value);
if (label == NULL)
{
label = ffelab_new (label_value);
ffelab_set_doref_line (label,
ffewhere_line_use (ffelex_token_where_line (label_token)));
ffelab_set_doref_column (label,
ffewhere_column_use (ffelex_token_where_column (label_token)));
}
switch (ffelab_type (label))
{
case FFELAB_typeASSIGNABLE:
ffelab_set_doref_line (label,
ffewhere_line_use (ffelex_token_where_line (label_token)));
ffelab_set_doref_column (label,
ffewhere_column_use (ffelex_token_where_column (label_token)));
ffewhere_line_kill (ffelab_firstref_line (label));
ffelab_set_firstref_line (label, ffewhere_line_unknown ());
ffewhere_column_kill (ffelab_firstref_column (label));
ffelab_set_firstref_column (label, ffewhere_column_unknown ());
/* Fall through. */
case FFELAB_typeUNKNOWN:
ffelab_set_type (label, FFELAB_typeLOOPEND);
ffelab_set_blocknum (label, 0);
break;
case FFELAB_typeLOOPEND:
if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
{ /* Def must follow all refs. */
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_DEF_DO);
ffebad_here (0, ffelab_definition_line (label),
ffelab_definition_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
}
if (ffelab_blocknum (label) != 0)
{ /* Had a branch ref earlier, can't go inside
this new block! */
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_USE);
ffebad_here (0, ffelab_firstref_line (label),
ffelab_firstref_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
}
if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
|| (ffestw_label (ffestw_stack_top ()) != label))
{ /* Top of stack interrupts flow between two
DOs specifying label. */
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
ffebad_here (0, ffelab_doref_line (label),
ffelab_doref_column (label));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_here (2, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
}
break;
case FFELAB_typeNOTLOOP:
case FFELAB_typeFORMAT:
if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
{
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_USE);
ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
}
/* Fall through. */
case FFELAB_typeUSELESS:
case FFELAB_typeENDIF:
ffelab_set_type (label, FFELAB_typeANY);
ffestd_labeldef_any (label);
ffebad_start (FFEBAD_LABEL_USE_DEF);
ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
ffebad_here (1, ffelex_token_where_line (label_token),
ffelex_token_where_column (label_token));
ffebad_finish ();
ffestc_try_shriek_do_ ();
return FALSE;
default:
assert ("bad label" == NULL);
/* Fall through. */
case FFELAB_typeANY:
break;
}
*x_label = label;
return TRUE;
}
/* ffestc_order_access_ -- Check ordering on <access> statement
if (ffestc_order_access_() != FFESTC_orderOK_)
return; */
#if FFESTR_F90
static ffestcOrder_
ffestc_order_access_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
if (ffestc_order_actiondo_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_actiondo_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateDO:
return FFESTC_orderOK_;
case FFESTV_stateIFTHEN:
case FFESTV_stateSELECT1:
if (ffestw_top_do (ffestw_stack_top ()) == NULL)
break;
return FFESTC_orderOK_;
case FFESTV_stateIF:
if (ffestw_top_do (ffestw_stack_top ()) == NULL)
break;
ffestc_shriek_after1_ = ffestc_shriek_if_;
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
default:
break;
}
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
/* ffestc_order_actionif_ -- Check ordering on <actionif> statement
if (ffestc_order_actionif_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_actionif_ ()
{
bool update;
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
update = TRUE;
break;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
update = TRUE;
break;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
update = TRUE;
break;
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
update = FALSE;
break;
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateIF:
ffestc_shriek_after1_ = ffestc_shriek_if_;
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
{
case FFESTV_stateINTERFACE0:
ffestc_order_bad_ ();
if (update)
ffestw_update (NULL);
return FFESTC_orderBAD_;
default:
if (update)
ffestw_update (NULL);
return FFESTC_orderOK_;
}
}
/* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_actionwhere_ ()
{
bool update;
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
update = TRUE;
break;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
update = TRUE;
break;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
update = TRUE;
break;
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
update = FALSE;
break;
case FFESTV_stateWHERETHEN:
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
#if FFESTR_F90
ffestc_shriek_after1_ = ffestc_shriek_where_;
#endif
return FFESTC_orderOK_;
case FFESTV_stateIF:
ffestc_shriek_after1_ = ffestc_shriek_if_;
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
{
case FFESTV_stateINTERFACE0:
ffestc_order_bad_ ();
if (update)
ffestw_update (NULL);
return FFESTC_orderBAD_;
default:
if (update)
ffestw_update (NULL);
return FFESTC_orderOK_;
}
}
/* Check ordering on "any" statement. Like _actionwhere_, but
doesn't produce any diagnostics. */
static void
ffestc_order_any_ ()
{
bool update;
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
update = TRUE;
break;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
update = TRUE;
break;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
update = TRUE;
break;
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
update = FALSE;
break;
case FFESTV_stateWHERETHEN:
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT1:
return;
case FFESTV_stateWHERE:
#if FFESTR_F90
ffestc_shriek_after1_ = ffestc_shriek_where_;
#endif
return;
case FFESTV_stateIF:
ffestc_shriek_after1_ = ffestc_shriek_if_;
return;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
default:
return;
}
switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
{
case FFESTV_stateINTERFACE0:
if (update)
ffestw_update (NULL);
return;
default:
if (update)
ffestw_update (NULL);
return;
}
}
/* ffestc_order_bad_ -- Whine about statement ordering violation
ffestc_order_bad_();
Uses current ffesta_tokens[0] and, if available, info on where current
state started to produce generic message. Someday we should do
fancier things than this, but this just gets things creaking along for
now. */
static void
ffestc_order_bad_ ()
{
if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
{
ffebad_start (FFEBAD_ORDER_1);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
}
else
{
ffebad_start (FFEBAD_ORDER_2);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestc_labeldef_useless_ (); /* Any label definition is useless. */
}
/* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
if (ffestc_order_blockdata_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_blockdata_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
case FFESTV_stateBLOCKDATA3:
case FFESTV_stateBLOCKDATA4:
case FFESTV_stateBLOCKDATA5:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
if (ffestc_order_blockspec_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_blockspec_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
case FFESTV_stateBLOCKDATA3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_component_ -- Check ordering on <component-decl> statement
if (ffestc_order_component_() != FFESTC_orderOK_)
return; */
#if FFESTR_F90
static ffestcOrder_
ffestc_order_component_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateTYPE:
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_contains_ -- Check ordering on CONTAINS statement
if (ffestc_order_contains_() != FFESTC_orderOK_)
return; */
#if FFESTR_F90
static ffestcOrder_
ffestc_order_contains_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
case FFESTV_statePROGRAM4:
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5);
break;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateSUBROUTINE4:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5);
break;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
case FFESTV_stateFUNCTION4:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5);
break;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
case FFESTV_stateMODULE3:
case FFESTV_stateMODULE4:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5);
break;
case FFESTV_stateUSE:
ffestc_shriek_end_uses_ (TRUE);
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
{
case FFESTV_stateNIL:
ffestw_update (NULL);
return FFESTC_orderOK_;
default:
ffestc_order_bad_ ();
ffestw_update (NULL);
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_data_ -- Check ordering on DATA statement
if (ffestc_order_data_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_data_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM2:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION2:
case FFESTV_stateBLOCKDATA2:
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateBLOCKDATA3:
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
case FFESTV_stateBLOCKDATA4:
case FFESTV_stateWHERETHEN:
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT0:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
if (ffestc_order_data77_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_data77_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
case FFESTV_stateBLOCKDATA3:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
case FFESTV_stateBLOCKDATA4:
return FFESTC_orderOK_;
case FFESTV_stateWHERETHEN:
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT0:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
return; */
#if FFESTR_F90
static ffestcOrder_
ffestc_order_derivedtype_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
ffestc_shriek_end_uses_ (TRUE);
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_do_ -- Check ordering on <do> statement
if (ffestc_order_do_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_do_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateDO:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_entry_ -- Check ordering on ENTRY statement
if (ffestc_order_entry_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_entry_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateSUBROUTINE0:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
break;
case FFESTV_stateFUNCTION0:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
break;
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
break;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
{
case FFESTV_stateNIL:
case FFESTV_stateMODULE5:
ffestw_update (NULL);
return FFESTC_orderOK_;
default:
ffestc_order_bad_ ();
ffestw_update (NULL);
return FFESTC_orderBAD_;
}
}
/* ffestc_order_exec_ -- Check ordering on <exec> statement
if (ffestc_order_exec_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_exec_ ()
{
bool update;
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
update = TRUE;
break;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
update = TRUE;
break;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
update = TRUE;
break;
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
update = FALSE;
break;
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
{
case FFESTV_stateINTERFACE0:
ffestc_order_bad_ ();
if (update)
ffestw_update (NULL);
return FFESTC_orderBAD_;
default:
if (update)
ffestw_update (NULL);
return FFESTC_orderOK_;
}
}
/* ffestc_order_format_ -- Check ordering on FORMAT statement
if (ffestc_order_format_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_format_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
case FFESTV_stateWHERETHEN:
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT0:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_function_ -- Check ordering on <function> statement
if (ffestc_order_function_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_function_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
case FFESTV_stateFUNCTION4:
case FFESTV_stateFUNCTION5:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_iface_ -- Check ordering on <iface> statement
if (ffestc_order_iface_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_iface_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
case FFESTV_statePROGRAM5:
case FFESTV_stateSUBROUTINE5:
case FFESTV_stateFUNCTION5:
case FFESTV_stateMODULE5:
case FFESTV_stateINTERFACE0:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
if (ffestc_order_ifthen_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_ifthen_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateIFTHEN:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
if (ffestc_order_implicit_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_implicit_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM2:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION2:
case FFESTV_stateMODULE2:
case FFESTV_stateBLOCKDATA2:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_implicitnone_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_interface_ -- Check ordering on <interface> statement
if (ffestc_order_interface_() != FFESTC_orderOK_)
return; */
#if FFESTR_F90
static ffestcOrder_
ffestc_order_interface_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateINTERFACE0:
case FFESTV_stateINTERFACE1:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_map_ -- Check ordering on <map> statement
if (ffestc_order_map_() != FFESTC_orderOK_)
return; */
#if FFESTR_VXT
static ffestcOrder_
ffestc_order_map_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateMAP:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_module_ -- Check ordering on <module> statement
if (ffestc_order_module_() != FFESTC_orderOK_)
return; */
#if FFESTR_F90
static ffestcOrder_
ffestc_order_module_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
case FFESTV_stateMODULE3:
case FFESTV_stateMODULE4:
case FFESTV_stateMODULE5:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
ffestc_shriek_end_uses_ (TRUE);
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
/* ffestc_order_parameter_ -- Check ordering on <parameter> statement
if (ffestc_order_parameter_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_parameter_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM2:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION2:
case FFESTV_stateMODULE2:
case FFESTV_stateBLOCKDATA2:
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
case FFESTV_stateBLOCKDATA3:
case FFESTV_stateTYPE: /* GNU extension here! */
case FFESTV_stateSTRUCTURE:
case FFESTV_stateUNION:
case FFESTV_stateMAP:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_program_ -- Check ordering on <program> statement
if (ffestc_order_program_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_program_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
case FFESTV_statePROGRAM3:
case FFESTV_statePROGRAM4:
case FFESTV_statePROGRAM5:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse; /* :::::::::::::::::::: */
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
/* ffestc_order_progspec_ -- Check ordering on <progspec> statement
if (ffestc_order_progspec_() != FFESTC_orderOK_)
return; */
static ffestcOrder_
ffestc_order_progspec_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse; /* :::::::::::::::::::: */
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FF