#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"
ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
typedef enum
{
FFESTC_orderOK_,
FFESTC_orderBAD_,
FFESTC_orderBADOK_,
FFESTC
} ffestcOrder_;
typedef enum
{
FFESTC_stateletSIMPLE_,
FFESTC_stateletATTRIB_,
FFESTC_stateletITEM_,
FFESTC_stateletITEMVALS_,
FFESTC_
} ffestcStatelet_;
union ffestc_local_u_
{
struct
{
ffebld initlist;
ffetargetCharacterSize stmt_size;
ffetargetCharacterSize size;
ffeinfoBasictype basic_type;
ffeinfoKindtype stmt_kind_type;
ffeinfoKindtype kind_type;
bool per_var_kind_ok;
char is_R426;
}
decl;
struct
{
ffebld objlist;
ffebldListBottom list_bottom;
}
data;
struct
{
ffebldListBottom list_bottom;
int entry_num;
}
dummy;
struct
{
ffesymbol symbol;
}
namelist;
struct
{
ffelexToken t;
ffeequiv eq;
ffebld list;
ffebldListBottom bottom;
bool ok;
bool save;
}
equiv;
struct
{
ffesymbol symbol;
}
common;
struct
{
ffesymbol symbol;
}
sfunc;
#if FFESTR_VXT
struct
{
char list_state;
}
V003;
#endif
};
static bool ffestc_ok_;
static bool ffestc_parent_ok_;
static char ffestc_namelist_;
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;
static int ffestc_entry_num_;
static int ffestc_sfdummy_argno_;
static int ffestc_saved_entry_num_;
static ffelab ffestc_label_;
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);
#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
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)
{
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;
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;
}
static void
ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
ffelexToken kindt, ffebld len, ffelexToken lent)
{
ffeinfoBasictype bt;
ffeinfoKindtype ktd;
ffeinfoKindtype kt;
ffetargetCharacterSize val;
bool per_var_kind_ok = TRUE;
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
{
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 = 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)
{
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;
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;
}
static void
ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
{
bool ok = FALSE;
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 ();
}
}
void
ffestc_init_3 ()
{
ffestv_save_state_ = FFESTV_savestateNONE;
ffestc_entry_num_ = 0;
ffestv_num_label_defines_ = 0;
}
void
ffestc_init_4 ()
{
ffestc_saved_entry_num_ = ffestc_entry_num_;
ffestc_entry_num_ = 0;
}
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;
}
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;
}
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_ ();
}
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;
}
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_))
{
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_);
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
ffelex_token_kill (ffesta_label_token);
ffesta_label_token = NULL;
}
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;
}
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_))
{
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
ffelex_token_kill (ffesta_label_token);
ffesta_label_token = NULL;
}
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_))
{
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
ffelex_token_kill (ffesta_label_token);
ffesta_label_token = NULL;
}
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;
}
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_))
{
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
ffelex_token_kill (ffesta_label_token);
ffesta_label_token = NULL;
}
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_))
{
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
ffelex_token_kill (ffesta_label_token);
ffesta_label_token = NULL;
}
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_))
{
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
ffelex_token_kill (ffesta_label_token);
ffesta_label_token = NULL;
}
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);
case FFELAB_typeANY:
break;
}
*x_label = label;
return TRUE;
}
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;
for (block = ffestw_top_do (ffestw_stack_top ());
(block != NULL) && (ffestw_label (block) != label);
block = ffestw_top_do (ffestw_previous (block)))
;
if (block == NULL)
{
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))
;
if (ffelab_blocknum (label) == ffestw_blocknum (block))
break;
if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
{
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;
}
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);
case FFELAB_typeANY:
break;
}
*x_label = label;
return TRUE;
}
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;
}
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);
case FFELAB_typeANY:
break;
}
ffestc_try_shriek_do_ ();
*x_label = label;
return TRUE;
}
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 ());
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)))
{
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)
{
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))
{
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;
}
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);
case FFELAB_typeANY:
break;
}
*x_label = label;
return TRUE;
}
#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
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_;
}
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_;
}
}
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_;
}
}
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;
}
}
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_ ();
}
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_;
}
}
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_;
}
}
#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
#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
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_;
}
}
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_;
}
}
#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
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_;
}
}
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_;
}
}
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_;
}
}
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_;
}
}
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_;
}
}
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_;
}
}
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_;
}
}
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_;
}
}
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_;
}
}
#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
#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
#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
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:
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_;
}
}
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_;
}
}
static ffestcOrder_
ffestc_order_progspec_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_BLOCKDATA_STMT);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#if FFESTR_VXT
static ffestcOrder_
ffestc_order_record_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
case FFESTV_stateBLOCKDATA3:
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
static ffestcOrder_
ffestc_order_selectcase_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateSELECT0:
case FFESTV_stateSELECT1:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
static ffestcOrder_
ffestc_order_sfunc_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#if FFESTR_F90
static ffestcOrder_
ffestc_order_spec_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
#if FFESTR_VXT
static ffestcOrder_
ffestc_order_structure_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateSTRUCTURE:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
static ffestcOrder_
ffestc_order_subroutine_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateSUBROUTINE5:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#if FFESTR_F90
static ffestcOrder_
ffestc_order_type_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateTYPE:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
static ffestcOrder_
ffestc_order_typedecl_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
case FFESTV_stateBLOCKDATA3:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#if FFESTR_VXT
static ffestcOrder_
ffestc_order_union_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateUNION:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
static ffestcOrder_
ffestc_order_unit_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#if FFESTR_F90
static ffestcOrder_
ffestc_order_use_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
ffestc_shriek_begin_uses_ ();
goto recurse;
case FFESTV_stateSUBROUTINE0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
ffestc_shriek_begin_uses_ ();
goto recurse;
case FFESTV_stateFUNCTION0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
ffestc_shriek_begin_uses_ ();
goto recurse;
case FFESTV_stateMODULE0:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1);
ffestc_shriek_begin_uses_ ();
goto recurse;
case FFESTV_stateUSE:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
#if FFESTR_VXT
static ffestcOrder_
ffestc_order_vxtstructure_ ()
{
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
case FFESTV_statePROGRAM1:
case FFESTV_statePROGRAM2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
return FFESTC_orderOK_;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
return FFESTC_orderOK_;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
return FFESTC_orderOK_;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
return FFESTC_orderOK_;
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
return FFESTC_orderOK_;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
case FFESTV_stateBLOCKDATA3:
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
return FFESTC_orderOK_;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
#if FFESTR_F90
ffestc_shriek_where_ (FALSE);
#endif
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
#if FFESTR_F90
static ffestcOrder_
ffestc_order_where_ ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateWHERETHEN:
return FFESTC_orderOK_;
case FFESTV_stateWHERE:
ffestc_order_bad_ ();
ffestc_shriek_where_ (FALSE);
return FFESTC_orderBAD_;
case FFESTV_stateIF:
ffestc_order_bad_ ();
ffestc_shriek_if_ (FALSE);
return FFESTC_orderBAD_;
default:
ffestc_order_bad_ ();
return FFESTC_orderBAD_;
}
}
#endif
static void
ffestc_promote_dummy_ (ffelexToken t)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffebld e;
bool sfref_ok;
assert (t != NULL);
if (ffelex_token_type (t) == FFELEX_typeASTERISK)
{
ffebld_append_item (&ffestc_local_.dummy.list_bottom,
ffebld_new_star ());
return;
}
s = ffesymbol_declare_local (t, FALSE);
sa = ffesymbol_attrs (s);
sfref_ok = FALSE;
if (sa & FFESYMBOL_attrsANY)
na = sa;
else if (sa & FFESYMBOL_attrsDUMMY)
{
if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
{
na = FFESYMBOL_attrsetNONE;
}
else
na = sa;
sfref_ok = TRUE;
}
else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsANY
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsDUMMY;
else
na = FFESYMBOL_attrsetNONE;
if (!ffesymbol_is_specable (s)
&& (!sfref_ok
|| (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (e,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
FFETARGET_charactersizeNONE));
ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
ffesymbol_signal_unreported (s);
}
}
static void
ffestc_promote_execdummy_ (ffelexToken t)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffesymbolState ss;
ffesymbolState ns;
ffeinfoKind kind;
ffeinfoWhere where;
ffebld e;
assert (t != NULL);
if (ffelex_token_type (t) == FFELEX_typeASTERISK)
{
ffebld_append_item (&ffestc_local_.dummy.list_bottom,
ffebld_new_star ());
return;
}
s = ffesymbol_declare_local (t, FALSE);
na = sa = ffesymbol_attrs (s);
ss = ffesymbol_state (s);
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
{
na = FFESYMBOL_attrsetNONE;
}
ns = FFESYMBOL_stateUNDERSTOOD;
switch (kind)
{
case FFEINFO_kindENTITY:
case FFEINFO_kindFUNCTION:
case FFEINFO_kindSUBROUTINE:
break;
case FFEINFO_kindNONE:
if (sa & FFESYMBOL_attrsDUMMY)
ns = FFESYMBOL_stateUNCERTAIN;
else if (sa & FFESYMBOL_attrsANYLEN)
{
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereDUMMY;
}
else if (sa & FFESYMBOL_attrsACTUALARG)
na = FFESYMBOL_attrsetNONE;
else
{
na = sa | FFESYMBOL_attrsDUMMY;
ns = FFESYMBOL_stateUNCERTAIN;
}
break;
default:
na = FFESYMBOL_attrsetNONE;
break;
}
switch (where)
{
case FFEINFO_whereDUMMY:
break;
case FFEINFO_whereNONE:
where = FFEINFO_whereDUMMY;
break;
default:
na = FFESYMBOL_attrsetNONE;
break;
}
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, ns);
ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
if ((ns == FFESYMBOL_stateUNDERSTOOD)
&& (kind != FFEINFO_kindSUBROUTINE)
&& !ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return;
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
}
static void
ffestc_promote_sfdummy_ (ffelexToken t)
{
ffesymbol s;
ffesymbol sp;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffebld e;
assert (t != NULL);
s = ffesymbol_declare_sfdummy (t);
if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
{
ffesymbol_error (s, t);
return;
}
sp = ffesymbol_sfdummyparent (s);
sa = ffesymbol_attrs (sp);
if (!ffesymbol_is_specable (sp)
&& ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
|| ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
&& (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
&& (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
&& (ffesymbol_where (sp) != FFEINFO_whereNONE))))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = sa;
else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsRESULT
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsSFARG;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
{
ffesymbol_error (sp, t);
ffesymbol_set_info (s, ffeinfo_new_any ());
}
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
ffesymbol_set_attrs (sp, na);
if (!ffeimplic_establish_symbol (sp)
|| ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
&& (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
ffesymbol_error (sp, t);
else
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (sp),
ffesymbol_kindtype (sp),
0,
FFEINFO_kindENTITY,
FFEINFO_whereDUMMY,
ffesymbol_size (sp)));
ffesymbol_signal_unreported (sp);
}
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
ffesymbol_signal_unreported (s);
e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
}
static void
ffestc_shriek_begin_program_ ()
{
ffestw b;
ffesymbol s;
ffestc_blocknum_ = 0;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_statePROGRAM0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_end_program_);
ffestw_set_name (b, NULL);
s = ffesymbol_declare_programunit (NULL,
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindPROGRAM,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_signal_unreported (s);
ffestd_R1102 (s, NULL);
}
#if FFESTR_F90
static void
ffestc_shriek_begin_uses_ ()
{
ffestw b;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateUSE);
ffestw_set_blocknum (b, 0);
ffestw_set_shriek (b, ffestc_shriek_end_uses_);
ffestd_begin_uses ();
}
#endif
static void
ffestc_shriek_blockdata_ (bool ok)
{
if (!ffesta_seen_first_exec)
{
ffesta_seen_first_exec = TRUE;
ffestd_exec_begin ();
}
ffestd_R1112 (ok);
ffestd_exec_end ();
if (ffestw_name (ffestw_stack_top ()) != NULL)
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffe_terminate_2 ();
ffe_init_2 ();
}
static void
ffestc_shriek_do_ (bool ok)
{
ffelab l;
if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
&& (ffewhere_line_is_unknown (ffelab_definition_line (l))))
{
assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
|| (ffelab_type (l) == FFELAB_typeANY));
if (ffelab_type (l) != FFELAB_typeANY)
{
ffelab_set_definition_line (l,
ffewhere_line_use (ffelab_doref_line (l)));
ffelab_set_definition_column (l,
ffewhere_column_use (ffelab_doref_column (l)));
ffestv_num_label_defines_++;
}
ffestd_labeldef_branch (l);
}
ffestd_do (ok);
if (ffestw_name (ffestw_stack_top ()) != NULL)
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
ffestw_kill (ffestw_pop ());
}
static void
ffestc_shriek_end_program_ (bool ok)
{
if (!ffesta_seen_first_exec)
{
ffesta_seen_first_exec = TRUE;
ffestd_exec_begin ();
}
ffestd_R1103 (ok);
ffestd_exec_end ();
if (ffestw_name (ffestw_stack_top ()) != NULL)
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffe_terminate_2 ();
ffe_init_2 ();
}
#if FFESTR_F90
static void
ffestc_shriek_end_uses_ (bool ok)
{
ffestd_end_uses (ok);
ffestw_kill (ffestw_pop ());
}
#endif
static void
ffestc_shriek_function_ (bool ok)
{
if (!ffesta_seen_first_exec)
{
ffesta_seen_first_exec = TRUE;
ffestd_exec_begin ();
}
ffestd_R1221 (ok);
ffestd_exec_end ();
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffesta_is_entry_valid = FALSE;
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffe_terminate_2 ();
ffe_init_2 ();
break;
default:
ffe_terminate_3 ();
ffe_init_3 ();
break;
case FFESTV_stateINTERFACE0:
ffe_terminate_4 ();
ffe_init_4 ();
break;
}
}
static void
ffestc_shriek_if_ (bool ok)
{
ffestd_end_R807 (ok);
ffestw_kill (ffestw_pop ());
ffestc_shriek_after1_ = NULL;
ffestc_try_shriek_do_ ();
}
static void
ffestc_shriek_ifthen_ (bool ok)
{
ffestd_R806 (ok);
if (ffestw_name (ffestw_stack_top ()) != NULL)
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#if FFESTR_F90
static void
ffestc_shriek_interface_ (bool ok)
{
ffestd_R1203 (ok);
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#endif
#if FFESTR_VXT
static void
ffestc_shriek_map_ (bool ok)
{
ffestd_V013 (ok);
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#endif
#if FFESTR_F90
static void
ffestc_shriek_module_ (bool ok)
{
if (!ffesta_seen_first_exec)
{
ffesta_seen_first_exec = TRUE;
ffestd_exec_begin ();
}
ffestd_R1106 (ok);
ffestd_exec_end ();
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffe_terminate_2 ();
ffe_init_2 ();
}
#endif
static void
ffestc_shriek_select_ (bool ok)
{
ffestwSelect s;
ffestwCase c;
ffestd_R811 (ok);
if (ffestw_name (ffestw_stack_top ()) != NULL)
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
s = ffestw_select (ffestw_stack_top ());
ffelex_token_kill (s->t);
for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
ffelex_token_kill (c->t);
malloc_pool_kill (s->pool);
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#if FFESTR_VXT
static void
ffestc_shriek_structure_ (bool ok)
{
ffestd_V004 (ok);
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#endif
static void
ffestc_shriek_subroutine_ (bool ok)
{
if (!ffesta_seen_first_exec)
{
ffesta_seen_first_exec = TRUE;
ffestd_exec_begin ();
}
ffestd_R1225 (ok);
ffestd_exec_end ();
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffesta_is_entry_valid = FALSE;
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffe_terminate_2 ();
ffe_init_2 ();
break;
default:
ffe_terminate_3 ();
ffe_init_3 ();
break;
case FFESTV_stateINTERFACE0:
ffe_terminate_4 ();
ffe_init_4 ();
break;
}
}
#if FFESTR_F90
static void
ffestc_shriek_type_ (bool ok)
{
ffestd_R425 (ok);
ffe_terminate_4 ();
ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#endif
#if FFESTR_VXT
static void
ffestc_shriek_union_ (bool ok)
{
ffestd_V010 (ok);
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#endif
#if FFESTR_F90
static void
ffestc_shriek_where_ (bool ok)
{
ffestd_R745 (ok);
ffestw_kill (ffestw_pop ());
ffestc_shriek_after1_ = NULL;
if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF)
ffestc_shriek_if_ (TRUE);
ffestc_try_shriek_do_ ();
}
#endif
#if FFESTR_F90
static void
ffestc_shriek_wherethen_ (bool ok)
{
ffestd_end_R740 (ok);
ffestw_kill (ffestw_pop ());
ffestc_try_shriek_do_ ();
}
#endif
static int
ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
const char *whine)
{
int lowest_tested;
int highest_tested;
int halfway;
int offset;
int c;
const char *str;
int len;
if (size == 0)
return 0;
lowest_tested = -1;
highest_tested = size;
halfway = size >> 1;
list += halfway;
c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
if (c == 2)
return 0;
c = -c;
next:
switch (c)
{
case -1:
offset = (halfway - lowest_tested) >> 1;
if (offset == 0)
goto nope;
highest_tested = halfway;
list -= offset;
halfway -= offset;
c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
goto next;
case 0:
return halfway + 1;
case 1:
offset = (highest_tested - halfway) >> 1;
if (offset == 0)
goto nope;
lowest_tested = halfway;
list += offset;
halfway += offset;
c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
goto next;
default:
assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
break;
}
nope:
ffebad_start (FFEBAD_SPEC_VALUE);
ffebad_here (0, ffelex_token_where_line (spec->value),
ffelex_token_where_column (spec->value));
ffebad_string (whine);
ffebad_finish ();
return 0;
}
static ffestvFormat
ffestc_subr_format_ (ffestpFile *spec)
{
if (!spec->kw_or_val_present)
return FFESTV_formatNONE;
assert (spec->value_present);
if (spec->value_is_label)
return FFESTV_formatLABEL;
assert (spec->value != NULL);
if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
return FFESTV_formatASTERISK;
if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
return FFESTV_formatNAMELIST;
if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
return FFESTV_formatCHAREXPR;
switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
{
case FFEINFO_basictypeINTEGER:
return FFESTV_formatINTEXPR;
case FFEINFO_basictypeCHARACTER:
return FFESTV_formatCHAREXPR;
case FFEINFO_basictypeANY:
return FFESTV_formatASTERISK;
default:
assert ("bad basictype" == NULL);
return FFESTV_formatINTEXPR;
}
}
static bool
ffestc_subr_is_branch_ (ffestpFile *spec)
{
if (!spec->kw_or_val_present)
return TRUE;
assert (spec->value_present);
assert (spec->value_is_label);
spec->value_is_label++;
return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
}
static bool
ffestc_subr_is_format_ (ffestpFile *spec)
{
if (!spec->kw_or_val_present)
return TRUE;
assert (spec->value_present);
if (!spec->value_is_label)
return TRUE;
spec->value_is_label++;
return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
}
static bool
ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
{
if (spec->kw_or_val_present)
{
assert (spec->value_present);
return TRUE;
}
ffebad_start (FFEBAD_MISSING_SPECIFIER);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_string (name);
ffebad_finish ();
return FALSE;
}
static int
ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
int *length)
{
ffebldConstant c;
int i;
if (!spec->kw_or_val_present || !spec->value_present
|| (spec->u.expr == NULL)
|| (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
{
if (target != NULL)
*target = NULL;
if (length != NULL)
*length = 0;
return 2;
}
if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
!= FFEBLD_constCHARACTERDEFAULT)
{
if (target != NULL)
*target = NULL;
if (length != NULL)
*length = 0;
return 2;
}
if (target != NULL)
*target = ffebld_constant_characterdefault (c).text;
if (length != NULL)
*length = ffebld_constant_characterdefault (c).length;
i = ffesrc_strcmp_1ns2i (ffe_case_match (),
ffebld_constant_characterdefault (c).text,
ffebld_constant_characterdefault (c).length,
string);
if (i == 0)
return 0;
if (i > 0)
return -1;
return 1;
}
static ffestvUnit
ffestc_subr_unit_ (ffestpFile *spec)
{
if (!spec->kw_or_val_present)
return FFESTV_unitNONE;
assert (spec->value_present);
assert (spec->value != NULL);
if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
return FFESTV_unitASTERISK;
switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
{
case FFEINFO_basictypeINTEGER:
return FFESTV_unitINTEXPR;
case FFEINFO_basictypeCHARACTER:
return FFESTV_unitCHAREXPR;
case FFEINFO_basictypeANY:
return FFESTV_unitASTERISK;
default:
assert ("bad basictype" == NULL);
return FFESTV_unitINTEXPR;
}
}
static void
ffestc_try_shriek_do_ ()
{
ffelab lab;
ffelabType ty;
while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
&& ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
&& (((ty = (ffelab_type (lab)))
== FFELAB_typeANY)
|| (ty == FFELAB_typeUSELESS)
|| (ty == FFELAB_typeFORMAT)
|| (ty == FFELAB_typeNOTLOOP)
|| (ty == FFELAB_typeENDIF)))
ffestc_shriek_do_ (FALSE);
}
void
ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
ffelexToken kindt, ffebld len, ffelexToken lent)
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
case FFESTV_statePROGRAM0:
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateFUNCTION0:
case FFESTV_stateMODULE0:
case FFESTV_stateBLOCKDATA0:
case FFESTV_statePROGRAM1:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateFUNCTION1:
case FFESTV_stateMODULE1:
case FFESTV_stateBLOCKDATA1:
case FFESTV_statePROGRAM2:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION2:
case FFESTV_stateMODULE2:
case FFESTV_stateBLOCKDATA2:
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateMODULE3:
case FFESTV_stateBLOCKDATA3:
case FFESTV_stateUSE:
ffestc_local_.decl.is_R426 = 2;
break;
case FFESTV_stateTYPE:
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
ffestc_local_.decl.is_R426 = 1;
break;
default:
ffestc_order_bad_ ();
ffestc_labeldef_useless_ ();
ffestc_local_.decl.is_R426 = 0;
return;
}
switch (ffestc_local_.decl.is_R426)
{
#if FFESTR_F90
case 1:
ffestc_R426_start (type, typet, kind, kindt, len, lent);
break;
#endif
case 2:
ffestc_R501_start (type, typet, kind, kindt, len, lent);
break;
default:
ffestc_labeldef_useless_ ();
break;
}
}
void
ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
ffelexToken attribt UNUSED,
ffestrOther intent_kw UNUSED,
ffesttDimList dims UNUSED)
{
#if FFESTR_F90
switch (ffestc_local_.decl.is_R426)
{
case 1:
ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
break;
case 2:
ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
break;
default:
break;
}
#else
ffebad_start (FFEBAD_F90);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
return;
#endif
}
void
ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
ffelexToken initt, bool clist)
{
switch (ffestc_local_.decl.is_R426)
{
#if FFESTR_F90
case 1:
ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
clist);
break;
#endif
case 2:
ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
clist);
break;
default:
break;
}
}
void
ffestc_decl_itemstartvals ()
{
switch (ffestc_local_.decl.is_R426)
{
#if FFESTR_F90
case 1:
ffestc_R426_itemstartvals ();
break;
#endif
case 2:
ffestc_R501_itemstartvals ();
break;
default:
break;
}
}
void
ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
ffebld value, ffelexToken value_token)
{
switch (ffestc_local_.decl.is_R426)
{
#if FFESTR_F90
case 1:
ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
break;
#endif
case 2:
ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
break;
default:
break;
}
}
void
ffestc_decl_itemendvals (ffelexToken t)
{
switch (ffestc_local_.decl.is_R426)
{
#if FFESTR_F90
case 1:
ffestc_R426_itemendvals (t);
break;
#endif
case 2:
ffestc_R501_itemendvals (t);
break;
default:
break;
}
}
void
ffestc_decl_finish ()
{
switch (ffestc_local_.decl.is_R426)
{
#if FFESTR_F90
case 1:
ffestc_R426_finish ();
break;
#endif
case 2:
ffestc_R501_finish ();
break;
default:
break;
}
}
void
ffestc_elsewhere (ffelexToken where)
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateIFTHEN:
ffestc_R805 (where);
break;
default:
#if FFESTR_F90
ffestc_R744 ();
#endif
break;
}
}
void
ffestc_end ()
{
ffestw b;
b = ffestw_stack_top ();
recurse:
switch (ffestw_state (b))
{
case FFESTV_stateBLOCKDATA0:
case FFESTV_stateBLOCKDATA1:
case FFESTV_stateBLOCKDATA2:
case FFESTV_stateBLOCKDATA3:
case FFESTV_stateBLOCKDATA4:
case FFESTV_stateBLOCKDATA5:
ffestc_R1112 (NULL);
break;
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
case FFESTV_stateFUNCTION4:
case FFESTV_stateFUNCTION5:
if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
&& (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
{
ffebad_start (FFEBAD_END_WO);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
ffebad_string ("FUNCTION");
ffebad_finish ();
}
ffestc_R1221 (NULL);
break;
case FFESTV_stateMODULE0:
case FFESTV_stateMODULE1:
case FFESTV_stateMODULE2:
case FFESTV_stateMODULE3:
case FFESTV_stateMODULE4:
case FFESTV_stateMODULE5:
#if FFESTR_F90
ffestc_R1106 (NULL);
#endif
break;
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateSUBROUTINE5:
if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
&& (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
{
ffebad_start (FFEBAD_END_WO);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
ffebad_string ("SUBROUTINE");
ffebad_finish ();
}
ffestc_R1225 (NULL);
break;
case FFESTV_stateUSE:
b = ffestw_previous (ffestw_stack_top ());
goto recurse;
default:
ffestc_R1103 (NULL);
break;
}
}
void
ffestc_eof ()
{
if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
{
ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
do
(*ffestw_shriek (ffestw_stack_top ()))(FALSE);
while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
}
}
bool
ffestc_exec_transition ()
{
bool update;
recurse:
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
ffestc_shriek_begin_program_ ();
goto recurse;
case FFESTV_statePROGRAM0:
case FFESTV_stateSUBROUTINE0:
case FFESTV_stateFUNCTION0:
case FFESTV_stateBLOCKDATA0:
ffestw_state (ffestw_stack_top ()) += 4;
update = TRUE;
break;
case FFESTV_statePROGRAM1:
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateFUNCTION1:
case FFESTV_stateBLOCKDATA1:
ffestw_state (ffestw_stack_top ()) += 3;
update = TRUE;
break;
case FFESTV_statePROGRAM2:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateFUNCTION2:
case FFESTV_stateBLOCKDATA2:
ffestw_state (ffestw_stack_top ()) += 2;
update = TRUE;
break;
case FFESTV_statePROGRAM3:
case FFESTV_stateSUBROUTINE3:
case FFESTV_stateFUNCTION3:
case FFESTV_stateBLOCKDATA3:
ffestw_state (ffestw_stack_top ()) += 1;
update = TRUE;
break;
case FFESTV_stateUSE:
#if FFESTR_F90
ffestc_shriek_end_uses_ (TRUE);
#endif
goto recurse;
default:
return FALSE;
}
if (update)
ffestw_update (NULL);
ffesta_seen_first_exec = TRUE;
ffestd_exec_begin ();
return TRUE;
}
void
ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
{
ffestw block;
for (block = ffestw_top_do (ffestw_stack_top ());
(block != NULL) && (ffestw_blocknum (block) != 0);
block = ffestw_top_do (ffestw_previous (block)))
{
if (ffestw_do_iter_var (block) == s)
{
ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
ffelex_token_where_column (ffestw_do_iter_var_t (block)));
return;
}
}
assert ("no do block found" == NULL);
}
bool
ffestc_is_decl_not_R1219 ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateNIL:
case FFESTV_statePROGRAM5:
case FFESTV_stateSUBROUTINE5:
case FFESTV_stateFUNCTION5:
case FFESTV_stateMODULE5:
case FFESTV_stateINTERFACE0:
return FALSE;
default:
return TRUE;
}
}
bool
ffestc_is_entry_in_subr ()
{
ffestvState s;
s = ffestw_state (ffestw_stack_top ());
recurse:
switch (s)
{
case FFESTV_stateFUNCTION0:
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
case FFESTV_stateFUNCTION4:
return FALSE;
case FFESTV_stateUSE:
s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
goto recurse;
default:
return TRUE;
}
}
bool
ffestc_is_let_not_V027 ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
case FFESTV_stateWHERETHEN:
case FFESTV_stateIFTHEN:
case FFESTV_stateDO:
case FFESTV_stateSELECT0:
case FFESTV_stateSELECT1:
case FFESTV_stateWHERE:
case FFESTV_stateIF:
return TRUE;
default:
return FALSE;
}
}
#if FFESTR_F90
void
ffestc_module (ffelexToken module, ffelexToken procedure)
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateINTERFACE0:
case FFESTV_stateINTERFACE1:
ffestc_R1205_start ();
ffestc_R1205_item (procedure);
ffestc_R1205_finish ();
break;
default:
ffestc_R1105 (module);
break;
}
}
#endif
#if FFESTR_F90
void
ffestc_private ()
{
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateTYPE:
ffestc_R423A ();
break;
default:
ffestc_R521B ();
break;
}
}
#endif
void
ffestc_terminate_4 ()
{
ffestc_entry_num_ = ffestc_saved_entry_num_;
}
#if FFESTR_F90
void
ffestc_R423A ()
{
ffestc_check_simple_ ();
if (ffestc_order_type_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 0)
{
ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
return;
}
if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
{
ffebad_start (FFEBAD_DERIVTYP_ACCESS);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
return;
}
ffestw_set_substate (ffestw_stack_top (), 1);
ffestd_R423A ();
}
void
ffestc_R423B ()
{
ffestc_check_simple_ ();
if (ffestc_order_type_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 0)
{
ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
return;
}
ffestw_set_substate (ffestw_stack_top (), 1);
ffestd_R423B ();
}
void
ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
{
ffestw b;
assert (name != NULL);
ffestc_check_simple_ ();
if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if ((access != NULL)
&& (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
{
ffebad_start (FFEBAD_DERIVTYP_ACCESS);
ffebad_here (0, ffelex_token_where_line (access),
ffelex_token_where_column (access));
ffebad_finish ();
access = NULL;
}
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateTYPE);
ffestw_set_blocknum (b, 0);
ffestw_set_shriek (b, ffestc_shriek_type_);
ffestw_set_name (b, ffelex_token_use (name));
ffestw_set_substate (b, 0);
ffestd_R424 (access, access_kw, name);
ffe_init_4 ();
}
void
ffestc_R425 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_type_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 2)
{
ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
if ((name != NULL)
&& (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
{
ffebad_start (FFEBAD_TYPE_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
ffestc_shriek_type_ (TRUE);
}
void
ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
ffelexToken kindt, ffebld len, ffelexToken lent)
{
ffestc_check_start_ ();
if (ffestc_order_component_ () != FFESTC_orderOK_)
{
ffestc_local_.decl.is_R426 = 0;
return;
}
ffestc_labeldef_useless_ ();
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
ffestw_set_substate (ffestw_stack_top (), 1);
break;
case FFESTV_stateTYPE:
ffestw_set_substate (ffestw_stack_top (), 2);
break;
default:
assert ("Component parent state invalid" == NULL);
break;
}
}
void
ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
ffestrOther intent_kw, ffesttDimList dims)
{
ffestc_check_attrib_ ();
}
void
ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
ffelexToken initt, bool clist)
{
ffestc_check_item_ ();
assert (name != NULL);
assert (ffelex_token_type (name) == FFELEX_typeNAME);
assert (kind == NULL);
if ((dims != NULL) || (init != NULL) || clist)
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
void
ffestc_R426_itemstartvals ()
{
ffestc_check_item_startvals_ ();
}
void
ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
ffebld value, ffelexToken value_token)
{
ffestc_check_item_value_ ();
}
void
ffestc_R426_itemendvals (ffelexToken t)
{
ffestc_check_item_endvals_ ();
}
void
ffestc_R426_finish ()
{
ffestc_check_finish_ ();
}
#endif
void
ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
ffelexToken kindt, ffebld len, ffelexToken lent)
{
ffestc_check_start_ ();
if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
{
ffestc_local_.decl.is_R426 = 0;
return;
}
ffestc_labeldef_useless_ ();
ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
}
void
ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
ffestrOther intent_kw UNUSED,
ffesttDimList dims UNUSED)
{
ffestc_check_attrib_ ();
switch (attrib)
{
#if FFESTR_F90
case FFESTP_attribALLOCATABLE:
break;
#endif
case FFESTP_attribDIMENSION:
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
break;
case FFESTP_attribEXTERNAL:
break;
#if FFESTR_F90
case FFESTP_attribINTENT:
break;
#endif
case FFESTP_attribINTRINSIC:
break;
#if FFESTR_F90
case FFESTP_attribOPTIONAL:
break;
#endif
case FFESTP_attribPARAMETER:
break;
#if FFESTR_F90
case FFESTP_attribPOINTER:
break;
#endif
#if FFESTR_F90
case FFESTP_attribPRIVATE:
break;
case FFESTP_attribPUBLIC:
break;
#endif
case FFESTP_attribSAVE:
switch (ffestv_save_state_)
{
case FFESTV_savestateNONE:
ffestv_save_state_ = FFESTV_savestateSPECIFIC;
ffestv_save_line_
= ffewhere_line_use (ffelex_token_where_line (attribt));
ffestv_save_col_
= ffewhere_column_use (ffelex_token_where_column (attribt));
break;
case FFESTV_savestateSPECIFIC:
case FFESTV_savestateANY:
break;
case FFESTV_savestateALL:
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_CONFLICTING_SAVES);
ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
ffebad_here (1, ffelex_token_where_line (attribt),
ffelex_token_where_column (attribt));
ffebad_finish ();
}
ffestv_save_state_ = FFESTV_savestateANY;
break;
default:
assert ("unexpected save state" == NULL);
break;
}
break;
#if FFESTR_F90
case FFESTP_attribTARGET:
break;
#endif
default:
assert ("unexpected attribute" == NULL);
break;
}
}
void
ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
ffesttDimList dims, ffebld len, ffelexToken lent,
ffebld init, ffelexToken initt, bool clist)
{
ffesymbol s;
ffesymbol sfn;
ffebld array_size;
ffebld extents;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestpDimtype nd;
bool is_init = (init != NULL) || clist;
bool is_assumed;
bool is_ugly_assumed;
ffeinfoRank rank;
ffestc_check_item_ ();
assert (name != NULL);
assert (ffelex_token_type (name) == FFELEX_typeNAME);
assert (kind == NULL);
ffestc_establish_declinfo_ (kind, kindt, len, lent);
is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
&& (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
if ((dims != NULL) || is_init)
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
s = ffesymbol_declare_local (name, TRUE);
sa = ffesymbol_attrs (s);
na = FFESYMBOL_attrsTYPE;
if (is_assumed)
na |= FFESYMBOL_attrsANYLEN;
is_ugly_assumed = (ffe_is_ugly_assumed ()
&& ((sa & FFESYMBOL_attrsDUMMY)
|| (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
nd = ffestt_dimlist_type (dims, is_ugly_assumed);
switch (nd)
{
case FFESTP_dimtypeNONE:
break;
case FFESTP_dimtypeKNOWN:
na |= FFESYMBOL_attrsARRAY;
break;
case FFESTP_dimtypeADJUSTABLE:
na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
break;
case FFESTP_dimtypeASSUMED:
na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
break;
case FFESTP_dimtypeADJUSTABLEASSUMED:
na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE;
break;
default:
assert ("unexpected dimtype" == NULL);
na = FFESYMBOL_attrsetNONE;
break;
}
if (!ffesta_is_entry_valid
&& (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
== (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
na = FFESYMBOL_attrsetNONE;
if (is_init)
{
if (na == FFESYMBOL_attrsetNONE)
;
else if (na & (FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE))
na = FFESYMBOL_attrsetNONE;
else
na |= FFESYMBOL_attrsINIT;
}
if (na == FFESYMBOL_attrsetNONE)
;
else if (!ffesymbol_is_specable (s)
&& (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
&& (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
|| (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = sa;
else if ((sa & na)
|| ((sa & (FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsADJUSTS))
&& (na & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsANYLEN)))
|| ((sa & FFESYMBOL_attrsRESULT)
&& (na & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsINIT)))
|| ((sa & (FFESYMBOL_attrsSFUNC
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsINTRINSIC
| FFESYMBOL_attrsINIT))
&& (na & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsINIT)))
|| ((sa & FFESYMBOL_attrsARRAY)
&& !ffesta_is_entry_valid
&& (na & FFESYMBOL_attrsANYLEN))
|| ((sa & (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsDUMMY))
&& (na & FFESYMBOL_attrsINIT))
|| ((sa & (FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV))
&& (na & (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE))))
na = FFESYMBOL_attrsetNONE;
else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
&& (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
&& (na & FFESYMBOL_attrsANYLEN))
{
na |= FFESYMBOL_attrsTYPE;
ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
}
else
na |= sa;
if (na == FFESYMBOL_attrsetNONE)
{
ffesymbol_error (s, name);
ffestc_parent_ok_ = FALSE;
}
else if (na & FFESYMBOL_attrsANY)
ffestc_parent_ok_ = FALSE;
else
{
ffesymbol_set_attrs (s, na);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
rank = ffesymbol_rank (s);
if (dims != NULL)
{
ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
&array_size,
&extents,
is_ugly_assumed));
ffesymbol_set_arraysize (s, array_size);
ffesymbol_set_extents (s, extents);
if (!(0 && ffe_is_90 ())
&& (ffebld_op (array_size) == FFEBLD_opCONTER)
&& (ffebld_constant_integerdefault (ffebld_conter (array_size))
== 0))
{
ffebad_start (FFEBAD_ZERO_ARRAY);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_finish ();
}
}
if (init != NULL)
{
ffesymbol_set_init (s,
ffeexpr_convert (init, initt, name,
ffestc_local_.decl.basic_type,
ffestc_local_.decl.kind_type,
rank,
ffestc_local_.decl.size,
FFEEXPR_contextDATA));
ffecom_notify_init_symbol (s);
ffesymbol_update_init (s);
#if FFEGLOBAL_ENABLED
if (ffesymbol_common (s) != NULL)
ffeglobal_init_common (ffesymbol_common (s), initt);
#endif
}
else if (clist)
{
ffebld symter;
symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (symter,
ffeinfo_new (ffestc_local_.decl.basic_type,
ffestc_local_.decl.kind_type,
rank,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
ffestc_local_.decl.size));
ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
}
if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
{
ffesymbol_set_info (s,
ffeinfo_new (ffestc_local_.decl.basic_type,
ffestc_local_.decl.kind_type,
rank,
ffesymbol_kind (s),
ffesymbol_where (s),
ffestc_local_.decl.size));
if ((na & FFESYMBOL_attrsRESULT)
&& ((sfn = ffesymbol_funcresult (s)) != NULL))
{
ffesymbol_set_info (sfn,
ffeinfo_new (ffestc_local_.decl.basic_type,
ffestc_local_.decl.kind_type,
rank,
ffesymbol_kind (sfn),
ffesymbol_where (sfn),
ffestc_local_.decl.size));
ffesymbol_signal_unreported (sfn);
}
}
else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
|| (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
|| ((ffestc_local_.decl.basic_type
== FFEINFO_basictypeCHARACTER)
&& (ffestc_local_.decl.size != ffesymbol_size (s))))
{
ffesymbol_error (s, name);
}
if ((na & FFESYMBOL_attrsADJUSTS)
&& ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
|| (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
ffesymbol_error (s, name);
ffesymbol_signal_unreported (s);
ffestc_parent_ok_ = TRUE;
}
}
void
ffestc_R501_itemstartvals ()
{
ffestc_check_item_startvals_ ();
if (ffestc_parent_ok_)
ffedata_begin (ffestc_local_.decl.initlist);
}
void
ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
ffebld value, ffelexToken value_token)
{
ffetargetIntegerDefault rpt;
ffestc_check_item_value_ ();
if (!ffestc_parent_ok_)
return;
if (repeat == NULL)
rpt = 1;
else if (ffebld_op (repeat) == FFEBLD_opCONTER)
rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
else
{
ffestc_parent_ok_ = FALSE;
ffedata_end (TRUE, NULL);
return;
}
if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
(repeat_token == NULL) ? value_token : repeat_token)))
ffedata_end (TRUE, NULL);
}
void
ffestc_R501_itemendvals (ffelexToken t)
{
ffestc_check_item_endvals_ ();
if (ffestc_parent_ok_)
ffestc_parent_ok_ = ffedata_end (FALSE, t);
if (ffestc_parent_ok_)
ffesymbol_signal_unreported (ffebld_symter (ffebld_head
(ffestc_local_.decl.initlist)));
}
void
ffestc_R501_finish ()
{
ffestc_check_finish_ ();
}
#if FFESTR_F90
void
ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
{
ffestc_check_start_ ();
if (ffestc_order_spec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R519_start (intent_kw);
ffestc_ok_ = TRUE;
}
void
ffestc_R519_item (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_R519_item (name);
}
void
ffestc_R519_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R519_finish ();
}
void
ffestc_R520_start ()
{
ffestc_check_start_ ();
if (ffestc_order_spec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R520_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R520_item (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_R520_item (name);
}
void
ffestc_R520_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R520_finish ();
}
void
ffestc_R521A ()
{
ffestc_check_simple_ ();
if (ffestc_order_access_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
switch (ffestv_access_state_)
{
case FFESTV_accessstateNONE:
ffestv_access_state_ = FFESTV_accessstatePUBLIC;
ffestv_access_line_
= ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
ffestv_access_col_
= ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
break;
case FFESTV_accessstateANY:
break;
case FFESTV_accessstatePUBLIC:
case FFESTV_accessstatePRIVATE:
ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
ffestv_access_state_ = FFESTV_accessstateANY;
break;
default:
assert ("unexpected access state" == NULL);
break;
}
ffestd_R521A ();
}
void
ffestc_R521Astart ()
{
ffestc_check_start_ ();
if (ffestc_order_access_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R521Astart ();
ffestc_ok_ = TRUE;
}
void
ffestc_R521Aitem (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_R521Aitem (name);
}
void
ffestc_R521Afinish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R521Afinish ();
}
void
ffestc_R521B ()
{
ffestc_check_simple_ ();
if (ffestc_order_access_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
switch (ffestv_access_state_)
{
case FFESTV_accessstateNONE:
ffestv_access_state_ = FFESTV_accessstatePRIVATE;
ffestv_access_line_
= ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
ffestv_access_col_
= ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
break;
case FFESTV_accessstateANY:
break;
case FFESTV_accessstatePUBLIC:
case FFESTV_accessstatePRIVATE:
ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
ffestv_access_state_ = FFESTV_accessstateANY;
break;
default:
assert ("unexpected access state" == NULL);
break;
}
ffestd_R521B ();
}
void
ffestc_R521Bstart ()
{
ffestc_check_start_ ();
if (ffestc_order_access_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R521Bstart ();
ffestc_ok_ = TRUE;
}
void
ffestc_R521Bitem (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_R521Bitem (name);
}
void
ffestc_R521Bfinish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R521Bfinish ();
}
#endif
void
ffestc_R522 ()
{
ffestc_check_simple_ ();
if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
switch (ffestv_save_state_)
{
case FFESTV_savestateNONE:
ffestv_save_state_ = FFESTV_savestateALL;
ffestv_save_line_
= ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
ffestv_save_col_
= ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
break;
case FFESTV_savestateANY:
break;
case FFESTV_savestateSPECIFIC:
case FFESTV_savestateALL:
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_CONFLICTING_SAVES);
ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
}
ffestv_save_state_ = FFESTV_savestateALL;
break;
default:
assert ("unexpected save state" == NULL);
break;
}
ffe_set_is_saveall (TRUE);
ffestd_R522 ();
}
void
ffestc_R522start ()
{
ffestc_check_start_ ();
if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
switch (ffestv_save_state_)
{
case FFESTV_savestateNONE:
ffestv_save_state_ = FFESTV_savestateSPECIFIC;
ffestv_save_line_
= ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
ffestv_save_col_
= ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
break;
case FFESTV_savestateSPECIFIC:
case FFESTV_savestateANY:
break;
case FFESTV_savestateALL:
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_CONFLICTING_SAVES);
ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
}
ffestv_save_state_ = FFESTV_savestateANY;
break;
default:
assert ("unexpected save state" == NULL);
break;
}
ffestd_R522start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R522item_object (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s)
&& ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
|| (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = sa;
else if (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsSAVE;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, name);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_update_save (s);
ffesymbol_signal_unreported (s);
}
ffestd_R522item_object (name);
}
void
ffestc_R522item_cblock (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = sa;
else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
na = sa | FFESYMBOL_attrsSAVECBLOCK;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_update_save (s);
ffesymbol_signal_unreported (s);
}
ffestd_R522item_cblock (name);
}
void
ffestc_R522finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R522finish ();
}
void
ffestc_R524_start (bool virtual)
{
ffestc_check_start_ ();
if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R524_start (virtual);
ffestc_ok_ = TRUE;
}
void
ffestc_R524_item (ffelexToken name, ffesttDimList dims)
{
ffesymbol s;
ffebld array_size;
ffebld extents;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestpDimtype nd;
ffeinfoRank rank;
bool is_ugly_assumed;
ffestc_check_item_ ();
assert (name != NULL);
assert (dims != NULL);
if (!ffestc_ok_)
return;
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
is_ugly_assumed = (ffe_is_ugly_assumed ()
&& ((sa & FFESYMBOL_attrsDUMMY)
|| (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
nd = ffestt_dimlist_type (dims, is_ugly_assumed);
switch (nd)
{
case FFESTP_dimtypeKNOWN:
na = FFESYMBOL_attrsARRAY;
break;
case FFESTP_dimtypeADJUSTABLE:
na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
break;
case FFESTP_dimtypeASSUMED:
na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
break;
case FFESTP_dimtypeADJUSTABLEASSUMED:
na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE;
break;
default:
assert ("Unexpected dims type" == NULL);
na = FFESYMBOL_attrsetNONE;
break;
}
if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (!ffesta_is_entry_valid
&& (sa & FFESYMBOL_attrsANYLEN))
na = FFESYMBOL_attrsetNONE;
else if ((sa & FFESYMBOL_attrsARRAY)
|| ((sa & (FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE))
&& (na & (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYSIZE))))
na = FFESYMBOL_attrsetNONE;
else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsANYSIZE
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsTYPE)))
na |= sa;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, name);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
&array_size,
&extents,
is_ugly_assumed));
ffesymbol_set_arraysize (s, array_size);
ffesymbol_set_extents (s, extents);
if (!(0 && ffe_is_90 ())
&& (ffebld_op (array_size) == FFEBLD_opCONTER)
&& (ffebld_constant_integerdefault (ffebld_conter (array_size))
== 0))
{
ffebad_start (FFEBAD_ZERO_ARRAY);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_finish ();
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
rank,
ffesymbol_kind (s),
ffesymbol_where (s),
ffesymbol_size (s)));
}
ffesymbol_signal_unreported (s);
ffestd_R524_item (name, dims);
}
void
ffestc_R524_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R524_finish ();
}
#if FFESTR_F90
void
ffestc_R525_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R525_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R525_item (ffelexToken name, ffesttDimList dims)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestd_R525_item (name, dims);
}
void
ffestc_R525_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R525_finish ();
}
void
ffestc_R526_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R526_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R526_item (ffelexToken name, ffesttDimList dims)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestd_R526_item (name, dims);
}
void
ffestc_R526_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R526_finish ();
}
void
ffestc_R527_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R527_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R527_item (ffelexToken name, ffesttDimList dims)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestd_R527_item (name, dims);
}
void
ffestc_R527_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R527_finish ();
}
#endif
void
ffestc_R528_start ()
{
ffestcOrder_ order;
ffestc_check_start_ ();
if (ffe_is_pedantic_not_90 ())
order = ffestc_order_data77_ ();
else
order = ffestc_order_data_ ();
if (order != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
#if 1
ffestc_local_.data.objlist = NULL;
#else
ffestd_R528_start_ ();
#endif
ffestc_ok_ = TRUE;
}
void
ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
#if 1
if (ffestc_local_.data.objlist == NULL)
ffebld_init_list (&ffestc_local_.data.objlist,
&ffestc_local_.data.list_bottom);
ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
#else
ffestd_R528_item_object_ (expr, expr_token);
#endif
}
void
ffestc_R528_item_startvals ()
{
ffestc_check_item_startvals_ ();
if (!ffestc_ok_)
return;
#if 1
assert (ffestc_local_.data.objlist != NULL);
ffebld_end_list (&ffestc_local_.data.list_bottom);
ffedata_begin (ffestc_local_.data.objlist);
#else
ffestd_R528_item_startvals_ ();
#endif
}
void
ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
ffebld value, ffelexToken value_token)
{
ffetargetIntegerDefault rpt;
ffestc_check_item_value_ ();
if (!ffestc_ok_)
return;
#if 1
if (repeat == NULL)
rpt = 1;
else if (ffebld_op (repeat) == FFEBLD_opCONTER)
rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
else
{
ffestc_ok_ = FALSE;
ffedata_end (TRUE, NULL);
return;
}
if (!(ffestc_ok_ = ffedata_value (rpt, value,
(repeat_token == NULL)
? value_token
: repeat_token)))
ffedata_end (TRUE, NULL);
#else
ffestd_R528_item_value_ (repeat, value);
#endif
}
void
ffestc_R528_item_endvals (ffelexToken t)
{
ffestc_check_item_endvals_ ();
if (!ffestc_ok_)
return;
#if 1
ffedata_end (!ffestc_ok_, t);
ffestc_local_.data.objlist = NULL;
#else
ffestd_R528_item_endvals_ (t);
#endif
}
void
ffestc_R528_finish ()
{
ffestc_check_finish_ ();
#if 1
#else
ffestd_R528_finish_ ();
#endif
}
void
ffestc_R537_start ()
{
ffestc_check_start_ ();
if (ffestc_order_parameter_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestd_R537_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
ffelexToken source_token)
{
ffesymbol s;
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if ((ffebld_op (dest) == FFEBLD_opANY)
|| (ffebld_op (source) == FFEBLD_opANY))
{
if (ffebld_op (dest) == FFEBLD_opSYMTER)
{
s = ffebld_symter (dest);
ffesymbol_set_init (s, ffebld_new_any ());
ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
ffesymbol_signal_unreported (s);
}
ffestd_R537_item (dest, source);
return;
}
assert (ffebld_op (dest) == FFEBLD_opSYMTER);
assert (ffebld_op (source) == FFEBLD_opCONTER);
s = ffebld_symter (dest);
if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
&& (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
{
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
0,
ffesymbol_kind (s),
ffesymbol_where (s),
ffebld_size (source)));
ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
}
source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
FFEEXPR_contextDATA);
ffesymbol_set_init (s, source);
ffesymbol_signal_unreported (s);
ffestd_R537_item (dest, source);
}
void
ffestc_R537_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R537_finish ();
}
void
ffestc_R539 ()
{
ffestc_check_simple_ ();
if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffeimplic_none ();
ffestd_R539 ();
}
void
ffestc_R539start ()
{
ffestc_check_start_ ();
if (ffestc_order_implicit_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R539start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
ffebld len, ffelexToken lent, ffesttImpList letters)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if ((type == FFESTP_typeCHARACTER) && (len != NULL)
&& (ffebld_op (len) == FFEBLD_opSTAR))
{
ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
ffebad_here (0, ffelex_token_where_line (lent),
ffelex_token_where_column (lent));
ffebad_finish ();
len = NULL;
lent = NULL;
}
ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
ffestt_implist_drive (letters, ffestc_establish_impletter_);
ffestd_R539item (type, kind, kindt, len, lent, letters);
}
void
ffestc_R539finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R539finish ();
}
void
ffestc_R542_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
if (ffe_is_f2c_library ()
&& (ffe_case_source () == FFE_caseNONE))
{
ffebad_start (FFEBAD_NAMELIST_CASE);
ffesta_ffebad_here_current_stmt (0);
ffebad_finish ();
}
ffestd_R542_start ();
ffestc_local_.namelist.symbol = NULL;
ffestc_ok_ = TRUE;
}
void
ffestc_R542_item_nlist (ffelexToken name)
{
ffesymbol s;
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
if (ffestc_local_.namelist.symbol != NULL)
ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
s = ffesymbol_declare_local (name, FALSE);
if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
&& (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
{
ffestc_parent_ok_ = TRUE;
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffebld_init_list (ffesymbol_ptr_to_namelist (s),
ffesymbol_ptr_to_listbottom (s));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindNAMELIST,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
}
}
else
{
if (ffesymbol_kind (s) != FFEINFO_kindANY)
ffesymbol_error (s, name);
ffestc_parent_ok_ = FALSE;
}
ffestc_local_.namelist.symbol = s;
ffestd_R542_item_nlist (name);
}
void
ffestc_R542_item_nitem (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffebld e;
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s)
&& ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
|| ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
&& (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsNAMELIST;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, name);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_namelisted (s, TRUE);
ffesymbol_signal_unreported (s);
#if 0
if (!ffeimplic_establish_symbol (s))
ffesymbol_error (s, name);
#endif
}
if (ffestc_parent_ok_)
{
e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (e,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE, 0,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
FFETARGET_charactersizeNONE));
ffebld_append_item
(ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
}
ffestd_R542_item_nitem (name);
}
void
ffestc_R542_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
ffestd_R542_finish ();
}
void
ffestc_R544_start ()
{
ffestc_check_start_ ();
if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestc_ok_ = TRUE;
}
void
ffestc_R544_item (ffesttExprList exprlist)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestc_local_.equiv.ok = TRUE;
ffestc_local_.equiv.t = NULL;
ffestc_local_.equiv.eq = NULL;
ffestc_local_.equiv.save = FALSE;
ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_);
ffebld_end_list (&ffestc_local_.equiv.bottom);
if (!ffestc_local_.equiv.ok)
return;
if (ffestc_local_.equiv.eq == NULL)
ffestc_local_.equiv.eq = ffeequiv_new ();
ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
ffestc_local_.equiv.t);
if (ffestc_local_.equiv.save)
ffeequiv_update_save (ffestc_local_.equiv.eq);
}
static void
ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
{
ffesymbol s;
if (!ffestc_local_.equiv.ok)
return;
if (ffestc_local_.equiv.t == NULL)
ffestc_local_.equiv.t = t;
switch (ffebld_op (expr))
{
case FFEBLD_opANY:
return;
case FFEBLD_opSYMTER:
case FFEBLD_opARRAYREF:
case FFEBLD_opSUBSTR:
break;
default:
assert ("ffestc_R544_equiv_ bad op" == NULL);
return;
}
ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
s = ffeequiv_symbol (expr);
if (ffesymbol_equiv (s) != NULL)
{
if (ffestc_local_.equiv.eq == NULL)
ffestc_local_.equiv.eq = ffesymbol_equiv (s);
else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
{
ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
ffestc_local_.equiv.eq,
t);
if (ffestc_local_.equiv.eq == NULL)
ffestc_local_.equiv.ok = FALSE;
}
}
if (ffesymbol_is_save (s))
ffestc_local_.equiv.save = TRUE;
}
void
ffestc_R544_finish ()
{
ffestc_check_finish_ ();
}
void
ffestc_R547_start ()
{
ffestc_check_start_ ();
if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestc_local_.common.symbol = NULL;
ffestc_parent_ok_ = TRUE;
ffestd_R547_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
{
ffesymbol s;
ffebld array_size;
ffebld extents;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestpDimtype nd;
ffebld e;
ffeinfoRank rank;
bool is_ugly_assumed;
if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
ffestc_R547_item_cblock (NULL);
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
if (dims != NULL)
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
is_ugly_assumed = (ffe_is_ugly_assumed ()
&& ((sa & FFESYMBOL_attrsDUMMY)
|| (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
nd = ffestt_dimlist_type (dims, is_ugly_assumed);
switch (nd)
{
case FFESTP_dimtypeNONE:
na = FFESYMBOL_attrsCOMMON;
break;
case FFESTP_dimtypeKNOWN:
na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
break;
default:
na = FFESYMBOL_attrsetNONE;
break;
}
if (na == FFESYMBOL_attrsetNONE)
;
else if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if ((sa & (FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsSFARG))
&& (na & FFESYMBOL_attrsARRAY))
na = FFESYMBOL_attrsetNONE;
else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)))
na |= sa;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, name);
else if ((ffesymbol_equiv (s) != NULL)
&& (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
&& (ffeequiv_common (ffesymbol_equiv (s))
!= ffestc_local_.common.symbol))
{
ffebad_start (FFEBAD_EQUIV_COMMON);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
ffebad_finish ();
ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
ffesymbol_set_info (s, ffeinfo_new_any ());
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_signal_unreported (s);
}
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_common (s, ffestc_local_.common.symbol);
#if FFEGLOBAL_ENABLED
if (ffesymbol_is_init (s))
ffeglobal_init_common (ffestc_local_.common.symbol, name);
#endif
if (ffesymbol_is_save (ffestc_local_.common.symbol))
ffesymbol_update_save (s);
if (ffesymbol_equiv (s) != NULL)
{
if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
ffeequiv_set_common (ffesymbol_equiv (s),
ffestc_local_.common.symbol);
#if FFEGLOBAL_ENABLED
if (ffeequiv_is_init (ffesymbol_equiv (s)))
ffeglobal_init_common (ffestc_local_.common.symbol, name);
#endif
if (ffesymbol_is_save (ffestc_local_.common.symbol))
ffeequiv_update_save (ffesymbol_equiv (s));
}
if (dims != NULL)
{
ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
&array_size,
&extents,
is_ugly_assumed));
ffesymbol_set_arraysize (s, array_size);
ffesymbol_set_extents (s, extents);
if (!(0 && ffe_is_90 ())
&& (ffebld_op (array_size) == FFEBLD_opCONTER)
&& (ffebld_constant_integerdefault (ffebld_conter (array_size))
== 0))
{
ffebad_start (FFEBAD_ZERO_ARRAY);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_finish ();
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
rank,
ffesymbol_kind (s),
ffesymbol_where (s),
ffesymbol_size (s)));
}
ffesymbol_signal_unreported (s);
}
if (ffestc_parent_ok_)
{
e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (e,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
FFETARGET_charactersizeNONE));
ffebld_append_item
(ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
}
ffestd_R547_item_object (name, dims);
}
void
ffestc_R547_item_cblock (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if (ffestc_local_.common.symbol != NULL)
ffesymbol_signal_unreported (ffestc_local_.common.symbol);
s = ffesymbol_declare_cblock (name,
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
| FFESYMBOL_attrsSAVECBLOCK)))
{
if (!(sa & FFESYMBOL_attrsCBLOCK))
ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
ffesymbol_ptr_to_listbottom (s));
na = sa | FFESYMBOL_attrsCBLOCK;
}
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
{
ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
ffestc_parent_ok_ = FALSE;
}
else if (na & FFESYMBOL_attrsANY)
ffestc_parent_ok_ = FALSE;
else
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
if (name == NULL)
ffesymbol_update_save (s);
ffestc_parent_ok_ = TRUE;
}
ffestc_local_.common.symbol = s;
ffestd_R547_item_cblock (name);
}
void
ffestc_R547_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
if (ffestc_local_.common.symbol != NULL)
ffesymbol_signal_unreported (ffestc_local_.common.symbol);
ffestd_R547_finish ();
}
#if FFESTR_F90
void
ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
ffestd_R620 (exprlist, stat);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R624 (ffesttExprList pointers)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
ffestd_R624 (pointers);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
ffestd_R625 (exprlist, stat);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#endif
#if FFESTR_F90
void
ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
{
ffestc_R737 (dest, source, source_token);
}
#endif
void
ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
{
ffestc_check_simple_ ();
switch (ffestw_state (ffestw_stack_top ()))
{
#if FFESTR_F90
case FFESTV_stateWHERE:
case FFESTV_stateWHERETHEN:
if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestd_R737B (dest, source);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
return;
#endif
default:
break;
}
if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
FFEEXPR_contextLET);
ffestd_R737A (dest, source);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#if FFESTR_F90
void
ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
ffestd_R738 (dest, source);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R740 (ffebld expr, ffelexToken expr_token)
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
ffestw_set_state (b, FFESTV_stateWHERE);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_where_lost_);
ffestd_R740 (expr);
}
void
ffestc_R742 (ffebld expr, ffelexToken expr_token)
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_probably_this_wont_work_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
ffestw_set_state (b, FFESTV_stateWHERETHEN);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_wherethen_);
ffestw_set_substate (b, 0);
ffestd_R742 (expr);
}
void
ffestc_R744 ()
{
ffestc_check_simple_ ();
if (ffestc_order_where_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 0)
{
ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestw_set_substate (ffestw_stack_top (), 1);
ffestd_R744 ();
}
void
ffestc_R745 ()
{
ffestc_check_simple_ ();
if (ffestc_order_where_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_shriek_wherethen_ (TRUE);
}
#endif
void
ffestc_R803 (ffelexToken construct_name, ffebld expr,
ffelexToken expr_token UNUSED)
{
ffestw b;
ffesymbol s;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
ffestw_set_state (b, FFESTV_stateIFTHEN);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_ifthen_);
ffestw_set_substate (b, 0);
if (construct_name == NULL)
ffestw_set_name (b, NULL);
else
{
ffestw_set_name (b, ffelex_token_use (construct_name));
s = ffesymbol_declare_local (construct_name, FALSE);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindCONSTRUCT,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, construct_name);
}
ffestd_R803 (construct_name, expr);
}
void
ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (name != NULL)
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name,
ffestw_name (ffestw_stack_top ()))
!= 0)
{
ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
if (ffestw_substate (ffestw_stack_top ()) != 0)
{
ffebad_start (FFEBAD_AFTER_ELSE);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
return;
}
ffestd_R804 (expr, name);
}
void
ffestc_R805 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (name != NULL)
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
{
ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
if (ffestw_substate (ffestw_stack_top ()) != 0)
{
ffebad_start (FFEBAD_AFTER_ELSE);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
return;
}
ffestw_set_substate (ffestw_stack_top (), 1);
ffestd_R805 (name);
}
void
ffestc_R806 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_endif_ ();
if (name == NULL)
{
if (ffestw_name (ffestw_stack_top ()) != NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NAMED);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
}
else
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
{
ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
ffestc_shriek_ifthen_ (TRUE);
}
void
ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_action_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
ffestw_set_state (b, FFESTV_stateIF);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_if_lost_);
ffestd_R807 (expr);
}
void
ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
{
ffestw b;
mallocPool pool;
ffestwSelect s;
ffesymbol sym;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
ffestw_set_state (b, FFESTV_stateSELECT0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_select_);
ffestw_set_substate (b, 0);
pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
s->first_rel = (ffestwCase) &s->first_rel;
s->last_rel = (ffestwCase) &s->first_rel;
s->first_stmt = (ffestwCase) &s->first_rel;
s->last_stmt = (ffestwCase) &s->first_rel;
s->pool = pool;
s->cases = 1;
s->t = ffelex_token_use (expr_token);
s->type = ffeinfo_basictype (ffebld_info (expr));
s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
ffestw_set_select (b, s);
if (construct_name == NULL)
ffestw_set_name (b, NULL);
else
{
ffestw_set_name (b, ffelex_token_use (construct_name));
sym = ffesymbol_declare_local (construct_name, FALSE);
if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (sym,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE, 0,
FFEINFO_kindCONSTRUCT,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
sym = ffecom_sym_learned (sym);
ffesymbol_signal_unreported (sym);
}
else
ffesymbol_error (sym, construct_name);
}
ffestd_R809 (construct_name, expr);
}
void
ffestc_R810 (ffesttCaseList cases, ffelexToken name)
{
ffesttCaseList caseobj;
ffestwSelect s;
ffestwCase c, nc;
ffebldConstant expr1c, expr2c;
ffestc_check_simple_ ();
if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
s = ffestw_select (ffestw_stack_top ());
if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
{
#if 0
ffestw_update (NULL);
#endif
ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
}
if (name != NULL)
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name,
ffestw_name (ffestw_stack_top ()))
!= 0)
{
ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
if (cases == NULL)
{
if (ffestw_substate (ffestw_stack_top ()) != 0)
{
ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestw_set_substate (ffestw_stack_top (), 1);
}
else
{
for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
{
if ((caseobj->expr1 == NULL)
&& (!caseobj->range
|| (caseobj->expr2 == NULL)))
{
ffebad_start (FFEBAD_CASE_BAD_RANGE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_finish ();
continue;
}
if (((caseobj->expr1 != NULL)
&& ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
!= s->type)))
|| ((caseobj->range)
&& (caseobj->expr2 != NULL)
&& ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
!= s->type))))
{
ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_here (1, ffelex_token_where_line (s->t),
ffelex_token_where_column (s->t));
ffebad_finish ();
continue;
}
if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
{
ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_finish ();
continue;
}
if (caseobj->expr1 == NULL)
expr1c = NULL;
else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
continue;
else
expr1c = ffebld_conter (caseobj->expr1);
if (!caseobj->range)
expr2c = expr1c;
else if (caseobj->expr2 == NULL)
expr2c = NULL;
else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
continue;
else
expr2c = ffebld_conter (caseobj->expr2);
if (expr1c == NULL)
{
c = s->first_rel;
if ((c != (ffestwCase) &s->first_rel)
&& ((c->low == NULL)
|| (ffebld_constant_cmp (expr2c, c->low) >= 0)))
{
ffebad_start (FFEBAD_CASE_DUPLICATE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_here (1, ffelex_token_where_line (c->t),
ffelex_token_where_column (c->t));
ffebad_finish ();
continue;
}
}
else if (expr2c == NULL)
{
c = s->last_rel;
if ((c != (ffestwCase) &s->first_rel)
&& ((c->high == NULL)
|| (ffebld_constant_cmp (expr1c, c->high) <= 0)))
{
ffebad_start (FFEBAD_CASE_DUPLICATE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_here (1, ffelex_token_where_line (c->t),
ffelex_token_where_column (c->t));
ffebad_finish ();
continue;
}
c = c->next_rel;
}
else
{
if (ffebld_constant_cmp (expr1c, expr2c) > 0)
{
ffebad_start (FFEBAD_CASE_RANGE_USELESS);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_finish ();
continue;
}
for (c = s->first_rel;
(c != (ffestwCase) &s->first_rel)
&& ((c->low == NULL)
|| (ffebld_constant_cmp (expr1c, c->low) > 0));
c = c->next_rel)
;
nc = c;
if (((c != (ffestwCase) &s->first_rel)
&& (ffebld_constant_cmp (expr2c, c->low) >= 0))
|| (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
&& (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
{
ffebad_start (FFEBAD_CASE_DUPLICATE);
ffebad_here (0, ffelex_token_where_line (caseobj->t),
ffelex_token_where_column (caseobj->t));
ffebad_here (1, ffelex_token_where_line (nc->t),
ffelex_token_where_column (nc->t));
ffebad_finish ();
continue;
}
}
nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
nc->next_rel = c;
nc->previous_rel = c->previous_rel;
nc->next_stmt = (ffestwCase) &s->first_rel;
nc->previous_stmt = s->last_stmt;
nc->low = expr1c;
nc->high = expr2c;
nc->casenum = s->cases;
nc->t = ffelex_token_use (caseobj->t);
nc->next_rel->previous_rel = nc;
nc->previous_rel->next_rel = nc;
nc->next_stmt->previous_stmt = nc;
nc->previous_stmt->next_stmt = nc;
}
}
ffestd_R810 ((cases == NULL) ? 0 : s->cases);
s->cases++;
}
void
ffestc_R811 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
if (name == NULL)
{
if (ffestw_name (ffestw_stack_top ()) != NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NAMED);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
}
else
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name,
ffestw_name (ffestw_stack_top ()))
!= 0)
{
ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
ffestc_shriek_select_ (TRUE);
}
void
ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
ffelexToken end_token, ffebld incr, ffelexToken incr_token)
{
ffestw b;
ffelab label;
ffesymbol s;
ffesymbol varsym;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
if (!ffestc_labelref_is_loopend_ (label_token, &label))
return;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, b);
ffestw_set_state (b, FFESTV_stateDO);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_do_);
ffestw_set_label (b, label);
switch (ffebld_op (var))
{
case FFEBLD_opSYMTER:
if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
&& ffe_is_warn_surprising ())
{
ffebad_start (FFEBAD_DO_REAL);
ffebad_here (0, ffelex_token_where_line (var_token),
ffelex_token_where_column (var_token));
ffebad_string (ffesymbol_text (ffebld_symter (var)));
ffebad_finish ();
}
if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
{
ffesymbol_set_is_doiter (varsym, TRUE);
ffestw_set_do_iter_var (b, varsym);
ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
break;
}
case FFEBLD_opANY:
ffestw_set_do_iter_var (b, NULL);
ffestw_set_do_iter_var_t (b, NULL);
break;
default:
assert ("bad iter var" == NULL);
break;
}
if (construct_name == NULL)
ffestw_set_name (b, NULL);
else
{
ffestw_set_name (b, ffelex_token_use (construct_name));
s = ffesymbol_declare_local (construct_name, FALSE);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindCONSTRUCT,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, construct_name);
}
if (incr == NULL)
{
incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
ffebld_set_info (incr, ffeinfo_new
(FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
}
start = ffeexpr_convert_expr (start, start_token, var, var_token,
FFEEXPR_contextLET);
end = ffeexpr_convert_expr (end, end_token, var, var_token,
FFEEXPR_contextLET);
incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
FFEEXPR_contextLET);
ffestd_R819A (construct_name, label, var,
start, start_token,
end, end_token,
incr, incr_token);
}
void
ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
ffebld expr, ffelexToken expr_token UNUSED)
{
ffestw b;
ffelab label;
ffesymbol s;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
if (!ffestc_labelref_is_loopend_ (label_token, &label))
return;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, b);
ffestw_set_state (b, FFESTV_stateDO);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_do_);
ffestw_set_label (b, label);
ffestw_set_do_iter_var (b, NULL);
ffestw_set_do_iter_var_t (b, NULL);
if (construct_name == NULL)
ffestw_set_name (b, NULL);
else
{
ffestw_set_name (b, ffelex_token_use (construct_name));
s = ffesymbol_declare_local (construct_name, FALSE);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindCONSTRUCT,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, construct_name);
}
ffestd_R819B (construct_name, label, expr);
}
void
ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
ffebld incr, ffelexToken incr_token)
{
ffestw b;
ffesymbol s;
ffesymbol varsym;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, b);
ffestw_set_state (b, FFESTV_stateDO);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_do_);
ffestw_set_label (b, NULL);
switch (ffebld_op (var))
{
case FFEBLD_opSYMTER:
if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
&& ffe_is_warn_surprising ())
{
ffebad_start (FFEBAD_DO_REAL);
ffebad_here (0, ffelex_token_where_line (var_token),
ffelex_token_where_column (var_token));
ffebad_string (ffesymbol_text (ffebld_symter (var)));
ffebad_finish ();
}
if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
{
ffesymbol_set_is_doiter (varsym, TRUE);
ffestw_set_do_iter_var (b, varsym);
ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
break;
}
case FFEBLD_opANY:
ffestw_set_do_iter_var (b, NULL);
ffestw_set_do_iter_var_t (b, NULL);
break;
default:
assert ("bad iter var" == NULL);
break;
}
if (construct_name == NULL)
ffestw_set_name (b, NULL);
else
{
ffestw_set_name (b, ffelex_token_use (construct_name));
s = ffesymbol_declare_local (construct_name, FALSE);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindCONSTRUCT,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, construct_name);
}
if (incr == NULL)
{
incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
ffebld_set_info (incr, ffeinfo_new
(FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
}
start = ffeexpr_convert_expr (start, start_token, var, var_token,
FFEEXPR_contextLET);
end = ffeexpr_convert_expr (end, end_token, var, var_token,
FFEEXPR_contextLET);
incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
FFEEXPR_contextLET);
#if 0
if ((ffebld_op (incr) == FFEBLD_opCONTER)
&& (ffebld_constant_is_zero (ffebld_conter (incr))))
{
ffebad_start (FFEBAD_DO_STEP_ZERO);
ffebad_here (0, ffelex_token_where_line (incr_token),
ffelex_token_where_column (incr_token));
ffebad_string ("Iterative DO loop");
ffebad_finish ();
}
#endif
ffestd_R819A (construct_name, NULL, var,
start, start_token,
end, end_token,
incr, incr_token);
}
void
ffestc_R820B (ffelexToken construct_name, ffebld expr,
ffelexToken expr_token UNUSED)
{
ffestw b;
ffesymbol s;
ffestc_check_simple_ ();
if (ffestc_order_exec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, b);
ffestw_set_state (b, FFESTV_stateDO);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_do_);
ffestw_set_label (b, NULL);
ffestw_set_do_iter_var (b, NULL);
ffestw_set_do_iter_var_t (b, NULL);
if (construct_name == NULL)
ffestw_set_name (b, NULL);
else
{
ffestw_set_name (b, ffelex_token_use (construct_name));
s = ffesymbol_declare_local (construct_name, FALSE);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindCONSTRUCT,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, construct_name);
}
ffestd_R819B (construct_name, NULL, expr);
}
void
ffestc_R825 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_do_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (name == NULL)
{
if (ffestw_name (ffestw_stack_top ()) != NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NAMED);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
}
else
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name,
ffestw_name (ffestw_stack_top ()))
!= 0)
{
ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
if (ffesta_label_token == NULL)
{
if (ffestw_label (ffestw_stack_top ()) != NULL)
{
ffebad_start (FFEBAD_DO_HAD_LABEL);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestc_shriek_do_ (TRUE);
ffestc_try_shriek_do_ ();
return;
}
ffestd_R825 (name);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R834 (ffelexToken name)
{
ffestw block;
ffestc_check_simple_ ();
if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
if (name == NULL)
block = ffestw_top_do (ffestw_stack_top ());
else
{
for (block = ffestw_top_do (ffestw_stack_top ());
(block != NULL) && (ffestw_blocknum (block) != 0);
block = ffestw_top_do (ffestw_previous (block)))
{
if ((ffestw_name (block) != NULL)
&& (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
break;
}
if ((block == NULL) || (ffestw_blocknum (block) == 0))
{
block = ffestw_top_do (ffestw_stack_top ());
ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_finish ();
}
}
ffestd_R834 (block);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R835 (ffelexToken name)
{
ffestw block;
ffestc_check_simple_ ();
if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
if (name == NULL)
block = ffestw_top_do (ffestw_stack_top ());
else
{
for (block = ffestw_top_do (ffestw_stack_top ());
(block != NULL) && (ffestw_blocknum (block) != 0);
block = ffestw_top_do (ffestw_previous (block)))
{
if ((ffestw_name (block) != NULL)
&& (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
break;
}
if ((block == NULL) || (ffestw_blocknum (block) == 0))
{
block = ffestw_top_do (ffestw_stack_top ());
ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_finish ();
}
}
ffestd_R835 (block);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R836 (ffelexToken label_token)
{
ffelab label;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
if (ffestc_labelref_is_branch_ (label_token, &label))
ffestd_R836 (label);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
ffelexToken expr_token UNUSED)
{
ffesttTokenItem ti;
bool ok = TRUE;
int i;
ffelab *labels;
assert (label_toks != NULL);
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
sizeof (*labels)
* ffestt_tokenlist_count (label_toks));
for (ti = label_toks->first, i = 0;
ti != (ffesttTokenItem) &label_toks->first;
ti = ti->next, ++i)
{
if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
{
ok = FALSE;
break;
}
}
if (ok)
ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R838 (ffelexToken label_token, ffebld target,
ffelexToken target_token UNUSED)
{
ffelab label;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffebld_op (target) == FFEBLD_opSYMTER)
ffesymbol_set_assigned (ffebld_symter (target), TRUE);
if (ffestc_labelref_is_assignable_ (label_token, &label))
ffestd_R838 (label, target);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
ffesttTokenList label_toks)
{
ffesttTokenItem ti;
bool ok = TRUE;
int i;
ffelab *labels;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
if (label_toks == NULL)
{
labels = NULL;
i = 0;
}
else
{
labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
sizeof (*labels) * ffestt_tokenlist_count (label_toks));
for (ti = label_toks->first, i = 0;
ti != (ffesttTokenItem) &label_toks->first;
ti = ti->next, ++i)
{
if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
{
ok = FALSE;
break;
}
}
}
if (ok)
ffestd_R839 (target, labels, i);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
ffelexToken neg_token, ffelexToken zero_token,
ffelexToken pos_token)
{
ffelab neg;
ffelab zero;
ffelab pos;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
if (ffestc_labelref_is_branch_ (neg_token, &neg)
&& ffestc_labelref_is_branch_ (zero_token, &zero)
&& ffestc_labelref_is_branch_ (pos_token, &pos))
ffestd_R840 (expr, neg, zero, pos);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R841 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
return;
switch (ffestw_state (ffestw_stack_top ()))
{
#if FFESTR_F90
case FFESTV_stateWHERE:
case FFESTV_stateWHERETHEN:
ffestc_labeldef_useless_ ();
ffestd_R841 (TRUE);
break;
#endif
default:
ffestc_labeldef_branch_begin_ ();
ffestd_R841 (FALSE);
break;
}
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
ffestd_R842 (expr);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
ffestd_R843 (expr);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R904 ()
{
int i;
int expect_file;
static const char *const status_strs[] =
{
"New",
"Old",
"Replace",
"Scratch",
"Unknown"
};
static const char *const access_strs[] =
{
"Append",
"Direct",
"Keyed",
"Sequential"
};
static const char *const blank_strs[] =
{
"Null",
"Zero"
};
static const char *const carriagecontrol_strs[] =
{
"Fortran",
"List",
"None"
};
static const char *const dispose_strs[] =
{
"Delete",
"Keep",
"Print",
"Print/Delete",
"Save",
"Submit",
"Submit/Delete"
};
static const char *const form_strs[] =
{
"Formatted",
"Unformatted"
};
static const char *const organization_strs[] =
{
"Indexed",
"Relative",
"Sequential"
};
static const char *const position_strs[] =
{
"Append",
"AsIs",
"Rewind"
};
static const char *const action_strs[] =
{
"Read",
"ReadWrite",
"Write"
};
static const char *const delim_strs[] =
{
"Apostrophe",
"None",
"Quote"
};
static const char *const recordtype_strs[] =
{
"Fixed",
"Segmented",
"Stream",
"Stream_CR",
"Stream_LF",
"Variable"
};
static const char *const pad_strs[] =
{
"No",
"Yes"
};
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.open.open_spec[FFESTP_openixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.open.open_spec[FFESTP_openixUNIT]))
{
i = ffestc_subr_binsrch_ (status_strs,
ARRAY_SIZE (status_strs),
&ffestp_file.open.open_spec[FFESTP_openixSTATUS],
"NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
switch (i)
{
case 0:
case 5:
expect_file = 2;
break;
case 1:
case 2:
if (ffe_is_pedantic ())
expect_file = 1;
else
expect_file = 2;
break;
case 3:
expect_file = 1;
break;
case 4:
expect_file = 0;
break;
default:
assert ("invalid _binsrch_ result" == NULL);
expect_file = 0;
break;
}
if ((expect_file == 0)
&& ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
{
ffebad_start (FFEBAD_CONFLICTING_SPECS);
assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
ffelex_token_where_column
(ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
}
else
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.open.open_spec[FFESTP_openixFILE].value),
ffelex_token_where_column
(ffestp_file.open.open_spec[FFESTP_openixFILE].value));
}
assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
ffelex_token_where_column
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
}
else
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
ffelex_token_where_column
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
}
ffebad_finish ();
}
else if ((expect_file == 1)
&& !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
{
ffebad_start (FFEBAD_MISSING_SPECIFIER);
assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
ffelex_token_where_column
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
}
else
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
ffelex_token_where_column
(ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
}
ffebad_string ("FILE=");
ffebad_finish ();
}
ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
&ffestp_file.open.open_spec[FFESTP_openixACCESS],
"APPEND, DIRECT, KEYED, or SEQUENTIAL");
ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
&ffestp_file.open.open_spec[FFESTP_openixBLANK],
"NULL or ZERO");
ffestc_subr_binsrch_ (carriagecontrol_strs,
ARRAY_SIZE (carriagecontrol_strs),
&ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
"FORTRAN, LIST, or NONE");
ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
&ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
"DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
&ffestp_file.open.open_spec[FFESTP_openixFORM],
"FORMATTED or UNFORMATTED");
ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
&ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
"INDEXED, RELATIVE, or SEQUENTIAL");
ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
&ffestp_file.open.open_spec[FFESTP_openixPOSITION],
"APPEND, ASIS, or REWIND");
ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
&ffestp_file.open.open_spec[FFESTP_openixACTION],
"READ, READWRITE, or WRITE");
ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
&ffestp_file.open.open_spec[FFESTP_openixDELIM],
"APOSTROPHE, NONE, or QUOTE");
ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
&ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
"FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
&ffestp_file.open.open_spec[FFESTP_openixPAD],
"NO or YES");
ffestd_R904 ();
}
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R907 ()
{
static const char *const status_strs[] =
{
"Delete",
"Keep",
"Print",
"Print/Delete",
"Save",
"Submit",
"Submit/Delete"
};
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.close.close_spec[FFESTP_closeixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
{
ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
&ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
"DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
ffestd_R907 ();
}
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R909_start (bool only_format)
{
ffestvUnit unit;
ffestvFormat format;
bool rec;
bool key;
ffestpReadIx keyn;
ffestpReadIx spec1;
ffestpReadIx spec2;
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_format_
(&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
{
ffestc_ok_ = FALSE;
return;
}
format = ffestc_subr_format_
(&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
if (only_format)
{
ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
ffestc_ok_ = TRUE;
return;
}
if (!ffestc_subr_is_branch_
(&ffestp_file.read.read_spec[FFESTP_readixEOR])
|| !ffestc_subr_is_branch_
(&ffestp_file.read.read_spec[FFESTP_readixERR])
|| !ffestc_subr_is_branch_
(&ffestp_file.read.read_spec[FFESTP_readixEND]))
{
ffestc_ok_ = FALSE;
return;
}
unit = ffestc_subr_unit_
(&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
if (unit == FFESTV_unitNONE)
{
ffebad_start (FFEBAD_NO_UNIT_SPEC);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
{
key = TRUE;
keyn = spec1 = FFESTP_readixKEYEQ;
}
else
{
key = FALSE;
keyn = spec1 = FFESTP_readix;
}
if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
{
if (key)
{
spec2 = FFESTP_readixKEYGT;
whine:
ffebad_start (FFEBAD_CONFLICTING_SPECS);
assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
if (ffestp_file.read.read_spec[spec1].kw_present)
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.read.read_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec1].kw));
}
else
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.read.read_spec[spec1].value),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec1].value));
}
assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
if (ffestp_file.read.read_spec[spec2].kw_present)
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.read.read_spec[spec2].kw),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec2].kw));
}
else
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.read.read_spec[spec2].value),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec2].value));
}
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
key = TRUE;
keyn = spec1 = FFESTP_readixKEYGT;
}
if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
{
if (key)
{
spec2 = FFESTP_readixKEYGT;
goto whine;
}
key = TRUE;
keyn = FFESTP_readixKEYGT;
}
if (rec)
{
spec1 = FFESTP_readixREC;
if (key)
{
spec2 = keyn;
goto whine;
}
if (unit == FFESTV_unitCHAREXPR)
{
spec2 = FFESTP_readixUNIT;
goto whine;
}
if ((format == FFESTV_formatASTERISK)
|| (format == FFESTV_formatNAMELIST))
{
spec2 = FFESTP_readixFORMAT;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
spec2 = FFESTP_readixADVANCE;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
{
spec2 = FFESTP_readixEND;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
{
spec2 = FFESTP_readixNULLS;
goto whine;
}
}
else if (key)
{
spec1 = keyn;
if (unit == FFESTV_unitCHAREXPR)
{
spec2 = FFESTP_readixUNIT;
goto whine;
}
if ((format == FFESTV_formatASTERISK)
|| (format == FFESTV_formatNAMELIST))
{
spec2 = FFESTP_readixFORMAT;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
spec2 = FFESTP_readixADVANCE;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
{
spec2 = FFESTP_readixEND;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
{
spec2 = FFESTP_readixEOR;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
{
spec2 = FFESTP_readixNULLS;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
{
spec2 = FFESTP_readixREC;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
{
spec2 = FFESTP_readixSIZE;
goto whine;
}
}
else
{
if (unit == FFESTV_unitCHAREXPR)
{
spec1 = FFESTP_readixUNIT;
if (format == FFESTV_formatNAMELIST)
{
spec2 = FFESTP_readixFORMAT;
goto whine;
}
if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
spec2 = FFESTP_readixADVANCE;
goto whine;
}
}
if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
{
spec1 = FFESTP_readixADVANCE;
if (format == FFESTV_formatNONE)
{
ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
ffebad_here (0, ffelex_token_where_line
(ffestp_file.read.read_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec1].kw));
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
if (format == FFESTV_formatNAMELIST)
{
spec2 = FFESTP_readixFORMAT;
goto whine;
}
}
if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
{
spec1 = FFESTP_readixEOR;
if (ffestc_subr_speccmp_ ("No",
&ffestp_file.read.read_spec[FFESTP_readixADVANCE],
NULL, NULL) != 0)
{
goto whine_advance;
}
}
if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
{
spec1 = FFESTP_readixNULLS;
if (format != FFESTV_formatASTERISK)
{
spec2 = FFESTP_readixFORMAT;
goto whine;
}
}
if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
{
spec1 = FFESTP_readixSIZE;
if (ffestc_subr_speccmp_ ("No",
&ffestp_file.read.read_spec[FFESTP_readixADVANCE],
NULL, NULL) != 0)
{
whine_advance:
if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
.kw_or_val_present)
{
ffebad_start (FFEBAD_CONFLICTING_SPECS);
ffebad_here (0, ffelex_token_where_line
(ffestp_file.read.read_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec1].kw));
ffebad_here (1, ffelex_token_where_line
(ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
ffelex_token_where_column
(ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
ffebad_finish ();
}
else
{
ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
ffebad_here (0, ffelex_token_where_line
(ffestp_file.read.read_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.read.read_spec[spec1].kw));
ffebad_finish ();
}
ffestc_ok_ = FALSE;
return;
}
}
}
if (unit == FFESTV_unitCHAREXPR)
ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
else
ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
ffestd_R909_start (FALSE, unit, format, rec, key);
ffestc_ok_ = TRUE;
}
void
ffestc_R909_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if (ffestc_namelist_ != 0)
{
if (ffestc_namelist_ == 1)
{
ffestc_namelist_ = 2;
ffebad_start (FFEBAD_NAMELIST_ITEMS);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
}
return;
}
ffestd_R909_item (expr, expr_token);
}
void
ffestc_R909_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R909_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R910_start ()
{
ffestvUnit unit;
ffestvFormat format;
bool rec;
ffestpWriteIx spec1;
ffestpWriteIx spec2;
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_branch_
(&ffestp_file.write.write_spec[FFESTP_writeixEOR])
|| !ffestc_subr_is_branch_
(&ffestp_file.write.write_spec[FFESTP_writeixERR])
|| !ffestc_subr_is_format_
(&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
{
ffestc_ok_ = FALSE;
return;
}
format = ffestc_subr_format_
(&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
unit = ffestc_subr_unit_
(&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
if (unit == FFESTV_unitNONE)
{
ffebad_start (FFEBAD_NO_UNIT_SPEC);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
if (rec)
{
spec1 = FFESTP_writeixREC;
if (unit == FFESTV_unitCHAREXPR)
{
spec2 = FFESTP_writeixUNIT;
whine:
ffebad_start (FFEBAD_CONFLICTING_SPECS);
assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
if (ffestp_file.write.write_spec[spec1].kw_present)
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.write.write_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec1].kw));
}
else
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.write.write_spec[spec1].value),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec1].value));
}
assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
if (ffestp_file.write.write_spec[spec2].kw_present)
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.write.write_spec[spec2].kw),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec2].kw));
}
else
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.write.write_spec[spec2].value),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec2].value));
}
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
if ((format == FFESTV_formatASTERISK)
|| (format == FFESTV_formatNAMELIST))
{
spec2 = FFESTP_writeixFORMAT;
goto whine;
}
if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
{
spec2 = FFESTP_writeixADVANCE;
goto whine;
}
}
else
{
if (unit == FFESTV_unitCHAREXPR)
{
spec1 = FFESTP_writeixUNIT;
if (format == FFESTV_formatNAMELIST)
{
spec2 = FFESTP_writeixFORMAT;
goto whine;
}
if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
{
spec2 = FFESTP_writeixADVANCE;
goto whine;
}
}
if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
{
spec1 = FFESTP_writeixADVANCE;
if (format == FFESTV_formatNONE)
{
ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
ffebad_here (0, ffelex_token_where_line
(ffestp_file.write.write_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec1].kw));
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
if (format == FFESTV_formatNAMELIST)
{
spec2 = FFESTP_writeixFORMAT;
goto whine;
}
}
if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
{
spec1 = FFESTP_writeixEOR;
if (ffestc_subr_speccmp_ ("No",
&ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
NULL, NULL) != 0)
{
if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
.kw_or_val_present)
{
ffebad_start (FFEBAD_CONFLICTING_SPECS);
ffebad_here (0, ffelex_token_where_line
(ffestp_file.write.write_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec1].kw));
ffebad_here (1, ffelex_token_where_line
(ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
ffelex_token_where_column
(ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
ffebad_finish ();
}
else
{
ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
ffebad_here (0, ffelex_token_where_line
(ffestp_file.write.write_spec[spec1].kw),
ffelex_token_where_column
(ffestp_file.write.write_spec[spec1].kw));
ffebad_finish ();
}
ffestc_ok_ = FALSE;
return;
}
}
}
if (unit == FFESTV_unitCHAREXPR)
ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
else
ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
ffestd_R910_start (unit, format, rec);
ffestc_ok_ = TRUE;
}
void
ffestc_R910_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if (ffestc_namelist_ != 0)
{
if (ffestc_namelist_ == 1)
{
ffestc_namelist_ = 2;
ffebad_start (FFEBAD_NAMELIST_ITEMS);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
}
return;
}
ffestd_R910_item (expr, expr_token);
}
void
ffestc_R910_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R910_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R911_start ()
{
ffestvFormat format;
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_format_
(&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
{
ffestc_ok_ = FALSE;
return;
}
format = ffestc_subr_format_
(&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
ffestd_R911_start (format);
ffestc_ok_ = TRUE;
}
void
ffestc_R911_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if (ffestc_namelist_ != 0)
{
if (ffestc_namelist_ == 1)
{
ffestc_namelist_ = 2;
ffebad_start (FFEBAD_NAMELIST_ITEMS);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
}
return;
}
ffestd_R911_item (expr, expr_token);
}
void
ffestc_R911_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R911_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R919 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
ffestd_R919 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R920 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
ffestd_R920 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R921 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
ffestd_R921 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R923A ()
{
bool by_file;
bool by_unit;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
{
by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
.kw_or_val_present;
by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
.kw_or_val_present;
if (by_file && by_unit)
{
ffebad_start (FFEBAD_CONFLICTING_SPECS);
assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
ffelex_token_where_column
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
}
else
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
ffelex_token_where_column
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
}
assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
ffelex_token_where_column
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
}
else
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
ffelex_token_where_column
(ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
}
ffebad_finish ();
}
else if (!by_file && !by_unit)
{
ffebad_start (FFEBAD_MISSING_SPECIFIER);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_string ("UNIT= or FILE=");
ffebad_finish ();
}
else
ffestd_R923A (by_file);
}
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R923B_start ()
{
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
ffestd_R923B_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestd_R923B_item (expr);
}
void
ffestc_R923B_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R923B_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_R1001 (ffesttFormatList f)
{
ffestc_check_simple_ ();
if (ffestc_order_format_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_format_ ();
ffestd_R1001 (f);
}
void
ffestc_R1102 (ffelexToken name)
{
ffestw b;
ffesymbol s;
assert (name != NULL);
ffestc_check_simple_ ();
if (ffestc_order_unit_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_blocknum_ = 0;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_statePROGRAM0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_end_program_);
ffestw_set_name (b, ffelex_token_use (name));
s = ffesymbol_declare_programunit (name,
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindPROGRAM,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, name);
ffestd_R1102 (s, name);
}
void
ffestc_R1103 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_program_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
if (name != NULL)
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
{
ffebad_start (FFEBAD_UNIT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
ffestc_shriek_end_program_ (TRUE);
}
#if FFESTR_F90
void
ffestc_R1105 (ffelexToken name)
{
ffestw b;
assert (name != NULL);
ffestc_check_simple_ ();
if (ffestc_order_unit_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_blocknum_ = 0;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateMODULE0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_module_);
ffestw_set_name (b, ffelex_token_use (name));
ffestd_R1105 (name);
}
void
ffestc_R1106 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_module_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if ((name != NULL)
&& (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
{
ffebad_start (FFEBAD_UNIT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
ffestc_shriek_module_ (TRUE);
}
void
ffestc_R1107_start (ffelexToken name, bool only)
{
ffestc_check_start_ ();
if (ffestc_order_use_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R1107_start (name, only);
ffestc_ok_ = TRUE;
}
void
ffestc_R1107_item (ffelexToken local, ffelexToken use)
{
ffestc_check_item_ ();
assert (use != NULL);
if (!ffestc_ok_)
return;
ffestd_R1107_item (local, use);
}
void
ffestc_R1107_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R1107_finish ();
}
#endif
void
ffestc_R1111 (ffelexToken name)
{
ffestw b;
ffesymbol s;
ffestc_check_simple_ ();
if (ffestc_order_unit_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_blocknum_ = 0;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_blockdata_);
if (name == NULL)
ffestw_set_name (b, NULL);
else
ffestw_set_name (b, ffelex_token_use (name));
s = ffesymbol_declare_blockdataunit (name,
ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindBLOCKDATA,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, name);
ffestd_R1111 (s, name);
}
void
ffestc_R1112 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (name != NULL)
{
if (ffestw_name (ffestw_stack_top ()) == NULL)
{
ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
{
ffebad_start (FFEBAD_UNIT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
}
ffestc_shriek_blockdata_ (TRUE);
}
#if FFESTR_F90
void
ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateINTERFACE0);
ffestw_set_blocknum (b, 0);
ffestw_set_shriek (b, ffestc_shriek_interface_);
if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
ffestw_set_substate (b, 0);
else
ffestw_set_substate (b, 1);
ffestd_R1202 (operator, name);
ffe_init_4 ();
}
void
ffestc_R1203 ()
{
ffestc_check_simple_ ();
if (ffestc_order_interface_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_shriek_interface_ (TRUE);
ffe_terminate_4 ();
}
void
ffestc_R1205_start ()
{
ffestc_check_start_ ();
if (ffestc_order_interface_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) == 0)
{
ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
}
if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
{
ffestw_update (NULL);
ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
}
ffestd_R1205_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R1205_item (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_R1205_item (name);
}
void
ffestc_R1205_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R1205_finish ();
}
#endif
void
ffestc_R1207_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R1207_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R1207_item (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsEXTERNAL;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, name);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_explicitwhere (s, TRUE);
ffesymbol_reference (s, name, FALSE);
ffesymbol_signal_unreported (s);
}
ffestd_R1207_item (name);
}
void
ffestc_R1207_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R1207_finish ();
}
void
ffestc_R1208_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_R1208_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_R1208_item (ffelexToken name)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeintrinGen gen;
ffeintrinSpec spec;
ffeintrinImp imp;
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
s = ffesymbol_declare_local (name, TRUE);
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = sa;
else if (!(sa & ~FFESYMBOL_attrsTYPE))
{
if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
&gen, &spec, &imp)
&& ((imp == FFEINTRIN_impNONE)
#if 0
|| ((ffeintrin_basictype (spec)
== ffesymbol_basictype (s))
&& (ffeintrin_kindtype (spec)
== ffesymbol_kindtype (s)))
#else
|| 1
#endif
|| !(sa & FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsINTRINSIC;
else
na = FFESYMBOL_attrsetNONE;
}
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, name);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_generic (s, gen);
ffesymbol_set_specific (s, spec);
ffesymbol_set_implementation (s, imp);
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
0,
FFEINFO_kindNONE,
FFEINFO_whereINTRINSIC,
ffesymbol_size (s)));
ffesymbol_set_explicitwhere (s, TRUE);
ffesymbol_reference (s, name, TRUE);
}
ffesymbol_signal_unreported (s);
ffestd_R1208_item (name);
}
void
ffestc_R1208_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_R1208_finish ();
}
void
ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
{
ffebld item;
ffebld labexpr;
ffelab label;
bool ok;
bool ok1;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffebld_op (expr) != FFEBLD_opSUBRREF)
ffestd_R841 (FALSE);
else
{
ok = TRUE;
for (item = ffebld_right (expr);
item != NULL;
item = ffebld_trail (item))
{
if (((labexpr = ffebld_head (item)) != NULL)
&& (ffebld_op (labexpr) == FFEBLD_opLABTOK))
{
ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
&label);
ffelex_token_kill (ffebld_labtok (labexpr));
if (!ok1)
{
label = NULL;
ok = FALSE;
}
ffebld_set_op (labexpr, FFEBLD_opLABTER);
ffebld_set_labter (labexpr, label);
}
}
if (ok)
ffestd_R1212 (expr);
}
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#if FFESTR_F90
void
ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
ffestd_R1213 (dest, source);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#endif
void
ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
ffelexToken final UNUSED, ffestpType type, ffebld kind,
ffelexToken kindt, ffebld len, ffelexToken lent,
ffelexToken recursive, ffelexToken result)
{
ffestw b;
ffesymbol s;
ffesymbol fs;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffelexToken res;
bool separate_result;
assert ((funcname != NULL)
&& (ffelex_token_type (funcname) == FFELEX_typeNAME));
ffestc_check_simple_ ();
if (ffestc_order_iface_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_blocknum_ = 0;
ffesta_is_entry_valid =
(ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateFUNCTION0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_function_);
ffestw_set_name (b, ffelex_token_use (funcname));
if (type == FFESTP_typeNone)
{
ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
}
else
{
ffestc_establish_declstmt_ (type, ffesta_tokens[0],
kind, kindt, len, lent);
ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
}
separate_result = (result != NULL)
&& (ffelex_token_strcmp (funcname, result) != 0);
if (separate_result)
fs = ffesymbol_declare_funcnotresunit (funcname);
else
fs = ffesymbol_declare_funcunit (funcname);
if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_signal_unreported (fs);
ffesymbol_set_info (fs,
ffeinfo_new (ffestc_local_.decl.basic_type,
ffestc_local_.decl.kind_type,
0,
FFEINFO_kindFUNCTION,
FFEINFO_whereLOCAL,
ffestc_local_.decl.size));
ffesymbol_reference (fs, funcname, FALSE);
if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
ffestc_parent_ok_ = FALSE;
else
ffestc_parent_ok_ = TRUE;
}
else
{
if (ffesymbol_kind (fs) != FFEINFO_kindANY)
ffesymbol_error (fs, funcname);
ffestc_parent_ok_ = FALSE;
}
if (ffestc_parent_ok_)
{
ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
ffebld_end_list (&ffestc_local_.dummy.list_bottom);
}
if (result == NULL)
res = funcname;
else
res = result;
s = ffesymbol_declare_funcresult (res);
sa = ffesymbol_attrs (s);
if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
na = FFESYMBOL_attrsetNONE;
else
{
na = FFESYMBOL_attrsRESULT;
if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
{
na |= FFESYMBOL_attrsTYPE;
if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
&& (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
na |= FFESYMBOL_attrsANYLEN;
}
}
if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
{
if (!(na & FFESYMBOL_attrsANY))
ffesymbol_error (s, res);
ffesymbol_set_funcresult (fs, NULL);
ffesymbol_set_funcresult (s, NULL);
ffestc_parent_ok_ = FALSE;
}
else
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_funcresult (fs, s);
ffesymbol_set_funcresult (s, fs);
if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
{
ffesymbol_set_info (s,
ffeinfo_new (ffestc_local_.decl.basic_type,
ffestc_local_.decl.kind_type,
0,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
ffestc_local_.decl.size));
}
}
ffesymbol_signal_unreported (fs);
ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
(recursive != NULL), result, separate_result);
}
void
ffestc_R1221 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_function_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
if ((name != NULL)
&& (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
{
ffebad_start (FFEBAD_UNIT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
ffestc_shriek_function_ (TRUE);
}
void
ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
ffelexToken final, ffelexToken recursive)
{
ffestw b;
ffesymbol s;
assert ((subrname != NULL)
&& (ffelex_token_type (subrname) == FFELEX_typeNAME));
ffestc_check_simple_ ();
if (ffestc_order_iface_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestc_blocknum_ = 0;
ffesta_is_entry_valid
= (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
ffestw_set_blocknum (b, ffestc_blocknum_++);
ffestw_set_shriek (b, ffestc_shriek_subroutine_);
ffestw_set_name (b, ffelex_token_use (subrname));
s = ffesymbol_declare_subrunit (subrname);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindSUBROUTINE,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
ffestc_parent_ok_ = TRUE;
}
else
{
if (ffesymbol_kind (s) != FFEINFO_kindANY)
ffesymbol_error (s, subrname);
ffestc_parent_ok_ = FALSE;
}
if (ffestc_parent_ok_)
{
ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
ffebld_end_list (&ffestc_local_.dummy.list_bottom);
}
ffesymbol_signal_unreported (s);
ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
}
void
ffestc_R1225 (ffelexToken name)
{
ffestc_check_simple_ ();
if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_ ();
if ((name != NULL)
&& (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
{
ffebad_start (FFEBAD_UNIT_WRONG_NAME);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
ffebad_finish ();
}
ffestc_shriek_subroutine_ (TRUE);
}
void
ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
ffelexToken final UNUSED)
{
ffesymbol s;
ffesymbol fs;
ffesymbolAttrs sa;
ffesymbolAttrs na;
bool in_spec;
bool in_func;
assert ((entryname != NULL)
&& (ffelex_token_type (entryname) == FFELEX_typeNAME));
ffestc_check_simple_ ();
if (ffestc_order_entry_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateFUNCTION1:
case FFESTV_stateFUNCTION2:
case FFESTV_stateFUNCTION3:
in_func = TRUE;
in_spec = TRUE;
break;
case FFESTV_stateFUNCTION4:
in_func = TRUE;
in_spec = FALSE;
break;
case FFESTV_stateSUBROUTINE1:
case FFESTV_stateSUBROUTINE2:
case FFESTV_stateSUBROUTINE3:
in_func = FALSE;
in_spec = TRUE;
break;
case FFESTV_stateSUBROUTINE4:
in_func = FALSE;
in_spec = FALSE;
break;
default:
assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
in_func = FALSE;
in_spec = FALSE;
break;
}
if (in_func)
fs = ffesymbol_declare_funcunit (entryname);
else
fs = ffesymbol_declare_subrunit (entryname);
if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
else
{
if (ffesymbol_kind (fs) != FFEINFO_kindANY)
ffesymbol_error (fs, entryname);
}
++ffestc_entry_num_;
ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
if (in_spec)
ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
else
ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
ffebld_end_list (&ffestc_local_.dummy.list_bottom);
if (in_func)
{
s = ffesymbol_declare_funcresult (entryname);
ffesymbol_set_funcresult (fs, s);
ffesymbol_set_funcresult (s, fs);
sa = ffesymbol_attrs (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (!(sa & ~(FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsRESULT;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
{
ffesymbol_error (s, entryname);
ffestc_parent_ok_ = FALSE;
}
else if (na & FFESYMBOL_attrsANY)
{
ffestc_parent_ok_ = FALSE;
}
else
{
ffesymbol_set_attrs (s, na);
if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
{
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
0,
FFEINFO_kindENTITY,
FFEINFO_whereRESULT,
ffesymbol_size (s)));
ffesymbol_resolve_intrin (s);
ffestorag_exec_layout (s);
}
}
if (!in_spec && ffesymbol_is_specable (s))
{
if (!ffeimplic_establish_symbol (s))
ffesymbol_error (s, entryname);
s = ffecom_sym_exec_transition (s);
}
ffesymbol_set_info (fs,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
0,
FFEINFO_kindFUNCTION,
FFEINFO_whereLOCAL,
ffesymbol_size (s)));
ffesymbol_reference (fs, entryname, FALSE);
ffesymbol_signal_unreported (s);
}
else
{
ffesymbol_set_info (fs,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindSUBROUTINE,
FFEINFO_whereLOCAL,
FFETARGET_charactersizeNONE));
}
if (!in_spec)
fs = ffecom_sym_exec_transition (fs);
ffesymbol_signal_unreported (fs);
ffestd_R1226 (fs);
}
void
ffestc_R1227 (ffebld expr, ffelexToken expr_token)
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_notloop_begin_ ();
for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
{
switch (ffestw_state (b))
{
case FFESTV_statePROGRAM4:
case FFESTV_stateSUBROUTINE4:
case FFESTV_stateFUNCTION4:
goto base;
case FFESTV_stateNIL:
assert ("bad state" == NULL);
break;
default:
break;
}
}
base:
switch (ffestw_state (b))
{
case FFESTV_statePROGRAM4:
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_RETURN_IN_MAIN);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
}
if (expr != NULL)
{
ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
expr = NULL;
}
break;
case FFESTV_stateSUBROUTINE4:
break;
case FFESTV_stateFUNCTION4:
if (expr != NULL)
{
ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
expr = NULL;
}
break;
default:
assert ("bad state #2" == NULL);
break;
}
ffestd_R1227 (expr);
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#if FFESTR_F90
void
ffestc_R1228 ()
{
ffestc_check_simple_ ();
if (ffestc_order_contains_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestd_R1228 ();
ffe_terminate_3 ();
ffe_init_3 ();
}
#endif
void
ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
ffelexToken final UNUSED)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffestc_check_start_ ();
if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
assert (name != NULL);
assert (args != NULL);
s = ffesymbol_declare_local (name, FALSE);
sa = ffesymbol_attrs (s);
if (!ffesymbol_is_specable (s))
na = FFESYMBOL_attrsetNONE;
else if (sa & FFESYMBOL_attrsANY)
na = FFESYMBOL_attrsANY;
else if (!(sa & ~FFESYMBOL_attrsTYPE))
na = sa | FFESYMBOL_attrsSFUNC;
else
na = FFESYMBOL_attrsetNONE;
if (na == FFESYMBOL_attrsetNONE)
{
ffesymbol_error (s, name);
ffestc_parent_ok_ = FALSE;
}
else if (na & FFESYMBOL_attrsANY)
ffestc_parent_ok_ = FALSE;
else
{
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
if (!ffeimplic_establish_symbol (s)
|| ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
&& (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
{
ffesymbol_error (s, ffesta_tokens[0]);
ffestc_parent_ok_ = FALSE;
}
else
{
ffesymbol_set_sfexpr (s, ffebld_new_any ());
ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
ffestc_parent_ok_ = TRUE;
}
}
ffe_init_4 ();
if (ffestc_parent_ok_)
{
ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
ffestc_sfdummy_argno_ = 0;
ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
ffebld_end_list (&ffestc_local_.dummy.list_bottom);
}
ffestc_local_.sfunc.symbol = s;
ffestd_R1229_start (name, args);
ffestc_ok_ = TRUE;
}
void
ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
if (ffestc_parent_ok_ && (expr != NULL))
ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
ffeexpr_convert_to_sym (expr,
expr_token,
ffestc_local_.sfunc.symbol,
ffesta_tokens[0]));
ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
ffe_terminate_4 ();
}
void
ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
{
ffestc_check_simple_ ();
ffestc_labeldef_invalid_ ();
ffestd_S3P4 (filename);
}
#if FFESTR_VXT
void
ffestc_V003_start (ffelexToken structure_name)
{
ffestw b;
ffestc_check_start_ ();
if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
ffestc_local_.V003.list_state = 2;
ffestw_set_substate (ffestw_stack_top (), 1);
break;
default:
ffestc_local_.V003.list_state = 0;
if (structure_name == NULL)
{
ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_finish ();
}
break;
}
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateSTRUCTURE);
ffestw_set_blocknum (b, 0);
ffestw_set_shriek (b, ffestc_shriek_structure_);
ffestw_set_substate (b, 0);
ffestd_V003_start (structure_name);
ffestc_ok_ = TRUE;
}
void
ffestc_V003_item (ffelexToken name, ffesttDimList dims)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
if (ffestc_local_.V003.list_state < 2)
{
if (ffestc_local_.V003.list_state == 0)
{
ffestc_local_.V003.list_state = 1;
ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
ffebad_here (0, ffelex_token_where_line (name),
ffelex_token_where_column (name));
ffebad_finish ();
}
return;
}
ffestc_local_.V003.list_state = 3;
if (dims != NULL)
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestd_V003_item (name, dims);
}
void
ffestc_V003_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
if (ffestc_local_.V003.list_state == 2)
{
ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
ffestw_col (ffestw_previous (ffestw_stack_top ())));
ffebad_finish ();
}
ffestd_V003_finish ();
}
void
ffestc_V004 ()
{
ffestc_check_simple_ ();
if (ffestc_order_structure_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 1)
{
ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestc_shriek_structure_ (TRUE);
}
void
ffestc_V009 ()
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_structure_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
ffestw_set_substate (ffestw_stack_top (), 1);
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateUNION);
ffestw_set_blocknum (b, 0);
ffestw_set_shriek (b, ffestc_shriek_union_);
ffestw_set_substate (b, 0);
ffestd_V009 ();
}
void
ffestc_V010 ()
{
ffestc_check_simple_ ();
if (ffestc_order_union_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 2)
{
ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestc_shriek_union_ (TRUE);
}
void
ffestc_V012 ()
{
ffestw b;
ffestc_check_simple_ ();
if (ffestc_order_union_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 2)
ffestw_substate (ffestw_stack_top ())++;
b = ffestw_update (ffestw_push (NULL));
ffestw_set_top_do (b, NULL);
ffestw_set_state (b, FFESTV_stateMAP);
ffestw_set_blocknum (b, 0);
ffestw_set_shriek (b, ffestc_shriek_map_);
ffestw_set_substate (b, 0);
ffestd_V012 ();
}
void
ffestc_V013 ()
{
ffestc_check_simple_ ();
if (ffestc_order_map_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_useless_ ();
if (ffestw_substate (ffestw_stack_top ()) != 1)
{
ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
ffebad_finish ();
}
ffestc_shriek_map_ (TRUE);
}
#endif
void
ffestc_V014_start ()
{
ffestc_check_start_ ();
if (ffestc_order_progspec_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_V014_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_V014_item_object (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_V014_item_object (name);
}
void
ffestc_V014_item_cblock (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_V014_item_cblock (name);
}
void
ffestc_V014_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V014_finish ();
}
#if FFESTR_VXT
void
ffestc_V016_start ()
{
ffestc_check_start_ ();
if (ffestc_order_record_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
switch (ffestw_state (ffestw_stack_top ()))
{
case FFESTV_stateSTRUCTURE:
case FFESTV_stateMAP:
ffestw_set_substate (ffestw_stack_top (), 1);
break;
default:
break;
}
ffestd_V016_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_V016_item_structure (ffelexToken name)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
ffestd_V016_item_structure (name);
}
void
ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
{
ffestc_check_item_ ();
assert (name != NULL);
if (!ffestc_ok_)
return;
if (dims != NULL)
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
ffestd_V016_item_object (name, dims);
}
void
ffestc_V016_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V016_finish ();
}
void
ffestc_V018_start ()
{
ffestvFormat format;
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_branch_
(&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
|| !ffestc_subr_is_format_
(&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
|| !ffestc_subr_is_present_ ("UNIT",
&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
{
ffestc_ok_ = FALSE;
return;
}
format = ffestc_subr_format_
(&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
switch (format)
{
case FFESTV_formatNAMELIST:
case FFESTV_formatASTERISK:
ffebad_start (FFEBAD_CONFLICTING_SPECS);
ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
ffelex_token_where_column (ffesta_tokens[0]));
assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
{
ffebad_here (0, ffelex_token_where_line
(ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
ffelex_token_where_column
(ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
}
else
{
ffebad_here (1, ffelex_token_where_line
(ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
ffelex_token_where_column
(ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
}
ffebad_finish ();
ffestc_ok_ = FALSE;
return;
default:
break;
}
ffestd_V018_start (format);
ffestc_ok_ = TRUE;
}
void
ffestc_V018_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestd_V018_item (expr);
}
void
ffestc_V018_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V018_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_V019_start ()
{
ffestvFormat format;
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_format_
(&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
{
ffestc_ok_ = FALSE;
return;
}
format = ffestc_subr_format_
(&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
ffestd_V019_start (format);
ffestc_ok_ = TRUE;
}
void
ffestc_V019_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if (ffestc_namelist_ != 0)
{
if (ffestc_namelist_ == 1)
{
ffestc_namelist_ = 2;
ffebad_start (FFEBAD_NAMELIST_ITEMS);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
}
return;
}
ffestd_V019_item (expr);
}
void
ffestc_V019_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V019_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#endif
void
ffestc_V020_start ()
{
ffestvFormat format;
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_format_
(&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
{
ffestc_ok_ = FALSE;
return;
}
format = ffestc_subr_format_
(&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
ffestd_V020_start (format);
ffestc_ok_ = TRUE;
}
void
ffestc_V020_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
if (ffestc_namelist_ != 0)
{
if (ffestc_namelist_ == 1)
{
ffestc_namelist_ = 2;
ffebad_start (FFEBAD_NAMELIST_ITEMS);
ffebad_here (0, ffelex_token_where_line (expr_token),
ffelex_token_where_column (expr_token));
ffebad_finish ();
}
return;
}
ffestd_V020_item (expr);
}
void
ffestc_V020_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V020_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#if FFESTR_VXT
void
ffestc_V021 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
ffestd_V021 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_V022 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
ffestd_V022 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_V023_start ()
{
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_branch_
(&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
{
ffestc_ok_ = FALSE;
return;
}
ffestd_V023_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_V023_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestd_V023_item (expr);
}
void
ffestc_V023_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V023_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_V024_start ()
{
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
if (!ffestc_subr_is_branch_
(&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
{
ffestc_ok_ = FALSE;
return;
}
ffestd_V024_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_V024_item (ffebld expr, ffelexToken expr_token)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestd_V024_item (expr);
}
void
ffestc_V024_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V024_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_V025_start ()
{
ffestc_check_start_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_branch_begin_ ();
ffestd_V025_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestd_V025_item (u, m, n, asv);
}
void
ffestc_V025_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V025_finish ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
void
ffestc_V026 ()
{
ffestc_check_simple_ ();
if (ffestc_order_actionif_ () != FFESTC_orderOK_)
return;
ffestc_labeldef_branch_begin_ ();
if (ffestc_subr_is_branch_
(&ffestp_file.find.find_spec[FFESTP_findixERR])
&& ffestc_subr_is_present_ ("UNIT",
&ffestp_file.find.find_spec[FFESTP_findixUNIT])
&& ffestc_subr_is_present_ ("REC",
&ffestp_file.find.find_spec[FFESTP_findixREC]))
ffestd_V026 ();
if (ffestc_shriek_after1_ != NULL)
(*ffestc_shriek_after1_) (TRUE);
ffestc_labeldef_branch_end_ ();
}
#endif
void
ffestc_V027_start ()
{
ffestc_check_start_ ();
if (ffestc_order_parameter_ () != FFESTC_orderOK_)
{
ffestc_ok_ = FALSE;
return;
}
ffestc_labeldef_useless_ ();
ffestd_V027_start ();
ffestc_ok_ = TRUE;
}
void
ffestc_V027_item (ffelexToken dest_token, ffebld source,
ffelexToken source_token UNUSED)
{
ffestc_check_item_ ();
if (!ffestc_ok_)
return;
ffestd_V027_item (dest_token, source);
}
void
ffestc_V027_finish ()
{
ffestc_check_finish_ ();
if (!ffestc_ok_)
return;
ffestd_V027_finish ();
}
void
ffestc_any ()
{
ffestc_check_simple_ ();
ffestc_order_any_ ();
ffestc_labeldef_any_ ();
if (ffestc_shriek_after1_ == NULL)
return;
ffestd_any ();
(*ffestc_shriek_after1_) (TRUE);
}