#include "proj.h"
#include "expr.h"
#include "bad.h"
#include "bld.h"
#include "com.h"
#include "global.h"
#include "implic.h"
#include "intrin.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
#include "src.h"
#include "st.h"
#include "symbol.h"
#include "str.h"
#include "target.h"
#include "where.h"
#include "real.h"
typedef enum
{
FFEEXPR_exprtypeUNKNOWN_,
FFEEXPR_exprtypeOPERAND_,
FFEEXPR_exprtypeUNARY_,
FFEEXPR_exprtypeBINARY_,
FFEEXPR_exprtype_
} ffeexprExprtype_;
typedef enum
{
FFEEXPR_operatorPOWER_,
FFEEXPR_operatorMULTIPLY_,
FFEEXPR_operatorDIVIDE_,
FFEEXPR_operatorADD_,
FFEEXPR_operatorSUBTRACT_,
FFEEXPR_operatorCONCATENATE_,
FFEEXPR_operatorLT_,
FFEEXPR_operatorLE_,
FFEEXPR_operatorEQ_,
FFEEXPR_operatorNE_,
FFEEXPR_operatorGT_,
FFEEXPR_operatorGE_,
FFEEXPR_operatorNOT_,
FFEEXPR_operatorAND_,
FFEEXPR_operatorOR_,
FFEEXPR_operatorXOR_,
FFEEXPR_operatorEQV_,
FFEEXPR_operatorNEQV_,
FFEEXPR_operator_
} ffeexprOperator_;
typedef enum
{
FFEEXPR_operatorprecedenceHIGHEST_ = 1,
FFEEXPR_operatorprecedencePOWER_ = 1,
FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
FFEEXPR_operatorprecedenceDIVIDE_ = 2,
FFEEXPR_operatorprecedenceADD_ = 3,
FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
FFEEXPR_operatorprecedenceLOWARITH_ = 3,
FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
FFEEXPR_operatorprecedenceLT_ = 4,
FFEEXPR_operatorprecedenceLE_ = 4,
FFEEXPR_operatorprecedenceEQ_ = 4,
FFEEXPR_operatorprecedenceNE_ = 4,
FFEEXPR_operatorprecedenceGT_ = 4,
FFEEXPR_operatorprecedenceGE_ = 4,
FFEEXPR_operatorprecedenceNOT_ = 5,
FFEEXPR_operatorprecedenceAND_ = 6,
FFEEXPR_operatorprecedenceOR_ = 7,
FFEEXPR_operatorprecedenceXOR_ = 8,
FFEEXPR_operatorprecedenceEQV_ = 8,
FFEEXPR_operatorprecedenceNEQV_ = 8,
FFEEXPR_operatorprecedenceLOWEST_ = 8,
FFEEXPR_operatorprecedence_
} ffeexprOperatorPrecedence_;
#define FFEEXPR_operatorassociativityL2R_ TRUE
#define FFEEXPR_operatorassociativityR2L_ FALSE
#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
typedef enum
{
FFEEXPR_parentypeFUNCTION_,
FFEEXPR_parentypeSUBROUTINE_,
FFEEXPR_parentypeARRAY_,
FFEEXPR_parentypeSUBSTRING_,
FFEEXPR_parentypeFUNSUBSTR_,
FFEEXPR_parentypeEQUIVALENCE_,
FFEEXPR_parentypeANY_,
FFEEXPR_parentype_
} ffeexprParenType_;
typedef enum
{
FFEEXPR_percentNONE_,
FFEEXPR_percentLOC_,
FFEEXPR_percentVAL_,
FFEEXPR_percentREF_,
FFEEXPR_percentDESCR_,
FFEEXPR_percent_
} ffeexprPercent_;
typedef struct _ffeexpr_expr_ *ffeexprExpr_;
typedef bool ffeexprOperatorAssociativity_;
typedef struct _ffeexpr_stack_ *ffeexprStack_;
struct _ffeexpr_expr_
{
ffeexprExpr_ previous;
ffelexToken token;
ffeexprExprtype_ type;
union
{
struct
{
ffeexprOperator_ op;
ffeexprOperatorPrecedence_ prec;
ffeexprOperatorAssociativity_ as;
}
operator;
ffebld operand;
}
u;
};
struct _ffeexpr_stack_
{
ffeexprStack_ previous;
mallocPool pool;
ffeexprContext context;
ffeexprCallback callback;
ffelexToken first_token;
ffeexprExpr_ exprstack;
ffelexToken tokens[10];
ffebld expr;
ffebld bound_list;
ffebldListBottom bottom;
ffeinfoRank rank;
bool constant;
bool immediate;
ffebld next_dummy;
ffebldListLength num_args;
bool is_rhs;
ffeexprPercent_ percent;
};
struct _ffeexpr_find_
{
ffelexToken t;
ffelexHandler after;
int level;
};
static ffeexprStack_ ffeexpr_stack_;
static ffelexToken ffeexpr_tokens_[10];
static ffestrOther ffeexpr_current_dotdot_;
static long ffeexpr_hollerith_count_;
static int ffeexpr_level_;
static bool ffeexpr_is_substr_ok_;
static struct _ffeexpr_find_ ffeexpr_find_;
static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
ffebld expr, ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
ffebld expr, ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
ffebld dovar, ffelexToken dovar_t);
static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
static ffeexprExpr_ ffeexpr_expr_new_ (void);
static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
static bool ffeexpr_isdigits_ (const char *p);
static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
static void ffeexpr_reduce_ (void);
static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
ffeexprExpr_ r);
static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
ffeexprExpr_ r);
static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
ffelexHandler after);
static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
static ffelexHandler ffeexpr_finished_ (ffelexToken t);
static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
ffelexToken t);
static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
ffelexToken exponent_sign, ffelexToken exponent_digits);
static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
bool maybe_intrin,
ffeexprParenType_ *paren_type);
static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
ffebld
ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffetargetCharacterSize sz;
ffetargetCharacterSize sz2;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
sz = FFETARGET_charactersizeNONE;
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_integer1_integer2
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_integer1_integer3
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_integer1_integer4
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER1/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer1_real1
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer1_real2
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer1_real3
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer1_real4
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER1/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer1_complex1
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer1_complex2
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer1_complex3
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer1_complex4
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_integer1_logical1
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_integer1_logical2
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_integer1_logical3
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_integer1_logical4
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_integer1_character1
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_integer1_hollerith
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_integer1_typeless
(ffebld_cu_ptr_integer1 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("INTEGER1 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_integer2_integer1
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_integer2_integer3
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_integer2_integer4
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER2/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer2_real1
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer2_real2
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer2_real3
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer2_real4
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER2/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer2_complex1
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer2_complex2
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer2_complex3
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer2_complex4
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_integer2_logical1
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_integer2_logical2
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_integer2_logical3
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_integer2_logical4
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_integer2_character1
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_integer2_hollerith
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_integer2_typeless
(ffebld_cu_ptr_integer2 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("INTEGER2 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_integer3_integer1
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_integer3_integer2
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_integer3_integer4
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER3/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer3_real1
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer3_real2
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer3_real3
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer3_real4
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER3/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer3_complex1
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer3_complex2
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer3_complex3
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer3_complex4
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_integer3_logical1
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_integer3_logical2
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_integer3_logical3
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_integer3_logical4
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_integer3_character1
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_integer3_hollerith
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_integer3_typeless
(ffebld_cu_ptr_integer3 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("INTEGER3 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_integer4_integer1
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_integer4_integer2
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_integer4_integer3
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER4/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer4_real1
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer4_real2
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer4_real3
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer4_real4
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER4/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_integer4_complex1
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_integer4_complex2
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_integer4_complex3
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_integer4_complex4
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_integer4_logical1
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_integer4_logical2
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_integer4_logical3
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_integer4_logical4
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_integer4_character1
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_integer4_hollerith
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_integer4_typeless
(ffebld_cu_ptr_integer4 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("INTEGER4 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
sz = FFETARGET_charactersizeNONE;
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_logical1_logical2
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_logical1_logical3
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_logical1_logical4
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_logical1_integer1
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_logical1_integer2
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_logical1_integer3
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_logical1_integer4
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_logical1_character1
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_logical1_hollerith
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_logical1_typeless
(ffebld_cu_ptr_logical1 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("LOGICAL1 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_logical2_logical1
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_logical2_logical3
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_logical2_logical4
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_logical2_integer1
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_logical2_integer2
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_logical2_integer3
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_logical2_integer4
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_logical2_character1
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_logical2_hollerith
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_logical2_typeless
(ffebld_cu_ptr_logical2 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("LOGICAL2 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_logical3_logical1
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_logical3_logical2
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_convert_logical3_logical4
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_logical3_integer1
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_logical3_integer2
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_logical3_integer3
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_logical3_integer4
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_logical3_character1
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_logical3_hollerith
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_logical3_typeless
(ffebld_cu_ptr_logical3 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("LOGICAL3 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_convert_logical4_logical1
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_convert_logical4_logical2
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_convert_logical4_logical3
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical3 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_logical4_integer1
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_logical4_integer2
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_logical4_integer3
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_logical4_integer4
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_logical4_character1
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_logical4_hollerith
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_logical4_typeless
(ffebld_cu_ptr_logical4 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("LOGICAL4 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
sz = FFETARGET_charactersizeNONE;
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_real1_integer1
(ffebld_cu_ptr_real1 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_real1_integer2
(ffebld_cu_ptr_real1 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_real1_integer3
(ffebld_cu_ptr_real1 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_real1_integer4
(ffebld_cu_ptr_real1 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL1/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real1_real2
(ffebld_cu_ptr_real1 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real1_real3
(ffebld_cu_ptr_real1 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real1_real4
(ffebld_cu_ptr_real1 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL1/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real1_complex1
(ffebld_cu_ptr_real1 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real1_complex2
(ffebld_cu_ptr_real1 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real1_complex3
(ffebld_cu_ptr_real1 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real1_complex4
(ffebld_cu_ptr_real1 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL1/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_real1_character1
(ffebld_cu_ptr_real1 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_real1_hollerith
(ffebld_cu_ptr_real1 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_real1_typeless
(ffebld_cu_ptr_real1 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("REAL1 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_real1_val
(ffebld_cu_val_real1 (u)), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_real2_integer1
(ffebld_cu_ptr_real2 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_real2_integer2
(ffebld_cu_ptr_real2 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_real2_integer3
(ffebld_cu_ptr_real2 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_real2_integer4
(ffebld_cu_ptr_real2 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL2/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real2_real1
(ffebld_cu_ptr_real2 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real2_real3
(ffebld_cu_ptr_real2 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real2_real4
(ffebld_cu_ptr_real2 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL2/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real2_complex1
(ffebld_cu_ptr_real2 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real2_complex2
(ffebld_cu_ptr_real2 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real2_complex3
(ffebld_cu_ptr_real2 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real2_complex4
(ffebld_cu_ptr_real2 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL2/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_real2_character1
(ffebld_cu_ptr_real2 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_real2_hollerith
(ffebld_cu_ptr_real2 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_real2_typeless
(ffebld_cu_ptr_real2 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("REAL2 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_real2_val
(ffebld_cu_val_real2 (u)), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_real3_integer1
(ffebld_cu_ptr_real3 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_real3_integer2
(ffebld_cu_ptr_real3 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_real3_integer3
(ffebld_cu_ptr_real3 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_real3_integer4
(ffebld_cu_ptr_real3 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL3/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real3_real1
(ffebld_cu_ptr_real3 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real3_real2
(ffebld_cu_ptr_real3 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real3_real4
(ffebld_cu_ptr_real3 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL3/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real3_complex1
(ffebld_cu_ptr_real3 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real3_complex2
(ffebld_cu_ptr_real3 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real3_complex3
(ffebld_cu_ptr_real3 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real3_complex4
(ffebld_cu_ptr_real3 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL3/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_real3_character1
(ffebld_cu_ptr_real3 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_real3_hollerith
(ffebld_cu_ptr_real3 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_real3_typeless
(ffebld_cu_ptr_real3 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("REAL3 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_real3_val
(ffebld_cu_val_real3 (u)), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_real4_integer1
(ffebld_cu_ptr_real4 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_real4_integer2
(ffebld_cu_ptr_real4 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_real4_integer3
(ffebld_cu_ptr_real4 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_real4_integer4
(ffebld_cu_ptr_real4 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL4/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real4_real1
(ffebld_cu_ptr_real4 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real4_real2
(ffebld_cu_ptr_real4 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real4_real3
(ffebld_cu_ptr_real4 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL4/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_real4_complex1
(ffebld_cu_ptr_real4 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_real4_complex2
(ffebld_cu_ptr_real4 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_real4_complex3
(ffebld_cu_ptr_real4 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_real4_complex4
(ffebld_cu_ptr_real4 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("REAL4/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_real4_character1
(ffebld_cu_ptr_real4 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_real4_hollerith
(ffebld_cu_ptr_real4 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_real4_typeless
(ffebld_cu_ptr_real4 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("REAL4 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_real4_val
(ffebld_cu_val_real4 (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
sz = FFETARGET_charactersizeNONE;
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_complex1_integer1
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_complex1_integer2
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_complex1_integer3
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_complex1_integer4
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex1_real1
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex1_real2
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex1_real3
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex1_real4
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX1/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex1_complex2
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex1_complex3
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex1_complex4
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_complex1_character1
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_complex1_hollerith
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_complex1_typeless
(ffebld_cu_ptr_complex1 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("COMPLEX1 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complex1_val
(ffebld_cu_val_complex1 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_complex2_integer1
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_complex2_integer2
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_complex2_integer3
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_complex2_integer4
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex2_real1
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex2_real2
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex2_real3
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex2_real4
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX2/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex2_complex1
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex2_complex3
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex2_complex4
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_complex2_character1
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_complex2_hollerith
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_complex2_typeless
(ffebld_cu_ptr_complex2 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("COMPLEX2 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complex2_val
(ffebld_cu_val_complex2 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_complex3_integer1
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_complex3_integer2
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_complex3_integer3
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_complex3_integer4
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex3_real1
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex3_real2
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex3_real3
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex3_real4
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX3/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex3_complex1
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex3_complex2
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex3_complex4
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_complex3_character1
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_complex3_hollerith
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_complex3_typeless
(ffebld_cu_ptr_complex3 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("COMPLEX3 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complex3_val
(ffebld_cu_val_complex3 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_convert_complex4_integer1
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_integer1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_convert_complex4_integer2
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_integer2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_convert_complex4_integer3
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_integer3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_convert_complex4_integer4
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_integer4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex4_real1
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_real1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex4_real2
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_real2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex4_real3
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_real3 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_convert_complex4_real4
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_real4 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX4/REAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_convert_complex4_complex1
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex1 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_convert_complex4_complex2
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex2 (ffebld_conter (l)));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_convert_complex4_complex3
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex3 (ffebld_conter (l)));
break;
#endif
default:
assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
error = ffetarget_convert_complex4_character1
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_character1 (ffebld_conter (l)));
break;
case FFEINFO_basictypeHOLLERITH:
error = ffetarget_convert_complex4_hollerith
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_hollerith (ffebld_conter (l)));
break;
case FFEINFO_basictypeTYPELESS:
error = ffetarget_convert_complex4_typeless
(ffebld_cu_ptr_complex4 (u),
ffebld_constant_typeless (ffebld_conter (l)));
break;
default:
assert ("COMPLEX4 bad type" == NULL);
break;
}
if (error == FFEBAD_NOCANDO)
return expr;
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complex4_val
(ffebld_cu_val_complex4 (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
return expr;
kt = ffeinfo_kindtype (ffebld_info (expr));
switch (kt)
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
switch (ffeinfo_basictype (ffebld_info (l)))
{
case FFEINFO_basictypeCHARACTER:
if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
return expr;
assert (kt == ffeinfo_kindtype (ffebld_info (l)));
assert (sz2 == ffetarget_length_character1
(ffebld_constant_character1
(ffebld_conter (l))));
error
= ffetarget_convert_character1_character1
(ffebld_cu_ptr_character1 (u), sz,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error
= ffetarget_convert_character1_integer1
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error
= ffetarget_convert_character1_integer2
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error
= ffetarget_convert_character1_integer3
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error
= ffetarget_convert_character1_integer4
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
default:
assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (ffeinfo_kindtype (ffebld_info (l)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error
= ffetarget_convert_character1_logical1
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_logical1 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error
= ffetarget_convert_character1_logical2
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_logical2 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error
= ffetarget_convert_character1_logical3
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_logical3 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error
= ffetarget_convert_character1_logical4
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_logical4 (ffebld_conter (l)),
ffebld_constant_pool ());
break;
#endif
default:
assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeHOLLERITH:
error
= ffetarget_convert_character1_hollerith
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_hollerith (ffebld_conter (l)),
ffebld_constant_pool ());
break;
case FFEINFO_basictypeTYPELESS:
error
= ffetarget_convert_character1_typeless
(ffebld_cu_ptr_character1 (u),
sz,
ffebld_constant_typeless (ffebld_conter (l)),
ffebld_constant_pool ());
break;
default:
assert ("CHARACTER1 bad type" == NULL);
}
expr
= ffebld_new_conter_with_orig
(ffebld_constant_new_character1_val
(ffebld_cu_val_character1 (u)),
expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
sz));
if ((error != FFEBAD)
&& ffebad_start (error))
{
assert (t != NULL);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
{
ffebld r;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffetargetCharacterSize len;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
r = ffebld_left (expr);
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
bt = ffeinfo_basictype (ffebld_info (r));
kt = ffeinfo_kindtype (ffebld_info (r));
len = ffebld_size (r);
expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
expr);
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
len));
return expr;
}
ffebld
ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
{
ffebld r;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffetargetCharacterSize len;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
r = ffebld_left (expr);
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
bt = ffeinfo_basictype (ffebld_info (r));
kt = ffeinfo_kindtype (ffebld_info (r));
len = ffebld_size (r);
expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
expr);
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
len));
return expr;
}
ffebld
ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
r = ffebld_left (expr);
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
(ffebld_cu_val_real1 (u)), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
(ffebld_cu_val_real2 (u)), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
(ffebld_cu_val_real3 (u)), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
(ffebld_cu_val_real4 (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
(ffebld_cu_val_complex1 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
(ffebld_cu_val_complex2 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
(ffebld_cu_val_complex3 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
(ffebld_cu_val_complex4 (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_not (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
r = ffebld_left (expr);
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_add (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
(ffebld_cu_val_real1 (u)), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
(ffebld_cu_val_real2 (u)), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
(ffebld_cu_val_real3 (u)), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
(ffebld_cu_val_real4 (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex1 (ffebld_conter (l)),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
(ffebld_cu_val_complex1 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex2 (ffebld_conter (l)),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
(ffebld_cu_val_complex2 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex3 (ffebld_conter (l)),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
(ffebld_cu_val_complex3 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex4 (ffebld_conter (l)),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
(ffebld_cu_val_complex4 (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
(ffebld_cu_val_real1 (u)), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
(ffebld_cu_val_real2 (u)), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
(ffebld_cu_val_real3 (u)), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
(ffebld_cu_val_real4 (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex1 (ffebld_conter (l)),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
(ffebld_cu_val_complex1 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex2 (ffebld_conter (l)),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
(ffebld_cu_val_complex2 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex3 (ffebld_conter (l)),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
(ffebld_cu_val_complex3 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex4 (ffebld_conter (l)),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
(ffebld_cu_val_complex4 (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
(ffebld_cu_val_real1 (u)), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
(ffebld_cu_val_real2 (u)), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
(ffebld_cu_val_real3 (u)), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
(ffebld_cu_val_real4 (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex1 (ffebld_conter (l)),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
(ffebld_cu_val_complex1 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex2 (ffebld_conter (l)),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
(ffebld_cu_val_complex2 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex3 (ffebld_conter (l)),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
(ffebld_cu_val_complex3 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex4 (ffebld_conter (l)),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
(ffebld_cu_val_complex4 (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
(ffebld_cu_val_real1 (u)), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
(ffebld_cu_val_real2 (u)), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
(ffebld_cu_val_real3 (u)), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
(ffebld_cu_val_real4 (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
ffebld_constant_complex1 (ffebld_conter (l)),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
(ffebld_cu_val_complex1 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
ffebld_constant_complex2 (ffebld_conter (l)),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
(ffebld_cu_val_complex2 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex3 (ffebld_conter (l)),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
(ffebld_cu_val_complex3 (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
ffebld_constant_complex4 (ffebld_conter (l)),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
(ffebld_cu_val_complex4 (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_power (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
|| (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
case FFEINFO_kindtypeINTEGERDEFAULT:
error = ffetarget_power_integerdefault_integerdefault
(ffebld_cu_ptr_integerdefault (u),
ffebld_constant_integerdefault (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_integerdefault_val
(ffebld_cu_val_integerdefault (u)), expr);
break;
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
case FFEINFO_kindtypeREALDEFAULT:
error = ffetarget_power_realdefault_integerdefault
(ffebld_cu_ptr_realdefault (u),
ffebld_constant_realdefault (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_realdefault_val
(ffebld_cu_val_realdefault (u)), expr);
break;
case FFEINFO_kindtypeREALDOUBLE:
error = ffetarget_power_realdouble_integerdefault
(ffebld_cu_ptr_realdouble (u),
ffebld_constant_realdouble (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_realdouble_val
(ffebld_cu_val_realdouble (u)), expr);
break;
#if FFETARGET_okREALQUAD
case FFEINFO_kindtypeREALQUAD:
error = ffetarget_power_realquad_integerdefault
(ffebld_cu_ptr_realquad (u),
ffebld_constant_realquad (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_realquad_val
(ffebld_cu_val_realquad (u)), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
case FFEINFO_kindtypeREALDEFAULT:
error = ffetarget_power_complexdefault_integerdefault
(ffebld_cu_ptr_complexdefault (u),
ffebld_constant_complexdefault (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complexdefault_val
(ffebld_cu_val_complexdefault (u)), expr);
break;
#if FFETARGET_okCOMPLEXDOUBLE
case FFEINFO_kindtypeREALDOUBLE:
error = ffetarget_power_complexdouble_integerdefault
(ffebld_cu_ptr_complexdouble (u),
ffebld_constant_complexdouble (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complexdouble_val
(ffebld_cu_val_complexdouble (u)), expr);
break;
#endif
#if FFETARGET_okCOMPLEXQUAD
case FFEINFO_kindtypeREALQUAD:
error = ffetarget_power_complexquad_integerdefault
(ffebld_cu_ptr_complexquad (u),
ffebld_constant_complexquad (ffebld_conter (l)),
ffebld_constant_integerdefault (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_complexquad_val
(ffebld_cu_val_complexquad (u)), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoKindtype kt;
ffetargetCharacterSize len;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeCHARACTER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)),
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
(ffebld_cu_val_character1 (u)), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)),
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
(ffebld_cu_val_character2 (u)), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)),
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
(ffebld_cu_val_character3 (u)), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)),
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
(ffebld_cu_val_character4 (u)), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeCHARACTER,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
len));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
bool val;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_eq_integer1 (&val,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_eq_integer2 (&val,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_eq_integer3 (&val,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_eq_integer4 (&val,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_eq_real1 (&val,
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_eq_real2 (&val,
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_eq_real3 (&val,
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_eq_real4 (&val,
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_eq_complex1 (&val,
ffebld_constant_complex1 (ffebld_conter (l)),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_eq_complex2 (&val,
ffebld_constant_complex2 (ffebld_conter (l)),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_eq_complex3 (&val,
ffebld_constant_complex3 (ffebld_conter (l)),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_eq_complex4 (&val,
ffebld_constant_complex4 (ffebld_conter (l)),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_eq_character1 (&val,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_eq_character2 (&val,
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_eq_character3 (&val,
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_eq_character4 (&val,
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
bool val;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_ne_integer1 (&val,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_ne_integer2 (&val,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_ne_integer3 (&val,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_ne_integer4 (&val,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_ne_real1 (&val,
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_ne_real2 (&val,
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_ne_real3 (&val,
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_ne_real4 (&val,
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCOMPLEX:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
error = ffetarget_ne_complex1 (&val,
ffebld_constant_complex1 (ffebld_conter (l)),
ffebld_constant_complex1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
error = ffetarget_ne_complex2 (&val,
ffebld_constant_complex2 (ffebld_conter (l)),
ffebld_constant_complex2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
error = ffetarget_ne_complex3 (&val,
ffebld_constant_complex3 (ffebld_conter (l)),
ffebld_constant_complex3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
error = ffetarget_ne_complex4 (&val,
ffebld_constant_complex4 (ffebld_conter (l)),
ffebld_constant_complex4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad complex kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_ne_character1 (&val,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_ne_character2 (&val,
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_ne_character3 (&val,
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_ne_character4 (&val,
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
bool val;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_ge_integer1 (&val,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_ge_integer2 (&val,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_ge_integer3 (&val,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_ge_integer4 (&val,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_ge_real1 (&val,
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_ge_real2 (&val,
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_ge_real3 (&val,
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_ge_real4 (&val,
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_ge_character1 (&val,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_ge_character2 (&val,
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_ge_character3 (&val,
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_ge_character4 (&val,
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
bool val;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_gt_integer1 (&val,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_gt_integer2 (&val,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_gt_integer3 (&val,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_gt_integer4 (&val,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_gt_real1 (&val,
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_gt_real2 (&val,
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_gt_real3 (&val,
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_gt_real4 (&val,
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_gt_character1 (&val,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_gt_character2 (&val,
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_gt_character3 (&val,
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_gt_character4 (&val,
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_le (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
bool val;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_le_integer1 (&val,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_le_integer2 (&val,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_le_integer3 (&val,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_le_integer4 (&val,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_le_real1 (&val,
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_le_real2 (&val,
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_le_real3 (&val,
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_le_real4 (&val,
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_le_character1 (&val,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_le_character2 (&val,
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_le_character3 (&val,
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_le_character4 (&val,
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
bool val;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_lt_integer1 (&val,
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_lt_integer2 (&val,
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_lt_integer3 (&val,
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_lt_integer4 (&val,
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeREAL:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okREAL1
case FFEINFO_kindtypeREAL1:
error = ffetarget_lt_real1 (&val,
ffebld_constant_real1 (ffebld_conter (l)),
ffebld_constant_real1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL2
case FFEINFO_kindtypeREAL2:
error = ffetarget_lt_real2 (&val,
ffebld_constant_real2 (ffebld_conter (l)),
ffebld_constant_real2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL3
case FFEINFO_kindtypeREAL3:
error = ffetarget_lt_real3 (&val,
ffebld_constant_real3 (ffebld_conter (l)),
ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okREAL4
case FFEINFO_kindtypeREAL4:
error = ffetarget_lt_real4 (&val,
ffebld_constant_real4 (ffebld_conter (l)),
ffebld_constant_real4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad real kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeCHARACTER:
switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_lt_character1 (&val,
ffebld_constant_character1 (ffebld_conter (l)),
ffebld_constant_character1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_lt_character2 (&val,
ffebld_constant_character2 (ffebld_conter (l)),
ffebld_constant_character2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_lt_character3 (&val,
ffebld_constant_character3 (ffebld_conter (l)),
ffebld_constant_character3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_lt_character4 (&val,
ffebld_constant_character4 (ffebld_conter (l)),
ffebld_constant_character4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_and (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical1 (ffebld_conter (l)),
ffebld_constant_logical1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical2 (ffebld_conter (l)),
ffebld_constant_logical2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical3 (ffebld_conter (l)),
ffebld_constant_logical3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical4 (ffebld_conter (l)),
ffebld_constant_logical4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_or (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical1 (ffebld_conter (l)),
ffebld_constant_logical1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical2 (ffebld_conter (l)),
ffebld_constant_logical2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical3 (ffebld_conter (l)),
ffebld_constant_logical3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical4 (ffebld_conter (l)),
ffebld_constant_logical4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical1 (ffebld_conter (l)),
ffebld_constant_logical1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical2 (ffebld_conter (l)),
ffebld_constant_logical2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical3 (ffebld_conter (l)),
ffebld_constant_logical3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical4 (ffebld_conter (l)),
ffebld_constant_logical4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical1 (ffebld_conter (l)),
ffebld_constant_logical1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical2 (ffebld_conter (l)),
ffebld_constant_logical2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical3 (ffebld_conter (l)),
ffebld_constant_logical3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical4 (ffebld_conter (l)),
ffebld_constant_logical4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebldConstantUnion u;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
if (ffebld_op (r) != FFEBLD_opCONTER)
return expr;
switch (bt = ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeINTEGER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
ffebld_constant_integer1 (ffebld_conter (l)),
ffebld_constant_integer1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
(ffebld_cu_val_integer1 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
ffebld_constant_integer2 (ffebld_conter (l)),
ffebld_constant_integer2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
(ffebld_cu_val_integer2 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
ffebld_constant_integer3 (ffebld_conter (l)),
ffebld_constant_integer3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
(ffebld_cu_val_integer3 (u)), expr);
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
ffebld_constant_integer4 (ffebld_conter (l)),
ffebld_constant_integer4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
(ffebld_cu_val_integer4 (u)), expr);
break;
#endif
default:
assert ("bad integer kind type" == NULL);
break;
}
break;
case FFEINFO_basictypeLOGICAL:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okLOGICAL1
case FFEINFO_kindtypeLOGICAL1:
error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
ffebld_constant_logical1 (ffebld_conter (l)),
ffebld_constant_logical1 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
(ffebld_cu_val_logical1 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL2
case FFEINFO_kindtypeLOGICAL2:
error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
ffebld_constant_logical2 (ffebld_conter (l)),
ffebld_constant_logical2 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
(ffebld_cu_val_logical2 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL3
case FFEINFO_kindtypeLOGICAL3:
error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
ffebld_constant_logical3 (ffebld_conter (l)),
ffebld_constant_logical3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
(ffebld_cu_val_logical3 (u)), expr);
break;
#endif
#if FFETARGET_okLOGICAL4
case FFEINFO_kindtypeLOGICAL4:
error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
ffebld_constant_logical4 (ffebld_conter (l)),
ffebld_constant_logical4 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
(ffebld_cu_val_logical4 (u)), expr);
break;
#endif
default:
assert ("bad logical kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
{
ffebld r;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffetargetCharacterSize len;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
return expr;
switch (ffebld_op (r))
{
case FFEBLD_opCONTER:
break;
case FFEBLD_opANY:
return r;
default:
return expr;
}
bt = ffeinfo_basictype (ffebld_info (r));
kt = ffeinfo_kindtype (ffebld_info (r));
len = ffebld_size (r);
expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
expr);
ffebld_set_info (expr, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
len));
return expr;
}
ffebld
ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
{
return expr;
}
ffebld
ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
{
return expr;
}
ffebld
ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
{
ffebad error = FFEBAD;
ffebld l;
ffebld r;
ffebld start;
ffebld stop;
ffebldConstantUnion u;
ffeinfoKindtype kt;
ffetargetCharacterSize len;
ffetargetIntegerDefault first;
ffetargetIntegerDefault last;
if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
return expr;
l = ffebld_left (expr);
r = ffebld_right (expr);
if (ffebld_op (l) != FFEBLD_opCONTER)
return expr;
kt = ffeinfo_kindtype (ffebld_info (l));
len = ffebld_size (l);
start = ffebld_head (r);
stop = ffebld_head (ffebld_trail (r));
if (start == NULL)
first = 1;
else
{
if ((ffebld_op (start) != FFEBLD_opCONTER)
|| (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
|| (ffeinfo_kindtype (ffebld_info (start))
!= FFEINFO_kindtypeINTEGERDEFAULT))
return expr;
first = ffebld_constant_integerdefault (ffebld_conter (start));
}
if (stop == NULL)
last = len;
else
{
if ((ffebld_op (stop) != FFEBLD_opCONTER)
|| (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
|| (ffeinfo_kindtype (ffebld_info (stop))
!= FFEINFO_kindtypeINTEGERDEFAULT))
return expr;
last = ffebld_constant_integerdefault (ffebld_conter (stop));
}
if (first <= 0)
first = 1;
if (last < first)
last = first + len - 1;
if ((first == 1) && (last == len))
{
expr = ffebld_new_conter_with_orig (ffebld_constant_copy
(ffebld_conter (l)), expr);
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeCHARACTER,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
len));
return expr;
}
switch (ffeinfo_basictype (ffebld_info (expr)))
{
case FFEINFO_basictypeANY:
return expr;
case FFEINFO_basictypeCHARACTER:
switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
{
#if FFETARGET_okCHARACTER1
case FFEINFO_kindtypeCHARACTER1:
error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
ffebld_constant_character1 (ffebld_conter (l)), first, last,
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
(ffebld_cu_val_character1 (u)), expr);
break;
#endif
#if FFETARGET_okCHARACTER2
case FFEINFO_kindtypeCHARACTER2:
error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
ffebld_constant_character2 (ffebld_conter (l)), first, last,
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
(ffebld_cu_val_character2 (u)), expr);
break;
#endif
#if FFETARGET_okCHARACTER3
case FFEINFO_kindtypeCHARACTER3:
error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
ffebld_constant_character3 (ffebld_conter (l)), first, last,
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
(ffebld_cu_val_character3 (u)), expr);
break;
#endif
#if FFETARGET_okCHARACTER4
case FFEINFO_kindtypeCHARACTER4:
error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
ffebld_constant_character4 (ffebld_conter (l)), first, last,
ffebld_constant_pool (), &len);
expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
(ffebld_cu_val_character4 (u)), expr);
break;
#endif
default:
assert ("bad character kind type" == NULL);
break;
}
break;
default:
assert ("bad type" == NULL);
return expr;
}
ffebld_set_info (expr, ffeinfo_new
(FFEINFO_basictypeCHARACTER,
kt,
0,
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
len));
if ((error != FFEBAD)
&& ffebad_start (error))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return expr;
}
ffebld
ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
ffetargetCharacterSize sz, ffeexprContext context)
{
bool bad;
ffeinfo info;
ffeinfoWhere wh;
info = ffebld_info (source);
if ((bt != ffeinfo_basictype (info))
|| (kt != ffeinfo_kindtype (info))
|| (rk != 0)
|| (ffeinfo_rank (info) != 0)
|| (sz != ffebld_size_known (source)))
#if 0
|| ((context != FFEEXPR_contextLET)
&& (bt == FFEINFO_basictypeCHARACTER)
&& (sz == FFETARGET_charactersizeNONE)))
#endif
{
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
switch (bt)
{
case FFEINFO_basictypeLOGICAL:
bad = FALSE;
break;
case FFEINFO_basictypeINTEGER:
bad = !ffe_is_ugly_logint ();
break;
case FFEINFO_basictypeCHARACTER:
bad = ffe_is_pedantic ()
|| !(ffe_is_ugly_init ()
&& (context == FFEEXPR_contextDATA));
break;
default:
bad = TRUE;
break;
}
break;
case FFEINFO_basictypeINTEGER:
switch (bt)
{
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
bad = FALSE;
break;
case FFEINFO_basictypeLOGICAL:
bad = !ffe_is_ugly_logint ();
break;
case FFEINFO_basictypeCHARACTER:
bad = ffe_is_pedantic ()
|| !(ffe_is_ugly_init ()
&& (context == FFEEXPR_contextDATA));
break;
default:
bad = TRUE;
break;
}
break;
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
switch (bt)
{
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
bad = FALSE;
break;
case FFEINFO_basictypeCHARACTER:
bad = TRUE;
break;
default:
bad = TRUE;
break;
}
break;
case FFEINFO_basictypeCHARACTER:
bad = (bt != FFEINFO_basictypeCHARACTER)
&& (ffe_is_pedantic ()
|| (bt != FFEINFO_basictypeINTEGER)
|| !(ffe_is_ugly_init ()
&& (context == FFEEXPR_contextDATA)));
break;
case FFEINFO_basictypeTYPELESS:
case FFEINFO_basictypeHOLLERITH:
bad = ffe_is_pedantic ()
|| !(ffe_is_ugly_init ()
&& ((context == FFEEXPR_contextDATA)
|| (context == FFEEXPR_contextLET)));
break;
default:
bad = TRUE;
break;
}
if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
bad = TRUE;
if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
&& (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
&& (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
&& (ffeinfo_where (info) != FFEINFO_whereANY))
{
if (ffebad_start (FFEBAD_BAD_TYPES))
{
if (dest_token == NULL)
ffebad_here (0, ffewhere_line_unknown (),
ffewhere_column_unknown ());
else
ffebad_here (0, ffelex_token_where_line (dest_token),
ffelex_token_where_column (dest_token));
assert (source_token != NULL);
ffebad_here (1, ffelex_token_where_line (source_token),
ffelex_token_where_column (source_token));
ffebad_finish ();
}
source = ffebld_new_any ();
ffebld_set_info (source, ffeinfo_new_any ());
}
else
{
switch (ffeinfo_where (info))
{
case FFEINFO_whereCONSTANT:
wh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
wh = FFEINFO_whereIMMEDIATE;
break;
default:
wh = FFEINFO_whereFLEETING;
break;
}
source = ffebld_new_convert (source);
ffebld_set_info (source, ffeinfo_new
(bt,
kt,
0,
FFEINFO_kindENTITY,
wh,
sz));
source = ffeexpr_collapse_convert (source, source_token);
}
}
return source;
}
ffebld
ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
ffelexToken dest_token, ffeexprContext context)
{
ffeinfo info;
info = ffebld_info (dest);
return ffeexpr_convert (source, source_token, dest_token,
ffeinfo_basictype (info),
ffeinfo_kindtype (info),
ffeinfo_rank (info),
ffebld_size_known (dest),
context);
}
ffebld
ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
ffesymbol dest, ffelexToken dest_token)
{
return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
FFEEXPR_contextLET);
}
void
ffeexpr_init_2 ()
{
ffeexpr_stack_ = NULL;
ffeexpr_level_ = 0;
}
ffelexHandler
ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
{
ffeexprStack_ s;
ffebld_pool_push (pool);
s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
s->previous = ffeexpr_stack_;
s->pool = pool;
s->context = context;
s->callback = callback;
s->first_token = NULL;
s->exprstack = NULL;
s->is_rhs = FALSE;
ffeexpr_stack_ = s;
return (ffelexHandler) ffeexpr_token_first_lhs_;
}
ffelexHandler
ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
{
ffeexprStack_ s;
ffebld_pool_push (pool);
s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
s->previous = ffeexpr_stack_;
s->pool = pool;
s->context = context;
s->callback = callback;
s->first_token = NULL;
s->exprstack = NULL;
s->is_rhs = TRUE;
ffeexpr_stack_ = s;
return (ffelexHandler) ffeexpr_token_first_rhs_;
}
static ffelexHandler
ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprExpr_ e;
if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
{
if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
ffeexpr_exprstack_push_operand_ (e);
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_token_binary_);
}
if (expr->op == FFEBLD_opIMPDO)
{
if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
}
else
{
expr = ffebld_new_paren (expr);
ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand = expr;
e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
e->token = ffeexpr_stack_->tokens[0];
ffeexpr_exprstack_push_operand_ (e);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprCallback callback;
ffeexprStack_ s;
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
{
ffeexpr_stack_->expr = expr;
ffeexpr_tokens_[0] = ffelex_token_use (ft);
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
}
expr = ffeexpr_finished_ambig_ (ft, expr);
expr = ffebld_new_item (expr, NULL);
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ffelex_token_kill (ffeexpr_stack_->first_token);
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
return (ffelexHandler) (*callback) (ft, expr, t);
}
static ffelexHandler
ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
{
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken orig_ft = ffeexpr_tokens_[0];
ffelexToken orig_t = ffeexpr_tokens_[1];
ffebld expr = ffeexpr_stack_->expr;
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
if (ffe_is_pedantic ())
goto pedantic_comma;
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
|| (ffebld_op (expr) == FFEBLD_opSTAR)
|| (ffeinfo_basictype (ffebld_info (expr))
!= FFEINFO_basictypeCHARACTER))
break;
default:
pedantic_comma:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILENUMAMBIG:
ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
break;
case FFEEXPR_contextFILEUNITAMBIG:
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
break;
default:
assert ("bad context" == NULL);
break;
}
ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
ffelex_token_kill (orig_ft);
ffelex_token_kill (orig_t);
return (ffelexHandler) (*next) (t);
case FFELEX_typeOPEN_PAREN:
case FFELEX_typeNAME:
break;
}
expr = ffeexpr_finished_ambig_ (orig_ft, expr);
expr = ffebld_new_item (expr, NULL);
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ffelex_token_kill (ffeexpr_stack_->first_token);
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
ffelex_token_kill (orig_ft);
ffelex_token_kill (orig_t);
return (ffelexHandler) (*next) (t);
}
static ffelexHandler
ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
if (ffelex_token_type (t) == FFELEX_typeCOMMA)
{
ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
ffeexpr_stack_->expr = expr;
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
}
return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprExpr_ e;
ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
ffeinfoBasictype rty = (expr == NULL)
? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
ffeinfoKindtype lkt;
ffeinfoKindtype rkt;
ffeinfoKindtype nkt;
bool ok = TRUE;
ffebld orig;
if ((ffeexpr_stack_->expr == NULL)
|| (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
|| (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
&& (((ffebld_op (orig) != FFEBLD_opUMINUS)
&& (ffebld_op (orig) != FFEBLD_opUPLUS))
|| (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
|| ((lty != FFEINFO_basictypeINTEGER)
&& (lty != FFEINFO_basictypeREAL)))
{
if ((lty != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
ffebad_string ("Real");
ffebad_finish ();
}
ok = FALSE;
}
if ((expr == NULL)
|| (ffebld_op (expr) != FFEBLD_opCONTER)
|| (((orig = ffebld_conter_orig (expr)) != NULL)
&& (((ffebld_op (orig) != FFEBLD_opUMINUS)
&& (ffebld_op (orig) != FFEBLD_opUPLUS))
|| (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
|| ((rty != FFEINFO_basictypeINTEGER)
&& (rty != FFEINFO_basictypeREAL)))
{
if ((rty != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
{
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_string ("Imaginary");
ffebad_finish ();
}
ok = FALSE;
}
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_stack_->tokens[0];
if (ok)
{
if (lty == FFEINFO_basictypeINTEGER)
lkt = FFEINFO_kindtypeREALDEFAULT;
else
lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
if (rty == FFEINFO_basictypeINTEGER)
rkt = FFEINFO_kindtypeREALDEFAULT;
else
rkt = ffeinfo_kindtype (ffebld_info (expr));
nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
expr = ffeexpr_convert (expr,
ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
}
else
nkt = FFEINFO_kindtypeANY;
switch (nkt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
(ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
break;
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
(ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
break;
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
(ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
break;
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
(ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
break;
#endif
default:
if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
case FFEINFO_kindtypeANY:
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
break;
}
ffeexpr_exprstack_push_operand_ (e);
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_token_binary_;
if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_token_binary_);
}
static ffelexHandler
ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprContext ctx;
if (ffelex_token_type (t) == FFELEX_typeCOMMA)
{
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIMPDOITEM_:
ctx = FFEEXPR_contextIMPDOITEM_;
break;
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEMDF_:
ctx = FFEEXPR_contextIMPDOITEMDF_;
break;
default:
assert ("bad context" == NULL);
ctx = FFEEXPR_contextIMPDOITEM_;
break;
}
ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
ffeexpr_stack_->expr = expr;
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
ctx, ffeexpr_cb_comma_ci_);
}
ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffebld fexpr;
if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
&& (ffelex_token_type (t) != FFELEX_typeEQUALS))
{
ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
}
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
fexpr = ffeexpr_stack_->expr;
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeCOMMA)
{
if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffebld_end_list (&ffeexpr_stack_->bottom);
ffeexpr_stack_->expr = ffebld_new_any ();
ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
return (ffelexHandler) ffeexpr_cb_comma_i_5_;
}
return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprContext ctxi;
ffeexprContext ctxc;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
case FFEEXPR_contextDATAIMPDOITEM_:
ctxi = FFEEXPR_contextDATAIMPDOITEM_;
ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
break;
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIMPDOITEM_:
ctxi = FFEEXPR_contextIMPDOITEM_;
ctxc = FFEEXPR_contextIMPDOCTRL_;
break;
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEMDF_:
ctxi = FFEEXPR_contextIMPDOITEMDF_;
ctxc = FFEEXPR_contextIMPDOCTRL_;
break;
default:
assert ("bad context" == NULL);
ctxi = FFEEXPR_context;
ctxc = FFEEXPR_context;
break;
}
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
if (ffeexpr_stack_->is_rhs)
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
ctxi, ffeexpr_cb_comma_i_1_);
return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
ctxi, ffeexpr_cb_comma_i_1_);
case FFELEX_typeEQUALS:
ffebld_end_list (&ffeexpr_stack_->bottom);
if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
ffeexpr_stack_->first_token, expr, ft);
ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
ffebld_set_info (ffeexpr_stack_->expr,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
FFETARGET_charactersizeNONE));
ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
&ffeexpr_stack_->bottom);
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
ctxc, ffeexpr_cb_comma_i_2_);
default:
if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffebld_end_list (&ffeexpr_stack_->bottom);
ffeexpr_stack_->expr = ffebld_new_any ();
ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
return (ffelexHandler) ffeexpr_cb_comma_i_5_;
}
}
static ffelexHandler
ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
ffeexprContext ctx;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
case FFEEXPR_contextDATAIMPDOITEM_:
ctx = FFEEXPR_contextDATAIMPDOCTRL_;
break;
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
ctx = FFEEXPR_contextIMPDOCTRL_;
break;
default:
assert ("bad context" == NULL);
ctx = FFEEXPR_context;
break;
}
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
ctx, ffeexpr_cb_comma_i_3_);
break;
default:
if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffebld_end_list (&ffeexpr_stack_->bottom);
ffeexpr_stack_->expr = ffebld_new_any ();
ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
return (ffelexHandler) ffeexpr_cb_comma_i_5_;
}
}
static ffelexHandler
ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
ffeexprContext ctx;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
case FFEEXPR_contextDATAIMPDOITEM_:
ctx = FFEEXPR_contextDATAIMPDOCTRL_;
break;
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
ctx = FFEEXPR_contextIMPDOCTRL_;
break;
default:
assert ("bad context" == NULL);
ctx = FFEEXPR_context;
break;
}
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
ctx, ffeexpr_cb_comma_i_4_);
break;
case FFELEX_typeCLOSE_PAREN:
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
break;
default:
if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffebld_end_list (&ffeexpr_stack_->bottom);
ffeexpr_stack_->expr = ffebld_new_any ();
ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
return (ffelexHandler) ffeexpr_cb_comma_i_5_;
}
}
static ffelexHandler
ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
ffebld_end_list (&ffeexpr_stack_->bottom);
{
ffebld item;
for (item = ffebld_left (ffeexpr_stack_->expr);
item != NULL;
item = ffebld_trail (item))
if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
goto replace_with_any;
for (item = ffebld_right (ffeexpr_stack_->expr);
item != NULL;
item = ffebld_trail (item))
if ((ffebld_head (item) != NULL)
&& (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
goto replace_with_any;
}
break;
default:
if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffebld_end_list (&ffeexpr_stack_->bottom);
replace_with_any:
ffeexpr_stack_->expr = ffebld_new_any ();
ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
break;
}
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_cb_comma_i_5_;
return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
}
static ffelexHandler
ffeexpr_cb_comma_i_5_ (ffelexToken t)
{
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken ft;
ffebld expr;
bool terminate;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
case FFEEXPR_contextDATAIMPDOITEM_:
terminate = TRUE;
break;
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
terminate = FALSE;
break;
default:
assert ("bad context" == NULL);
terminate = FALSE;
break;
}
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ft = ffeexpr_stack_->first_token;
expr = ffeexpr_stack_->expr;
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (ft, expr, t);
ffelex_token_kill (ft);
if (terminate)
{
ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
--ffeexpr_level_;
if (ffeexpr_level_ == 0)
ffe_terminate_4 ();
}
return (ffelexHandler) next;
}
static ffelexHandler
ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
{
ffeexprExpr_ e;
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_stack_->tokens[0];
e->u.operand = ffebld_new_percent_loc (expr);
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeINTEGER,
ffecom_pointer_kind (),
0,
FFEINFO_kindENTITY,
FFEINFO_whereFLEETING,
FFETARGET_charactersizeNONE));
#if 0
e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
#endif
ffeexpr_exprstack_push_operand_ (e);
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
{
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
return (ffelexHandler) ffeexpr_token_binary_;
}
if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_token_binary_);
}
static ffelexHandler
ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprExpr_ e;
ffebldOp op;
op = ffebld_op (expr);
if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
|| (op == FFEBLD_opPERCENT_DESCR))
{
if (ffebad_start (FFEBAD_NESTED_PERCENT))
{
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
do
{
expr = ffebld_left (expr);
op = ffebld_op (expr);
}
while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
|| (op == FFEBLD_opPERCENT_DESCR));
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_stack_->tokens[0];
switch (ffeexpr_stack_->percent)
{
case FFEEXPR_percentVAL_:
e->u.operand = ffebld_new_percent_val (expr);
break;
case FFEEXPR_percentREF_:
e->u.operand = ffebld_new_percent_ref (expr);
break;
case FFEEXPR_percentDESCR_:
e->u.operand = ffebld_new_percent_descr (expr);
break;
default:
assert ("%lossage" == NULL);
e->u.operand = expr;
break;
}
ffebld_set_info (e->u.operand, ffebld_info (expr));
#if 0
e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
#endif
ffeexpr_exprstack_push_operand_ (e);
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
ffebad_finish ();
}
ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
assert ("bad context?!?!" == NULL);
break;
}
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_cb_end_notloc_1_);
}
static ffelexHandler
ffeexpr_cb_end_notloc_1_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
case FFELEX_typeCLOSE_PAREN:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextSFUNCDEFACTUALARG_:
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
break;
default:
assert ("bad context?!?!" == NULL);
break;
}
break;
default:
if (ffebad_start (FFEBAD_INVALID_PERCENT))
{
ffebad_here (0,
ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
ffebad_finish ();
}
ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
FFEBLD_opPERCENT_LOC);
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
assert ("bad context?!?!" == NULL);
break;
}
}
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
return
(ffelexHandler) ffeexpr_token_binary_ (t);
}
static ffesymbol
ffeexpr_check_impctrl_ (ffesymbol s)
{
assert (s != NULL);
assert (ffesymbol_sfdummyparent (s) != NULL);
switch (ffesymbol_state (s))
{
case FFESYMBOL_stateNONE:
if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
{
ffesymbol_signal_change (s);
ffesymbol_set_maxentrynum (s, ffeexpr_level_);
ffesymbol_signal_unreported (s);
}
break;
case FFESYMBOL_stateSEEN:
if ((ffeexpr_level_ == 1)
&& ffebad_start (FFEBAD_BAD_IMPDCL))
{
ffebad_string (ffesymbol_text (s));
ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
ffebad_finish ();
}
break;
case FFESYMBOL_stateUNCERTAIN:
assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
ffesymbol_signal_change (s);
ffesymbol_set_state (s, FFESYMBOL_stateNONE);
ffesymbol_signal_unreported (s);
break;
case FFESYMBOL_stateUNDERSTOOD:
break;
default:
assert ("Sasha Foo!!" == NULL);
break;
}
return s;
}
static void
ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
ffebld dovar, ffelexToken dovar_t)
{
ffebld item;
ffesymbol dovar_sym;
int itemnum;
if (ffebld_op (dovar) != FFEBLD_opSYMTER)
return;
dovar_sym = ffebld_symter (dovar);
for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
{
if (((item = ffebld_head (list)) != NULL)
&& (ffebld_op (item) == FFEBLD_opSYMTER)
&& (ffebld_symter (item) == dovar_sym))
{
char itemno[20];
sprintf (&itemno[0], "%d", itemnum);
if (ffebad_start (FFEBAD_DOITER_IMPDO))
{
ffebad_here (0, ffelex_token_where_line (list_t),
ffelex_token_where_column (list_t));
ffebad_here (1, ffelex_token_where_line (dovar_t),
ffelex_token_where_column (dovar_t));
ffebad_string (ffesymbol_text (dovar_sym));
ffebad_string (itemno);
ffebad_finish ();
}
}
}
}
static void
ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
{
ffesymbol dovar_sym;
if (ffebld_op (dovar) != FFEBLD_opSYMTER)
return;
dovar_sym = ffebld_symter (dovar);
ffeexpr_update_impdo_sym_ (list, dovar_sym);
}
static void
ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
{
tail_recurse:
if (expr == NULL)
return;
switch (ffebld_op (expr))
{
case FFEBLD_opSYMTER:
if (ffebld_symter (expr) == dovar)
ffebld_symter_set_is_doiter (expr, TRUE);
break;
case FFEBLD_opITEM:
ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
expr = ffebld_trail (expr);
goto tail_recurse;
default:
break;
}
switch (ffebld_arity (expr))
{
case 2:
ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
expr = ffebld_right (expr);
goto tail_recurse;
case 1:
expr = ffebld_left (expr);
goto tail_recurse;
default:
break;
}
return;
}
static ffeexprContext
ffeexpr_context_outer_ (ffeexprStack_ s)
{
assert (s != NULL);
for (;;)
{
switch (s->context)
{
case FFEEXPR_contextPAREN_:
case FFEEXPR_contextPARENFILENUM_:
case FFEEXPR_contextPARENFILEUNIT_:
break;
default:
return s->context;
}
s = s->previous;
assert (s != NULL);
}
}
static ffeexprPercent_
ffeexpr_percent_ (ffelexToken t)
{
const char *p;
switch (ffelex_token_length (t))
{
case 3:
switch (*(p = ffelex_token_text (t)))
{
case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
&& (ffesrc_char_match_noninit (*++p, 'C', 'c')))
return FFEEXPR_percentLOC_;
return FFEEXPR_percentNONE_;
case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
&& (ffesrc_char_match_noninit (*++p, 'F', 'f')))
return FFEEXPR_percentREF_;
return FFEEXPR_percentNONE_;
case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
&& (ffesrc_char_match_noninit (*++p, 'L', 'l')))
return FFEEXPR_percentVAL_;
return FFEEXPR_percentNONE_;
default:
no_match_3:
return FFEEXPR_percentNONE_;
}
case 5:
if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
"descr", "Descr") == 0)
return FFEEXPR_percentDESCR_;
return FFEEXPR_percentNONE_;
default:
return FFEEXPR_percentNONE_;
}
}
void
ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
ffeinfoBasictype lbt, ffeinfoKindtype lkt,
ffeinfoBasictype rbt, ffeinfoKindtype rkt,
ffelexToken t)
{
ffeinfoBasictype nbt;
ffeinfoKindtype nkt;
nbt = ffeinfo_basictype_combine (lbt, rbt);
if ((nbt == FFEINFO_basictypeCOMPLEX)
&& ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
&& ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
{
nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
nkt = FFEINFO_kindtypeNONE;
switch (nkt)
{
#if FFETARGET_okCOMPLEX1
case FFEINFO_kindtypeREAL1:
#endif
#if FFETARGET_okCOMPLEX2
case FFEINFO_kindtypeREAL2:
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
#endif
#if FFETARGET_okCOMPLEX4
case FFEINFO_kindtypeREAL4:
#endif
break;
default:
if (t != NULL)
{
ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
nbt = FFEINFO_basictypeNONE;
nkt = FFEINFO_kindtypeNONE;
break;
case FFEINFO_kindtypeANY:
nkt = FFEINFO_kindtypeREALDEFAULT;
break;
}
}
else
{
if (nbt == lbt)
{
if (nbt == rbt)
nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
else
nkt = lkt;
}
else if (nbt == rbt)
nkt = rkt;
else
{
nbt = FFEINFO_basictypeNONE;
nkt = FFEINFO_kindtypeNONE;
}
}
*xnbt = nbt;
*xnkt = nkt;
}
static ffelexHandler
ffeexpr_token_first_lhs_ (ffelexToken t)
{
ffeexpr_stack_->first_token = ffelex_token_use (t);
switch (ffelex_token_type (t))
{
case FFELEX_typeOPEN_PAREN:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
ffe_init_4 ();
ffeexpr_level_ = 1;
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
case FFEEXPR_contextDATAIMPDOITEM_:
++ffeexpr_level_;
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIMPDOITEM_:
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEMDF_:
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
case FFEEXPR_contextFILEEXTFUNC:
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_lhs_1_;
default:
break;
}
break;
case FFELEX_typeNAME:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILENAMELIST:
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_namelist_;
case FFEEXPR_contextFILEEXTFUNC:
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_lhs_1_;
default:
break;
}
break;
default:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILEEXTFUNC:
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_lhs_1_;
default:
break;
}
break;
}
return (ffelexHandler) ffeexpr_token_lhs_ (t);
}
static ffelexHandler
ffeexpr_token_first_lhs_1_ (ffelexToken t)
{
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken ft;
ffesymbol sy = NULL;
ffebld expr;
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ft = ffeexpr_stack_->first_token;
s = ffeexpr_stack_->previous;
if ((ffelex_token_type (ft) != FFELEX_typeNAME)
|| (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
& FFESYMBOL_attrANY))
{
if ((ffelex_token_type (ft) != FFELEX_typeNAME)
|| !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
{
ffebad_start (FFEBAD_EXPR_WRONG);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
expr = ffebld_new_any ();
ffebld_set_info (expr, ffeinfo_new_any ());
}
else
{
expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (expr, ffesymbol_info (sy));
}
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (ft, expr, t);
ffelex_token_kill (ft);
return (ffelexHandler) next;
}
static ffelexHandler
ffeexpr_token_first_rhs_ (ffelexToken t)
{
ffesymbol s;
ffeexpr_stack_->first_token = ffelex_token_use (t);
switch (ffelex_token_type (t))
{
case FFELEX_typeASTERISK:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILEFORMATNML:
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
case FFEEXPR_contextFILEUNIT:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextFILEFORMAT:
case FFEEXPR_contextCHARACTERSIZE:
if (ffeexpr_stack_->previous != NULL)
break;
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_rhs_1_;
case FFEEXPR_contextPARENFILEUNIT_:
if (ffeexpr_stack_->previous->previous != NULL)
break;
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_rhs_1_;
case FFEEXPR_contextACTUALARG_:
if (ffeexpr_stack_->previous->context
!= FFEEXPR_contextSUBROUTINEREF)
{
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
}
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_rhs_3_;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
break;
}
break;
case FFELEX_typeOPEN_PAREN:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILENUMAMBIG:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextPARENFILENUM_,
ffeexpr_cb_close_paren_ambig_);
case FFEEXPR_contextFILEUNITAMBIG:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextPARENFILEUNIT_,
ffeexpr_cb_close_paren_ambig_);
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIMPDOITEM_:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextIMPDOITEM_,
ffeexpr_cb_close_paren_ci_);
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextIMPDOITEMDF_:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextIMPDOITEMDF_,
ffeexpr_cb_close_paren_ci_);
case FFEEXPR_contextFILEFORMATNML:
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
break;
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
break;
}
break;
case FFELEX_typeNUMBER:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILEFORMATNML:
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
case FFEEXPR_contextFILEFORMAT:
if (ffeexpr_stack_->previous != NULL)
break;
assert (ffeexpr_stack_->exprstack == NULL);
return (ffelexHandler) ffeexpr_token_first_rhs_2_;
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
break;
}
break;
case FFELEX_typeNAME:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILEFORMATNML:
assert (ffeexpr_stack_->exprstack == NULL);
s = ffesymbol_lookup_local (t);
if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
return (ffelexHandler) ffeexpr_token_namelist_;
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
break;
default:
break;
}
break;
case FFELEX_typePERCENT:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextINDEXORACTUALARG_:
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
return (ffelexHandler) ffeexpr_token_first_rhs_5_;
case FFEEXPR_contextFILEFORMATNML:
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
break;
default:
break;
}
default:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextFILEFORMATNML:
ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
break;
default:
break;
}
break;
}
return (ffelexHandler) ffeexpr_token_rhs_ (t);
}
static ffelexHandler
ffeexpr_token_first_rhs_1_ (ffelexToken t)
{
ffebld expr;
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken ft;
expr = ffebld_new_star ();
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ft = ffeexpr_stack_->first_token;
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (ft, expr, t);
ffelex_token_kill (ft);
return (ffelexHandler) next;
}
static ffelexHandler
ffeexpr_token_first_rhs_2_ (ffelexToken t)
{
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken ft;
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
case FFELEX_typeCOMMA:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
break;
default:
next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
return (ffelexHandler) (*next) (t);
}
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ft = ffeexpr_stack_->first_token;
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (ft, NULL, t);
ffelex_token_kill (ft);
return (ffelexHandler) next;
}
static ffelexHandler
ffeexpr_token_first_rhs_3_ (ffelexToken t)
{
ffelexHandler next;
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
{
next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
return (ffelexHandler) (*next) (t);
}
ffest_confirmed ();
if (ffest_is_inhibited ())
ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
else
ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
ffebld_set_info (ffeexpr_stack_->expr,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindNONE,
FFEINFO_whereNONE,
FFETARGET_charactersizeNONE));
return (ffelexHandler) ffeexpr_token_first_rhs_4_;
}
static ffelexHandler
ffeexpr_token_first_rhs_4_ (ffelexToken t)
{
ffebld expr;
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken ft;
expr = ffeexpr_stack_->expr;
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ft = ffeexpr_stack_->first_token;
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (ft, expr, t);
ffelex_token_kill (ft);
return (ffelexHandler) next;
}
static ffelexHandler
ffeexpr_token_first_rhs_5_ (ffelexToken t)
{
ffelexHandler next;
if (ffelex_token_type (t) == FFELEX_typeNAME)
{
ffeexprPercent_ p = ffeexpr_percent_ (t);
switch (p)
{
case FFEEXPR_percentNONE_:
case FFEEXPR_percentLOC_:
break;
case FFEEXPR_percentVAL_:
case FFEEXPR_percentREF_:
case FFEEXPR_percentDESCR_:
ffeexpr_stack_->percent = p;
ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_first_rhs_6_;
default:
assert ("bad percent?!?" == NULL);
break;
}
}
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
assert ("bad context?!?!" == NULL);
break;
}
next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
return (ffelexHandler) (*next) (t);
}
static ffelexHandler
ffeexpr_token_first_rhs_6_ (ffelexToken t)
{
ffelexHandler next;
ffelexToken ft;
if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
{
ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
ffeexpr_stack_->context,
ffeexpr_cb_end_notloc_);
}
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
assert ("bad context?!?!" == NULL);
break;
}
ft = ffeexpr_stack_->tokens[0];
next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
next = (ffelexHandler) (*next) (ft);
ffelex_token_kill (ft);
return (ffelexHandler) (*next) (t);
}
static ffelexHandler
ffeexpr_token_namelist_ (ffelexToken t)
{
ffeexprCallback callback;
ffeexprStack_ s;
ffelexHandler next;
ffelexToken ft;
ffesymbol sy;
ffebld expr;
ffebld_pool_pop ();
callback = ffeexpr_stack_->callback;
ft = ffeexpr_stack_->first_token;
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
sy = ffesymbol_lookup_local (ft);
if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
{
ffebad_start (FFEBAD_EXPR_WRONG);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
expr = ffebld_new_any ();
ffebld_set_info (expr, ffeinfo_new_any ());
}
else
{
expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
FFEINTRIN_impNONE);
ffebld_set_info (expr, ffesymbol_info (sy));
}
next = (ffelexHandler) (*callback) (ft, expr, t);
ffelex_token_kill (ft);
return (ffelexHandler) next;
}
static void
ffeexpr_expr_kill_ (ffeexprExpr_ e)
{
if (e->token != NULL)
ffelex_token_kill (e->token);
malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
}
static ffeexprExpr_
ffeexpr_expr_new_ ()
{
ffeexprExpr_ e;
e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
sizeof (*e));
e->previous = NULL;
e->type = FFEEXPR_exprtypeUNKNOWN_;
e->token = NULL;
return e;
}
static void
ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
{
int n_args;
ffebld list;
ffebld item;
ffesymbol s;
assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
|| (ffebld_op (*expr) == FFEBLD_opFUNCREF));
if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
return;
if (ffesymbol_retractable ())
return;
s = ffebld_symter (ffebld_left (*expr));
if (ffesymbol_global (s) == NULL)
return;
for (n_args = 0, list = ffebld_right (*expr);
list != NULL;
list = ffebld_trail (list), ++n_args)
;
if (ffeglobal_proc_ref_nargs (s, n_args, t))
{
ffeglobalArgSummary as;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
bool array;
bool fail = FALSE;
for (n_args = 0, list = ffebld_right (*expr);
list != NULL;
list = ffebld_trail (list), ++n_args)
{
item = ffebld_head (list);
if (item != NULL)
{
bt = ffeinfo_basictype (ffebld_info (item));
kt = ffeinfo_kindtype (ffebld_info (item));
array = (ffeinfo_rank (ffebld_info (item)) > 0);
switch (ffebld_op (item))
{
case FFEBLD_opLABTOK:
case FFEBLD_opLABTER:
as = FFEGLOBAL_argsummaryALTRTN;
break;
#if 0
case FFEBLD_opPERCENT_LOC:
as = FFEGLOBAL_argsummaryPTR;
break;
#endif
case FFEBLD_opPERCENT_VAL:
as = FFEGLOBAL_argsummaryVAL;
break;
case FFEBLD_opPERCENT_REF:
as = FFEGLOBAL_argsummaryREF;
break;
case FFEBLD_opPERCENT_DESCR:
as = FFEGLOBAL_argsummaryDESCR;
break;
case FFEBLD_opFUNCREF:
#if 0
if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
&& (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
== FFEINTRIN_specLOC))
{
as = FFEGLOBAL_argsummaryPTR;
break;
}
#endif
default:
if (ffebld_op (item) == FFEBLD_opSYMTER)
{
as = FFEGLOBAL_argsummaryNONE;
switch (ffeinfo_kind (ffebld_info (item)))
{
case FFEINFO_kindFUNCTION:
as = FFEGLOBAL_argsummaryFUNC;
break;
case FFEINFO_kindSUBROUTINE:
as = FFEGLOBAL_argsummarySUBR;
break;
case FFEINFO_kindNONE:
as = FFEGLOBAL_argsummaryPROC;
break;
default:
break;
}
if (as != FFEGLOBAL_argsummaryNONE)
break;
}
if (bt == FFEINFO_basictypeCHARACTER)
as = FFEGLOBAL_argsummaryDESCR;
else
as = FFEGLOBAL_argsummaryREF;
break;
}
}
else
{
array = FALSE;
as = FFEGLOBAL_argsummaryNONE;
bt = FFEINFO_basictypeNONE;
kt = FFEINFO_kindtypeNONE;
}
if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
fail = TRUE;
}
if (! fail)
return;
}
*expr = ffebld_new_any ();
ffebld_set_info (*expr, ffeinfo_new_any ());
}
static bool
ffeexpr_isdigits_ (const char *p)
{
for (; *p != '\0'; ++p)
if (! ISDIGIT (*p))
return FALSE;
return TRUE;
}
static void
ffeexpr_exprstack_push_ (ffeexprExpr_ e)
{
e->previous = ffeexpr_stack_->exprstack;
ffeexpr_stack_->exprstack = e;
}
static void
ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
{
ffeexpr_exprstack_push_ (e);
#ifdef WEIRD_NONFORTRAN_RULES
if ((ffeexpr_stack_->exprstack != NULL)
&& (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
&& (ffeexpr_stack_->exprstack->expr->u.operator.prec
== FFEEXPR_operatorprecedenceHIGHEST_)
&& (ffeexpr_stack_->exprstack->expr->u.operator.as
== FFEEXPR_operatorassociativityL2R_))
ffeexpr_reduce_ ();
#endif
}
static void
ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
{
if ((ffe_is_pedantic ()
|| ffe_is_warn_surprising ())
&& (ffeexpr_stack_->exprstack != NULL)
&& (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
&& (ffeexpr_stack_->exprstack->u.operator.prec
<= FFEEXPR_operatorprecedenceLOWARITH_)
&& (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
{
ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
ffe_is_pedantic ()
? FFEBAD_severityPEDANTIC
: FFEBAD_severityWARNING);
ffebad_here (0,
ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
ffebad_here (1,
ffelex_token_where_line (e->token),
ffelex_token_where_column (e->token));
ffebad_finish ();
}
ffeexpr_exprstack_push_ (e);
}
static void
ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
{
ffeexprExpr_ ce;
if (ffe_is_warn_surprising ()
&& (ffeexpr_stack_->exprstack != NULL)
&& (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
&& (ffeexpr_stack_->exprstack->previous != NULL)
&& (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
&& (ffeexpr_stack_->exprstack->previous->u.operator.op
== FFEEXPR_operatorSUBTRACT_)
&& (e->u.operator.prec
< ffeexpr_stack_->exprstack->previous->u.operator.prec))
{
ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
ffebad_here (0,
ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
ffebad_here (1,
ffelex_token_where_line (e->token),
ffelex_token_where_column (e->token));
ffebad_finish ();
}
again:
assert (ffeexpr_stack_->exprstack != NULL);
assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
{
assert (ce->type != FFEEXPR_exprtypeOPERAND_);
if ((ce->u.operator.prec < e->u.operator.prec)
|| ((ce->u.operator.prec == e->u.operator.prec)
&& (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
{
ffeexpr_reduce_ ();
goto again;
}
}
ffeexpr_exprstack_push_ (e);
}
static void
ffeexpr_reduce_ ()
{
ffeexprExpr_ operand;
ffeexprExpr_ left_operand;
ffeexprExpr_ operator;
ffebld reduced;
ffebldConstant constnode;
ffebld expr;
ffebld left_expr;
bool submag = FALSE;
operand = ffeexpr_stack_->exprstack;
assert (operand != NULL);
assert (operand->type == FFEEXPR_exprtypeOPERAND_);
operator = operand->previous;
assert (operator != NULL);
assert (operator->type != FFEEXPR_exprtypeOPERAND_);
if (operator->type == FFEEXPR_exprtypeUNARY_)
{
expr = operand->u.operand;
switch (operator->u.operator.op)
{
case FFEEXPR_operatorADD_:
reduced = ffebld_new_uplus (expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
reduced = ffeexpr_collapse_uplus (reduced, operator->token);
break;
case FFEEXPR_operatorSUBTRACT_:
submag = TRUE;
reduced = ffebld_new_uminus (expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
reduced = ffeexpr_collapse_uminus (reduced, operator->token);
break;
case FFEEXPR_operatorNOT_:
reduced = ffebld_new_not (expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
reduced = ffeexpr_collapse_not (reduced, operator->token);
break;
default:
assert ("unexpected unary op" != NULL);
reduced = NULL;
break;
}
if (!submag
&& (ffebld_op (expr) == FFEBLD_opCONTER)
&& (ffebld_conter_orig (expr) == NULL)
&& ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
{
ffetarget_integer_bad_magical (operand->token);
}
ffeexpr_stack_->exprstack = operator->previous;
ffeexpr_expr_kill_ (operand);
operator->type = FFEEXPR_exprtypeOPERAND_;
operator->u.operand = reduced;
ffeexpr_exprstack_push_operand_ (operator);
}
else
{
assert (operator->type == FFEEXPR_exprtypeBINARY_);
left_operand = operator->previous;
assert (left_operand != NULL);
assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
expr = operand->u.operand;
left_expr = left_operand->u.operand;
switch (operator->u.operator.op)
{
case FFEEXPR_operatorADD_:
reduced = ffebld_new_add (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_add (reduced, operator->token);
break;
case FFEEXPR_operatorSUBTRACT_:
submag = TRUE;
reduced = ffebld_new_subtract (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_subtract (reduced, operator->token);
break;
case FFEEXPR_operatorMULTIPLY_:
reduced = ffebld_new_multiply (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_multiply (reduced, operator->token);
break;
case FFEEXPR_operatorDIVIDE_:
reduced = ffebld_new_divide (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_divide (reduced, operator->token);
break;
case FFEEXPR_operatorPOWER_:
reduced = ffebld_new_power (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_power (reduced, operator->token);
break;
case FFEEXPR_operatorCONCATENATE_:
reduced = ffebld_new_concatenate (left_expr, expr);
reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
break;
case FFEEXPR_operatorLT_:
reduced = ffebld_new_lt (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_lt (reduced, operator->token);
break;
case FFEEXPR_operatorLE_:
reduced = ffebld_new_le (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_le (reduced, operator->token);
break;
case FFEEXPR_operatorEQ_:
reduced = ffebld_new_eq (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_eq (reduced, operator->token);
break;
case FFEEXPR_operatorNE_:
reduced = ffebld_new_ne (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_ne (reduced, operator->token);
break;
case FFEEXPR_operatorGT_:
reduced = ffebld_new_gt (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_gt (reduced, operator->token);
break;
case FFEEXPR_operatorGE_:
reduced = ffebld_new_ge (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_ge (reduced, operator->token);
break;
case FFEEXPR_operatorAND_:
reduced = ffebld_new_and (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_and (reduced, operator->token);
break;
case FFEEXPR_operatorOR_:
reduced = ffebld_new_or (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_or (reduced, operator->token);
break;
case FFEEXPR_operatorXOR_:
reduced = ffebld_new_xor (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_xor (reduced, operator->token);
break;
case FFEEXPR_operatorEQV_:
reduced = ffebld_new_eqv (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_eqv (reduced, operator->token);
break;
case FFEEXPR_operatorNEQV_:
reduced = ffebld_new_neqv (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_neqv (reduced, operator->token);
break;
default:
assert ("bad bin op" == NULL);
reduced = expr;
break;
}
if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
&& (ffebld_conter_orig (expr) == NULL)
&& ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
{
if ((left_operand->previous != NULL)
&& (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
&& (left_operand->previous->u.operator.op
== FFEEXPR_operatorSUBTRACT_))
{
if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
ffetarget_integer_bad_magical_precedence (left_operand->token,
left_operand->previous->token,
operator->token);
else
ffetarget_integer_bad_magical_precedence_binary
(left_operand->token,
left_operand->previous->token,
operator->token);
}
else
ffetarget_integer_bad_magical (left_operand->token);
}
if ((ffebld_op (expr) == FFEBLD_opCONTER)
&& (ffebld_conter_orig (expr) == NULL)
&& ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
{
if (submag)
ffetarget_integer_bad_magical_binary (operand->token,
operator->token);
else
ffetarget_integer_bad_magical (operand->token);
}
ffeexpr_stack_->exprstack = left_operand->previous;
ffeexpr_expr_kill_ (left_operand);
ffeexpr_expr_kill_ (operand);
operator->type = FFEEXPR_exprtypeOPERAND_;
operator->u.operand = reduced;
ffeexpr_exprstack_push_operand_ (operator);
}
}
static ffebld
ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
ffeinfo rinfo, ninfo;
ffeinfoBasictype rbt;
ffeinfoKindtype rkt;
ffeinfoRank rrk;
ffeinfoKind rkd;
ffeinfoWhere rwh, nwh;
rinfo = ffebld_info (ffebld_left (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if (((rbt == FFEINFO_basictypeLOGICAL)
|| (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
&& (rrk == 0))
{
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
return reduced;
}
if ((rbt != FFEINFO_basictypeLOGICAL)
&& (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_NOT_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_NOT_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo, ninfo;
ffeinfoBasictype lbt, rbt, nbt;
ffeinfoKindtype lkt, rkt, nkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh, nwh;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
if (((nbt == FFEINFO_basictypeLOGICAL)
|| (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
&& (lrk == 0) && (rrk == 0))
{
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
return reduced;
}
if ((lbt != FFEINFO_basictypeLOGICAL)
&& (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
{
if ((rbt != FFEINFO_basictypeLOGICAL)
&& (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
{
if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((lbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_BOOL_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_finish ();
}
}
}
else if ((rbt != FFEINFO_basictypeLOGICAL)
&& (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_BOOL_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if (lrk != 0)
{
if ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_BOOL_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_BOOL_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo, ninfo;
ffeinfoBasictype lbt, rbt, nbt;
ffeinfoKindtype lkt, rkt, nkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd, nkd;
ffeinfoWhere lwh, rwh, nwh;
ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
lszk = ffeinfo_size (linfo);
lszm = ffebld_size_max (ffebld_left (reduced));
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
rszk = ffeinfo_size (rinfo);
rszm = ffebld_size_max (ffebld_right (reduced));
if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
&& (lkt == rkt) && (lrk == 0) && (rrk == 0)
&& (((lszm != FFETARGET_charactersizeNONE)
&& (rszm != FFETARGET_charactersizeNONE))
|| (ffeexpr_context_outer_ (ffeexpr_stack_)
== FFEEXPR_contextLET)
|| (ffeexpr_context_outer_ (ffeexpr_stack_)
== FFEEXPR_contextSFUNCDEF)))
{
nbt = FFEINFO_basictypeCHARACTER;
nkd = FFEINFO_kindENTITY;
if ((lszk == FFETARGET_charactersizeNONE)
|| (rszk == FFETARGET_charactersizeNONE))
nszk = FFETARGET_charactersizeNONE;
else
nszk = lszk + rszk;
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
nkt = lkt;
ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
ffebld_set_info (reduced, ninfo);
return reduced;
}
if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
{
if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if (lbt != FFEINFO_basictypeCHARACTER)
{
if ((lbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_finish ();
}
}
else if (rbt != FFEINFO_basictypeCHARACTER)
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
{
if ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_CONCAT_ARG_KIND))
{
const char *what;
if (lrk != 0)
what = "an array";
else
what = "of indeterminate length";
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_string (what);
ffebad_finish ();
}
}
else
{
if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
{
const char *what;
if (rrk != 0)
what = "an array";
else
what = "of indeterminate length";
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string (what);
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo, ninfo;
ffeinfoBasictype lbt, rbt, nbt;
ffeinfoKindtype lkt, rkt, nkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh, nwh;
ffetargetCharacterSize lsz, rsz;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
lsz = ffebld_size_known (ffebld_left (reduced));
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
rsz = ffebld_size_known (ffebld_right (reduced));
ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
|| (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
&& (lrk == 0) && (rrk == 0))
{
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
if ((lsz != FFETARGET_charactersizeNONE)
&& (rsz != FFETARGET_charactersizeNONE))
lsz = rsz = (lsz > rsz) ? lsz : rsz;
ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, nbt, nkt, 0, lsz,
FFEEXPR_contextLET));
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, nbt, nkt, 0, rsz,
FFEEXPR_contextLET));
return reduced;
}
if ((lbt == FFEINFO_basictypeLOGICAL)
&& (rbt == FFEINFO_basictypeLOGICAL))
{
if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
FFEBAD_severityFATAL))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
&& (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
{
if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
{
if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((lbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_EQOP_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_finish ();
}
}
}
else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_EQOP_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if (lrk != 0)
{
if ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_EQOP_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_EQOP_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
ffeinfo rinfo, ninfo;
ffeinfoBasictype rbt;
ffeinfoKindtype rkt;
ffeinfoRank rrk;
ffeinfoKind rkd;
ffeinfoWhere rwh, nwh;
rinfo = ffebld_info (ffebld_left (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
|| (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
{
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
return reduced;
}
if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCOMPLEX))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_MATH_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo, ninfo;
ffeinfoBasictype lbt, rbt, nbt;
ffeinfoKindtype lkt, rkt, nkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh, nwh;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
|| (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
{
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
return reduced;
}
if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
&& (lbt != FFEINFO_basictypeCOMPLEX))
{
if ((rbt != FFEINFO_basictypeINTEGER)
&& (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
{
if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARGS_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((lbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_finish ();
}
}
}
else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCOMPLEX))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if (lrk != 0)
{
if ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_MATH_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_MATH_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo, ninfo;
ffeinfoBasictype lbt, rbt, nbt;
ffeinfoKindtype lkt, rkt, nkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh, nwh;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if ((rbt == FFEINFO_basictypeINTEGER)
&& ((lbt == FFEINFO_basictypeREAL)
|| (lbt == FFEINFO_basictypeCOMPLEX)))
{
nbt = lbt;
nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
if (nkt != FFEINFO_kindtypeREALDEFAULT)
{
nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
if (nkt != FFEINFO_kindtypeREALDOUBLE)
nkt = FFEINFO_kindtypeREALDOUBLE;
}
if (rkt == FFEINFO_kindtypeINTEGER4)
{
ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
FFEBAD_severityWARNING);
ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
{
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token,
FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
rkt = FFEINFO_kindtypeINTEGERDEFAULT;
}
}
else
{
ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
#if 0
if ((nbt == FFEINFO_basictypeINTEGER)
&& (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
nkt = FFEINFO_kindtypeINTEGERDEFAULT;
#endif
if (((nbt == FFEINFO_basictypeREAL)
|| (nbt == FFEINFO_basictypeCOMPLEX))
&& (nkt != FFEINFO_kindtypeREALDEFAULT))
{
nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
if (nkt != FFEINFO_kindtypeREALDOUBLE)
nkt = FFEINFO_kindtypeREALDOUBLE;
}
}
if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
|| (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
{
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
if (rbt != FFEINFO_basictypeINTEGER)
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
return reduced;
}
if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
&& (lbt != FFEINFO_basictypeCOMPLEX))
{
if ((rbt != FFEINFO_basictypeINTEGER)
&& (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
{
if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARGS_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((lbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_finish ();
}
}
}
else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCOMPLEX))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_MATH_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if (lrk != 0)
{
if ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_MATH_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_MATH_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo, ninfo;
ffeinfoBasictype lbt, rbt, nbt;
ffeinfoKindtype lkt, rkt, nkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh, nwh;
ffetargetCharacterSize lsz, rsz;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
lsz = ffebld_size_known (ffebld_left (reduced));
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
rsz = ffebld_size_known (ffebld_right (reduced));
ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
|| (nbt == FFEINFO_basictypeCHARACTER))
&& (lrk == 0) && (rrk == 0))
{
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
nwh = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
nwh = FFEINFO_whereIMMEDIATE;
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
break;
default:
nwh = FFEINFO_whereFLEETING;
break;
}
if ((lsz != FFETARGET_charactersizeNONE)
&& (rsz != FFETARGET_charactersizeNONE))
lsz = rsz = (lsz > rsz) ? lsz : rsz;
ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
ffebld_set_info (reduced, ninfo);
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, nbt, nkt, 0, lsz,
FFEEXPR_contextLET));
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, nbt, nkt, 0, rsz,
FFEEXPR_contextLET));
return reduced;
}
if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
&& (lbt != FFEINFO_basictypeCHARACTER))
{
if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCHARACTER))
{
if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else
{
if ((lbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_RELOP_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_finish ();
}
}
}
else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
&& (rbt != FFEINFO_basictypeCHARACTER))
{
if ((rbt != FFEINFO_basictypeANY)
&& ffebad_start (FFEBAD_RELOP_ARG_TYPE))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_finish ();
}
}
else if (lrk != 0)
{
if ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_RELOP_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
else
{
if ((rkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_RELOP_ARG_KIND))
{
ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
ffebad_string ("an array");
ffebad_finish ();
}
}
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
return reduced;
}
static ffebld
ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
ffeinfo rinfo;
ffeinfoBasictype rbt;
ffeinfoKindtype rkt;
ffeinfoRank rrk;
ffeinfoKind rkd;
ffeinfoWhere rwh;
rinfo = ffebld_info (ffebld_left (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if ((rbt == FFEINFO_basictypeTYPELESS)
|| (rbt == FFEINFO_basictypeHOLLERITH))
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
r->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
rinfo = ffebld_info (ffebld_left (reduced));
rbt = FFEINFO_basictypeINTEGER;
rkt = FFEINFO_kindtypeINTEGERDEFAULT;
rrk = 0;
rkd = FFEINFO_kindENTITY;
rwh = ffeinfo_where (rinfo);
}
if (rbt == FFEINFO_basictypeLOGICAL)
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
r->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
}
return reduced;
}
static ffebld
ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
ffeinfo rinfo;
ffeinfoBasictype rbt;
ffeinfoKindtype rkt;
ffeinfoRank rrk;
ffeinfoKind rkd;
ffeinfoWhere rwh;
rinfo = ffebld_info (ffebld_left (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if ((rbt == FFEINFO_basictypeTYPELESS)
|| (rbt == FFEINFO_basictypeHOLLERITH))
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
FFEINFO_kindtypeLOGICALDEFAULT,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
rinfo = ffebld_info (ffebld_left (reduced));
rbt = FFEINFO_basictypeLOGICAL;
rkt = FFEINFO_kindtypeLOGICALDEFAULT;
rrk = 0;
rkd = FFEINFO_kindENTITY;
rwh = ffeinfo_where (rinfo);
}
return reduced;
}
static ffebld
ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo;
ffeinfoBasictype lbt, rbt;
ffeinfoKindtype lkt, rkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if ((lbt == FFEINFO_basictypeTYPELESS)
|| (lbt == FFEINFO_basictypeHOLLERITH))
{
if ((rbt == FFEINFO_basictypeTYPELESS)
|| (rbt == FFEINFO_basictypeHOLLERITH))
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, FFEINFO_basictypeINTEGER, 0,
FFEINFO_kindtypeINTEGERDEFAULT,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
linfo = ffebld_info (ffebld_left (reduced));
rinfo = ffebld_info (ffebld_right (reduced));
lbt = rbt = FFEINFO_basictypeINTEGER;
lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
lrk = rrk = 0;
lkd = rkd = FFEINFO_kindENTITY;
lwh = ffeinfo_where (linfo);
rwh = ffeinfo_where (rinfo);
}
else
{
ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
l->token, ffebld_right (reduced), r->token,
FFEEXPR_contextLET));
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
}
}
else
{
if ((rbt == FFEINFO_basictypeTYPELESS)
|| (rbt == FFEINFO_basictypeHOLLERITH))
{
ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
r->token, ffebld_left (reduced), l->token,
FFEEXPR_contextLET));
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
}
}
if (lbt == FFEINFO_basictypeLOGICAL)
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
}
if (rbt == FFEINFO_basictypeLOGICAL)
{
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
}
return reduced;
}
static ffebld
ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
ffeexprExpr_ r)
{
ffeinfo linfo, rinfo;
ffeinfoBasictype lbt, rbt;
ffeinfoKindtype lkt, rkt;
ffeinfoRank lrk, rrk;
ffeinfoKind lkd, rkd;
ffeinfoWhere lwh, rwh;
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
if ((lbt == FFEINFO_basictypeTYPELESS)
|| (lbt == FFEINFO_basictypeHOLLERITH))
{
if ((rbt == FFEINFO_basictypeTYPELESS)
|| (rbt == FFEINFO_basictypeHOLLERITH))
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
linfo = ffebld_info (ffebld_left (reduced));
rinfo = ffebld_info (ffebld_right (reduced));
lbt = rbt = FFEINFO_basictypeLOGICAL;
lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
lrk = rrk = 0;
lkd = rkd = FFEINFO_kindENTITY;
lwh = ffeinfo_where (linfo);
rwh = ffeinfo_where (rinfo);
}
else
{
ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
l->token, ffebld_right (reduced), r->token,
FFEEXPR_contextLET));
linfo = ffebld_info (ffebld_left (reduced));
lbt = ffeinfo_basictype (linfo);
lkt = ffeinfo_kindtype (linfo);
lrk = ffeinfo_rank (linfo);
lkd = ffeinfo_kind (linfo);
lwh = ffeinfo_where (linfo);
}
}
else
{
if ((rbt == FFEINFO_basictypeTYPELESS)
|| (rbt == FFEINFO_basictypeHOLLERITH))
{
ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
r->token, ffebld_left (reduced), l->token,
FFEEXPR_contextLET));
rinfo = ffebld_info (ffebld_right (reduced));
rbt = ffeinfo_basictype (rinfo);
rkt = ffeinfo_kindtype (rinfo);
rrk = ffeinfo_rank (rinfo);
rkd = ffeinfo_kind (rinfo);
rwh = ffeinfo_where (rinfo);
}
}
if (lbt == FFEINFO_basictypeLOGICAL)
{
ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
l->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
}
if (rbt == FFEINFO_basictypeLOGICAL)
{
ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
r->token, op->token, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET));
}
return reduced;
}
static ffelexHandler
ffeexpr_find_close_paren_ (ffelexToken t,
ffelexHandler after)
{
ffeexpr_find_.after = after;
ffeexpr_find_.level = 1;
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
}
static ffelexHandler
ffeexpr_nil_finished_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
if (--ffeexpr_find_.level == 0)
return (ffelexHandler) ffeexpr_find_.after;
return (ffelexHandler) ffeexpr_nil_binary_;
case FFELEX_typeCOMMA:
case FFELEX_typeCOLON:
case FFELEX_typeEQUALS:
case FFELEX_typePOINTS:
return (ffelexHandler) ffeexpr_nil_rhs_;
default:
if (--ffeexpr_find_.level == 0)
return (ffelexHandler) ffeexpr_find_.after (t);
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
}
}
static ffelexHandler
ffeexpr_nil_rhs_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeQUOTE:
if (ffe_is_vxt ())
return (ffelexHandler) ffeexpr_nil_quote_;
ffelex_set_expecting_hollerith (-1, '\"',
ffelex_token_where_line (t),
ffelex_token_where_column (t));
return (ffelexHandler) ffeexpr_nil_apostrophe_;
case FFELEX_typeAPOSTROPHE:
ffelex_set_expecting_hollerith (-1, '\'',
ffelex_token_where_line (t),
ffelex_token_where_column (t));
return (ffelexHandler) ffeexpr_nil_apostrophe_;
case FFELEX_typePERCENT:
return (ffelexHandler) ffeexpr_nil_percent_;
case FFELEX_typeOPEN_PAREN:
++ffeexpr_find_.level;
return (ffelexHandler) ffeexpr_nil_rhs_;
case FFELEX_typePLUS:
case FFELEX_typeMINUS:
return (ffelexHandler) ffeexpr_nil_rhs_;
case FFELEX_typePERIOD:
return (ffelexHandler) ffeexpr_nil_period_;
case FFELEX_typeNUMBER:
ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
if (ffeexpr_hollerith_count_ > 0)
ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
'\0',
ffelex_token_where_line (t),
ffelex_token_where_column (t));
return (ffelexHandler) ffeexpr_nil_number_;
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
return (ffelexHandler) ffeexpr_nil_name_rhs_;
case FFELEX_typeASTERISK:
case FFELEX_typeSLASH:
case FFELEX_typePOWER:
case FFELEX_typeCONCAT:
case FFELEX_typeREL_EQ:
case FFELEX_typeREL_NE:
case FFELEX_typeREL_LE:
case FFELEX_typeREL_GE:
return (ffelexHandler) ffeexpr_nil_rhs_;
default:
return (ffelexHandler) ffeexpr_nil_finished_ (t);
}
}
static ffelexHandler
ffeexpr_nil_period_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherNone:
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
case FFESTR_otherTRUE:
case FFESTR_otherFALSE:
case FFESTR_otherNOT:
return (ffelexHandler) ffeexpr_nil_end_period_;
default:
return (ffelexHandler) ffeexpr_nil_swallow_period_;
}
break;
case FFELEX_typeNUMBER:
return (ffelexHandler) ffeexpr_nil_real_;
default:
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
}
}
static ffelexHandler
ffeexpr_nil_end_period_ (ffelexToken t)
{
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherNOT:
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
return (ffelexHandler) ffeexpr_nil_rhs_;
case FFESTR_otherTRUE:
case FFESTR_otherFALSE:
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
default:
assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
exit (0);
return NULL;
}
}
static ffelexHandler
ffeexpr_nil_swallow_period_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
return (ffelexHandler) ffeexpr_nil_rhs_;
}
static ffelexHandler
ffeexpr_nil_real_ (ffelexToken t)
{
char d;
const char *p;
if (((ffelex_token_type (t) != FFELEX_typeNAME)
&& (ffelex_token_type (t) != FFELEX_typeNAMES))
|| !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q')))
&& ffeexpr_isdigits_ (++p)))
return (ffelexHandler) ffeexpr_nil_binary_ (t);
if (*p == '\0')
return (ffelexHandler) ffeexpr_nil_real_exponent_;
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_real_exponent_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
}
static ffelexHandler
ffeexpr_nil_real_exp_sign_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_number_ (ffelexToken t)
{
char d;
const char *p;
if (ffeexpr_hollerith_count_ > 0)
ffelex_set_expecting_hollerith (0, '\0',
ffewhere_line_unknown (),
ffewhere_column_unknown ());
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q'))
&& ffeexpr_isdigits_ (++p))
{
if (*p == '\0')
{
ffeexpr_find_.t = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_nil_number_exponent_;
}
return (ffelexHandler) ffeexpr_nil_binary_;
}
break;
case FFELEX_typePERIOD:
ffeexpr_find_.t = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_nil_number_period_;
case FFELEX_typeHOLLERITH:
return (ffelexHandler) ffeexpr_nil_binary_;
default:
break;
}
return (ffelexHandler) ffeexpr_nil_binary_ (t);
}
static ffelexHandler
ffeexpr_nil_number_exponent_ (ffelexToken t)
{
ffelexHandler nexthandler;
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
{
nexthandler
= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) (*nexthandler) (t);
}
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
}
static ffelexHandler
ffeexpr_nil_number_exp_sign_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_number_period_ (ffelexToken t)
{
ffelexHandler nexthandler;
char d;
const char *p;
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q'))
&& ffeexpr_isdigits_ (++p))
{
if (*p == '\0')
return (ffelexHandler) ffeexpr_nil_number_per_exp_;
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
nexthandler
= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) (*nexthandler) (t);
case FFELEX_typeNUMBER:
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) ffeexpr_nil_number_real_;
default:
break;
}
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) ffeexpr_nil_binary_ (t);
}
static ffelexHandler
ffeexpr_nil_number_per_exp_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
{
ffelexHandler nexthandler;
nexthandler
= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) (*nexthandler) (t);
}
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
}
static ffelexHandler
ffeexpr_nil_number_real_ (ffelexToken t)
{
char d;
const char *p;
if (((ffelex_token_type (t) != FFELEX_typeNAME)
&& (ffelex_token_type (t) != FFELEX_typeNAMES))
|| !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q')))
&& ffeexpr_isdigits_ (++p)))
return (ffelexHandler) ffeexpr_nil_binary_ (t);
if (*p == '\0')
return (ffelexHandler) ffeexpr_nil_number_real_exp_;
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_number_real_exp_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
}
static ffelexHandler
ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_binary_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typePLUS:
case FFELEX_typeMINUS:
case FFELEX_typeASTERISK:
case FFELEX_typeSLASH:
case FFELEX_typePOWER:
case FFELEX_typeCONCAT:
case FFELEX_typeOPEN_ANGLE:
case FFELEX_typeCLOSE_ANGLE:
case FFELEX_typeREL_EQ:
case FFELEX_typeREL_NE:
case FFELEX_typeREL_GE:
case FFELEX_typeREL_LE:
return (ffelexHandler) ffeexpr_nil_rhs_;
case FFELEX_typePERIOD:
return (ffelexHandler) ffeexpr_nil_binary_period_;
default:
return (ffelexHandler) ffeexpr_nil_finished_ (t);
}
}
static ffelexHandler
ffeexpr_nil_binary_period_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherTRUE:
case FFESTR_otherFALSE:
case FFESTR_otherNOT:
return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
default:
return (ffelexHandler) ffeexpr_nil_binary_end_per_;
}
break;
default:
return (ffelexHandler) ffeexpr_nil_binary_ (t);
}
}
static ffelexHandler
ffeexpr_nil_binary_end_per_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
return (ffelexHandler) ffeexpr_nil_rhs_;
}
static ffelexHandler
ffeexpr_nil_binary_sw_per_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_quote_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
}
static ffelexHandler
ffeexpr_nil_apostrophe_ (ffelexToken t)
{
assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
return (ffelexHandler) ffeexpr_nil_apos_char_;
}
static ffelexHandler
ffeexpr_nil_apos_char_ (ffelexToken t)
{
char c;
if ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNAMES))
{
if ((ffelex_token_length (t) == 1)
&& (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
'B', 'b')
|| ffesrc_char_match_init (c, 'O', 'o')
|| ffesrc_char_match_init (c, 'X', 'x')
|| ffesrc_char_match_init (c, 'Z', 'z')))
return (ffelexHandler) ffeexpr_nil_binary_;
}
if ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNAMES))
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
return (ffelexHandler) ffeexpr_nil_substrp_ (t);
}
static ffelexHandler
ffeexpr_nil_name_rhs_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeQUOTE:
case FFELEX_typeAPOSTROPHE:
ffelex_set_hexnum (TRUE);
return (ffelexHandler) ffeexpr_nil_name_apos_;
case FFELEX_typeOPEN_PAREN:
++ffeexpr_find_.level;
return (ffelexHandler) ffeexpr_nil_rhs_;
default:
return (ffelexHandler) ffeexpr_nil_binary_ (t);
}
}
static ffelexHandler
ffeexpr_nil_name_apos_ (ffelexToken t)
{
if (ffelex_token_type (t) == FFELEX_typeNAME)
return (ffelexHandler) ffeexpr_nil_name_apos_name_;
return (ffelexHandler) ffeexpr_nil_binary_ (t);
}
static ffelexHandler
ffeexpr_nil_name_apos_name_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeAPOSTROPHE:
case FFELEX_typeQUOTE:
return (ffelexHandler) ffeexpr_nil_finished_;
default:
return (ffelexHandler) ffeexpr_nil_finished_ (t);
}
}
static ffelexHandler
ffeexpr_nil_percent_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_stack_->percent = ffeexpr_percent_ (t);
ffeexpr_find_.t = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_nil_percent_name_;
default:
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
}
}
static ffelexHandler
ffeexpr_nil_percent_name_ (ffelexToken t)
{
ffelexHandler nexthandler;
if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
{
nexthandler
= (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
ffelex_token_kill (ffeexpr_find_.t);
return (ffelexHandler) (*nexthandler) (t);
}
ffelex_token_kill (ffeexpr_find_.t);
++ffeexpr_find_.level;
return (ffelexHandler) ffeexpr_nil_rhs_;
}
static ffelexHandler
ffeexpr_nil_substrp_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
++ffeexpr_find_.level;
return (ffelexHandler) ffeexpr_nil_rhs_;
}
static ffelexHandler
ffeexpr_finished_ (ffelexToken t)
{
ffeexprExpr_ operand;
ffebld expr;
ffeexprCallback callback;
ffeexprStack_ s;
ffebldConstant constnode;
ffelexToken ft;
ffelexHandler next;
ffeinfo info;
bool error = FALSE;
while (((operand = ffeexpr_stack_->exprstack) != NULL)
&& ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
{
if (operand->type == FFEEXPR_exprtypeOPERAND_)
ffeexpr_reduce_ ();
else
{
if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
ffebad_finish ();
}
ffeexpr_stack_->exprstack = operand->previous;
ffeexpr_expr_kill_ (operand);
}
}
assert ((operand == NULL) || (operand->previous == NULL));
ffebld_pool_pop ();
if (operand == NULL)
expr = NULL;
else
{
expr = operand->u.operand;
info = ffebld_info (expr);
if ((ffebld_op (expr) == FFEBLD_opCONTER)
&& (ffebld_conter_orig (expr) == NULL)
&& ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
{
ffetarget_integer_bad_magical (operand->token);
}
ffeexpr_expr_kill_ (operand);
ffeexpr_stack_->exprstack = NULL;
}
ft = ffeexpr_stack_->first_token;
again:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextLET:
case FFEEXPR_contextSFUNCDEF:
error = (expr == NULL)
|| (ffeinfo_rank (info) != 0);
break;
case FFEEXPR_contextPAREN_:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
break;
}
break;
case FFEEXPR_contextPARENFILENUM_:
if (ffelex_token_type (t) != FFELEX_typeCOMMA)
ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
else
ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
goto again;
case FFEEXPR_contextPARENFILEUNIT_:
if (ffelex_token_type (t) != FFELEX_typeCOMMA)
ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
else
ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
goto again;
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
if (!ffe_is_ugly_args ()
&& ffebad_start (FFEBAD_ACTUALARG))
{
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
break;
default:
break;
}
error = (expr != NULL) && (ffeinfo_rank (info) != 0);
break;
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextSFUNCDEFACTUALARG_:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
#if 0
expr = ffeexpr_convert (expr, ft, ft,
FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT,
0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
#else
assert ("why hollerith/typeless in actualarg_?" == NULL);
#endif
break;
default:
break;
}
switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
{
case FFEBLD_opSYMTER:
case FFEBLD_opPERCENT_LOC:
case FFEBLD_opPERCENT_VAL:
case FFEBLD_opPERCENT_REF:
case FFEBLD_opPERCENT_DESCR:
error = FALSE;
break;
default:
error = (expr != NULL) && (ffeinfo_rank (info) != 0);
break;
}
{
ffesymbol s;
ffeinfoWhere where;
ffeinfoKind kind;
if (!error
&& (expr != NULL)
&& (ffebld_op (expr) == FFEBLD_opSYMTER)
&& ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
(where == FFEINFO_whereINTRINSIC)
|| (where == FFEINFO_whereGLOBAL)
|| ((where == FFEINFO_whereDUMMY)
&& ((kind = ffesymbol_kind (s)),
(kind == FFEINFO_kindFUNCTION)
|| (kind == FFEINFO_kindSUBROUTINE))))
&& !ffesymbol_explicitwhere (s))
{
ffebad_start (where == FFEINFO_whereINTRINSIC
? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_string (ffesymbol_text (s));
ffebad_finish ();
ffesymbol_signal_change (s);
ffesymbol_set_explicitwhere (s, TRUE);
ffesymbol_signal_unreported (s);
}
}
break;
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextSFUNCDEFINDEX_:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeNONE:
error = FALSE;
break;
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeINTEGER:
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextRETURN:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeNONE:
error = FALSE;
break;
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextDO:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
error = !ffe_is_ugly_logint ();
if (!ffeexpr_stack_->is_rhs)
break;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
ffeinfo_kindtype (ffebld_info (expr)), 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
if (!ffeexpr_stack_->is_rhs)
{
error = TRUE;
break;
}
break;
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeREAL:
break;
default:
error = TRUE;
break;
}
if (!ffeexpr_stack_->is_rhs
&& (ffebld_op (expr) != FFEBLD_opSYMTER))
error = TRUE;
break;
case FFEEXPR_contextDOWHILE:
case FFEEXPR_contextIF:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeLOGICAL:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextASSIGN:
case FFEEXPR_contextAGOTO:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
break;
case FFEINFO_basictypeLOGICAL:
error = !ffe_is_ugly_logint ()
|| (ffeinfo_kindtype (info) != ffecom_label_kind ());
break;
default:
error = TRUE;
break;
}
if ((expr == NULL) || (ffeinfo_rank (info) != 0)
|| (ffebld_op (expr) != FFEBLD_opSYMTER))
error = TRUE;
break;
case FFEEXPR_contextCGOTO:
case FFEEXPR_contextFORMAT:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextFILENUM:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextARITHIF:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeREAL:
error = FALSE;
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextSTOP:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
break;
case FFEINFO_basictypeCHARACTER:
error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
break;
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeNONE:
error = FALSE;
break;
default:
error = TRUE;
break;
}
if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
|| (ffebld_conter_orig (expr) != NULL)))
error = TRUE;
break;
case FFEEXPR_contextINCLUDE:
error = (expr == NULL) || (ffeinfo_rank (info) != 0)
|| (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
|| (ffebld_op (expr) != FFEBLD_opCONTER)
|| (ffebld_conter_orig (expr) != NULL);
break;
case FFEEXPR_contextSELECTCASE:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeCHARACTER:
case FFEINFO_basictypeLOGICAL:
error = FALSE;
break;
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextCASE:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeCHARACTER:
case FFEINFO_basictypeLOGICAL:
error = FALSE;
break;
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
error = TRUE;
break;
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextDIMLISTCOMMON:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
error = TRUE;
break;
case FFEEXPR_contextEQVINDEX_:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeNONE:
error = FALSE;
break;
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
error = TRUE;
break;
case FFEEXPR_contextPARAMETER:
if (ffeexpr_stack_->is_rhs)
error = (expr == NULL) || (ffeinfo_rank (info) != 0)
|| (ffebld_op (expr) != FFEBLD_opCONTER);
else
error = (expr == NULL) || (ffeinfo_rank (info) != 0)
|| (ffebld_op (expr) != FFEBLD_opSYMTER);
break;
case FFEEXPR_contextINDEXORACTUALARG_:
if (ffelex_token_type (t) == FFELEX_typeCOLON)
ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
else
ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
goto again;
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
if (ffelex_token_type (t) == FFELEX_typeCOLON)
ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
else
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
goto again;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
if (ffelex_token_type (t) == FFELEX_typeCOLON)
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
else
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
goto again;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
if (ffelex_token_type (t) == FFELEX_typeCOLON)
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
else
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
goto again;
case FFEEXPR_contextIMPDOCTRL_:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
if (!ffeexpr_stack_->is_rhs
&& (ffebld_op (expr) != FFEBLD_opSYMTER))
error = TRUE;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
if (! ffe_is_ugly_logint ())
error = TRUE;
if (! ffeexpr_stack_->is_rhs)
break;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
ffeinfo_kindtype (info), 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
break;
case FFEINFO_basictypeREAL:
if (!ffeexpr_stack_->is_rhs
&& ffe_is_warn_surprising ()
&& !error)
{
ffebad_start (FFEBAD_DO_REAL);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_string (ffelex_token_text (ft));
ffebad_finish ();
}
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextDATAIMPDOCTRL_:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
if (ffeexpr_stack_->is_rhs)
{
if ((ffebld_op (expr) != FFEBLD_opCONTER)
&& (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
error = TRUE;
}
else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
|| (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
error = TRUE;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
if (! ffeexpr_stack_->is_rhs)
break;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
ffeinfo_kindtype (info), 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeINTEGER:
if (ffeexpr_stack_->is_rhs
&& (ffeinfo_kindtype (ffebld_info (expr))
!= FFEINFO_kindtypeINTEGERDEFAULT))
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeREAL:
if (!ffeexpr_stack_->is_rhs
&& ffe_is_warn_surprising ()
&& !error)
{
ffebad_start (FFEBAD_DO_REAL);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_string (ffelex_token_text (ft));
ffebad_finish ();
}
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextIMPDOITEM_:
if (ffelex_token_type (t) == FFELEX_typeEQUALS)
{
ffeexpr_stack_->is_rhs = FALSE;
ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
goto again;
}
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextFILEVXTCODE:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
break;
}
error = (expr == NULL)
|| ((ffeinfo_rank (info) != 0)
&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
== FFEBLD_opSTAR)));
break;
case FFEEXPR_contextIMPDOITEMDF_:
if (ffelex_token_type (t) == FFELEX_typeEQUALS)
{
ffeexpr_stack_->is_rhs = FALSE;
ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
goto again;
}
case FFEEXPR_contextIOLISTDF:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
break;
}
error
= (expr == NULL)
|| ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
&& (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
|| ((ffeinfo_rank (info) != 0)
&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
== FFEBLD_opSTAR)));
break;
case FFEEXPR_contextDATAIMPDOITEM_:
error = (expr == NULL)
|| (ffebld_op (expr) != FFEBLD_opARRAYREF)
|| ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
&& (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
break;
case FFEEXPR_contextDATAIMPDOINDEX_:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
&& (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
error = TRUE;
break;
case FFEEXPR_contextDATA:
if (expr == NULL)
error = TRUE;
else if (ffeexpr_stack_->is_rhs)
error = (ffebld_op (expr) != FFEBLD_opCONTER);
else if (ffebld_op (expr) == FFEBLD_opSYMTER)
error = FALSE;
else
error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
break;
case FFEEXPR_contextINITVAL:
error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
break;
case FFEEXPR_contextEQUIVALENCE:
if (expr == NULL)
error = TRUE;
else if (ffebld_op (expr) == FFEBLD_opSYMTER)
error = FALSE;
else
error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
break;
case FFEEXPR_contextFILEASSOC:
case FFEEXPR_contextFILEINT:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
error = ((! ffeexpr_stack_->is_rhs)
&& ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
break;
default:
error = TRUE;
break;
}
if ((expr == NULL) || (ffeinfo_rank (info) != 0))
error = TRUE;
break;
case FFEEXPR_contextFILEDFINT:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
break;
default:
error = TRUE;
break;
}
if ((expr == NULL) || (ffeinfo_rank (info) != 0))
error = TRUE;
break;
case FFEEXPR_contextFILELOG:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
error = FALSE;
break;
default:
error = TRUE;
break;
}
if ((expr == NULL) || (ffeinfo_rank (info) != 0))
error = TRUE;
break;
case FFEEXPR_contextFILECHAR:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeCHARACTER:
error = FALSE;
break;
default:
error = TRUE;
break;
}
if ((expr == NULL) || (ffeinfo_rank (info) != 0))
error = TRUE;
break;
case FFEEXPR_contextFILENUMCHAR:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeCHARACTER:
error = FALSE;
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextFILEDFCHAR:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
break;
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeCHARACTER:
error
= (ffeinfo_kindtype (info)
!= FFEINFO_kindtypeCHARACTERDEFAULT);
break;
default:
error = TRUE;
break;
}
if (!ffeexpr_stack_->is_rhs
&& (ffebld_op (expr) == FFEBLD_opSUBSTR))
error = TRUE;
break;
case FFEEXPR_contextFILEUNIT:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
if ((error = (ffeinfo_rank (info) != 0)))
break;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if ((error = (ffeinfo_rank (info) != 0)))
break;
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
if ((error = (ffeinfo_rank (info) != 0)))
break;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeCHARACTER:
switch (ffebld_op (expr))
{
case FFEBLD_opSYMTER:
error
= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
break;
case FFEBLD_opSUBSTR:
error = (ffeinfo_where (ffebld_info (expr))
== FFEINFO_whereCONSTANT_SUBOBJECT);
break;
case FFEBLD_opARRAYREF:
error = FALSE;
break;
default:
error = TRUE;
break;
}
if (!error
&& ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
|| ((ffeinfo_rank (info) != 0)
&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
== FFEBLD_opSTAR)))))
error = TRUE;
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextFILEFORMAT:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeINTEGER:
error = (expr == NULL)
|| ((ffeinfo_rank (info) != 0) ?
ffe_is_pedantic ()
: (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
|| (ffebld_op (expr) != FFEBLD_opSYMTER);
break;
case FFEINFO_basictypeLOGICAL:
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
error
= ffe_is_pedantic ()
|| (ffeinfo_rank (info) == 0);
break;
case FFEINFO_basictypeCHARACTER:
if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
|| ((ffeinfo_rank (info) != 0)
&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
== FFEBLD_opSTAR))))
error = TRUE;
else
error = FALSE;
break;
default:
error = TRUE;
break;
}
break;
case FFEEXPR_contextLOC_:
if ((expr == NULL)
|| (ffeinfo_kind (info) != FFEINFO_kindENTITY)
|| ((ffebld_op (expr) != FFEBLD_opSYMTER)
&& (ffebld_op (expr) != FFEBLD_opSUBSTR)
&& (ffebld_op (expr) != FFEBLD_opARRAYREF)))
error = TRUE;
break;
default:
error = FALSE;
break;
}
if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
{
ffebad_start (FFEBAD_EXPR_WRONG);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
expr = ffebld_new_any ();
ffebld_set_info (expr, ffeinfo_new_any ());
}
callback = ffeexpr_stack_->callback;
s = ffeexpr_stack_->previous;
malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
sizeof (*ffeexpr_stack_));
ffeexpr_stack_ = s;
next = (ffelexHandler) (*callback) (ft, expr, t);
ffelex_token_kill (ft);
return (ffelexHandler) next;
}
static ffebld
ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
{
ffeinfo info = ffebld_info (expr);
bool error;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFILENUMAMBIG:
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
default:
error = TRUE;
break;
}
if ((expr == NULL) || (ffeinfo_rank (info) != 0))
error = TRUE;
break;
case FFEEXPR_contextFILEUNITAMBIG:
if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
{
error = FALSE;
break;
}
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = (ffeinfo_rank (info) != 0);
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeCHARACTER:
switch (ffebld_op (expr))
{
case FFEBLD_opSYMTER:
error
= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
break;
case FFEBLD_opSUBSTR:
error = (ffeinfo_where (ffebld_info (expr))
== FFEINFO_whereCONSTANT_SUBOBJECT);
break;
case FFEBLD_opARRAYREF:
error = FALSE;
break;
default:
error = TRUE;
break;
}
break;
default:
error = TRUE;
break;
}
break;
default:
assert ("bad context" == NULL);
error = TRUE;
break;
}
if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
{
ffebad_start (FFEBAD_EXPR_WRONG);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
expr = ffebld_new_any ();
ffebld_set_info (expr, ffeinfo_new_any ());
}
return expr;
}
static ffelexHandler
ffeexpr_token_lhs_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_tokens_[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_name_lhs_;
default:
return (ffelexHandler) ffeexpr_finished_ (t);
}
}
static ffelexHandler
ffeexpr_token_rhs_ (ffelexToken t)
{
ffeexprExpr_ e;
switch (ffelex_token_type (t))
{
case FFELEX_typeQUOTE:
if (ffe_is_vxt ())
{
ffeexpr_tokens_[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_quote_;
}
ffeexpr_tokens_[0] = ffelex_token_use (t);
ffelex_set_expecting_hollerith (-1, '\"',
ffelex_token_where_line (t),
ffelex_token_where_column (t));
return (ffelexHandler) ffeexpr_token_apostrophe_;
case FFELEX_typeAPOSTROPHE:
ffeexpr_tokens_[0] = ffelex_token_use (t);
ffelex_set_expecting_hollerith (-1, '\'',
ffelex_token_where_line (t),
ffelex_token_where_column (t));
return (ffelexHandler) ffeexpr_token_apostrophe_;
case FFELEX_typePERCENT:
ffeexpr_tokens_[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_percent_;
case FFELEX_typeOPEN_PAREN:
ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextPAREN_,
ffeexpr_cb_close_paren_c_);
case FFELEX_typePLUS:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeUNARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorADD_;
e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
e->u.operator.as = FFEEXPR_operatorassociativityADD_;
ffeexpr_exprstack_push_unary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeMINUS:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeUNARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
ffeexpr_exprstack_push_unary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typePERIOD:
ffeexpr_tokens_[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_period_;
case FFELEX_typeNUMBER:
ffeexpr_tokens_[0] = ffelex_token_use (t);
ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
if (ffeexpr_hollerith_count_ > 0)
ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
'\0',
ffelex_token_where_line (t),
ffelex_token_where_column (t));
return (ffelexHandler) ffeexpr_token_number_;
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_tokens_[0] = ffelex_token_use (t);
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextINDEXORACTUALARG_:
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
return (ffelexHandler) ffeexpr_token_name_arg_;
default:
return (ffelexHandler) ffeexpr_token_name_rhs_;
}
case FFELEX_typeASTERISK:
case FFELEX_typeSLASH:
case FFELEX_typePOWER:
case FFELEX_typeCONCAT:
case FFELEX_typeREL_EQ:
case FFELEX_typeREL_NE:
case FFELEX_typeREL_LE:
case FFELEX_typeREL_GE:
if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
{
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
return (ffelexHandler) ffeexpr_token_rhs_;
#if 0
case FFELEX_typeEQUALS:
case FFELEX_typePOINTS:
case FFELEX_typeCLOSE_ANGLE:
case FFELEX_typeCLOSE_PAREN:
case FFELEX_typeCOMMA:
case FFELEX_typeCOLON:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
#endif
default:
return (ffelexHandler) ffeexpr_finished_ (t);
}
}
static ffelexHandler
ffeexpr_token_period_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherNone:
if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
case FFESTR_otherTRUE:
case FFESTR_otherFALSE:
case FFESTR_otherNOT:
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_end_period_;
default:
if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_swallow_period_;
}
break;
case FFELEX_typeNUMBER:
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_real_;
default:
if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
}
}
static ffelexHandler
ffeexpr_token_end_period_ (ffelexToken t)
{
ffeexprExpr_ e;
if (ffelex_token_type (t) != FFELEX_typePERIOD)
{
if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
ffebad_finish ();
}
}
ffelex_token_kill (ffeexpr_tokens_[1]);
e = ffeexpr_expr_new_ ();
e->token = ffeexpr_tokens_[0];
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherNOT:
e->type = FFEEXPR_exprtypeUNARY_;
e->u.operator.op = FFEEXPR_operatorNOT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
ffeexpr_exprstack_push_unary_ (e);
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_token_rhs_ (t);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFESTR_otherTRUE:
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand
= ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
ffeexpr_exprstack_push_operand_ (e);
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_token_binary_ (t);
return (ffelexHandler) ffeexpr_token_binary_;
case FFESTR_otherFALSE:
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand
= ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
ffeexpr_exprstack_push_operand_ (e);
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_token_binary_ (t);
return (ffelexHandler) ffeexpr_token_binary_;
default:
assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
exit (0);
return NULL;
}
}
static ffelexHandler
ffeexpr_token_swallow_period_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_token_rhs_ (t);
return (ffelexHandler) ffeexpr_token_rhs_;
}
static ffelexHandler
ffeexpr_token_real_ (ffelexToken t)
{
char d;
const char *p;
if (((ffelex_token_type (t) != FFELEX_typeNAME)
&& (ffelex_token_type (t) != FFELEX_typeNAMES))
|| !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q')))
&& ffeexpr_isdigits_ (++p)))
{
#if 0
if (((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNAMES))
&& ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
{
char bad[2];
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
bad[0] = *(p - 1);
bad[1] = '\0';
ffebad_string (bad);
ffebad_finish ();
}
#endif
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
if (*p == '\0')
{
ffeexpr_tokens_[2] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_real_exponent_;
}
ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
t, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_real_exponent_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
{
if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
ffelex_token_where_column (ffeexpr_tokens_[2]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
ffeexpr_tokens_[3] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_real_exp_sign_;
}
static ffelexHandler
ffeexpr_token_real_exp_sign_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
{
if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
ffelex_token_where_column (ffeexpr_tokens_[2]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
ffeexpr_tokens_[3], t);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_number_ (ffelexToken t)
{
ffeexprExpr_ e;
ffeinfo ni;
char d;
const char *p;
if (ffeexpr_hollerith_count_ > 0)
ffelex_set_expecting_hollerith (0, '\0',
ffewhere_line_unknown (),
ffewhere_column_unknown ());
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q'))
&& ffeexpr_isdigits_ (++p))
{
if (*p == '\0')
{
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_number_exponent_;
}
ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_binary_;
}
break;
case FFELEX_typePERIOD:
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_number_period_;
case FFELEX_typeHOLLERITH:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
ffelex_token_length (t));
ffebld_set_info (e->u.operand, ni);
ffeexpr_exprstack_push_operand_ (e);
return (ffelexHandler) ffeexpr_token_binary_;
default:
break;
}
ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
NULL, NULL, NULL);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
static ffelexHandler
ffeexpr_token_number_exponent_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
{
ffeexprExpr_ e;
ffelexHandler nexthandler;
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
(ffeexpr_tokens_[0]));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
ffeexpr_exprstack_push_operand_ (e);
nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) (*nexthandler) (t);
}
ffeexpr_tokens_[2] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_number_exp_sign_;
}
static ffelexHandler
ffeexpr_token_number_exp_sign_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
{
if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
ffelex_token_where_column (ffeexpr_tokens_[1]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
ffeexpr_tokens_[0], NULL, NULL,
ffeexpr_tokens_[1], ffeexpr_tokens_[2],
NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
ffeexpr_tokens_[0], NULL, NULL,
ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_number_period_ (ffelexToken t)
{
ffeexprExpr_ e;
ffelexHandler nexthandler;
const char *p;
char d;
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q'))
&& ffeexpr_isdigits_ (++p))
{
if (*p == '\0')
{
ffeexpr_tokens_[2] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_number_per_exp_;
}
ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
ffeexpr_tokens_[1], NULL, t, NULL,
NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_binary_;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
(ffeexpr_tokens_[0]));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
ffeexpr_exprstack_push_operand_ (e);
nexthandler = (ffelexHandler) ffeexpr_token_binary_
(ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) (*nexthandler) (t);
case FFELEX_typeNUMBER:
ffeexpr_tokens_[2] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_number_real_;
default:
break;
}
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
NULL, NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
static ffelexHandler
ffeexpr_token_number_per_exp_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
{
ffelexHandler nexthandler;
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
NULL, NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) (*nexthandler) (t);
}
ffeexpr_tokens_[3] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
}
static ffelexHandler
ffeexpr_token_number_real_ (ffelexToken t)
{
char d;
const char *p;
if (((ffelex_token_type (t) != FFELEX_typeNAME)
&& (ffelex_token_type (t) != FFELEX_typeNAMES))
|| !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
'D', 'd')
|| ffesrc_char_match_init (d, 'E', 'e')
|| ffesrc_char_match_init (d, 'Q', 'q')))
&& ffeexpr_isdigits_ (++p)))
{
#if 0
if (((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNAMES))
&& ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
{
char bad[2];
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
bad[0] = *(p - 1);
bad[1] = '\0';
ffebad_string (bad);
ffebad_finish ();
}
#endif
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
ffeexpr_tokens_[2], NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
if (*p == '\0')
{
ffeexpr_tokens_[3] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_number_real_exp_;
}
ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
ffeexpr_tokens_[2], t, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
{
if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
ffelex_token_where_column (ffeexpr_tokens_[2]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
NULL, NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_number_real_exp_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typePLUS)
&& (ffelex_token_type (t) != FFELEX_typeMINUS))
{
if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
ffelex_token_where_column (ffeexpr_tokens_[3]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
ffeexpr_tokens_[2], NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
ffeexpr_tokens_[4] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
}
static ffelexHandler
ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
{
if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
ffelex_token_where_column (ffeexpr_tokens_[3]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
ffeexpr_tokens_[2], NULL, NULL, NULL);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
ffelex_token_kill (ffeexpr_tokens_[4]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
ffeexpr_tokens_[0], ffeexpr_tokens_[1],
ffeexpr_tokens_[2], ffeexpr_tokens_[3],
ffeexpr_tokens_[4], t);
ffelex_token_kill (ffeexpr_tokens_[0]);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
ffelex_token_kill (ffeexpr_tokens_[3]);
ffelex_token_kill (ffeexpr_tokens_[4]);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_binary_ (ffelexToken t)
{
ffeexprExpr_ e;
if (!ffeexpr_stack_->is_rhs)
return (ffelexHandler) ffeexpr_finished_ (t);
switch (ffelex_token_type (t))
{
case FFELEX_typePLUS:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorADD_;
e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
e->u.operator.as = FFEEXPR_operatorassociativityADD_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeMINUS:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeASTERISK:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
return (ffelexHandler) ffeexpr_finished_ (t);
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeSLASH:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATA:
return (ffelexHandler) ffeexpr_finished_ (t);
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorDIVIDE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typePOWER:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorPOWER_;
e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeCONCAT:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeOPEN_ANGLE:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFORMAT:
ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
break;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorLT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
e->u.operator.as = FFEEXPR_operatorassociativityLT_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeCLOSE_ANGLE:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFORMAT:
return ffeexpr_finished_ (t);
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorGT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
e->u.operator.as = FFEEXPR_operatorassociativityGT_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeREL_EQ:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFORMAT:
ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
break;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorEQ_;
e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeREL_NE:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFORMAT:
ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
break;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorNE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
e->u.operator.as = FFEEXPR_operatorassociativityNE_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeREL_LE:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFORMAT:
ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
break;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorLE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
e->u.operator.as = FFEEXPR_operatorassociativityLE_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typeREL_GE:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextFORMAT:
ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
break;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorGE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
e->u.operator.as = FFEEXPR_operatorassociativityGE_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_;
case FFELEX_typePERIOD:
ffeexpr_tokens_[0] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_binary_period_;
#if 0
case FFELEX_typeOPEN_PAREN:
case FFELEX_typeCLOSE_PAREN:
case FFELEX_typeEQUALS:
case FFELEX_typePOINTS:
case FFELEX_typeCOMMA:
case FFELEX_typeCOLON:
case FFELEX_typeEOS:
case FFELEX_typeSEMICOLON:
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
#endif
default:
return (ffelexHandler) ffeexpr_finished_ (t);
}
}
static ffelexHandler
ffeexpr_token_binary_period_ (ffelexToken t)
{
ffeexprExpr_ operand;
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherTRUE:
case FFESTR_otherFALSE:
case FFESTR_otherNOT:
if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
{
operand = ffeexpr_stack_->exprstack;
assert (operand != NULL);
assert (operand->type == FFEEXPR_exprtypeOPERAND_);
ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
ffebad_here (1, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_binary_sw_per_;
default:
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_binary_end_per_;
}
break;
default:
if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
}
static ffelexHandler
ffeexpr_token_binary_end_per_ (ffelexToken t)
{
ffeexprExpr_ e;
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffeexpr_tokens_[0];
switch (ffeexpr_current_dotdot_)
{
case FFESTR_otherAND:
e->u.operator.op = FFEEXPR_operatorAND_;
e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
e->u.operator.as = FFEEXPR_operatorassociativityAND_;
break;
case FFESTR_otherOR:
e->u.operator.op = FFEEXPR_operatorOR_;
e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
e->u.operator.as = FFEEXPR_operatorassociativityOR_;
break;
case FFESTR_otherXOR:
e->u.operator.op = FFEEXPR_operatorXOR_;
e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
break;
case FFESTR_otherEQV:
e->u.operator.op = FFEEXPR_operatorEQV_;
e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
break;
case FFESTR_otherNEQV:
e->u.operator.op = FFEEXPR_operatorNEQV_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
break;
case FFESTR_otherLT:
e->u.operator.op = FFEEXPR_operatorLT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
e->u.operator.as = FFEEXPR_operatorassociativityLT_;
break;
case FFESTR_otherLE:
e->u.operator.op = FFEEXPR_operatorLE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
e->u.operator.as = FFEEXPR_operatorassociativityLE_;
break;
case FFESTR_otherEQ:
e->u.operator.op = FFEEXPR_operatorEQ_;
e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
break;
case FFESTR_otherNE:
e->u.operator.op = FFEEXPR_operatorNE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
e->u.operator.as = FFEEXPR_operatorassociativityNE_;
break;
case FFESTR_otherGT:
e->u.operator.op = FFEEXPR_operatorGT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
e->u.operator.as = FFEEXPR_operatorassociativityGT_;
break;
case FFESTR_otherGE:
e->u.operator.op = FFEEXPR_operatorGE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
e->u.operator.as = FFEEXPR_operatorassociativityGE_;
break;
default:
if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
ffebad_finish ();
}
e->u.operator.op = FFEEXPR_operatorEQ_;
e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
break;
}
ffeexpr_exprstack_push_binary_ (e);
if (ffelex_token_type (t) != FFELEX_typePERIOD)
{
if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
}
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_rhs_;
}
static ffelexHandler
ffeexpr_token_binary_sw_per_ (ffelexToken t)
{
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_token_binary_ (t);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_quote_ (ffelexToken t)
{
ffeexprExpr_ e;
ffebld anyexpr;
if (ffelex_token_type (t) != FFELEX_typeNUMBER)
{
if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
}
anyexpr = ffebld_new_any ();
ffebld_set_info (anyexpr, ffeinfo_new_any ());
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
e->u.operand = ffebld_new_conter_with_orig
(ffebld_constant_new_integeroctal (t), anyexpr);
ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
ffeexpr_exprstack_push_operand_ (e);
return (ffelexHandler) ffeexpr_token_binary_;
}
static ffelexHandler
ffeexpr_token_apostrophe_ (ffelexToken t)
{
assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
{
ffebad_start (FFEBAD_NULL_CHAR_CONST);
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_apos_char_;
}
static ffelexHandler
ffeexpr_token_apos_char_ (ffelexToken t)
{
ffeexprExpr_ e;
ffeinfo ni;
char c;
ffetargetCharacterSize size;
if ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNAMES))
{
if ((ffelex_token_length (t) == 1)
&& (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
'b')
|| ffesrc_char_match_init (c, 'O', 'o')
|| ffesrc_char_match_init (c, 'X', 'x')
|| ffesrc_char_match_init (c, 'Z', 'z')))
{
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
switch (c)
{
case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
e->u.operand = ffebld_new_conter
(ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
break;
case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
e->u.operand = ffebld_new_conter
(ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
break;
case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
e->u.operand = ffebld_new_conter
(ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
break;
case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
e->u.operand = ffebld_new_conter
(ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
break;
default:
no_match:
assert ("not BOXZ!" == NULL);
size = 0;
break;
}
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
ffeexpr_exprstack_push_operand_ (e);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) ffeexpr_token_binary_;
}
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
(ffeexpr_tokens_[1]));
ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
ffelex_token_length (ffeexpr_tokens_[1]));
ffebld_set_info (e->u.operand, ni);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffeexpr_exprstack_push_operand_ (e);
if ((ffelex_token_type (t) == FFELEX_typeNAME)
|| (ffelex_token_type (t) == FFELEX_typeNAMES))
{
if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
{
ffebad_string (ffelex_token_text (t));
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_finish ();
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffelex_token_use (t);
e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
ffeexpr_exprstack_push_binary_ (e);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
}
ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();
return (ffelexHandler) ffeexpr_token_substrp_ (t);
}
static ffelexHandler
ffeexpr_token_name_lhs_ (ffelexToken t)
{
ffeexprExpr_ e;
ffeexprParenType_ paren_type;
ffesymbol s;
ffebld expr;
ffeinfo info;
switch (ffelex_token_type (t))
{
case FFELEX_typeOPEN_PAREN:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextASSIGN:
case FFEEXPR_contextAGOTO:
case FFEEXPR_contextFILEUNIT_DF:
goto just_name;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffelex_token_use (ffeexpr_tokens_[0]);
s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
&paren_type);
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
case FFEINFO_whereINTRINSIC:
case FFEINFO_whereGLOBAL:
if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
case FFEINFO_whereCOMMON:
case FFEINFO_whereDUMMY:
case FFEINFO_whereRESULT:
break;
case FFEINFO_whereNONE:
case FFEINFO_whereANY:
break;
default:
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
}
if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
{
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
}
else
{
e->u.operand = ffebld_new_symter (s,
ffesymbol_generic (s),
ffesymbol_specific (s),
ffesymbol_implementation (s));
ffebld_set_info (e->u.operand, ffesymbol_info (s));
}
ffeexpr_exprstack_push_ (e);
ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
switch (paren_type)
{
case FFEEXPR_parentypeSUBROUTINE_:
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextACTUALARG_,
ffeexpr_token_arguments_);
case FFEEXPR_parentypeARRAY_:
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
ffeexpr_stack_->bound_list = ffesymbol_dims (s);
ffeexpr_stack_->rank = 0;
ffeexpr_stack_->constant = TRUE;
ffeexpr_stack_->immediate = TRUE;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextDATAIMPDOITEM_:
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextDATAIMPDOINDEX_,
ffeexpr_token_elements_);
case FFEEXPR_contextEQUIVALENCE:
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextEQVINDEX_,
ffeexpr_token_elements_);
default:
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextINDEX_,
ffeexpr_token_elements_);
}
case FFEEXPR_parentypeSUBSTRING_:
e->u.operand = ffeexpr_collapse_symter (e->u.operand,
ffeexpr_tokens_[0]);
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextINDEX_,
ffeexpr_token_substring_);
case FFEEXPR_parentypeEQUIVALENCE_:
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
ffeexpr_stack_->bound_list = ffesymbol_dims (s);
ffeexpr_stack_->rank = 0;
ffeexpr_stack_->constant = TRUE;
ffeexpr_stack_->immediate = TRUE;
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextEQVINDEX_,
ffeexpr_token_equivalence_);
case FFEEXPR_parentypeFUNCTION_:
case FFEEXPR_parentypeFUNSUBSTR_:
ffesymbol_error (s, ffeexpr_tokens_[0]);
case FFEEXPR_parentypeANY_:
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextACTUALARG_,
ffeexpr_token_anything_);
default:
assert ("bad paren type" == NULL);
break;
}
case FFELEX_typeEQUALS:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
break;
case FFEEXPR_contextDATAIMPDOITEM_:
ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
break;
default:
break;
}
break;
#if 0
case FFELEX_typePERIOD:
case FFELEX_typePERCENT:
assert ("FOO%, FOO. not yet supported!~~" == NULL);
break;
#endif
default:
break;
}
just_name:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
(ffeexpr_stack_->context
== FFEEXPR_contextSUBROUTINEREF));
switch (ffesymbol_where (s))
{
case FFEINFO_whereCONSTANT:
if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
|| (ffesymbol_kind (s) != FFEINFO_kindENTITY))
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
case FFEINFO_whereIMMEDIATE:
if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
&& (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
case FFEINFO_whereLOCAL:
if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
case FFEINFO_whereINTRINSIC:
if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
ffesymbol_error (s, ffeexpr_tokens_[0]);
break;
default:
break;
}
if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
{
expr = ffebld_new_any ();
info = ffeinfo_new_any ();
ffebld_set_info (expr, info);
}
else
{
expr = ffebld_new_symter (s,
ffesymbol_generic (s),
ffesymbol_specific (s),
ffesymbol_implementation (s));
info = ffesymbol_info (s);
ffebld_set_info (expr, info);
if (ffesymbol_is_doiter (s))
{
ffebad_start (FFEBAD_DOITER);
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffest_ffebad_here_doiter (1, s);
ffebad_string (ffesymbol_text (s));
ffebad_finish ();
}
expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
}
if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
{
if (ffebld_op (expr) == FFEBLD_opANY)
{
expr = ffebld_new_any ();
ffebld_set_info (expr, ffeinfo_new_any ());
}
else
{
expr = ffebld_new_subrref (expr, NULL);
if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
ffeintrin_fulfill_generic (&expr, &info, e->token);
else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
else
ffeexpr_fulfill_call_ (&expr, e->token);
if (ffebld_op (expr) != FFEBLD_opANY)
ffebld_set_info (expr,
ffeinfo_new (ffeinfo_basictype (info),
ffeinfo_kindtype (info),
0,
FFEINFO_kindENTITY,
FFEINFO_whereFLEETING,
ffeinfo_size (info)));
else
ffebld_set_info (expr, ffeinfo_new_any ());
}
}
e->u.operand = expr;
ffeexpr_exprstack_push_operand_ (e);
return (ffelexHandler) ffeexpr_finished_ (t);
}
static ffelexHandler
ffeexpr_token_name_arg_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeCLOSE_PAREN:
case FFELEX_typeCOMMA:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
break;
default:
break;
}
break;
default:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
break;
case FFEEXPR_contextINDEXORACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
break;
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
ffeexpr_stack_->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
break;
default:
assert ("bad context in _name_arg_" == NULL);
break;
}
break;
}
return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
}
static ffelexHandler
ffeexpr_token_name_rhs_ (ffelexToken t)
{
ffeexprExpr_ e;
ffeexprParenType_ paren_type;
ffesymbol s;
bool sfdef;
switch (ffelex_token_type (t))
{
case FFELEX_typeQUOTE:
case FFELEX_typeAPOSTROPHE:
ffeexpr_tokens_[1] = ffelex_token_use (t);
ffelex_set_hexnum (TRUE);
return (ffelexHandler) ffeexpr_token_name_apos_;
case FFELEX_typeOPEN_PAREN:
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffelex_token_use (ffeexpr_tokens_[0]);
s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
&paren_type);
if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
e->u.operand = ffebld_new_any ();
else
e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
ffesymbol_specific (s),
ffesymbol_implementation (s));
ffeexpr_exprstack_push_ (e);
ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
sfdef = TRUE;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
assert ("weird context!" == NULL);
sfdef = FALSE;
break;
default:
sfdef = FALSE;
break;
}
switch (paren_type)
{
case FFEEXPR_parentypeFUNCTION_:
ffebld_set_info (e->u.operand, ffesymbol_info (s));
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
{
ffeexpr_stack_->num_args
= ffebld_list_length
(ffeexpr_stack_->next_dummy
= ffesymbol_dummyargs (s));
ffeexpr_stack_->tokens[1] = NULL;
}
else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
&& !ffe_is_pedantic_not_90 ()
&& ((ffesymbol_implementation (s)
== FFEINTRIN_impICHAR)
|| (ffesymbol_implementation (s)
== FFEINTRIN_impIACHAR)
|| (ffesymbol_implementation (s)
== FFEINTRIN_impLEN)))
{
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
sfdef
? FFEEXPR_contextSFUNCDEF
: FFEEXPR_contextLET,
ffeexpr_token_arguments_);
}
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
sfdef
? FFEEXPR_contextSFUNCDEFACTUALARG_
: FFEEXPR_contextACTUALARG_,
ffeexpr_token_arguments_);
case FFEEXPR_parentypeARRAY_:
ffebld_set_info (e->u.operand,
ffesymbol_info (ffebld_symter (e->u.operand)));
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
ffeexpr_stack_->bound_list = ffesymbol_dims (s);
ffeexpr_stack_->rank = 0;
ffeexpr_stack_->constant = TRUE;
ffeexpr_stack_->immediate = TRUE;
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
sfdef
? FFEEXPR_contextSFUNCDEFINDEX_
: FFEEXPR_contextINDEX_,
ffeexpr_token_elements_);
case FFEEXPR_parentypeSUBSTRING_:
ffebld_set_info (e->u.operand,
ffesymbol_info (ffebld_symter (e->u.operand)));
e->u.operand = ffeexpr_collapse_symter (e->u.operand,
ffeexpr_tokens_[0]);
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
sfdef
? FFEEXPR_contextSFUNCDEFINDEX_
: FFEEXPR_contextINDEX_,
ffeexpr_token_substring_);
case FFEEXPR_parentypeFUNSUBSTR_:
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
sfdef
? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
: FFEEXPR_contextINDEXORACTUALARG_,
ffeexpr_token_funsubstr_);
case FFEEXPR_parentypeANY_:
ffebld_set_info (e->u.operand, ffesymbol_info (s));
return
(ffelexHandler)
ffeexpr_rhs (ffeexpr_stack_->pool,
sfdef
? FFEEXPR_contextSFUNCDEFACTUALARG_
: FFEEXPR_contextACTUALARG_,
ffeexpr_token_anything_);
default:
assert ("bad paren type" == NULL);
break;
}
case FFELEX_typeEQUALS:
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
ffeexpr_stack_->is_rhs = FALSE;
ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
break;
default:
break;
}
break;
#if 0
case FFELEX_typePERIOD:
case FFELEX_typePERCENT:
~~Support these two someday, though not required
assert ("FOO%, FOO. not yet supported!~~" == NULL);
break;
#endif
default:
break;
}
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextINDEXORACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
assert ("strange context" == NULL);
break;
default:
break;
}
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
{
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
}
else
{
e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
ffesymbol_specific (s),
ffesymbol_implementation (s));
if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
else
{
ffebld_set_info (e->u.operand, ffeinfo_new
(ffeintrin_basictype (ffesymbol_specific (s)),
ffeintrin_kindtype (ffesymbol_specific (s)),
0,
ffesymbol_kind (s),
ffesymbol_where (s),
FFETARGET_charactersizeNONE));
}
if (ffesymbol_is_doiter (s))
ffebld_symter_set_is_doiter (e->u.operand, TRUE);
e->u.operand = ffeexpr_collapse_symter (e->u.operand,
ffeexpr_tokens_[0]);
}
ffeexpr_exprstack_push_operand_ (e);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
static ffelexHandler
ffeexpr_token_name_apos_ (ffelexToken t)
{
ffeexprExpr_ e;
ffelex_set_hexnum (FALSE);
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
ffeexpr_tokens_[2] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_name_apos_name_;
default:
break;
}
if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
{
ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[1]);
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
e->token = ffeexpr_tokens_[0];
ffeexpr_exprstack_push_operand_ (e);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
static ffelexHandler
ffeexpr_token_name_apos_name_ (ffelexToken t)
{
ffeexprExpr_ e;
char c;
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
e->token = ffeexpr_tokens_[0];
if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
&& (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
&& (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
'B', 'b')
|| ffesrc_char_match_init (c, 'O', 'o')
|| ffesrc_char_match_init (c, 'X', 'x')
|| ffesrc_char_match_init (c, 'Z', 'z')))
{
ffetargetCharacterSize size;
if (!ffe_is_typeless_boz ()) {
switch (c)
{
case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
(ffeexpr_tokens_[2]));
break;
case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
(ffeexpr_tokens_[2]));
break;
case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
(ffeexpr_tokens_[2]));
break;
case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
(ffeexpr_tokens_[2]));
break;
default:
no_imatch:
assert ("not BOXZ!" == NULL);
abort ();
}
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
ffeexpr_exprstack_push_operand_ (e);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_;
}
switch (c)
{
case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
(ffeexpr_tokens_[2]));
size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
break;
case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
(ffeexpr_tokens_[2]));
size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
break;
case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
(ffeexpr_tokens_[2]));
size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
break;
case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
(ffeexpr_tokens_[2]));
size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
break;
default:
no_match:
assert ("not BOXZ!" == NULL);
e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
(ffeexpr_tokens_[2]));
size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
break;
}
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
ffeexpr_exprstack_push_operand_ (e);
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
return (ffelexHandler) ffeexpr_token_binary_;
}
if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
{
ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[2]);
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
e->token = ffeexpr_tokens_[0];
ffeexpr_exprstack_push_operand_ (e);
switch (ffelex_token_type (t))
{
case FFELEX_typeAPOSTROPHE:
case FFELEX_typeQUOTE:
return (ffelexHandler) ffeexpr_token_binary_;
default:
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
}
static ffelexHandler
ffeexpr_token_percent_ (ffelexToken t)
{
switch (ffelex_token_type (t))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
ffeexpr_stack_->percent = ffeexpr_percent_ (t);
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_percent_name_;
default:
if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
}
}
static ffelexHandler
ffeexpr_token_percent_name_ (ffelexToken t)
{
ffelexHandler nexthandler;
if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
{
if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
ffelex_token_where_column (ffeexpr_stack_->first_token));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_tokens_[0]);
nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
ffelex_token_kill (ffeexpr_tokens_[1]);
return (ffelexHandler) (*nexthandler) (t);
}
switch (ffeexpr_stack_->percent)
{
default:
if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_where_column (ffeexpr_tokens_[0]));
ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
ffebad_finish ();
}
ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
case FFEEXPR_percentLOC_:
ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
ffelex_token_kill (ffeexpr_tokens_[1]);
ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextLOC_,
ffeexpr_cb_end_loc_);
}
}
static void
ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
ffelexToken decimal, ffelexToken fraction,
ffelexToken exponent, ffelexToken exponent_sign,
ffelexToken exponent_digits)
{
ffeexprExpr_ e;
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeOPERAND_;
if (integer != NULL)
e->token = ffelex_token_use (integer);
else
{
assert (decimal != NULL);
e->token = ffelex_token_use (decimal);
}
switch (exp_letter)
{
#if !FFETARGET_okREALQUAD
case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
{
ffebad_here (0, ffelex_token_where_line (e->token),
ffelex_token_where_column (e->token));
ffebad_finish ();
}
goto match_d;
#endif
case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
break;
case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
break;
#if FFETARGET_okREALQUAD
case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
break;
#endif
case 'I':
e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
(ffeexpr_tokens_[0]));
ffebld_set_info (e->u.operand,
ffeinfo_new (FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0,
FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
break;
default:
no_match:
assert ("Lost the exponent letter!" == NULL);
}
ffeexpr_exprstack_push_operand_ (e);
}
static ffesymbol
ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
{
ffesymbol s;
ffeinfoKind k;
bool bad;
s = ffesymbol_declare_local (t, maybe_intrin);
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextDATAIMPDOINDEX_:
case FFEEXPR_contextDATAIMPDOCTRL_:
if (ffeexpr_context_outer_ (ffeexpr_stack_)
== FFEEXPR_contextDATAIMPDOINDEX_)
s = ffeexpr_sym_impdoitem_ (s, t);
else
if (ffeexpr_stack_->is_rhs)
s = ffeexpr_sym_impdoitem_ (s, t);
else
s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
|| ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
&& (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
ffesymbol_error (s, t);
return s;
default:
break;
}
switch ((ffesymbol_sfdummyparent (s) == NULL)
? ffesymbol_state (s)
: FFESYMBOL_stateUNDERSTOOD)
{
case FFESYMBOL_stateNONE:
if (!ffest_seen_first_exec ())
goto seen;
case FFESYMBOL_stateUNCERTAIN:
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextSUBROUTINEREF:
s = ffeexpr_sym_lhs_call_ (s, t);
break;
case FFEEXPR_contextFILEEXTFUNC:
s = ffeexpr_sym_lhs_extfunc_ (s, t);
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
case FFEEXPR_contextACTUALARG_:
s = ffeexpr_sym_rhs_actualarg_ (s, t);
break;
case FFEEXPR_contextDATA:
if (ffeexpr_stack_->is_rhs)
s = ffeexpr_sym_rhs_let_ (s, t);
else
s = ffeexpr_sym_lhs_data_ (s, t);
break;
case FFEEXPR_contextDATAIMPDOITEM_:
s = ffeexpr_sym_lhs_data_ (s, t);
break;
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
case FFEEXPR_contextLET:
case FFEEXPR_contextPAREN_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextASSIGN:
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextDO:
case FFEEXPR_contextDOWHILE:
case FFEEXPR_contextAGOTO:
case FFEEXPR_contextCGOTO:
case FFEEXPR_contextIF:
case FFEEXPR_contextARITHIF:
case FFEEXPR_contextFORMAT:
case FFEEXPR_contextSTOP:
case FFEEXPR_contextRETURN:
case FFEEXPR_contextSELECTCASE:
case FFEEXPR_contextCASE:
case FFEEXPR_contextFILEASSOC:
case FFEEXPR_contextFILEINT:
case FFEEXPR_contextFILEDFINT:
case FFEEXPR_contextFILELOG:
case FFEEXPR_contextFILENUM:
case FFEEXPR_contextFILENUMAMBIG:
case FFEEXPR_contextFILECHAR:
case FFEEXPR_contextFILENUMCHAR:
case FFEEXPR_contextFILEDFCHAR:
case FFEEXPR_contextFILEKEY:
case FFEEXPR_contextFILEUNIT:
case FFEEXPR_contextFILEUNIT_DF:
case FFEEXPR_contextFILEUNITAMBIG:
case FFEEXPR_contextFILEFORMAT:
case FFEEXPR_contextFILENAMELIST:
case FFEEXPR_contextFILEVXTCODE:
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
case FFEEXPR_contextIMPDOCTRL_:
case FFEEXPR_contextLOC_:
if (ffeexpr_stack_->is_rhs)
s = ffeexpr_sym_rhs_let_ (s, t);
else
s = ffeexpr_sym_lhs_let_ (s, t);
break;
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextEQUIVALENCE:
case FFEEXPR_contextINCLUDE:
case FFEEXPR_contextPARAMETER:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
break;
default:
ffesymbol_error (s, t);
break;
}
case FFESYMBOL_stateUNDERSTOOD:
understood:
k = ffesymbol_kind (s);
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextSUBROUTINEREF:
bad = ((k != FFEINFO_kindSUBROUTINE)
&& ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
|| (k != FFEINFO_kindNONE)));
break;
case FFEEXPR_contextFILEEXTFUNC:
bad = (k != FFEINFO_kindFUNCTION)
|| (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextACTUALARG_:
switch (k)
{
case FFEINFO_kindENTITY:
bad = FALSE;
break;
case FFEINFO_kindFUNCTION:
case FFEINFO_kindSUBROUTINE:
bad
= ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
&& (ffesymbol_where (s) != FFEINFO_whereDUMMY)
&& ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
|| !ffeintrin_is_actualarg (ffesymbol_specific (s))));
break;
case FFEINFO_kindNONE:
if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
{
bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
break;
}
if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE))
== FFESYMBOL_attrsEXTERNAL)
bad = FALSE;
else
bad = TRUE;
break;
default:
bad = TRUE;
break;
}
break;
case FFEEXPR_contextDATA:
if (ffeexpr_stack_->is_rhs)
bad = (k != FFEINFO_kindENTITY)
|| (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
else
bad = (k != FFEINFO_kindENTITY)
|| ((ffesymbol_where (s) != FFEINFO_whereNONE)
&& (ffesymbol_where (s) != FFEINFO_whereLOCAL)
&& (ffesymbol_where (s) != FFEINFO_whereCOMMON));
break;
case FFEEXPR_contextDATAIMPDOITEM_:
bad = TRUE;
break;
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
case FFEEXPR_contextLET:
case FFEEXPR_contextPAREN_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextASSIGN:
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextDO:
case FFEEXPR_contextDOWHILE:
case FFEEXPR_contextAGOTO:
case FFEEXPR_contextCGOTO:
case FFEEXPR_contextIF:
case FFEEXPR_contextARITHIF:
case FFEEXPR_contextFORMAT:
case FFEEXPR_contextSTOP:
case FFEEXPR_contextRETURN:
case FFEEXPR_contextSELECTCASE:
case FFEEXPR_contextCASE:
case FFEEXPR_contextFILEASSOC:
case FFEEXPR_contextFILEINT:
case FFEEXPR_contextFILEDFINT:
case FFEEXPR_contextFILELOG:
case FFEEXPR_contextFILENUM:
case FFEEXPR_contextFILENUMAMBIG:
case FFEEXPR_contextFILECHAR:
case FFEEXPR_contextFILENUMCHAR:
case FFEEXPR_contextFILEDFCHAR:
case FFEEXPR_contextFILEKEY:
case FFEEXPR_contextFILEUNIT:
case FFEEXPR_contextFILEUNIT_DF:
case FFEEXPR_contextFILEUNITAMBIG:
case FFEEXPR_contextFILEFORMAT:
case FFEEXPR_contextFILENAMELIST:
case FFEEXPR_contextFILEVXTCODE:
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
case FFEEXPR_contextIMPDOCTRL_:
case FFEEXPR_contextLOC_:
bad = (k != FFEINFO_kindENTITY);
break;
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextEQUIVALENCE:
case FFEEXPR_contextPARAMETER:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
bad = (k != FFEINFO_kindENTITY)
|| (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
break;
case FFEEXPR_contextINCLUDE:
bad = TRUE;
break;
default:
bad = TRUE;
break;
}
if (bad && (k != FFEINFO_kindANY))
ffesymbol_error (s, t);
return s;
case FFESYMBOL_stateSEEN:
seen:
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextPARAMETER:
if (ffeexpr_stack_->is_rhs)
ffesymbol_error (s, t);
else
s = ffeexpr_sym_lhs_parameter_ (s, t);
break;
case FFEEXPR_contextDATA:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
if (ffeexpr_stack_->is_rhs)
ffesymbol_error (s, t);
else
s = ffeexpr_sym_lhs_data_ (s, t);
goto understood;
case FFEEXPR_contextDATAIMPDOITEM_:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
s = ffeexpr_sym_lhs_data_ (s, t);
goto understood;
case FFEEXPR_contextEQUIVALENCE:
s = ffeexpr_sym_lhs_equivalence_ (s, t);
break;
case FFEEXPR_contextDIMLIST:
s = ffeexpr_sym_rhs_dimlist_ (s, t);
break;
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
ffesymbol_error (s, t);
break;
case FFEEXPR_contextINCLUDE:
ffesymbol_error (s, t);
break;
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextSFUNCDEFACTUALARG_:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
s = ffeexpr_sym_rhs_actualarg_ (s, t);
goto understood;
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
assert (ffeexpr_stack_->is_rhs);
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
s = ffeexpr_sym_rhs_let_ (s, t);
goto understood;
default:
ffesymbol_error (s, t);
break;
}
return s;
default:
assert ("bad symbol state" == NULL);
return NULL;
break;
}
}
static ffesymbol
ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
{
ffesymbol s;
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffesymbolState ss;
ffesymbolState ns;
ffeinfoKind kind;
ffeinfoWhere where;
ss = ffesymbol_state (sp);
if (ffesymbol_sfdummyparent (sp) != NULL)
{
switch (ss)
{
case FFESYMBOL_stateNONE:
if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
ffesymbol_error (sp, t);
else
{
ffesymbol_signal_change (sp);
ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
ffesymbol_signal_unreported (sp);
}
break;
case FFESYMBOL_stateSEEN:
if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
{
ffesymbol_signal_change (sp);
ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
ffesymbol_signal_unreported (sp);
}
break;
case FFESYMBOL_stateUNCERTAIN:
assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
ffesymbol_error (sp, t);
break;
case FFESYMBOL_stateUNDERSTOOD:
break;
default:
assert ("Foo Bar!!" == NULL);
break;
}
return sp;
}
sa = ffesymbol_attrs (sp);
if (ffesymbol_state_is_specable (ss)
&& ffest_seen_first_exec ())
{
assert (sa == FFESYMBOL_attrsetNONE);
ffesymbol_signal_change (sp);
ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
ffesymbol_resolve_intrin (sp);
if (ffeimplic_establish_symbol (sp))
ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
else
ffesymbol_error (sp, t);
sp = ffecom_sym_exec_transition (sp);
sa = ffesymbol_attrs (sp);
ss = ffesymbol_state (sp);
}
ns = ss;
kind = ffesymbol_kind (sp);
where = ffesymbol_where (sp);
if (ss == FFESYMBOL_stateUNDERSTOOD)
{
if (kind != FFEINFO_kindENTITY)
ffesymbol_error (sp, t);
if (where == FFEINFO_whereCONSTANT)
return sp;
}
else
{
if (ss != FFESYMBOL_stateUNCERTAIN)
{
ns = FFESYMBOL_stateSEEN;
if (sa & FFESYMBOL_attrsANY)
na = sa;
else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsANY
| 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;
}
else
{
na = sa | FFESYMBOL_attrsSFARG;
ns = FFESYMBOL_stateUNDERSTOOD;
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
na = FFESYMBOL_attrsetNONE;
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
kind = FFEINFO_kindENTITY;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
na = FFESYMBOL_attrsetNONE;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
ns = FFESYMBOL_stateUNCERTAIN;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
kind = FFEINFO_kindENTITY;
if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
na = FFESYMBOL_attrsetNONE;
else if (ffest_is_entry_valid ())
ns = FFESYMBOL_stateUNCERTAIN;
else
where = FFEINFO_whereLOCAL;
}
else
na = FFESYMBOL_attrsetNONE;
}
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (sp, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (sp);
if (!ffeimplic_establish_symbol (sp))
ffesymbol_error (sp, t);
else
{
ffesymbol_set_info (sp,
ffeinfo_new (ffesymbol_basictype (sp),
ffesymbol_kindtype (sp),
ffesymbol_rank (sp),
kind,
where,
ffesymbol_size (sp)));
ffesymbol_set_attrs (sp, na);
ffesymbol_set_state (sp, ns);
ffesymbol_resolve_intrin (sp);
if (!ffesymbol_state_is_specable (ns))
sp = ffecom_sym_learned (sp);
ffesymbol_signal_unreported (sp);
}
}
}
s = ffesymbol_declare_sfdummy (t);
assert (sp == ffesymbol_sfdummyparent (s));
ffesymbol_signal_change (s);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_set_maxentrynum (s, ffeexpr_level_);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT,
0,
FFEINFO_kindENTITY,
FFEINFO_whereIMMEDIATE,
FFETARGET_charactersizeNONE));
ffesymbol_signal_unreported (s);
if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
&& (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
ffesymbol_error (s, t);
return s;
}
static ffesymbol
ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
ffeintrinGen gen;
ffeintrinSpec spec;
ffeintrinImp imp;
bool error = FALSE;
assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
error = TRUE;
else
{
kind = FFEINFO_kindSUBROUTINE;
if (sa & FFESYMBOL_attrsDUMMY)
;
else if (sa & FFESYMBOL_attrsACTUALARG)
;
else
where = FFEINFO_whereGLOBAL;
}
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
error = TRUE;
else
kind = FFEINFO_kindSUBROUTINE;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
error = TRUE;
}
else if (sa == FFESYMBOL_attrsetNONE)
{
assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
&gen, &spec, &imp))
{
ffesymbol_signal_change (s);
ffesymbol_set_generic (s, gen);
ffesymbol_set_specific (s, spec);
ffesymbol_set_implementation (s, imp);
ffesymbol_set_info (s,
ffeinfo_new (FFEINFO_basictypeNONE,
FFEINFO_kindtypeNONE,
0,
FFEINFO_kindSUBROUTINE,
FFEINFO_whereINTRINSIC,
FFETARGET_charactersizeNONE));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, t, FALSE);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
return s;
}
kind = FFEINFO_kindSUBROUTINE;
where = FFEINFO_whereGLOBAL;
}
else
error = TRUE;
if (error)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, t, FALSE);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
bool error = FALSE;
assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsADJUSTABLE)
error = TRUE;
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
error = TRUE;
else
{
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
}
}
else if (sa == FFESYMBOL_attrsetNONE)
{
assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
}
else
error = TRUE;
if (error)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
if (!ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
na = sa = ffesymbol_attrs (s);
kind = FFEINFO_kindENTITY;
where = ffesymbol_where (s);
if (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSAVE
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsEQUIV;
else
na = FFESYMBOL_attrsetNONE;
if (where == FFEINFO_whereNONE)
{
if (na & (FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON))
where = FFEINFO_whereCOMMON;
else if (na & FFESYMBOL_attrsSAVE)
where = FFEINFO_whereLOCAL;
}
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_resolve_intrin (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
bool needs_type = FALSE;
bool error = FALSE;
assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
where = FFEINFO_whereGLOBAL;
else
{
kind = FFEINFO_kindFUNCTION;
needs_type = TRUE;
if (sa & FFESYMBOL_attrsDUMMY)
;
else if (sa & FFESYMBOL_attrsACTUALARG)
;
else
where = FFEINFO_whereGLOBAL;
}
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
kind = FFEINFO_kindFUNCTION;
if (!(sa & FFESYMBOL_attrsTYPE))
needs_type = TRUE;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
error = TRUE;
else
{
kind = FFEINFO_kindFUNCTION;
where = FFEINFO_whereGLOBAL;
}
}
else if (sa == FFESYMBOL_attrsetNONE)
{
assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
kind = FFEINFO_kindFUNCTION;
where = FFEINFO_whereGLOBAL;
needs_type = TRUE;
}
else
error = TRUE;
if (error)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
if (needs_type && !ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
if (!ffesymbol_explicitwhere (s))
{
ffebad_start (FFEBAD_NEED_EXTERNAL);
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_string (ffesymbol_text (s));
ffebad_finish ();
ffesymbol_set_explicitwhere (s, TRUE);
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, t, FALSE);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
{
ffesymbolState ss;
if (ffesymbol_sfdummyparent (s) == NULL)
{
s = ffeexpr_sym_impdoitem_ (s, t);
if (ffesymbol_sfdummyparent (s) == NULL)
{
ffesymbol_error (s, t);
return s;
}
}
ss = ffesymbol_state (s);
switch (ss)
{
case FFESYMBOL_stateNONE:
if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
ffesymbol_error (s, t);
else
{
#if 1
ffesymbol_error (s, t);
#else
ffesymbol_signal_change (s);
ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
ffesymbol_set_maxentrynum (s, ffeexpr_level_);
ffesymbol_signal_unreported (s);
#endif
}
break;
case FFESYMBOL_stateSEEN:
if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
{
ffesymbol_signal_change (s);
ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
ffesymbol_signal_unreported (s);
}
else
ffesymbol_error (s, t);
break;
case FFESYMBOL_stateUNCERTAIN:
assert ("DATA implied-DO control var seen twice!!" == NULL);
ffesymbol_error (s, t);
break;
case FFESYMBOL_stateUNDERSTOOD:
break;
default:
assert ("Foo Bletch!!" == NULL);
break;
}
return s;
}
static ffesymbol
ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
sa = ffesymbol_attrs (s);
if (sa & ~(FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsTYPE))
{
if (!(sa & FFESYMBOL_attrsANY))
ffesymbol_error (s, t);
}
else
{
ffesymbol_signal_change (s);
if (!ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
ffesymbolState ns;
bool needs_type = FALSE;
assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
ns = FFESYMBOL_stateUNDERSTOOD;
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
where = FFEINFO_whereGLOBAL;
else
{
ns = FFESYMBOL_stateUNCERTAIN;
if (sa & FFESYMBOL_attrsDUMMY)
assert (kind == FFEINFO_kindNONE);
else if (sa & FFESYMBOL_attrsACTUALARG)
;
else
{
assert (kind == FFEINFO_kindNONE);
na |= FFESYMBOL_attrsACTUALARG;
where = FFEINFO_whereGLOBAL;
}
}
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
kind = FFEINFO_kindENTITY;
if (!(sa & FFESYMBOL_attrsTYPE))
needs_type = TRUE;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
if (sa & FFESYMBOL_attrsANYLEN)
ns = FFESYMBOL_stateNONE;
else
{
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
}
}
else if (sa == FFESYMBOL_attrsetNONE)
{
assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
needs_type = TRUE;
}
else
ns = FFESYMBOL_stateNONE;
if (ns == FFESYMBOL_stateNONE)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
if (needs_type && !ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, ns);
s = ffecom_sym_learned (s);
ffesymbol_reference (s, t, FALSE);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
na = sa = ffesymbol_attrs (s);
kind = FFEINFO_kindENTITY;
where = ffesymbol_where (s);
if (!(sa & ~(FFESYMBOL_attrsADJUSTS
| FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsADJUSTS;
else
na = FFESYMBOL_attrsetNONE;
if (where == FFEINFO_whereNONE)
{
if (na & (FFESYMBOL_attrsCOMMON
| FFESYMBOL_attrsEQUIV
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST))
where = FFEINFO_whereCOMMON;
else if (na & FFESYMBOL_attrsDUMMY)
where = FFEINFO_whereDUMMY;
}
if (na == FFESYMBOL_attrsetNONE)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
if (!ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_attrs (s, na);
ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
ffesymbol_resolve_intrin (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
bool error = FALSE;
assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
error = TRUE;
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
kind = FFEINFO_kindENTITY;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
if (sa & FFESYMBOL_attrsANYLEN)
error = TRUE;
else
{
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
}
}
else if (sa == FFESYMBOL_attrsetNONE)
{
assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
}
else
error = TRUE;
if (error)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
if (!ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffesymbol
ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
ffeexprParenType_ *paren_type)
{
ffesymbol s;
ffesymbolState st;
ffeinfoKind k;
bool bad;
if (maybe_intrin && ffesrc_check_symbol ())
{
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextSUBROUTINEREF:
case FFEEXPR_contextDATA:
case FFEEXPR_contextDATAIMPDOINDEX_:
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
case FFEEXPR_contextLET:
case FFEEXPR_contextPAREN_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextDO:
case FFEEXPR_contextDOWHILE:
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextCGOTO:
case FFEEXPR_contextIF:
case FFEEXPR_contextARITHIF:
case FFEEXPR_contextFORMAT:
case FFEEXPR_contextSTOP:
case FFEEXPR_contextRETURN:
case FFEEXPR_contextSELECTCASE:
case FFEEXPR_contextCASE:
case FFEEXPR_contextFILEASSOC:
case FFEEXPR_contextFILEINT:
case FFEEXPR_contextFILEDFINT:
case FFEEXPR_contextFILELOG:
case FFEEXPR_contextFILENUM:
case FFEEXPR_contextFILENUMAMBIG:
case FFEEXPR_contextFILECHAR:
case FFEEXPR_contextFILENUMCHAR:
case FFEEXPR_contextFILEDFCHAR:
case FFEEXPR_contextFILEKEY:
case FFEEXPR_contextFILEUNIT:
case FFEEXPR_contextFILEUNIT_DF:
case FFEEXPR_contextFILEUNITAMBIG:
case FFEEXPR_contextFILEFORMAT:
case FFEEXPR_contextFILENAMELIST:
case FFEEXPR_contextFILEVXTCODE:
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
case FFEEXPR_contextIMPDOCTRL_:
case FFEEXPR_contextDATAIMPDOCTRL_:
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextPARAMETER:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
break;
case FFEEXPR_contextAGOTO:
case FFEEXPR_contextFILEFORMATNML:
case FFEEXPR_contextALLOCATE:
case FFEEXPR_contextDEALLOCATE:
case FFEEXPR_contextHEAPSTAT:
case FFEEXPR_contextNULLIFY:
case FFEEXPR_contextINCLUDE:
case FFEEXPR_contextDATAIMPDOITEM_:
case FFEEXPR_contextLOC_:
case FFEEXPR_contextINDEXORACTUALARG_:
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
case FFEEXPR_contextPARENFILENUM_:
case FFEEXPR_contextPARENFILEUNIT_:
maybe_intrin = FALSE;
break;
default:
assert ("blah! blah! waaauuggh!" == NULL);
break;
}
}
s = ffesymbol_declare_local (t, maybe_intrin);
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextDATAIMPDOINDEX_:
case FFEEXPR_contextDATAIMPDOCTRL_:
if (ffeexpr_context_outer_ (ffeexpr_stack_)
== FFEEXPR_contextDATAIMPDOINDEX_)
s = ffeexpr_sym_impdoitem_ (s, t);
else
if (ffeexpr_stack_->is_rhs)
s = ffeexpr_sym_impdoitem_ (s, t);
else
s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
if (ffesymbol_kind (s) != FFEINFO_kindANY)
ffesymbol_error (s, t);
return s;
default:
break;
}
switch ((ffesymbol_sfdummyparent (s) == NULL)
? ffesymbol_state (s)
: FFESYMBOL_stateUNDERSTOOD)
{
case FFESYMBOL_stateNONE:
if (!ffest_seen_first_exec ())
goto seen;
case FFESYMBOL_stateUNCERTAIN:
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextSUBROUTINEREF:
s = ffeexpr_sym_lhs_call_ (s, t);
break;
case FFEEXPR_contextDATA:
if (ffeexpr_stack_->is_rhs)
s = ffeexpr_sym_rhs_let_ (s, t);
else
s = ffeexpr_sym_lhs_data_ (s, t);
break;
case FFEEXPR_contextDATAIMPDOITEM_:
s = ffeexpr_sym_lhs_data_ (s, t);
break;
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
case FFEEXPR_contextLET:
case FFEEXPR_contextPAREN_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextDO:
case FFEEXPR_contextDOWHILE:
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextCGOTO:
case FFEEXPR_contextIF:
case FFEEXPR_contextARITHIF:
case FFEEXPR_contextFORMAT:
case FFEEXPR_contextSTOP:
case FFEEXPR_contextRETURN:
case FFEEXPR_contextSELECTCASE:
case FFEEXPR_contextCASE:
case FFEEXPR_contextFILEASSOC:
case FFEEXPR_contextFILEINT:
case FFEEXPR_contextFILEDFINT:
case FFEEXPR_contextFILELOG:
case FFEEXPR_contextFILENUM:
case FFEEXPR_contextFILENUMAMBIG:
case FFEEXPR_contextFILECHAR:
case FFEEXPR_contextFILENUMCHAR:
case FFEEXPR_contextFILEDFCHAR:
case FFEEXPR_contextFILEKEY:
case FFEEXPR_contextFILEUNIT:
case FFEEXPR_contextFILEUNIT_DF:
case FFEEXPR_contextFILEUNITAMBIG:
case FFEEXPR_contextFILEFORMAT:
case FFEEXPR_contextFILENAMELIST:
case FFEEXPR_contextFILEVXTCODE:
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
case FFEEXPR_contextIMPDOCTRL_:
case FFEEXPR_contextLOC_:
if (ffeexpr_stack_->is_rhs)
s = ffeexpr_paren_rhs_let_ (s, t);
else
s = ffeexpr_paren_lhs_let_ (s, t);
break;
case FFEEXPR_contextASSIGN:
case FFEEXPR_contextAGOTO:
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextEQUIVALENCE:
case FFEEXPR_contextINCLUDE:
case FFEEXPR_contextPARAMETER:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
break;
default:
ffesymbol_error (s, t);
break;
}
case FFESYMBOL_stateUNDERSTOOD:
understood:
st = ((ffesymbol_sfdummyparent (s) == NULL)
? ffesymbol_state (s)
: FFESYMBOL_stateUNDERSTOOD);
k = ffesymbol_kind (s);
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextSUBROUTINEREF:
bad = ((k != FFEINFO_kindSUBROUTINE)
&& ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
|| (k != FFEINFO_kindNONE)));
break;
case FFEEXPR_contextDATA:
if (ffeexpr_stack_->is_rhs)
bad = (k != FFEINFO_kindENTITY)
|| (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
else
bad = (k != FFEINFO_kindENTITY)
|| ((ffesymbol_where (s) != FFEINFO_whereNONE)
&& (ffesymbol_where (s) != FFEINFO_whereLOCAL)
&& (ffesymbol_where (s) != FFEINFO_whereCOMMON));
break;
case FFEEXPR_contextDATAIMPDOITEM_:
bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
|| ((ffesymbol_where (s) != FFEINFO_whereNONE)
&& (ffesymbol_where (s) != FFEINFO_whereLOCAL)
&& (ffesymbol_where (s) != FFEINFO_whereCOMMON));
break;
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
case FFEEXPR_contextLET:
case FFEEXPR_contextPAREN_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextIOLIST:
case FFEEXPR_contextIOLISTDF:
case FFEEXPR_contextDO:
case FFEEXPR_contextDOWHILE:
case FFEEXPR_contextACTUALARG_:
case FFEEXPR_contextCGOTO:
case FFEEXPR_contextIF:
case FFEEXPR_contextARITHIF:
case FFEEXPR_contextFORMAT:
case FFEEXPR_contextSTOP:
case FFEEXPR_contextRETURN:
case FFEEXPR_contextSELECTCASE:
case FFEEXPR_contextCASE:
case FFEEXPR_contextFILEASSOC:
case FFEEXPR_contextFILEINT:
case FFEEXPR_contextFILEDFINT:
case FFEEXPR_contextFILELOG:
case FFEEXPR_contextFILENUM:
case FFEEXPR_contextFILENUMAMBIG:
case FFEEXPR_contextFILECHAR:
case FFEEXPR_contextFILENUMCHAR:
case FFEEXPR_contextFILEDFCHAR:
case FFEEXPR_contextFILEKEY:
case FFEEXPR_contextFILEUNIT:
case FFEEXPR_contextFILEUNIT_DF:
case FFEEXPR_contextFILEUNITAMBIG:
case FFEEXPR_contextFILEFORMAT:
case FFEEXPR_contextFILENAMELIST:
case FFEEXPR_contextFILEVXTCODE:
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextIMPDOITEM_:
case FFEEXPR_contextIMPDOITEMDF_:
case FFEEXPR_contextIMPDOCTRL_:
case FFEEXPR_contextLOC_:
bad = FALSE;
break;
case FFEEXPR_contextASSIGN:
case FFEEXPR_contextAGOTO:
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextEQUIVALENCE:
case FFEEXPR_contextPARAMETER:
case FFEEXPR_contextDIMLIST:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
bad = (k != FFEINFO_kindENTITY)
|| (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
break;
case FFEEXPR_contextINCLUDE:
bad = TRUE;
break;
default:
bad = TRUE;
break;
}
switch (bad ? FFEINFO_kindANY : k)
{
case FFEINFO_kindNONE:
if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
{
if (ffeexpr_context_outer_ (ffeexpr_stack_)
== FFEEXPR_contextSUBROUTINEREF)
*paren_type = FFEEXPR_parentypeSUBROUTINE_;
else
*paren_type = FFEEXPR_parentypeFUNCTION_;
break;
}
if (st == FFESYMBOL_stateUNDERSTOOD)
{
bad = TRUE;
*paren_type = FFEEXPR_parentypeANY_;
}
else
*paren_type = FFEEXPR_parentypeFUNSUBSTR_;
break;
case FFEINFO_kindFUNCTION:
*paren_type = FFEEXPR_parentypeFUNCTION_;
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
bad = TRUE;
break;
case FFEINFO_whereCONSTANT:
bad = ((ffesymbol_sfexpr (s) == NULL)
|| (ffebld_op (ffesymbol_sfexpr (s))
== FFEBLD_opANY));
break;
default:
break;
}
break;
case FFEINFO_kindSUBROUTINE:
if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
|| (ffeexpr_stack_->previous != NULL))
{
bad = TRUE;
*paren_type = FFEEXPR_parentypeANY_;
break;
}
*paren_type = FFEEXPR_parentypeSUBROUTINE_;
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
case FFEINFO_whereCONSTANT:
bad = TRUE;
break;
default:
break;
}
break;
case FFEINFO_kindENTITY:
if (ffesymbol_rank (s) == 0)
{
if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
*paren_type = FFEEXPR_parentypeSUBSTRING_;
else
{
bad = TRUE;
*paren_type = FFEEXPR_parentypeANY_;
}
}
else
*paren_type = FFEEXPR_parentypeARRAY_;
break;
default:
case FFEINFO_kindANY:
bad = TRUE;
*paren_type = FFEEXPR_parentypeANY_;
break;
}
if (bad)
{
if (k == FFEINFO_kindANY)
ffest_shutdown ();
else
ffesymbol_error (s, t);
}
return s;
case FFESYMBOL_stateSEEN:
seen:
bad = TRUE;
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextPARAMETER:
if (ffeexpr_stack_->is_rhs)
ffesymbol_error (s, t);
else
s = ffeexpr_sym_lhs_parameter_ (s, t);
break;
case FFEEXPR_contextDATA:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
if (ffeexpr_stack_->is_rhs)
ffesymbol_error (s, t);
else
s = ffeexpr_sym_lhs_data_ (s, t);
goto understood;
case FFEEXPR_contextDATAIMPDOITEM_:
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
s = ffeexpr_sym_lhs_data_ (s, t);
goto understood;
case FFEEXPR_contextEQUIVALENCE:
s = ffeexpr_sym_lhs_equivalence_ (s, t);
bad = FALSE;
break;
case FFEEXPR_contextDIMLIST:
s = ffeexpr_sym_rhs_dimlist_ (s, t);
bad = FALSE;
break;
case FFEEXPR_contextCHARACTERSIZE:
case FFEEXPR_contextKINDTYPE:
case FFEEXPR_contextDIMLISTCOMMON:
case FFEEXPR_contextINITVAL:
case FFEEXPR_contextEQVINDEX_:
break;
case FFEEXPR_contextINCLUDE:
break;
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextACTUALARGEXPR_:
case FFEEXPR_contextINDEXORACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
assert (ffeexpr_stack_->is_rhs);
s = ffecom_sym_exec_transition (s);
if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
goto understood;
s = ffeexpr_paren_rhs_let_ (s, t);
goto understood;
default:
break;
}
k = ffesymbol_kind (s);
switch (bad ? FFEINFO_kindANY : k)
{
case FFEINFO_kindNONE:
*paren_type = FFEEXPR_parentypeFUNSUBSTR_;
break;
case FFEINFO_kindFUNCTION:
*paren_type = FFEEXPR_parentypeFUNCTION_;
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
bad = TRUE;
break;
case FFEINFO_whereCONSTANT:
bad = ((ffesymbol_sfexpr (s) == NULL)
|| (ffebld_op (ffesymbol_sfexpr (s))
== FFEBLD_opANY));
break;
default:
break;
}
break;
case FFEINFO_kindSUBROUTINE:
*paren_type = FFEEXPR_parentypeANY_;
bad = TRUE;
break;
case FFEINFO_kindENTITY:
if (ffesymbol_rank (s) == 0)
{
if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
*paren_type = FFEEXPR_parentypeEQUIVALENCE_;
else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
*paren_type = FFEEXPR_parentypeSUBSTRING_;
else
{
bad = TRUE;
*paren_type = FFEEXPR_parentypeANY_;
}
}
else
*paren_type = FFEEXPR_parentypeARRAY_;
break;
default:
case FFEINFO_kindANY:
bad = TRUE;
*paren_type = FFEEXPR_parentypeANY_;
break;
}
if (bad)
{
if (k == FFEINFO_kindANY)
ffest_shutdown ();
else
ffesymbol_error (s, t);
}
return s;
default:
assert ("bad symbol state" == NULL);
return NULL;
}
}
static ffesymbol
ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
{
ffesymbolAttrs sa;
ffesymbolAttrs na;
ffeinfoKind kind;
ffeinfoWhere where;
ffeintrinGen gen;
ffeintrinSpec spec;
ffeintrinImp imp;
bool maybe_ambig = FALSE;
bool error = FALSE;
assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
|| (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
na = sa = ffesymbol_attrs (s);
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
kind = ffesymbol_kind (s);
where = ffesymbol_where (s);
if (sa & FFESYMBOL_attrsEXTERNAL)
{
assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
if (sa & FFESYMBOL_attrsTYPE)
where = FFEINFO_whereGLOBAL;
else
{
kind = FFEINFO_kindFUNCTION;
if (sa & FFESYMBOL_attrsDUMMY)
;
else if (sa & FFESYMBOL_attrsACTUALARG)
;
else
where = FFEINFO_whereGLOBAL;
}
}
else if (sa & FFESYMBOL_attrsDUMMY)
{
assert (!(sa & FFESYMBOL_attrsEXTERNAL));
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsTYPE)));
kind = FFEINFO_kindFUNCTION;
maybe_ambig = TRUE;
}
else if (sa & FFESYMBOL_attrsARRAY)
{
assert (!(sa & ~(FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsSFARG)
{
assert (!(sa & ~(FFESYMBOL_attrsSFARG
| FFESYMBOL_attrsTYPE)));
where = FFEINFO_whereLOCAL;
}
else if (sa & FFESYMBOL_attrsTYPE)
{
assert (!(sa & (FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
assert (!(sa & ~(FFESYMBOL_attrsTYPE
| FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
| FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsEXTERNAL
| FFESYMBOL_attrsSFARG)));
if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
&gen, &spec, &imp))
{
if (!(sa & FFESYMBOL_attrsANYLEN)
&& (ffeimplic_peek_symbol_type (s, NULL)
== FFEINFO_basictypeCHARACTER))
return s;
ffesymbol_signal_change (s);
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_kindFUNCTION,
FFEINFO_whereINTRINSIC,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
ffesymbol_reference (s, t, FALSE);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
return s;
}
if (sa & FFESYMBOL_attrsANYLEN)
error = TRUE;
else if (sa & FFESYMBOL_attrsADJUSTABLE)
{
kind = FFEINFO_kindENTITY;
where = FFEINFO_whereLOCAL;
}
else
{
kind = FFEINFO_kindFUNCTION;
where = FFEINFO_whereGLOBAL;
maybe_ambig = TRUE;
}
}
else if (sa == FFESYMBOL_attrsetNONE)
{
assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
&gen, &spec, &imp))
{
if (ffeimplic_peek_symbol_type (s, NULL)
== FFEINFO_basictypeCHARACTER)
return s;
ffesymbol_signal_change (s);
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_kindFUNCTION,
FFEINFO_whereINTRINSIC,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_reference (s, t, FALSE);
ffesymbol_signal_unreported (s);
return s;
}
kind = FFEINFO_kindFUNCTION;
where = FFEINFO_whereGLOBAL;
maybe_ambig = TRUE;
}
else
error = TRUE;
if (error)
ffesymbol_error (s, t);
else if (!(na & FFESYMBOL_attrsANY))
{
ffesymbol_signal_change (s);
if (!ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, t);
return s;
}
if (maybe_ambig
&& (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
return s;
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
kind,
where,
ffesymbol_size (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_reference (s, t, FALSE);
ffesymbol_signal_unreported (s);
}
return s;
}
static ffelexHandler
ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprExpr_ procedure;
ffebld reduced;
ffeinfo info;
ffeexprContext ctx;
bool check_intrin = FALSE;
procedure = ffeexpr_stack_->exprstack;
info = ffebld_info (procedure->u.operand);
if ((expr != NULL)
|| (ffelex_token_type (t) == FFELEX_typeCOMMA)
|| (ffe_is_ugly_comma ()
&& (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
{
if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
{
if ((expr == NULL)
&& ffebad_start (FFEBAD_NULL_ARGUMENT))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_here (1, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
if (expr == NULL)
;
else
{
if (ffeexpr_stack_->next_dummy == NULL)
{
if (ffeexpr_stack_->tokens[1] == NULL)
{
ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
ffeexpr_stack_->num_args = 0;
}
++ffeexpr_stack_->num_args;
}
else
{
if ((ffeinfo_rank (ffebld_info (expr)) != 0)
&& ffebad_start (FFEBAD_ARRAY_AS_SFARG))
{
ffebad_here (0,
ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_here (1, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
(ffebld_symter (ffebld_head
(ffeexpr_stack_->next_dummy)))));
ffebad_finish ();
}
else
{
expr = ffeexpr_convert_expr (expr, ft,
ffebld_head (ffeexpr_stack_->next_dummy),
ffeexpr_stack_->tokens[0],
FFEEXPR_contextLET);
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
}
--ffeexpr_stack_->num_args;
ffeexpr_stack_->next_dummy
= ffebld_trail (ffeexpr_stack_->next_dummy);
}
}
}
else
{
if ((expr == NULL)
&& ffe_is_pedantic ()
&& ffebad_start (FFEBAD_NULL_ARGUMENT_W))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_here (1, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
}
}
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
case FFEEXPR_contextSFUNCDEFINDEX_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
assert ("bad context" == NULL);
ctx = FFEEXPR_context;
break;
default:
ctx = FFEEXPR_contextACTUALARG_;
break;
}
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
ffeexpr_token_arguments_);
default:
break;
}
if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
&& (ffeexpr_stack_->next_dummy != NULL))
{
if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
{
char num[10];
sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_string (num);
ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
(ffebld_head (ffeexpr_stack_->next_dummy)))));
ffebad_finish ();
}
for (;
ffeexpr_stack_->next_dummy != NULL;
ffeexpr_stack_->next_dummy
= ffebld_trail (ffeexpr_stack_->next_dummy))
{
expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
ffebld_set_info (expr, ffeinfo_new_any ());
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
}
}
if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
&& (ffeexpr_stack_->tokens[1] != NULL))
{
if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
{
char num[10];
sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_string (num);
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
}
ffebld_end_list (&ffeexpr_stack_->bottom);
if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
{
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
}
else
{
if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
reduced = ffebld_new_funcref (procedure->u.operand,
ffeexpr_stack_->expr);
else
reduced = ffebld_new_subrref (procedure->u.operand,
ffeexpr_stack_->expr);
if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
else if (ffebld_symter_specific (procedure->u.operand)
!= FFEINTRIN_specNONE)
ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
ffeexpr_stack_->tokens[0]);
else
ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
if (ffebld_op (reduced) != FFEBLD_opANY)
ffebld_set_info (reduced,
ffeinfo_new (ffeinfo_basictype (info),
ffeinfo_kindtype (info),
0,
FFEINFO_kindENTITY,
FFEINFO_whereFLEETING,
ffeinfo_size (info)));
else
ffebld_set_info (reduced, ffeinfo_new_any ());
}
if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
ffeexpr_stack_->exprstack = procedure->previous;
procedure->u.operand = reduced;
ffeexpr_exprstack_push_operand_ (procedure);
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
{
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
ffeexpr_is_substr_ok_ = FALSE;
if (check_intrin
&& !ffe_is_90 ()
&& !ffe_is_ugly_complex ())
{
if ((ffeexpr_stack_->previous != NULL)
&& (ffeexpr_stack_->previous->exprstack != NULL)
&& (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
&& ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
&& (ffebld_op (reduced) == FFEBLD_opSYMTER)
&& (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
return (ffelexHandler) ffeexpr_token_intrincheck_;
if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
{
ffebad_string (ffeintrin_name_implementation
(ffebld_symter_implementation
(ffebld_left
(ffeexpr_stack_->exprstack->u.operand))));
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
ffebad_finish ();
}
}
return (ffelexHandler) ffeexpr_token_substrp_;
}
if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
ffeexpr_is_substr_ok_ = FALSE;
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_token_substrp_);
}
static ffelexHandler
ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprExpr_ array;
ffebld reduced;
ffeinfo info;
ffeinfoWhere where;
ffetargetIntegerDefault val;
ffetargetIntegerDefault lval = 0;
ffetargetIntegerDefault uval = 0;
ffebld lbound;
ffebld ubound;
bool lcheck;
bool ucheck;
array = ffeexpr_stack_->exprstack;
info = ffebld_info (array->u.operand);
if ((expr == NULL) )
{
if (ffebad_start (FFEBAD_NULL_ELEMENT))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_here (1, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_finish ();
}
if (ffeexpr_stack_->rank < ffeinfo_rank (info))
{
expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
ffebld_set_info (expr, ffeinfo_new_any ());
}
}
if (expr == NULL)
;
else if (ffeinfo_rank (info) == 0)
{
++ffeexpr_stack_->rank;
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
}
else
{
++ffeexpr_stack_->rank;
if (ffeexpr_stack_->rank > ffeinfo_rank (info))
{
if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
}
else
{
switch (ffeinfo_where (ffebld_info (expr)))
{
case FFEINFO_whereCONSTANT:
break;
case FFEINFO_whereIMMEDIATE:
ffeexpr_stack_->constant = FALSE;
break;
default:
ffeexpr_stack_->constant = FALSE;
ffeexpr_stack_->immediate = FALSE;
break;
}
if (ffebld_op (expr) == FFEBLD_opCONTER
&& ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
{
val = ffebld_constant_integerdefault (ffebld_conter (expr));
lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
if (lbound == NULL)
{
lcheck = TRUE;
lval = 1;
}
else if (ffebld_op (lbound) == FFEBLD_opCONTER)
{
lcheck = TRUE;
lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
}
else
lcheck = FALSE;
ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
assert (ubound != NULL);
if (ffebld_op (ubound) == FFEBLD_opCONTER)
{
ucheck = TRUE;
uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
}
else
ucheck = FALSE;
if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
{
ffebad_start (FFEBAD_RANGE_ARRAY);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
}
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
}
}
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
switch (ffeexpr_context_outer_ (ffeexpr_stack_))
{
case FFEEXPR_contextDATAIMPDOITEM_:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextDATAIMPDOINDEX_,
ffeexpr_token_elements_);
case FFEEXPR_contextEQUIVALENCE:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextEQVINDEX_,
ffeexpr_token_elements_);
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextSFUNCDEFINDEX_,
ffeexpr_token_elements_);
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
assert ("bad context" == NULL);
break;
default:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextINDEX_,
ffeexpr_token_elements_);
}
default:
break;
}
if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
&& (ffeinfo_rank (info) != 0))
{
char num[10];
if (ffeexpr_stack_->rank < ffeinfo_rank (info))
{
if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
{
sprintf (num, "%d",
(int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1,
ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_string (num);
ffebad_finish ();
}
}
else
{
if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
{
sprintf (num, "%d",
(int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
ffebad_here (0,
ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
ffebad_here (1,
ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_string (num);
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_stack_->tokens[1]);
}
while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
{
expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT,
0, FFEINFO_kindENTITY,
FFEINFO_whereCONSTANT,
FFETARGET_charactersizeNONE));
ffebld_append_item (&ffeexpr_stack_->bottom, expr);
}
}
ffebld_end_list (&ffeexpr_stack_->bottom);
if (ffebld_op (array->u.operand) == FFEBLD_opANY)
{
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
}
else
{
reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
if (ffeexpr_stack_->constant)
where = FFEINFO_whereFLEETING_CADDR;
else if (ffeexpr_stack_->immediate)
where = FFEINFO_whereFLEETING_IADDR;
else
where = FFEINFO_whereFLEETING;
ffebld_set_info (reduced,
ffeinfo_new (ffeinfo_basictype (info),
ffeinfo_kindtype (info),
0,
FFEINFO_kindENTITY,
where,
ffeinfo_size (info)));
reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
}
ffeexpr_stack_->exprstack = array->previous;
array->u.operand = reduced;
ffeexpr_exprstack_push_operand_ (array);
switch (ffeinfo_basictype (info))
{
case FFEINFO_basictypeCHARACTER:
ffeexpr_is_substr_ok_ = TRUE;
break;
case FFEINFO_basictypeNONE:
ffeexpr_is_substr_ok_ = TRUE;
assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
break;
default:
ffeexpr_is_substr_ok_ = FALSE;
break;
}
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
{
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
return (ffelexHandler) ffeexpr_token_substrp_;
}
if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_token_substrp_);
}
static ffelexHandler
ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
if (ffelex_token_type (t) == FFELEX_typeCOLON)
return ffeexpr_token_substring_ (ft, expr, t);
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return ffeexpr_token_elements_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeexprExpr_ string;
ffeinfo info;
ffetargetIntegerDefault i;
ffeexprContext ctx;
ffetargetCharacterSize size;
string = ffeexpr_stack_->exprstack;
info = ffebld_info (string->u.operand);
size = ffebld_size_max (string->u.operand);
if (ffelex_token_type (t) == FFELEX_typeCOLON)
{
if ((expr != NULL)
&& (ffebld_op (expr) == FFEBLD_opCONTER)
&& (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
< 1)
|| ((size != FFETARGET_charactersizeNONE) && (i > size))))
{
ffebad_start (FFEBAD_RANGE_SUBSTR);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
ffeexpr_stack_->expr = expr;
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
ctx = FFEEXPR_contextSFUNCDEFINDEX_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
assert ("bad context" == NULL);
ctx = FFEEXPR_context;
break;
default:
ctx = FFEEXPR_contextINDEX_;
break;
}
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
ffeexpr_token_substring_1_);
}
if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
ffeexpr_stack_->expr = NULL;
return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
{
ffeexprExpr_ string;
ffebld reduced;
ffebld substrlist;
ffebld first = ffeexpr_stack_->expr;
ffebld strop;
ffeinfo info;
ffeinfoWhere lwh;
ffeinfoWhere rwh;
ffeinfoWhere where;
ffeinfoKindtype first_kt;
ffeinfoKindtype last_kt;
ffetargetIntegerDefault first_val;
ffetargetIntegerDefault last_val;
ffetargetCharacterSize size;
ffetargetCharacterSize strop_size_max;
bool first_known;
string = ffeexpr_stack_->exprstack;
strop = string->u.operand;
info = ffebld_info (strop);
if (first == NULL
|| (ffebld_op (first) == FFEBLD_opCONTER
&& ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
{
first_val = (first == NULL) ? 1
: ffebld_constant_integerdefault (ffebld_conter (first));
first_known = TRUE;
}
else
{
first_val = 1;
first_known = FALSE;
}
if (last != NULL
&& (ffebld_op (last) == FFEBLD_opCONTER
&& ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
{
last_val = ffebld_constant_integerdefault (ffebld_conter (last));
if (first_known)
{
if (first_val <= last_val)
size = last_val - first_val + 1;
else
{
if (0 && ffe_is_90 ())
size = 0;
else
{
size = 1;
ffebad_start (FFEBAD_ZERO_SIZE);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
}
}
else
size = FFETARGET_charactersizeNONE;
strop_size_max = ffebld_size_max (strop);
if ((strop_size_max != FFETARGET_charactersizeNONE)
&& (last_val > strop_size_max))
{
ffebad_start (FFEBAD_RANGE_SUBSTR);
ffebad_here (0, ffelex_token_where_line (ft),
ffelex_token_where_column (ft));
ffebad_finish ();
}
}
else
size = FFETARGET_charactersizeNONE;
#if 0
if (size == FFETARGET_charactersizeNONE)
size = strop_size_max;
#endif
substrlist
= ffebld_new_item
(first,
ffebld_new_item
(last,
NULL
)
)
;
if (first == NULL)
lwh = FFEINFO_whereCONSTANT;
else
lwh = ffeinfo_where (ffebld_info (first));
if (last == NULL)
rwh = FFEINFO_whereCONSTANT;
else
rwh = ffeinfo_where (ffebld_info (last));
switch (lwh)
{
case FFEINFO_whereCONSTANT:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
where = FFEINFO_whereCONSTANT;
break;
case FFEINFO_whereIMMEDIATE:
where = FFEINFO_whereIMMEDIATE;
break;
default:
where = FFEINFO_whereFLEETING;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (rwh)
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
where = FFEINFO_whereIMMEDIATE;
break;
default:
where = FFEINFO_whereFLEETING;
break;
}
break;
default:
where = FFEINFO_whereFLEETING;
break;
}
if (first == NULL)
first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
else
first_kt = ffeinfo_kindtype (ffebld_info (first));
if (last == NULL)
last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
else
last_kt = ffeinfo_kindtype (ffebld_info (last));
switch (where)
{
case FFEINFO_whereCONSTANT:
switch (ffeinfo_where (info))
{
case FFEINFO_whereCONSTANT:
break;
case FFEINFO_whereIMMEDIATE:
where = FFEINFO_whereIMMEDIATE;
break;
default:
where = FFEINFO_whereFLEETING_CADDR;
break;
}
break;
case FFEINFO_whereIMMEDIATE:
switch (ffeinfo_where (info))
{
case FFEINFO_whereCONSTANT:
case FFEINFO_whereIMMEDIATE:
break;
default:
where = FFEINFO_whereFLEETING_IADDR;
break;
}
break;
default:
switch (ffeinfo_where (info))
{
case FFEINFO_whereCONSTANT:
where = FFEINFO_whereCONSTANT_SUBOBJECT;
break;
case FFEINFO_whereIMMEDIATE:
default:
where = FFEINFO_whereFLEETING;
break;
}
break;
}
if (ffebld_op (strop) == FFEBLD_opANY)
{
reduced = ffebld_new_any ();
ffebld_set_info (reduced, ffeinfo_new_any ());
}
else
{
reduced = ffebld_new_substr (strop, substrlist);
ffebld_set_info (reduced, ffeinfo_new
(FFEINFO_basictypeCHARACTER,
ffeinfo_kindtype (info),
0,
FFEINFO_kindENTITY,
where,
size));
reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
}
ffeexpr_stack_->exprstack = string->previous;
string->u.operand = reduced;
ffeexpr_exprstack_push_operand_ (string);
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
{
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
ffeexpr_is_substr_ok_ = FALSE;
return (ffelexHandler) ffeexpr_token_substrp_;
}
if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
ffebad_finish ();
}
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
ffeexpr_is_substr_ok_ = FALSE;
return
(ffelexHandler) ffeexpr_find_close_paren_ (t,
(ffelexHandler)
ffeexpr_token_substrp_);
}
static ffelexHandler
ffeexpr_token_substrp_ (ffelexToken t)
{
ffeexprContext ctx;
if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
return (ffelexHandler) ffeexpr_token_binary_ (t);
ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
switch (ffeexpr_stack_->context)
{
case FFEEXPR_contextSFUNCDEF:
case FFEEXPR_contextSFUNCDEFINDEX_:
ctx = FFEEXPR_contextSFUNCDEFINDEX_;
break;
case FFEEXPR_contextSFUNCDEFACTUALARG_:
case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
assert ("bad context" == NULL);
ctx = FFEEXPR_context;
break;
default:
ctx = FFEEXPR_contextINDEX_;
break;
}
if (!ffeexpr_is_substr_ok_)
{
if (ffebad_start (FFEBAD_BAD_SUBSTR))
{
ffebad_here (0, ffelex_token_where_line (t),
ffelex_token_where_column (t));
ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
ffebad_finish ();
}
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
ffeexpr_token_anything_);
}
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
ffeexpr_token_substring_);
}
static ffelexHandler
ffeexpr_token_intrincheck_ (ffelexToken t)
{
if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
&& ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
{
ffebad_string (ffeintrin_name_implementation
(ffebld_symter_implementation
(ffebld_left
(ffeexpr_stack_->exprstack->u.operand))));
ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
ffebad_finish ();
}
return (ffelexHandler) ffeexpr_token_substrp_ (t);
}
static ffelexHandler
ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
ffeinfoWhere where;
ffesymbol s;
ffesymbolAttrs sa;
ffebld symter = ffeexpr_stack_->exprstack->u.operand;
bool needs_type;
ffeintrinGen gen;
ffeintrinSpec spec;
ffeintrinImp imp;
s = ffebld_symter (symter);
sa = ffesymbol_attrs (s);
where = ffesymbol_where (s);
assert (!(sa & ~(FFESYMBOL_attrsDUMMY
| FFESYMBOL_attrsTYPE)));
needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
ffesymbol_signal_change (s);
if (ffelex_token_type (t) == FFELEX_typeCOLON)
{
if (needs_type && !ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
FFEINFO_kindENTITY,
(where == FFEINFO_whereNONE)
? FFEINFO_whereLOCAL
: where,
ffesymbol_size (s)));
ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_signal_unreported (s);
ffeexpr_stack_->exprstack->u.operand
= ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
}
if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
FALSE, &gen, &spec, &imp))
{
ffebld_symter_set_generic (symter, gen);
ffebld_symter_set_specific (symter, spec);
ffebld_symter_set_implementation (symter, imp);
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_kindFUNCTION,
FFEINFO_whereINTRINSIC,
ffesymbol_size (s)));
}
else
{
if (!ffeimplic_establish_symbol (s))
{
ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
}
ffesymbol_set_info (s,
ffeinfo_new (ffesymbol_basictype (s),
ffesymbol_kindtype (s),
ffesymbol_rank (s),
FFEINFO_kindFUNCTION,
(where == FFEINFO_whereNONE)
? FFEINFO_whereGLOBAL
: where,
ffesymbol_size (s)));
}
ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
ffesymbol_resolve_intrin (s);
s = ffecom_sym_learned (s);
ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
ffesymbol_signal_unreported (s);
ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
}
static ffelexHandler
ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
ffelexToken t)
{
ffeexprExpr_ e = ffeexpr_stack_->exprstack;
switch (ffelex_token_type (t))
{
case FFELEX_typeCOMMA:
case FFELEX_typeCOLON:
return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
FFEEXPR_contextACTUALARG_,
ffeexpr_token_anything_);
default:
e->u.operand = ffebld_new_any ();
ffebld_set_info (e->u.operand, ffeinfo_new_any ());
ffelex_token_kill (ffeexpr_stack_->tokens[0]);
ffeexpr_is_substr_ok_ = FALSE;
if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
return (ffelexHandler) ffeexpr_token_substrp_;
return (ffelexHandler) ffeexpr_token_substrp_ (t);
}
}
void
ffeexpr_terminate_2 ()
{
assert (ffeexpr_stack_ == NULL);
assert (ffeexpr_level_ == 0);
}