blob: ef7661dc3ec3e95e60099e5b716b406fa3b17e3d [file] [log] [blame]
/* expr.c -- Implementation File (module.c template V1.0)
Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.
Related Modules:
None.
Description:
Handles syntactic and semantic analysis of Fortran expressions.
Modifications:
*/
/* Include files. */
#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"
/* Externals defined here. */
/* Simple definitions and enumerations. */
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_,/* Ambig: check for colon after first expr. */
FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
FFEEXPR_parentypeANY_, /* Allow basically anything. */
FFEEXPR_parentype_
} ffeexprParenType_;
typedef enum
{
FFEEXPR_percentNONE_,
FFEEXPR_percentLOC_,
FFEEXPR_percentVAL_,
FFEEXPR_percentREF_,
FFEEXPR_percentDESCR_,
FFEEXPR_percent_
} ffeexprPercent_;
/* Internal typedefs. */
typedef struct _ffeexpr_expr_ *ffeexprExpr_;
typedef bool ffeexprOperatorAssociativity_;
typedef struct _ffeexpr_stack_ *ffeexprStack_;
/* Private include files. */
/* Internal structure definitions. */
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]; /* Used in certain cases, like (unary)
open-paren. */
ffebld expr; /* For first of
complex/implied-do/substring/array-elements
/ actual-args expression. */
ffebld bound_list; /* For tracking dimension bounds list of
array. */
ffebldListBottom bottom; /* For building lists. */
ffeinfoRank rank; /* For elements in an array reference. */
bool constant; /* TRUE while elements seen so far are
constants. */
bool immediate; /* TRUE while elements seen so far are
immediate/constants. */
ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
ffebldListLength num_args; /* Number of dummy args expected in arg list. */
bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
ffeexprPercent_ percent; /* Current %FOO keyword. */
};
struct _ffeexpr_find_
{
ffelexToken t;
ffelexHandler after;
int level;
};
/* Static objects accessed by functions in this module. */
static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
static struct _ffeexpr_find_ ffeexpr_find_;
/* Static functions (internal). */
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,
bool *);
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);
/* Internal macros. */
#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)
/* ffeexpr_collapse_convert -- Collapse convert expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_convert(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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 conversion operation is not implemented, return original expr. */
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 conversion operation is not implemented, return original expr. */
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 conversion operation is not implemented, return original expr. */
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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
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 conversion operation is not implemented, return original expr. */
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
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;
}
/* ffeexpr_collapse_paren -- Collapse paren expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_paren(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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;
}
/* ffeexpr_collapse_uplus -- Collapse uplus expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_uplus(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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;
}
/* ffeexpr_collapse_uminus -- Collapse uminus expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_uminus(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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
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
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;
}
/* ffeexpr_collapse_not -- Collapse not expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_not(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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;
}
/* ffeexpr_collapse_add -- Collapse add expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_add(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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
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
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;
}
/* ffeexpr_collapse_subtract -- Collapse subtract expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_subtract(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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
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
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;
}
/* ffeexpr_collapse_multiply -- Collapse multiply expr
ffebld expr;
ffelexToken token;
expr = ffeexpr_collapse_multiply(expr,token);
If the result of the expr is a constant, replaces the expr with the
computed constant. */
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