/gcc-2.95.2/gcc/f/expr.c
C | 17141 lines | 13729 code | 2051 blank | 1361 comment | 2451 complexity | 37669c40c33a4929d1f2149bbd001c83 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0
Large files files are truncated, but you can click here to view the full file
- /* expr.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995-1998 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"
- /* 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);
- 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
- #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 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
- #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 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
- #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 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
- #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 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
- …
Large files files are truncated, but you can click here to view the full file