| /* 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 |
| |
| |