/* expr.c -- Implementation File (module.c template V1.0) Copyright (C) 1995-1998 Free Software Foundation, Inc. Contributed by James Craig Burley. This file is part of GNU Fortran. GNU Fortran is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU Fortran is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU Fortran; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. Related Modules: None. Description: Handles syntactic and semantic analysis of Fortran expressions. Modifications: */ /* Include files. */ #include "proj.h" #include "expr.h" #include "bad.h" #include "bld.h" #include "com.h" #include "global.h" #include "implic.h" #include "intrin.h" #include "info.h" #include "lex.h" #include "malloc.h" #include "src.h" #include "st.h" #include "symbol.h" #include "str.h" #include "target.h" #include "where.h" /* Externals defined here. */ /* Simple definitions and enumerations. */ typedef enum { FFEEXPR_exprtypeUNKNOWN_, FFEEXPR_exprtypeOPERAND_, FFEEXPR_exprtypeUNARY_, FFEEXPR_exprtypeBINARY_, FFEEXPR_exprtype_ } ffeexprExprtype_; typedef enum { FFEEXPR_operatorPOWER_, FFEEXPR_operatorMULTIPLY_, FFEEXPR_operatorDIVIDE_, FFEEXPR_operatorADD_, FFEEXPR_operatorSUBTRACT_, FFEEXPR_operatorCONCATENATE_, FFEEXPR_operatorLT_, FFEEXPR_operatorLE_, FFEEXPR_operatorEQ_, FFEEXPR_operatorNE_, FFEEXPR_operatorGT_, FFEEXPR_operatorGE_, FFEEXPR_operatorNOT_, FFEEXPR_operatorAND_, FFEEXPR_operatorOR_, FFEEXPR_operatorXOR_, FFEEXPR_operatorEQV_, FFEEXPR_operatorNEQV_, FFEEXPR_operator_ } ffeexprOperator_; typedef enum { FFEEXPR_operatorprecedenceHIGHEST_ = 1, FFEEXPR_operatorprecedencePOWER_ = 1, FFEEXPR_operatorprecedenceMULTIPLY_ = 2, FFEEXPR_operatorprecedenceDIVIDE_ = 2, FFEEXPR_operatorprecedenceADD_ = 3, FFEEXPR_operatorprecedenceSUBTRACT_ = 3, FFEEXPR_operatorprecedenceLOWARITH_ = 3, FFEEXPR_operatorprecedenceCONCATENATE_ = 3, FFEEXPR_operatorprecedenceLT_ = 4, FFEEXPR_operatorprecedenceLE_ = 4, FFEEXPR_operatorprecedenceEQ_ = 4, FFEEXPR_operatorprecedenceNE_ = 4, FFEEXPR_operatorprecedenceGT_ = 4, FFEEXPR_operatorprecedenceGE_ = 4, FFEEXPR_operatorprecedenceNOT_ = 5, FFEEXPR_operatorprecedenceAND_ = 6, FFEEXPR_operatorprecedenceOR_ = 7, FFEEXPR_operatorprecedenceXOR_ = 8, FFEEXPR_operatorprecedenceEQV_ = 8, FFEEXPR_operatorprecedenceNEQV_ = 8, FFEEXPR_operatorprecedenceLOWEST_ = 8, FFEEXPR_operatorprecedence_ } ffeexprOperatorPrecedence_; #define FFEEXPR_operatorassociativityL2R_ TRUE #define FFEEXPR_operatorassociativityR2L_ FALSE #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_ #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_ #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_ typedef enum { FFEEXPR_parentypeFUNCTION_, FFEEXPR_parentypeSUBROUTINE_, FFEEXPR_parentypeARRAY_, FFEEXPR_parentypeSUBSTRING_, FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */ FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */ FFEEXPR_parentypeANY_, /* Allow basically anything. */ FFEEXPR_parentype_ } ffeexprParenType_; typedef enum { FFEEXPR_percentNONE_, FFEEXPR_percentLOC_, FFEEXPR_percentVAL_, FFEEXPR_percentREF_, FFEEXPR_percentDESCR_, FFEEXPR_percent_ } ffeexprPercent_; /* Internal typedefs. */ typedef struct _ffeexpr_expr_ *ffeexprExpr_; typedef bool ffeexprOperatorAssociativity_; typedef struct _ffeexpr_stack_ *ffeexprStack_; /* Private include files. */ /* Internal structure definitions. */ struct _ffeexpr_expr_ { ffeexprExpr_ previous; ffelexToken token; ffeexprExprtype_ type; union { struct { ffeexprOperator_ op; ffeexprOperatorPrecedence_ prec; ffeexprOperatorAssociativity_ as; } operator; ffebld operand; } u; }; struct _ffeexpr_stack_ { ffeexprStack_ previous; mallocPool pool; ffeexprContext context; ffeexprCallback callback; ffelexToken first_token; ffeexprExpr_ exprstack; ffelexToken tokens[10]; /* Used in certain cases, like (unary) open-paren. */ ffebld expr; /* For first of complex/implied-do/substring/array-elements / actual-args expression. */ ffebld bound_list; /* For tracking dimension bounds list of array. */ ffebldListBottom bottom; /* For building lists. */ ffeinfoRank rank; /* For elements in an array reference. */ bool constant; /* TRUE while elements seen so far are constants. */ bool immediate; /* TRUE while elements seen so far are immediate/constants. */ ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */ ffebldListLength num_args; /* Number of dummy args expected in arg list. */ bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */ ffeexprPercent_ percent; /* Current %FOO keyword. */ }; struct _ffeexpr_find_ { ffelexToken t; ffelexHandler after; int level; }; /* Static objects accessed by functions in this module. */ static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */ static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */ static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */ static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */ static int ffeexpr_level_; /* Level of DATA implied-DO construct. */ static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */ static struct _ffeexpr_find_ ffeexpr_find_; /* Static functions (internal). */ static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t); static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t); static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t); static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s); static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, ffebld dovar, ffelexToken dovar_t); static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar); static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar); static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s); static ffeexprExpr_ ffeexpr_expr_new_ (void); static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); static bool ffeexpr_isdigits_ (const char *p); static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t); static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t); static void ffeexpr_expr_kill_ (ffeexprExpr_ e); static void ffeexpr_exprstack_push_ (ffeexprExpr_ e); static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e); static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e); static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e); static void ffeexpr_reduce_ (void); static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r); static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t, ffelexHandler after); static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t); static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t); static ffelexHandler ffeexpr_nil_period_ (ffelexToken t); static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t); static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t); static ffelexHandler ffeexpr_nil_real_ (ffelexToken t); static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t); static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t); static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t); static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t); static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t); static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t); static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t); static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t); static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t); static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t); static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t); static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t); static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t); static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t); static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t); static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t); static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t); static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t); static ffelexHandler ffeexpr_finished_ (ffelexToken t); static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr); static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_binary_ (ffelexToken t); static ffelexHandler ffeexpr_token_period_ (ffelexToken t); static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t); static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t); static ffelexHandler ffeexpr_token_real_ (ffelexToken t); static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t); static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t); static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t); static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t); static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t); static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t); static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t); static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t); static ffelexHandler ffeexpr_token_quote_ (ffelexToken t); static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t); static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t); static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t); static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t); static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t); static ffelexHandler ffeexpr_token_percent_ (ffelexToken t); static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t); static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t); static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t); static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t); static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr, ffelexToken t); static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign, ffelexToken exponent_digits); static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin); static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t); static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin, ffeexprParenType_ *paren_type); static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t); /* Internal macros. */ #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) /* ffeexpr_collapse_convert -- Collapse convert expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_convert(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_convert (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; ffetargetCharacterSize sz; ffetargetCharacterSize sz2; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: sz = FFETARGET_charactersizeNONE; switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_integer1_integer2 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_integer1_integer3 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_integer1_integer4 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER1/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer1_real1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer1_real2 (ffebld_cu_ptr_integer1 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer1_real3 (ffebld_cu_ptr_integer1 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer1_real4 (ffebld_cu_ptr_integer1 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER1/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer1_complex1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer1_complex2 (ffebld_cu_ptr_integer1 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer1_complex3 (ffebld_cu_ptr_integer1 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer1_complex4 (ffebld_cu_ptr_integer1 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER1/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_integer1_logical1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_integer1_logical2 (ffebld_cu_ptr_integer1 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_integer1_logical3 (ffebld_cu_ptr_integer1 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_integer1_logical4 (ffebld_cu_ptr_integer1 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER1/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_integer1_character1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_integer1_hollerith (ffebld_cu_ptr_integer1 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_integer1_typeless (ffebld_cu_ptr_integer1 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("INTEGER1 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_integer2_integer1 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_integer2_integer3 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_integer2_integer4 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER2/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer2_real1 (ffebld_cu_ptr_integer2 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer2_real2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer2_real3 (ffebld_cu_ptr_integer2 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer2_real4 (ffebld_cu_ptr_integer2 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER2/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer2_complex1 (ffebld_cu_ptr_integer2 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer2_complex2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer2_complex3 (ffebld_cu_ptr_integer2 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer2_complex4 (ffebld_cu_ptr_integer2 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER2/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_integer2_logical1 (ffebld_cu_ptr_integer2 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_integer2_logical2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_integer2_logical3 (ffebld_cu_ptr_integer2 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_integer2_logical4 (ffebld_cu_ptr_integer2 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER2/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_integer2_character1 (ffebld_cu_ptr_integer2 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_integer2_hollerith (ffebld_cu_ptr_integer2 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_integer2_typeless (ffebld_cu_ptr_integer2 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("INTEGER2 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_integer3_integer1 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_integer3_integer2 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_integer3_integer4 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER3/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer3_real1 (ffebld_cu_ptr_integer3 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer3_real2 (ffebld_cu_ptr_integer3 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer3_real3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer3_real4 (ffebld_cu_ptr_integer3 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER3/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer3_complex1 (ffebld_cu_ptr_integer3 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer3_complex2 (ffebld_cu_ptr_integer3 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer3_complex3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer3_complex4 (ffebld_cu_ptr_integer3 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER3/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_integer3_logical1 (ffebld_cu_ptr_integer3 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_integer3_logical2 (ffebld_cu_ptr_integer3 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_integer3_logical3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_integer3_logical4 (ffebld_cu_ptr_integer3 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER3/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_integer3_character1 (ffebld_cu_ptr_integer3 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_integer3_hollerith (ffebld_cu_ptr_integer3 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_integer3_typeless (ffebld_cu_ptr_integer3 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("INTEGER3 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_integer4_integer1 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_integer4_integer2 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_integer4_integer3 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif default: assert ("INTEGER4/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer4_real1 (ffebld_cu_ptr_integer4 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer4_real2 (ffebld_cu_ptr_integer4 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer4_real3 (ffebld_cu_ptr_integer4 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer4_real4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER4/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_integer4_complex1 (ffebld_cu_ptr_integer4 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_integer4_complex2 (ffebld_cu_ptr_integer4 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_integer4_complex3 (ffebld_cu_ptr_integer4 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_integer4_complex4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER3/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_integer4_logical1 (ffebld_cu_ptr_integer4 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_integer4_logical2 (ffebld_cu_ptr_integer4 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_integer4_logical3 (ffebld_cu_ptr_integer4 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_integer4_logical4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("INTEGER4/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_integer4_character1 (ffebld_cu_ptr_integer4 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_integer4_hollerith (ffebld_cu_ptr_integer4 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_integer4_typeless (ffebld_cu_ptr_integer4 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("INTEGER4 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: sz = FFETARGET_charactersizeNONE; switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_logical1_logical2 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_logical1_logical3 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_logical1_logical4 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL1/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_logical1_integer1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_logical1_integer2 (ffebld_cu_ptr_logical1 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_logical1_integer3 (ffebld_cu_ptr_logical1 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_logical1_integer4 (ffebld_cu_ptr_logical1 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL1/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_logical1_character1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_logical1_hollerith (ffebld_cu_ptr_logical1 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_logical1_typeless (ffebld_cu_ptr_logical1 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("LOGICAL1 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_logical2_logical1 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_logical2_logical3 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_logical2_logical4 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL2/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_logical2_integer1 (ffebld_cu_ptr_logical2 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_logical2_integer2 (ffebld_cu_ptr_logical2 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_logical2_integer3 (ffebld_cu_ptr_logical2 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_logical2_integer4 (ffebld_cu_ptr_logical2 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL2/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_logical2_character1 (ffebld_cu_ptr_logical2 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_logical2_hollerith (ffebld_cu_ptr_logical2 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_logical2_typeless (ffebld_cu_ptr_logical2 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("LOGICAL2 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_logical3_logical1 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_logical3_logical2 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_logical3_logical4 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL3/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_logical3_integer1 (ffebld_cu_ptr_logical3 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_logical3_integer2 (ffebld_cu_ptr_logical3 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_logical3_integer3 (ffebld_cu_ptr_logical3 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_logical3_integer4 (ffebld_cu_ptr_logical3 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL3/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_logical3_character1 (ffebld_cu_ptr_logical3 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_logical3_hollerith (ffebld_cu_ptr_logical3 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_logical3_typeless (ffebld_cu_ptr_logical3 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("LOGICAL3 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_logical4_logical1 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical1 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_logical4_logical2 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical2 (ffebld_conter (l))); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_logical4_logical3 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical3 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL4/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_logical4_integer1 (ffebld_cu_ptr_logical4 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_logical4_integer2 (ffebld_cu_ptr_logical4 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_logical4_integer3 (ffebld_cu_ptr_logical4 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_logical4_integer4 (ffebld_cu_ptr_logical4 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("LOGICAL4/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_logical4_character1 (ffebld_cu_ptr_logical4 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_logical4_hollerith (ffebld_cu_ptr_logical4 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_logical4_typeless (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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real1_real4 (ffebld_cu_ptr_real1 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("REAL1/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_real1_complex1 (ffebld_cu_ptr_real1 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_real1_complex2 (ffebld_cu_ptr_real1 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_real1_complex3 (ffebld_cu_ptr_real1 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real1_complex4 (ffebld_cu_ptr_real1 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("REAL1/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_real1_character1 (ffebld_cu_ptr_real1 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_real1_hollerith (ffebld_cu_ptr_real1 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_real1_typeless (ffebld_cu_ptr_real1 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("REAL1 bad type" == NULL); break; } /* If 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real2_real4 (ffebld_cu_ptr_real2 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("REAL2/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_real2_complex1 (ffebld_cu_ptr_real2 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_real2_complex2 (ffebld_cu_ptr_real2 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_real2_complex3 (ffebld_cu_ptr_real2 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real2_complex4 (ffebld_cu_ptr_real2 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("REAL2/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_real2_character1 (ffebld_cu_ptr_real2 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_real2_hollerith (ffebld_cu_ptr_real2 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_real2_typeless (ffebld_cu_ptr_real2 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("REAL2 bad type" == NULL); break; } /* If 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real3_real4 (ffebld_cu_ptr_real3 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("REAL3/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_real3_complex1 (ffebld_cu_ptr_real3 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_real3_complex2 (ffebld_cu_ptr_real3 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_real3_complex3 (ffebld_cu_ptr_real3 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real3_complex4 (ffebld_cu_ptr_real3 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("REAL3/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_real3_character1 (ffebld_cu_ptr_real3 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_real3_hollerith (ffebld_cu_ptr_real3 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_real3_typeless (ffebld_cu_ptr_real3 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("REAL3 bad type" == NULL); break; } /* If 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_real4_integer1 (ffebld_cu_ptr_real4 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_real4_integer2 (ffebld_cu_ptr_real4 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_real4_integer3 (ffebld_cu_ptr_real4 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_real4_integer4 (ffebld_cu_ptr_real4 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("REAL4/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_real4_real1 (ffebld_cu_ptr_real4 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_real4_real2 (ffebld_cu_ptr_real4 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_real4_real3 (ffebld_cu_ptr_real4 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif default: assert ("REAL4/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_real4_complex1 (ffebld_cu_ptr_real4 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_real4_complex2 (ffebld_cu_ptr_real4 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_real4_complex3 (ffebld_cu_ptr_real4 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_real4_complex4 (ffebld_cu_ptr_real4 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("REAL4/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_real4_character1 (ffebld_cu_ptr_real4 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_real4_hollerith (ffebld_cu_ptr_real4 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_real4_typeless (ffebld_cu_ptr_real4 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("REAL4 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: sz = FFETARGET_charactersizeNONE; switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_complex1_integer1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_complex1_integer2 (ffebld_cu_ptr_complex1 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_complex1_integer3 (ffebld_cu_ptr_complex1 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_complex1_integer4 (ffebld_cu_ptr_complex1 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX1/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_complex1_real1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_complex1_real2 (ffebld_cu_ptr_complex1 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_complex1_real3 (ffebld_cu_ptr_complex1 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex1_real4 (ffebld_cu_ptr_complex1 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX1/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_complex1_complex2 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_complex1_complex3 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex1_complex4 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX1/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_complex1_character1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_complex1_hollerith (ffebld_cu_ptr_complex1 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_complex1_typeless (ffebld_cu_ptr_complex1 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("COMPLEX1 bad type" == NULL); break; } /* If 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex2_real4 (ffebld_cu_ptr_complex2 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX2/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_complex2_complex1 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_complex2_complex3 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex2_complex4 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX2/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_complex2_character1 (ffebld_cu_ptr_complex2 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_complex2_hollerith (ffebld_cu_ptr_complex2 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_complex2_typeless (ffebld_cu_ptr_complex2 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("COMPLEX2 bad type" == NULL); break; } /* If 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex3_real4 (ffebld_cu_ptr_complex3 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX3/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_complex3_complex1 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_complex3_complex2 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex3_complex4 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX3/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_complex3_character1 (ffebld_cu_ptr_complex3 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_complex3_hollerith (ffebld_cu_ptr_complex3 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_complex3_typeless (ffebld_cu_ptr_complex3 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("COMPLEX3 bad type" == NULL); break; } /* If 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 #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_complex4_integer1 (ffebld_cu_ptr_complex4 (u), ffebld_constant_integer1 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_complex4_integer2 (ffebld_cu_ptr_complex4 (u), ffebld_constant_integer2 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_complex4_integer3 (ffebld_cu_ptr_complex4 (u), ffebld_constant_integer3 (ffebld_conter (l))); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_complex4_integer4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_integer4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX4/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_complex4_real1 (ffebld_cu_ptr_complex4 (u), ffebld_constant_real1 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_complex4_real2 (ffebld_cu_ptr_complex4 (u), ffebld_constant_real2 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_complex4_real3 (ffebld_cu_ptr_complex4 (u), ffebld_constant_real3 (ffebld_conter (l))); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_convert_complex4_real4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_real4 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX4/REAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_convert_complex4_complex1 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex1 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_convert_complex4_complex2 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex2 (ffebld_conter (l))); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_convert_complex4_complex3 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex3 (ffebld_conter (l))); break; #endif default: assert ("COMPLEX4/COMPLEX bad source kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: error = ffetarget_convert_complex4_character1 (ffebld_cu_ptr_complex4 (u), ffebld_constant_character1 (ffebld_conter (l))); break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_complex4_hollerith (ffebld_cu_ptr_complex4 (u), ffebld_constant_hollerith (ffebld_conter (l))); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_complex4_typeless (ffebld_cu_ptr_complex4 (u), ffebld_constant_typeless (ffebld_conter (l))); break; default: assert ("COMPLEX4 bad type" == NULL); break; } /* If conversion operation is not implemented, return original expr. */ if (error == FFEBAD_NOCANDO) return expr; expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE) return expr; kt = ffeinfo_kindtype (ffebld_info (expr)); switch (kt) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: switch (ffeinfo_basictype (ffebld_info (l))) { case FFEINFO_basictypeCHARACTER: if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE) return expr; assert (kt == ffeinfo_kindtype (ffebld_info (l))); assert (sz2 == ffetarget_length_character1 (ffebld_constant_character1 (ffebld_conter (l)))); error = ffetarget_convert_character1_character1 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_pool ()); break; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_convert_character1_integer1 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_convert_character1_integer2 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_convert_character1_integer3 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_convert_character1_integer4 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif default: assert ("CHARACTER1/INTEGER bad source kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (ffeinfo_kindtype (ffebld_info (l))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_convert_character1_logical1 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_logical1 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_convert_character1_logical2 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_logical2 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_convert_character1_logical3 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_logical3 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_convert_character1_logical4 (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_logical4 (ffebld_conter (l)), ffebld_constant_pool ()); break; #endif default: assert ("CHARACTER1/LOGICAL bad source kind type" == NULL); break; } break; case FFEINFO_basictypeHOLLERITH: error = ffetarget_convert_character1_hollerith (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_hollerith (ffebld_conter (l)), ffebld_constant_pool ()); break; case FFEINFO_basictypeTYPELESS: error = ffetarget_convert_character1_typeless (ffebld_cu_ptr_character1 (u), sz, ffebld_constant_typeless (ffebld_conter (l)), ffebld_constant_pool ()); break; default: assert ("CHARACTER1 bad type" == NULL); } expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val (ffebld_cu_val_character1 (u)), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, sz)); if ((error != FFEBAD) && ffebad_start (error)) { assert (t != NULL); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val (ffebld_cu_val_complex1 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val (ffebld_cu_val_complex2 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val (ffebld_cu_val_complex3 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u), ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex1 (ffebld_conter (l)), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val (ffebld_cu_val_complex1 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex2 (ffebld_conter (l)), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val (ffebld_cu_val_complex2 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex3 (ffebld_conter (l)), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val (ffebld_cu_val_complex3 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex4 (ffebld_conter (l)), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* 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 #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u), ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex1 (ffebld_conter (l)), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val (ffebld_cu_val_complex1 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex2 (ffebld_conter (l)), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val (ffebld_cu_val_complex2 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex3 (ffebld_conter (l)), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val (ffebld_cu_val_complex3 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex4 (ffebld_conter (l)), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* 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 #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u), ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val (ffebld_cu_val_real1 (u)), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u), ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val (ffebld_cu_val_real2 (u)), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u), ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val (ffebld_cu_val_real3 (u)), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u), ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex1 (ffebld_conter (l)), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val (ffebld_cu_val_complex1 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex2 (ffebld_conter (l)), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val (ffebld_cu_val_complex2 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex3 (ffebld_conter (l)), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val (ffebld_cu_val_complex3 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex4 (ffebld_conter (l)), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_divide -- Collapse divide expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_divide(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_divide (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u), ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val (ffebld_cu_val_real1 (u)), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u), ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val (ffebld_cu_val_real2 (u)), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u), ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val (ffebld_cu_val_real3 (u)), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u), ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u), ffebld_constant_complex1 (ffebld_conter (l)), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val (ffebld_cu_val_complex1 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u), ffebld_constant_complex2 (ffebld_conter (l)), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val (ffebld_cu_val_complex2 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u), ffebld_constant_complex3 (ffebld_conter (l)), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val (ffebld_cu_val_complex3 (u)), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u), ffebld_constant_complex4 (ffebld_conter (l)), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_power -- Collapse power expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_power(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_power (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER) || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT)) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { case FFEINFO_kindtypeINTEGERDEFAULT: error = ffetarget_power_integerdefault_integerdefault (ffebld_cu_ptr_integerdefault (u), ffebld_constant_integerdefault (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integerdefault_val (ffebld_cu_val_integerdefault (u)), expr); break; default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { case FFEINFO_kindtypeREALDEFAULT: error = ffetarget_power_realdefault_integerdefault (ffebld_cu_ptr_realdefault (u), ffebld_constant_realdefault (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_realdefault_val (ffebld_cu_val_realdefault (u)), expr); break; case FFEINFO_kindtypeREALDOUBLE: error = ffetarget_power_realdouble_integerdefault (ffebld_cu_ptr_realdouble (u), ffebld_constant_realdouble (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_realdouble_val (ffebld_cu_val_realdouble (u)), expr); break; #if FFETARGET_okREALQUAD case FFEINFO_kindtypeREALQUAD: error = ffetarget_power_realquad_integerdefault (ffebld_cu_ptr_realquad (u), ffebld_constant_realquad (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_realquad_val (ffebld_cu_val_realquad (u)), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { case FFEINFO_kindtypeREALDEFAULT: error = ffetarget_power_complexdefault_integerdefault (ffebld_cu_ptr_complexdefault (u), ffebld_constant_complexdefault (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complexdefault_val (ffebld_cu_val_complexdefault (u)), expr); break; #if FFETARGET_okCOMPLEXDOUBLE case FFEINFO_kindtypeREALDOUBLE: error = ffetarget_power_complexdouble_integerdefault (ffebld_cu_ptr_complexdouble (u), ffebld_constant_complexdouble (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complexdouble_val (ffebld_cu_val_complexdouble (u)), expr); break; #endif #if FFETARGET_okCOMPLEXQUAD case FFEINFO_kindtypeREALQUAD: error = ffetarget_power_complexquad_integerdefault (ffebld_cu_ptr_complexquad (u), ffebld_constant_complexquad (ffebld_conter (l)), ffebld_constant_integerdefault (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_complexquad_val (ffebld_cu_val_complexquad (u)), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_concatenate -- Collapse concatenate expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_concatenate(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoKindtype kt; ffetargetCharacterSize len; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeCHARACTER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u), ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r)), ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val (ffebld_cu_val_character1 (u)), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u), ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r)), ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val (ffebld_cu_val_character2 (u)), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u), ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r)), ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val (ffebld_cu_val_character3 (u)), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u), ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r)), ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val (ffebld_cu_val_character4 (u)), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, len)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_eq -- Collapse eq expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_eq(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_eq (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; bool val; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_eq_integer1 (&val, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_eq_integer2 (&val, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_eq_integer3 (&val, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_eq_integer4 (&val, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_eq_real1 (&val, ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_eq_real2 (&val, ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_eq_real3 (&val, ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_eq_real4 (&val, ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_eq_complex1 (&val, ffebld_constant_complex1 (ffebld_conter (l)), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_eq_complex2 (&val, ffebld_constant_complex2 (ffebld_conter (l)), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_eq_complex3 (&val, ffebld_constant_complex3 (ffebld_conter (l)), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_eq_complex4 (&val, ffebld_constant_complex4 (ffebld_conter (l)), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_eq_character1 (&val, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_eq_character2 (&val, ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_eq_character3 (&val, ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_eq_character4 (&val, ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_ne -- Collapse ne expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_ne(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_ne (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; bool val; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_ne_integer1 (&val, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_ne_integer2 (&val, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_ne_integer3 (&val, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_ne_integer4 (&val, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_ne_real1 (&val, ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_ne_real2 (&val, ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_ne_real3 (&val, ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_ne_real4 (&val, ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCOMPLEX: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: error = ffetarget_ne_complex1 (&val, ffebld_constant_complex1 (ffebld_conter (l)), ffebld_constant_complex1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: error = ffetarget_ne_complex2 (&val, ffebld_constant_complex2 (ffebld_conter (l)), ffebld_constant_complex2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: error = ffetarget_ne_complex3 (&val, ffebld_constant_complex3 (ffebld_conter (l)), ffebld_constant_complex3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: error = ffetarget_ne_complex4 (&val, ffebld_constant_complex4 (ffebld_conter (l)), ffebld_constant_complex4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad complex kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_ne_character1 (&val, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_ne_character2 (&val, ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_ne_character3 (&val, ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_ne_character4 (&val, ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_ge -- Collapse ge expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_ge(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_ge (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; bool val; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_ge_integer1 (&val, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_ge_integer2 (&val, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_ge_integer3 (&val, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_ge_integer4 (&val, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_ge_real1 (&val, ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_ge_real2 (&val, ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_ge_real3 (&val, ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_ge_real4 (&val, ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_ge_character1 (&val, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_ge_character2 (&val, ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_ge_character3 (&val, ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_ge_character4 (&val, ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_gt -- Collapse gt expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_gt(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_gt (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; bool val; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_gt_integer1 (&val, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_gt_integer2 (&val, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_gt_integer3 (&val, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_gt_integer4 (&val, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_gt_real1 (&val, ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_gt_real2 (&val, ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_gt_real3 (&val, ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_gt_real4 (&val, ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_gt_character1 (&val, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_gt_character2 (&val, ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_gt_character3 (&val, ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_gt_character4 (&val, ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_le -- Collapse le expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_le(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_le (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; bool val; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_le_integer1 (&val, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_le_integer2 (&val, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_le_integer3 (&val, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_le_integer4 (&val, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_le_real1 (&val, ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_le_real2 (&val, ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_le_real3 (&val, ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_le_real4 (&val, ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_le_character1 (&val, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_le_character2 (&val, ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_le_character3 (&val, ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_le_character4 (&val, ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_lt -- Collapse lt expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_lt(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_lt (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; bool val; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_lt_integer1 (&val, ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_lt_integer2 (&val, ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_lt_integer3 (&val, ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_lt_integer4 (&val, ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeREAL: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okREAL1 case FFEINFO_kindtypeREAL1: error = ffetarget_lt_real1 (&val, ffebld_constant_real1 (ffebld_conter (l)), ffebld_constant_real1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL2 case FFEINFO_kindtypeREAL2: error = ffetarget_lt_real2 (&val, ffebld_constant_real2 (ffebld_conter (l)), ffebld_constant_real2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL3 case FFEINFO_kindtypeREAL3: error = ffetarget_lt_real3 (&val, ffebld_constant_real3 (ffebld_conter (l)), ffebld_constant_real3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okREAL4 case FFEINFO_kindtypeREAL4: error = ffetarget_lt_real4 (&val, ffebld_constant_real4 (ffebld_conter (l)), ffebld_constant_real4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad real kind type" == NULL); break; } break; case FFEINFO_basictypeCHARACTER: switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_lt_character1 (&val, ffebld_constant_character1 (ffebld_conter (l)), ffebld_constant_character1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_lt_character2 (&val, ffebld_constant_character2 (ffebld_conter (l)), ffebld_constant_character2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_lt_character3 (&val, ffebld_constant_character3 (ffebld_conter (l)), ffebld_constant_character3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_lt_character4 (&val, ffebld_constant_character4 (ffebld_conter (l)), ffebld_constant_character4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logicaldefault (val), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_and -- Collapse and expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_and(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_and (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical1 (ffebld_conter (l)), ffebld_constant_logical1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical2 (ffebld_conter (l)), ffebld_constant_logical2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical3 (ffebld_conter (l)), ffebld_constant_logical3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical4 (ffebld_conter (l)), ffebld_constant_logical4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val (ffebld_cu_val_logical4 (u)), expr); break; #endif default: assert ("bad logical kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_or -- Collapse or expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_or(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_or (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical1 (ffebld_conter (l)), ffebld_constant_logical1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical2 (ffebld_conter (l)), ffebld_constant_logical2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical3 (ffebld_conter (l)), ffebld_constant_logical3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical4 (ffebld_conter (l)), ffebld_constant_logical4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val (ffebld_cu_val_logical4 (u)), expr); break; #endif default: assert ("bad logical kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_xor -- Collapse xor expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_xor(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_xor (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical1 (ffebld_conter (l)), ffebld_constant_logical1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical2 (ffebld_conter (l)), ffebld_constant_logical2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical3 (ffebld_conter (l)), ffebld_constant_logical3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical4 (ffebld_conter (l)), ffebld_constant_logical4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val (ffebld_cu_val_logical4 (u)), expr); break; #endif default: assert ("bad logical kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_eqv -- Collapse eqv expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_eqv(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_eqv (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical1 (ffebld_conter (l)), ffebld_constant_logical1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical2 (ffebld_conter (l)), ffebld_constant_logical2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical3 (ffebld_conter (l)), ffebld_constant_logical3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical4 (ffebld_conter (l)), ffebld_constant_logical4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val (ffebld_cu_val_logical4 (u)), expr); break; #endif default: assert ("bad logical kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_neqv -- Collapse neqv expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_neqv(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_neqv (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebldConstantUnion u; ffeinfoBasictype bt; ffeinfoKindtype kt; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); if (ffebld_op (l) != FFEBLD_opCONTER) return expr; if (ffebld_op (r) != FFEBLD_opCONTER) return expr; switch (bt = ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeINTEGER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okINTEGER1 case FFEINFO_kindtypeINTEGER1: error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u), ffebld_constant_integer1 (ffebld_conter (l)), ffebld_constant_integer1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); break; #endif #if FFETARGET_okINTEGER2 case FFEINFO_kindtypeINTEGER2: error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u), ffebld_constant_integer2 (ffebld_conter (l)), ffebld_constant_integer2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); break; #endif #if FFETARGET_okINTEGER3 case FFEINFO_kindtypeINTEGER3: error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u), ffebld_constant_integer3 (ffebld_conter (l)), ffebld_constant_integer3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); break; #endif #if FFETARGET_okINTEGER4 case FFEINFO_kindtypeINTEGER4: error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u), ffebld_constant_integer4 (ffebld_conter (l)), ffebld_constant_integer4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); break; #endif default: assert ("bad integer kind type" == NULL); break; } break; case FFEINFO_basictypeLOGICAL: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okLOGICAL1 case FFEINFO_kindtypeLOGICAL1: error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u), ffebld_constant_logical1 (ffebld_conter (l)), ffebld_constant_logical1 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); break; #endif #if FFETARGET_okLOGICAL2 case FFEINFO_kindtypeLOGICAL2: error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u), ffebld_constant_logical2 (ffebld_conter (l)), ffebld_constant_logical2 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); break; #endif #if FFETARGET_okLOGICAL3 case FFEINFO_kindtypeLOGICAL3: error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u), ffebld_constant_logical3 (ffebld_conter (l)), ffebld_constant_logical3 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); break; #endif #if FFETARGET_okLOGICAL4 case FFEINFO_kindtypeLOGICAL4: error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u), ffebld_constant_logical4 (ffebld_conter (l)), ffebld_constant_logical4 (ffebld_conter (r))); expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val (ffebld_cu_val_logical4 (u)), expr); break; #endif default: assert ("bad logical kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_collapse_symter -- Collapse symter expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_symter(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED) { ffebld r; ffeinfoBasictype bt; ffeinfoKindtype kt; ffetargetCharacterSize len; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL) return expr; /* A PARAMETER lhs in progress. */ switch (ffebld_op (r)) { case FFEBLD_opCONTER: break; case FFEBLD_opANY: return r; default: return expr; } bt = ffeinfo_basictype (ffebld_info (r)); kt = ffeinfo_kindtype (ffebld_info (r)); len = ffebld_size (r); expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), expr); ffebld_set_info (expr, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, len)); return expr; } /* ffeexpr_collapse_funcref -- Collapse funcref expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_funcref(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED) { return expr; /* ~~someday go ahead and collapse these, though not required */ } /* ffeexpr_collapse_arrayref -- Collapse arrayref expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_arrayref(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED) { return expr; } /* ffeexpr_collapse_substr -- Collapse substr expr ffebld expr; ffelexToken token; expr = ffeexpr_collapse_substr(expr,token); If the result of the expr is a constant, replaces the expr with the computed constant. */ ffebld ffeexpr_collapse_substr (ffebld expr, ffelexToken t) { ffebad error = FFEBAD; ffebld l; ffebld r; ffebld start; ffebld stop; ffebldConstantUnion u; ffeinfoKindtype kt; ffetargetCharacterSize len; ffetargetIntegerDefault first; ffetargetIntegerDefault last; if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) return expr; l = ffebld_left (expr); r = ffebld_right (expr); /* opITEM. */ if (ffebld_op (l) != FFEBLD_opCONTER) return expr; kt = ffeinfo_kindtype (ffebld_info (l)); len = ffebld_size (l); start = ffebld_head (r); stop = ffebld_head (ffebld_trail (r)); if (start == NULL) first = 1; else { if ((ffebld_op (start) != FFEBLD_opCONTER) || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER) || (ffeinfo_kindtype (ffebld_info (start)) != FFEINFO_kindtypeINTEGERDEFAULT)) return expr; first = ffebld_constant_integerdefault (ffebld_conter (start)); } if (stop == NULL) last = len; else { if ((ffebld_op (stop) != FFEBLD_opCONTER) || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER) || (ffeinfo_kindtype (ffebld_info (stop)) != FFEINFO_kindtypeINTEGERDEFAULT)) return expr; last = ffebld_constant_integerdefault (ffebld_conter (stop)); } /* Handle problems that should have already been diagnosed, but left in the expression tree. */ if (first <= 0) first = 1; if (last < first) last = first + len - 1; if ((first == 1) && (last == len)) { /* Same as original. */ expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (l)), expr); ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, len)); return expr; } switch (ffeinfo_basictype (ffebld_info (expr))) { case FFEINFO_basictypeANY: return expr; case FFEINFO_basictypeCHARACTER: switch (kt = ffeinfo_kindtype (ffebld_info (expr))) { #if FFETARGET_okCHARACTER1 case FFEINFO_kindtypeCHARACTER1: error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u), ffebld_constant_character1 (ffebld_conter (l)), first, last, ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val (ffebld_cu_val_character1 (u)), expr); break; #endif #if FFETARGET_okCHARACTER2 case FFEINFO_kindtypeCHARACTER2: error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u), ffebld_constant_character2 (ffebld_conter (l)), first, last, ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val (ffebld_cu_val_character2 (u)), expr); break; #endif #if FFETARGET_okCHARACTER3 case FFEINFO_kindtypeCHARACTER3: error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u), ffebld_constant_character3 (ffebld_conter (l)), first, last, ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val (ffebld_cu_val_character3 (u)), expr); break; #endif #if FFETARGET_okCHARACTER4 case FFEINFO_kindtypeCHARACTER4: error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u), ffebld_constant_character4 (ffebld_conter (l)), first, last, ffebld_constant_pool (), &len); expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val (ffebld_cu_val_character4 (u)), expr); break; #endif default: assert ("bad character kind type" == NULL); break; } break; default: assert ("bad type" == NULL); return expr; } ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER, kt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, len)); if ((error != FFEBAD) && ffebad_start (error)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return expr; } /* ffeexpr_convert -- Convert source expression to given type ffebld source; ffelexToken source_token; ffelexToken dest_token; // Any appropriate token for "destination". ffeinfoBasictype bt; ffeinfoKindtype kt; ffetargetCharactersize sz; ffeexprContext context; // Mainly LET or DATA. source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context); If the expression conforms, returns the source expression. Otherwise returns source wrapped in a convert node doing the conversion, or ANY wrapped in convert if there is a conversion error (and issues an error message). Be sensitive to the context for certain aspects of the conversion. */ ffebld ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk, ffetargetCharacterSize sz, ffeexprContext context) { bool bad; ffeinfo info; ffeinfoWhere wh; info = ffebld_info (source); if ((bt != ffeinfo_basictype (info)) || (kt != ffeinfo_kindtype (info)) || (rk != 0) /* Can't convert from or to arrays yet. */ || (ffeinfo_rank (info) != 0) || (sz != ffebld_size_known (source))) #if 0 /* Nobody seems to need this spurious CONVERT node. */ || ((context != FFEEXPR_contextLET) && (bt == FFEINFO_basictypeCHARACTER) && (sz == FFETARGET_charactersizeNONE))) #endif { switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: switch (bt) { case FFEINFO_basictypeLOGICAL: bad = FALSE; break; case FFEINFO_basictypeINTEGER: bad = !ffe_is_ugly_logint (); break; case FFEINFO_basictypeCHARACTER: bad = ffe_is_pedantic () || !(ffe_is_ugly_init () && (context == FFEEXPR_contextDATA)); break; default: bad = TRUE; break; } break; case FFEINFO_basictypeINTEGER: switch (bt) { case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: bad = FALSE; break; case FFEINFO_basictypeLOGICAL: bad = !ffe_is_ugly_logint (); break; case FFEINFO_basictypeCHARACTER: bad = ffe_is_pedantic () || !(ffe_is_ugly_init () && (context == FFEEXPR_contextDATA)); break; default: bad = TRUE; break; } break; case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: switch (bt) { case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: bad = FALSE; break; case FFEINFO_basictypeCHARACTER: bad = TRUE; break; default: bad = TRUE; break; } break; case FFEINFO_basictypeCHARACTER: bad = (bt != FFEINFO_basictypeCHARACTER) && (ffe_is_pedantic () || (bt != FFEINFO_basictypeINTEGER) || !(ffe_is_ugly_init () && (context == FFEEXPR_contextDATA))); break; case FFEINFO_basictypeTYPELESS: case FFEINFO_basictypeHOLLERITH: bad = ffe_is_pedantic () || !(ffe_is_ugly_init () && ((context == FFEEXPR_contextDATA) || (context == FFEEXPR_contextLET))); break; default: bad = TRUE; break; } if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0))) bad = TRUE; if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY) && (ffeinfo_basictype (info) != FFEINFO_basictypeANY) && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY) && (ffeinfo_where (info) != FFEINFO_whereANY)) { if (ffebad_start (FFEBAD_BAD_TYPES)) { if (dest_token == NULL) ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); else ffebad_here (0, ffelex_token_where_line (dest_token), ffelex_token_where_column (dest_token)); assert (source_token != NULL); ffebad_here (1, ffelex_token_where_line (source_token), ffelex_token_where_column (source_token)); ffebad_finish (); } source = ffebld_new_any (); ffebld_set_info (source, ffeinfo_new_any ()); } else { switch (ffeinfo_where (info)) { case FFEINFO_whereCONSTANT: wh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: wh = FFEINFO_whereIMMEDIATE; break; default: wh = FFEINFO_whereFLEETING; break; } source = ffebld_new_convert (source); ffebld_set_info (source, ffeinfo_new (bt, kt, 0, FFEINFO_kindENTITY, wh, sz)); source = ffeexpr_collapse_convert (source, source_token); } } return source; } /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr ffebld source; ffebld dest; ffelexToken source_token; ffelexToken dest_token; ffeexprContext context; source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context); If the expressions conform, returns the source expression. Otherwise returns source wrapped in a convert node doing the conversion, or ANY wrapped in convert if there is a conversion error (and issues an error message). Be sensitive to the context, such as LET or DATA. */ ffebld ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest, ffelexToken dest_token, ffeexprContext context) { ffeinfo info; info = ffebld_info (dest); return ffeexpr_convert (source, source_token, dest_token, ffeinfo_basictype (info), ffeinfo_kindtype (info), ffeinfo_rank (info), ffebld_size_known (dest), context); } /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol ffebld source; ffesymbol dest; ffelexToken source_token; ffelexToken dest_token; source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token); If the expressions conform, returns the source expression. Otherwise returns source wrapped in a convert node doing the conversion, or ANY wrapped in convert if there is a conversion error (and issues an error message). */ ffebld ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token, ffesymbol dest, ffelexToken dest_token) { return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest), ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest), FFEEXPR_contextLET); } /* Initializes the module. */ void ffeexpr_init_2 () { ffeexpr_stack_ = NULL; ffeexpr_level_ = 0; } /* ffeexpr_lhs -- Begin processing left-hand-side-context expression Prepares cluster for delivery of lexer tokens representing an expression in a left-hand-side context (A in A=B, for example). ffebld is used to build expressions in the given pool. The appropriate lexer-token handling routine within ffeexpr is returned. When the end of the expression is detected, mycallbackroutine is called with the resulting single ffebld object specifying the entire expression and the first lexer token that is not considered part of the expression. This caller- supplied routine itself returns a lexer-token handling routine. Thus, if necessary, ffeexpr can return several tokens as end-of-expression tokens if it needs to scan forward more than one in any instance. */ ffelexHandler ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) { ffeexprStack_ s; ffebld_pool_push (pool); s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); s->previous = ffeexpr_stack_; s->pool = pool; s->context = context; s->callback = callback; s->first_token = NULL; s->exprstack = NULL; s->is_rhs = FALSE; ffeexpr_stack_ = s; return (ffelexHandler) ffeexpr_token_first_lhs_; } /* ffeexpr_rhs -- Begin processing right-hand-side-context expression return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer. Prepares cluster for delivery of lexer tokens representing an expression in a right-hand-side context (B in A=B, for example). ffebld is used to build expressions in the given pool. The appropriate lexer-token handling routine within ffeexpr is returned. When the end of the expression is detected, mycallbackroutine is called with the resulting single ffebld object specifying the entire expression and the first lexer token that is not considered part of the expression. This caller- supplied routine itself returns a lexer-token handling routine. Thus, if necessary, ffeexpr can return several tokens as end-of-expression tokens if it needs to scan forward more than one in any instance. */ ffelexHandler ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) { ffeexprStack_ s; ffebld_pool_push (pool); s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); s->previous = ffeexpr_stack_; s->pool = pool; s->context = context; s->callback = callback; s->first_token = NULL; s->exprstack = NULL; s->is_rhs = TRUE; ffeexpr_stack_ = s; return (ffelexHandler) ffeexpr_token_first_rhs_; } /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr Pass it to ffeexpr_rhs as the callback routine. Makes sure the end token is close-paren and swallows it, else issues an error message and doesn't swallow the token (passing it along instead). In either case wraps up subexpression construction by enclosing the ffebld expression in a paren. */ static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprExpr_ e; if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) { /* Oops, naughty user didn't specify the close paren! */ if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_token_binary_); } if (expr->op == FFEBLD_opIMPDO) { if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } } else { expr = ffebld_new_paren (expr); ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr)))); } /* Now push the (parenthesized) expression as an operand onto the expression stack. */ e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->u.operand = expr; e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft); e->token = ffeexpr_stack_->tokens[0]; ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr Pass it to ffeexpr_rhs as the callback routine. We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" with the next token in t. If the next token is possibly a binary operator, continue processing the outer expression. If the next token is COMMA, then the expression is a unit specifier, and parentheses should not be added to it because it surrounds the I/O control list that starts with the unit specifier (and continues on from here -- we haven't seen the CLOSE_PAREN that matches the OPEN_PAREN, it is up to the callback function to expect to see it at some point). In this case, we notify the callback function that the COMMA is inside, not outside, the parens by wrapping the expression in an opITEM (with a NULL trail) -- the callback function presumably unwraps it after seeing this kludgey indicator. If the next token is CLOSE_PAREN, then we go to the _1_ state to decide what to do with the token after that. 15-Feb-91 JCB 1.1 Use an extra state for the CLOSE_PAREN case to make READ &co really work right. */ static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprCallback callback; ffeexprStack_ s; if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) { /* Need to see the next token before we decide anything. */ ffeexpr_stack_->expr = expr; ffeexpr_tokens_[0] = ffelex_token_use (ft); ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_; } expr = ffeexpr_finished_ambig_ (ft, expr); /* Let the callback function handle the case where t isn't COMMA. */ /* Here is a kludge whereby we tell the callback function the OPEN_PAREN that preceded the expression starts a list of expressions, and the expr hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN node. The callback function should extract the real expr from the head of this opITEM node after testing it. */ expr = ffebld_new_item (expr, NULL); ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ffelex_token_kill (ffeexpr_stack_->first_token); s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; return (ffelexHandler) (*callback) (ft, expr, t); } /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN See ffeexpr_cb_close_paren_ambig_. We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" with the next token in t. If the next token is possibly a binary operator, continue processing the outer expression. If the next token is COMMA, the expression is a parenthesized format specifier. If the next token is not EOS or SEMICOLON, then because it is not a binary operator (it is NAME, OPEN_PAREN, &c), the expression is a unit specifier, and parentheses should not be added to it because they surround the I/O control list that consists of only the unit specifier. If the next token is EOS or SEMICOLON, the statement must be disambiguated by looking at the type of the expression -- a character expression is a parenthesized format specifier, while a non-character expression is a unit specifier. Another issue is how to do the callback so the recipient of the next token knows how to handle it if it is a COMMA. In all other cases, disambiguation is straightforward: the same approach as the above is used. EXTENSION: in COMMA case, if not pedantic, use same disambiguation as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]" and apparently other compilers do, as well, and some code out there uses this "feature". 19-Feb-91 JCB 1.1 Extend to allow COMMA as nondisambiguating by itself. Remember to not try and check info field for opSTAR, since that expr doesn't have a valid info field. */ static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t) { ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers these. */ ffelexToken orig_t = ffeexpr_tokens_[1]; ffebld expr = ffeexpr_stack_->expr; switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */ if (ffe_is_pedantic ()) goto pedantic_comma; /* :::::::::::::::::::: */ /* Fall through. */ case FFELEX_typeEOS: /* Ambiguous; use type of expr to disambiguate. */ case FFELEX_typeSEMICOLON: if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY) || (ffebld_op (expr) == FFEBLD_opSTAR) || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)) break; /* Not a valid CHARACTER entity, can't be a format spec. */ /* Fall through. */ default: /* Binary op (we assume; error otherwise); format specifier. */ pedantic_comma: /* :::::::::::::::::::: */ switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILENUMAMBIG: ffeexpr_stack_->context = FFEEXPR_contextFILENUM; break; case FFEEXPR_contextFILEUNITAMBIG: ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; break; default: assert ("bad context" == NULL); break; } ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t); ffelex_token_kill (orig_ft); ffelex_token_kill (orig_t); return (ffelexHandler) (*next) (t); case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */ case FFELEX_typeNAME: break; } expr = ffeexpr_finished_ambig_ (orig_ft, expr); /* Here is a kludge whereby we tell the callback function the OPEN_PAREN that preceded the expression starts a list of expressions, and the expr hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN node. The callback function should extract the real expr from the head of this opITEM node after testing it. */ expr = ffebld_new_item (expr, NULL); ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ffelex_token_kill (ffeexpr_stack_->first_token); s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t); ffelex_token_kill (orig_ft); ffelex_token_kill (orig_t); return (ffelexHandler) (*next) (t); } /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex) Pass it to ffeexpr_rhs as the callback routine. Makes sure the end token is close-paren and swallows it, or a comma and handles complex/implied-do possibilities, else issues an error message and doesn't swallow the token (passing it along instead). */ static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t) { /* First check to see if this is a possible complex entity. It is if the token is a comma. */ if (ffelex_token_type (t) == FFELEX_typeCOMMA) { ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); ffeexpr_stack_->expr = expr; return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_); } return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); } /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr Pass it to ffeexpr_rhs as the callback routine. If this token is not a comma, we have a complex constant (or an attempt at one), so handle it accordingly, displaying error messages if the token is not a close-paren. */ static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprExpr_ e; ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr)); ffeinfoBasictype rty = (expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr)); ffeinfoKindtype lkt; ffeinfoKindtype rkt; ffeinfoKindtype nkt; bool ok = TRUE; ffebld orig; if ((ffeexpr_stack_->expr == NULL) || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER) || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL) && (((ffebld_op (orig) != FFEBLD_opUMINUS) && (ffebld_op (orig) != FFEBLD_opUPLUS)) || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) || ((lty != FFEINFO_basictypeINTEGER) && (lty != FFEINFO_basictypeREAL))) { if ((lty != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), ffelex_token_where_column (ffeexpr_stack_->tokens[1])); ffebad_string ("Real"); ffebad_finish (); } ok = FALSE; } if ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER) || (((orig = ffebld_conter_orig (expr)) != NULL) && (((ffebld_op (orig) != FFEBLD_opUMINUS) && (ffebld_op (orig) != FFEBLD_opUPLUS)) || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) || ((rty != FFEINFO_basictypeINTEGER) && (rty != FFEINFO_basictypeREAL))) { if ((rty != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) { ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_string ("Imaginary"); ffebad_finish (); } ok = FALSE; } ffelex_token_kill (ffeexpr_stack_->tokens[1]); /* Push the (parenthesized) expression as an operand onto the expression stack. */ e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_stack_->tokens[0]; if (ok) { if (lty == FFEINFO_basictypeINTEGER) lkt = FFEINFO_kindtypeREALDEFAULT; else lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr)); if (rty == FFEINFO_basictypeINTEGER) rkt = FFEINFO_kindtypeREALDEFAULT; else rkt = ffeinfo_kindtype (ffebld_info (expr)); nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt); ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr, ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); expr = ffeexpr_convert (expr, ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); } else nkt = FFEINFO_kindtypeANY; switch (nkt) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; #endif default: if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } /* Fall through. */ case FFEINFO_kindtypeANY: e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); break; } ffeexpr_exprstack_push_operand_ (e); /* Now, if the token is a close parenthese, we're in great shape so return the next handler. */ if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_token_binary_; /* Oops, naughty user didn't specify the close paren! */ if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_token_binary_); } /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or implied-DO construct) Pass it to ffeexpr_rhs as the callback routine. Makes sure the end token is close-paren and swallows it, or a comma and handles complex/implied-do possibilities, else issues an error message and doesn't swallow the token (passing it along instead). */ static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprContext ctx; /* First check to see if this is a possible complex or implied-DO entity. It is if the token is a comma. */ if (ffelex_token_type (t) == FFELEX_typeCOMMA) { switch (ffeexpr_stack_->context) { case FFEEXPR_contextIOLIST: case FFEEXPR_contextIMPDOITEM_: ctx = FFEEXPR_contextIMPDOITEM_; break; case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEMDF_: ctx = FFEEXPR_contextIMPDOITEMDF_; break; default: assert ("bad context" == NULL); ctx = FFEEXPR_contextIMPDOITEM_; break; } ffeexpr_stack_->tokens[0] = ffelex_token_use (ft); ffeexpr_stack_->expr = expr; return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_cb_comma_ci_); } ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); } /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr Pass it to ffeexpr_rhs as the callback routine. If this token is not a comma, we have a complex constant (or an attempt at one), so handle it accordingly, displaying error messages if the token is not a close-paren. If we have a comma here, it is an attempt at an implied-DO, so start making a list accordingly. Oh, it might be an equal sign also, meaning an implied-DO with only one item in its list. */ static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffebld fexpr; /* First check to see if this is a possible complex constant. It is if the token is not a comma or an equals sign, in which case it should be a close-paren. */ if ((ffelex_token_type (t) != FFELEX_typeCOMMA) && (ffelex_token_type (t) != FFELEX_typeEQUALS)) { ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0]; ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t); } /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO construct. Make a list and handle accordingly. */ ffelex_token_kill (ffeexpr_stack_->tokens[0]); fexpr = ffeexpr_stack_->expr; ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); ffebld_append_item (&ffeexpr_stack_->bottom, fexpr); return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); } /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr Pass it to ffeexpr_rhs as the callback routine. Handle first item in an implied-DO construct. */ static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeCOMMA) { if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffebld_end_list (&ffeexpr_stack_->bottom); ffeexpr_stack_->expr = ffebld_new_any (); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); return (ffelexHandler) ffeexpr_cb_comma_i_5_; } return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); } /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr Pass it to ffeexpr_rhs as the callback routine. Handle first item in an implied-DO construct. */ static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprContext ctxi; ffeexprContext ctxc; switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: case FFEEXPR_contextDATAIMPDOITEM_: ctxi = FFEEXPR_contextDATAIMPDOITEM_; ctxc = FFEEXPR_contextDATAIMPDOCTRL_; break; case FFEEXPR_contextIOLIST: case FFEEXPR_contextIMPDOITEM_: ctxi = FFEEXPR_contextIMPDOITEM_; ctxc = FFEEXPR_contextIMPDOCTRL_; break; case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEMDF_: ctxi = FFEEXPR_contextIMPDOITEMDF_; ctxc = FFEEXPR_contextIMPDOCTRL_; break; default: assert ("bad context" == NULL); ctxi = FFEEXPR_context; ctxc = FFEEXPR_context; break; } switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: ffebld_append_item (&ffeexpr_stack_->bottom, expr); if (ffeexpr_stack_->is_rhs) return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctxi, ffeexpr_cb_comma_i_1_); return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, ctxi, ffeexpr_cb_comma_i_1_); case FFELEX_typeEQUALS: ffebld_end_list (&ffeexpr_stack_->bottom); /* Complain if implied-DO variable in list of items to be read. */ if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs) ffeexpr_check_impdo_ (ffeexpr_stack_->expr, ffeexpr_stack_->first_token, expr, ft); /* Set doiter flag for all appropriate SYMTERs. */ ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr); ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE)); ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)), &ffeexpr_stack_->bottom); ffebld_append_item (&ffeexpr_stack_->bottom, expr); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctxc, ffeexpr_cb_comma_i_2_); default: if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffebld_end_list (&ffeexpr_stack_->bottom); ffeexpr_stack_->expr = ffebld_new_any (); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); return (ffelexHandler) ffeexpr_cb_comma_i_5_; } } /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr Pass it to ffeexpr_rhs as the callback routine. Handle start-value in an implied-DO construct. */ static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) { ffeexprContext ctx; switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: case FFEEXPR_contextDATAIMPDOITEM_: ctx = FFEEXPR_contextDATAIMPDOCTRL_; break; case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: ctx = FFEEXPR_contextIMPDOCTRL_; break; default: assert ("bad context" == NULL); ctx = FFEEXPR_context; break; } switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: ffebld_append_item (&ffeexpr_stack_->bottom, expr); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_cb_comma_i_3_); break; default: if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffebld_end_list (&ffeexpr_stack_->bottom); ffeexpr_stack_->expr = ffebld_new_any (); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); return (ffelexHandler) ffeexpr_cb_comma_i_5_; } } /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr Pass it to ffeexpr_rhs as the callback routine. Handle end-value in an implied-DO construct. */ static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) { ffeexprContext ctx; switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: case FFEEXPR_contextDATAIMPDOITEM_: ctx = FFEEXPR_contextDATAIMPDOCTRL_; break; case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: ctx = FFEEXPR_contextIMPDOCTRL_; break; default: assert ("bad context" == NULL); ctx = FFEEXPR_context; break; } switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: ffebld_append_item (&ffeexpr_stack_->bottom, expr); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_cb_comma_i_4_); break; case FFELEX_typeCLOSE_PAREN: ffebld_append_item (&ffeexpr_stack_->bottom, expr); return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t); break; default: if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffebld_end_list (&ffeexpr_stack_->bottom); ffeexpr_stack_->expr = ffebld_new_any (); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); return (ffelexHandler) ffeexpr_cb_comma_i_5_; } } /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr [COMMA expr] Pass it to ffeexpr_rhs as the callback routine. Handle incr-value in an implied-DO construct. */ static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeCLOSE_PAREN: ffebld_append_item (&ffeexpr_stack_->bottom, expr); ffebld_end_list (&ffeexpr_stack_->bottom); { ffebld item; for (item = ffebld_left (ffeexpr_stack_->expr); item != NULL; item = ffebld_trail (item)) if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY) goto replace_with_any; /* :::::::::::::::::::: */ for (item = ffebld_right (ffeexpr_stack_->expr); item != NULL; item = ffebld_trail (item)) if ((ffebld_head (item) != NULL) /* Increment may be NULL. */ && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)) goto replace_with_any; /* :::::::::::::::::::: */ } break; default: if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffebld_end_list (&ffeexpr_stack_->bottom); replace_with_any: /* :::::::::::::::::::: */ ffeexpr_stack_->expr = ffebld_new_any (); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); break; } if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_cb_comma_i_5_; return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); } /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr [COMMA expr] CLOSE_PAREN Pass it to ffeexpr_rhs as the callback routine. Collects token following implied-DO construct for callback function. */ static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t) { ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken ft; ffebld expr; bool terminate; switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: case FFEEXPR_contextDATAIMPDOITEM_: terminate = TRUE; break; case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: terminate = FALSE; break; default: assert ("bad context" == NULL); terminate = FALSE; break; } ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ft = ffeexpr_stack_->first_token; expr = ffeexpr_stack_->expr; s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (ft, expr, t); ffelex_token_kill (ft); if (terminate) { ffesymbol_drive_sfnames (ffeexpr_check_impctrl_); --ffeexpr_level_; if (ffeexpr_level_ == 0) ffe_terminate_4 (); } return (ffelexHandler) next; } /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression Makes sure the end token is close-paren and swallows it, else issues an error message and doesn't swallow the token (passing it along instead). In either case wraps up subexpression construction by enclosing the ffebld expression in a %LOC. */ static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) { ffeexprExpr_ e; /* First push the (%LOC) expression as an operand onto the expression stack. */ e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_stack_->tokens[0]; e->u.operand = ffebld_new_percent_loc (expr); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, ffecom_pointer_kind (), 0, FFEINFO_kindENTITY, FFEINFO_whereFLEETING, FFETARGET_charactersizeNONE)); #if 0 /* ~~ */ e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft); #endif ffeexpr_exprstack_push_operand_ (e); /* Now, if the token is a close parenthese, we're in great shape so return the next handler. */ if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) { ffelex_token_kill (ffeexpr_stack_->tokens[1]); return (ffelexHandler) ffeexpr_token_binary_; } /* Oops, naughty user didn't specify the close paren! */ if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), ffelex_token_where_column (ffeexpr_stack_->tokens[1])); ffebad_finish (); } ffelex_token_kill (ffeexpr_stack_->tokens[1]); return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_token_binary_); } /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */ static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprExpr_ e; ffebldOp op; /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all such things until the lowest-level expression is reached. */ op = ffebld_op (expr); if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) || (op == FFEBLD_opPERCENT_DESCR)) { if (ffebad_start (FFEBAD_NESTED_PERCENT)) { ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } do { expr = ffebld_left (expr); op = ffebld_op (expr); } while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) || (op == FFEBLD_opPERCENT_DESCR)); } /* Push the expression as an operand onto the expression stack. */ e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_stack_->tokens[0]; switch (ffeexpr_stack_->percent) { case FFEEXPR_percentVAL_: e->u.operand = ffebld_new_percent_val (expr); break; case FFEEXPR_percentREF_: e->u.operand = ffebld_new_percent_ref (expr); break; case FFEEXPR_percentDESCR_: e->u.operand = ffebld_new_percent_descr (expr); break; default: assert ("%lossage" == NULL); e->u.operand = expr; break; } ffebld_set_info (e->u.operand, ffebld_info (expr)); #if 0 /* ~~ */ e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft); #endif ffeexpr_exprstack_push_operand_ (e); /* Now, if the token is a close parenthese, we're in great shape so return the next handler. */ if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_cb_end_notloc_1_; /* Oops, naughty user didn't specify the close paren! */ if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), ffelex_token_where_column (ffeexpr_stack_->tokens[1])); ffebad_finish (); } ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC); switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: assert ("bad context?!?!" == NULL); break; } ffelex_token_kill (ffeexpr_stack_->tokens[1]); return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_cb_end_notloc_1_); } /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr CLOSE_PAREN Should be COMMA or CLOSE_PAREN, else change back to %LOC. */ static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: case FFELEX_typeCLOSE_PAREN: switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextSFUNCDEFACTUALARG_: break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; break; default: assert ("bad context?!?!" == NULL); break; } break; default: if (ffebad_start (FFEBAD_INVALID_PERCENT)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1])); ffebad_finish (); } ffebld_set_op (ffeexpr_stack_->exprstack->u.operand, FFEBLD_opPERCENT_LOC); switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: assert ("bad context?!?!" == NULL); break; } } ffelex_token_kill (ffeexpr_stack_->tokens[1]); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* Process DATA implied-DO iterator variables as this implied-DO level terminates. At this point, ffeexpr_level_ == 1 when we see the last right-paren in "DATA (A(I),I=1,10)/.../". */ static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s) { assert (s != NULL); assert (ffesymbol_sfdummyparent (s) != NULL); switch (ffesymbol_state (s)) { case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol be used as iterator at any level at or innermore than the outermost of the current level and the symbol's current level. */ if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) { ffesymbol_signal_change (s); ffesymbol_set_maxentrynum (s, ffeexpr_level_); ffesymbol_signal_unreported (s); } break; case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. Error if at outermost level, else it can still become an iterator. */ if ((ffeexpr_level_ == 1) && ffebad_start (FFEBAD_BAD_IMPDCL)) { ffebad_string (ffesymbol_text (s)); ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); ffebad_finish (); } break; case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s)); ffesymbol_signal_change (s); ffesymbol_set_state (s, FFESYMBOL_stateNONE); ffesymbol_signal_unreported (s); break; case FFESYMBOL_stateUNDERSTOOD: break; /* ANY. */ default: assert ("Sasha Foo!!" == NULL); break; } return s; } /* Issue diagnostic if implied-DO variable appears in list of lhs expressions (as in "READ *, (I,I=1,10)"). */ static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, ffebld dovar, ffelexToken dovar_t) { ffebld item; ffesymbol dovar_sym; int itemnum; if (ffebld_op (dovar) != FFEBLD_opSYMTER) return; /* Presumably opANY. */ dovar_sym = ffebld_symter (dovar); for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum) { if (((item = ffebld_head (list)) != NULL) && (ffebld_op (item) == FFEBLD_opSYMTER) && (ffebld_symter (item) == dovar_sym)) { char itemno[20]; sprintf (&itemno[0], "%d", itemnum); if (ffebad_start (FFEBAD_DOITER_IMPDO)) { ffebad_here (0, ffelex_token_where_line (list_t), ffelex_token_where_column (list_t)); ffebad_here (1, ffelex_token_where_line (dovar_t), ffelex_token_where_column (dovar_t)); ffebad_string (ffesymbol_text (dovar_sym)); ffebad_string (itemno); ffebad_finish (); } } } } /* Decorate any SYMTERs referencing the DO variable with the "doiter" flag. */ static void ffeexpr_update_impdo_ (ffebld list, ffebld dovar) { ffesymbol dovar_sym; if (ffebld_op (dovar) != FFEBLD_opSYMTER) return; /* Presumably opANY. */ dovar_sym = ffebld_symter (dovar); ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */ } /* Recursive function to update any expr so SYMTERs have "doiter" flag if they refer to the given variable. */ static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar) { tail_recurse: /* :::::::::::::::::::: */ if (expr == NULL) return; switch (ffebld_op (expr)) { case FFEBLD_opSYMTER: if (ffebld_symter (expr) == dovar) ffebld_symter_set_is_doiter (expr, TRUE); break; case FFEBLD_opITEM: ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar); expr = ffebld_trail (expr); goto tail_recurse; /* :::::::::::::::::::: */ default: break; } switch (ffebld_arity (expr)) { case 2: ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar); expr = ffebld_right (expr); goto tail_recurse; /* :::::::::::::::::::: */ case 1: expr = ffebld_left (expr); goto tail_recurse; /* :::::::::::::::::::: */ default: break; } return; } /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF) // After zero or more PAREN_ contexts, an IF context exists */ static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s) { assert (s != NULL); for (;;) { switch (s->context) { case FFEEXPR_contextPAREN_: case FFEEXPR_contextPARENFILENUM_: case FFEEXPR_contextPARENFILEUNIT_: break; default: return s->context; } s = s->previous; assert (s != NULL); } } /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities ffeexprPercent_ p; ffelexToken t; p = ffeexpr_percent_(t); Returns the identifier for the name, or the NONE identifier. */ static ffeexprPercent_ ffeexpr_percent_ (ffelexToken t) { const char *p; switch (ffelex_token_length (t)) { case 3: switch (*(p = ffelex_token_text (t))) { case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3): if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) && (ffesrc_char_match_noninit (*++p, 'C', 'c'))) return FFEEXPR_percentLOC_; return FFEEXPR_percentNONE_; case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3): if ((ffesrc_char_match_noninit (*++p, 'E', 'e')) && (ffesrc_char_match_noninit (*++p, 'F', 'f'))) return FFEEXPR_percentREF_; return FFEEXPR_percentNONE_; case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3): if ((ffesrc_char_match_noninit (*++p, 'A', 'a')) && (ffesrc_char_match_noninit (*++p, 'L', 'l'))) return FFEEXPR_percentVAL_; return FFEEXPR_percentNONE_; default: no_match_3: /* :::::::::::::::::::: */ return FFEEXPR_percentNONE_; } case 5: if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR", "descr", "Descr") == 0) return FFEEXPR_percentDESCR_; return FFEEXPR_percentNONE_; default: return FFEEXPR_percentNONE_; } } /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX See prototype. If combining the two basictype/kindtype pairs produces a COMPLEX with an unsupported kind type, complain and use the default kind type for COMPLEX. */ void ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt, ffeinfoBasictype lbt, ffeinfoKindtype lkt, ffeinfoBasictype rbt, ffeinfoKindtype rkt, ffelexToken t) { ffeinfoBasictype nbt; ffeinfoKindtype nkt; nbt = ffeinfo_basictype_combine (lbt, rbt); if ((nbt == FFEINFO_basictypeCOMPLEX) && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL)) && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL))) { nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE)) nkt = FFEINFO_kindtypeNONE; /* Force error. */ switch (nkt) { #if FFETARGET_okCOMPLEX1 case FFEINFO_kindtypeREAL1: #endif #if FFETARGET_okCOMPLEX2 case FFEINFO_kindtypeREAL2: #endif #if FFETARGET_okCOMPLEX3 case FFEINFO_kindtypeREAL3: #endif #if FFETARGET_okCOMPLEX4 case FFEINFO_kindtypeREAL4: #endif break; /* Fine and dandy. */ default: if (t != NULL) { ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } nbt = FFEINFO_basictypeNONE; nkt = FFEINFO_kindtypeNONE; break; case FFEINFO_kindtypeANY: nkt = FFEINFO_kindtypeREALDEFAULT; break; } } else { /* The normal stuff. */ if (nbt == lbt) { if (nbt == rbt) nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); else nkt = lkt; } else if (nbt == rbt) nkt = rkt; else { /* Let the caller do the complaining. */ nbt = FFEINFO_basictypeNONE; nkt = FFEINFO_kindtypeNONE; } } /* Always a good idea to avoid aliasing problems. */ *xnbt = nbt; *xnkt = nkt; } /* ffeexpr_token_first_lhs_ -- First state for lhs expression Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Record line and column of first token in expression, then invoke the initial-state lhs handler. */ static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t) { ffeexpr_stack_->first_token = ffelex_token_use (t); /* When changing the list of valid initial lhs tokens, check whether to update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the READ (expr) case -- it assumes it knows which tokens can be to indicate an lhs (or implied DO), which right now is the set {NAME,OPEN_PAREN}. This comment also appears in ffeexpr_token_lhs_. */ switch (ffelex_token_type (t)) { case FFELEX_typeOPEN_PAREN: switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: ffe_init_4 (); ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */ ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_); case FFEEXPR_contextDATAIMPDOITEM_: ++ffeexpr_level_; /* Level of DATA implied-DO construct. */ ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_); case FFEEXPR_contextIOLIST: case FFEEXPR_contextIMPDOITEM_: ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_); case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEMDF_: ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_); case FFEEXPR_contextFILEEXTFUNC: assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_lhs_1_; default: break; } break; case FFELEX_typeNAME: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILENAMELIST: assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_namelist_; case FFEEXPR_contextFILEEXTFUNC: assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_lhs_1_; default: break; } break; default: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILEEXTFUNC: assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_lhs_1_; default: break; } break; } return (ffelexHandler) ffeexpr_token_lhs_ (t); } /* ffeexpr_token_first_lhs_1_ -- NAME return ffeexpr_token_first_lhs_1_; // to lexer Handle NAME as an external function (USEROPEN= VXT extension to OPEN statement). */ static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t) { ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken ft; ffesymbol sy = NULL; ffebld expr; ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ft = ffeexpr_stack_->first_token; s = ffeexpr_stack_->previous; if ((ffelex_token_type (ft) != FFELEX_typeNAME) || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE)) & FFESYMBOL_attrANY)) { if ((ffelex_token_type (ft) != FFELEX_typeNAME) || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY)) { ffebad_start (FFEBAD_EXPR_WRONG); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } expr = ffebld_new_any (); ffebld_set_info (expr, ffeinfo_new_any ()); } else { expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE, FFEINTRIN_impNONE); ffebld_set_info (expr, ffesymbol_info (sy)); } malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (ft, expr, t); ffelex_token_kill (ft); return (ffelexHandler) next; } /* ffeexpr_token_first_rhs_ -- First state for rhs expression Record line and column of first token in expression, then invoke the initial-state rhs handler. 19-Feb-91 JCB 1.1 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only (i.e. only as in READ(*), not READ((*))). */ static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t) { ffesymbol s; ffeexpr_stack_->first_token = ffelex_token_use (t); switch (ffelex_token_type (t)) { case FFELEX_typeASTERISK: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILEFORMATNML: ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; /* Fall through. */ case FFEEXPR_contextFILEUNIT: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextFILEFORMAT: case FFEEXPR_contextCHARACTERSIZE: if (ffeexpr_stack_->previous != NULL) break; /* Valid only on first level. */ assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_rhs_1_; case FFEEXPR_contextPARENFILEUNIT_: if (ffeexpr_stack_->previous->previous != NULL) break; /* Valid only on second level. */ assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_rhs_1_; case FFEEXPR_contextACTUALARG_: if (ffeexpr_stack_->previous->context != FFEEXPR_contextSUBROUTINEREF) { ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; } assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_rhs_3_; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: break; } break; case FFELEX_typeOPEN_PAREN: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILENUMAMBIG: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextPARENFILENUM_, ffeexpr_cb_close_paren_ambig_); case FFEEXPR_contextFILEUNITAMBIG: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextPARENFILEUNIT_, ffeexpr_cb_close_paren_ambig_); case FFEEXPR_contextIOLIST: case FFEEXPR_contextIMPDOITEM_: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_close_paren_ci_); case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextIMPDOITEMDF_: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_close_paren_ci_); case FFEEXPR_contextFILEFORMATNML: ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; break; case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: break; } break; case FFELEX_typeNUMBER: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILEFORMATNML: ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; /* Fall through. */ case FFEEXPR_contextFILEFORMAT: if (ffeexpr_stack_->previous != NULL) break; /* Valid only on first level. */ assert (ffeexpr_stack_->exprstack == NULL); return (ffelexHandler) ffeexpr_token_first_rhs_2_; case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: break; } break; case FFELEX_typeNAME: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILEFORMATNML: assert (ffeexpr_stack_->exprstack == NULL); s = ffesymbol_lookup_local (t); if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) return (ffelexHandler) ffeexpr_token_namelist_; ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; break; default: break; } break; case FFELEX_typePERCENT: switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextINDEXORACTUALARG_: case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: return (ffelexHandler) ffeexpr_token_first_rhs_5_; case FFEEXPR_contextFILEFORMATNML: ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; break; default: break; } default: switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextFILEFORMATNML: ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; break; default: break; } break; } return (ffelexHandler) ffeexpr_token_rhs_ (t); } /* ffeexpr_token_first_rhs_1_ -- ASTERISK return ffeexpr_token_first_rhs_1_; // to lexer Return STAR as expression. */ static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t) { ffebld expr; ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken ft; expr = ffebld_new_star (); ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ft = ffeexpr_stack_->first_token; s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (ft, expr, t); ffelex_token_kill (ft); return (ffelexHandler) next; } /* ffeexpr_token_first_rhs_2_ -- NUMBER return ffeexpr_token_first_rhs_2_; // to lexer Return NULL as expression; NUMBER as first (and only) token, unless the current token is not a terminating token, in which case run normal expression handling. */ static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t) { ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken ft; switch (ffelex_token_type (t)) { case FFELEX_typeCLOSE_PAREN: case FFELEX_typeCOMMA: case FFELEX_typeEOS: case FFELEX_typeSEMICOLON: break; default: next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); return (ffelexHandler) (*next) (t); } ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ft = ffeexpr_stack_->first_token; s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (ft, NULL, t); ffelex_token_kill (ft); return (ffelexHandler) next; } /* ffeexpr_token_first_rhs_3_ -- ASTERISK return ffeexpr_token_first_rhs_3_; // to lexer Expect NUMBER, make LABTOK (with copy of token if not inhibited after confirming, else NULL). */ static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t) { ffelexHandler next; if (ffelex_token_type (t) != FFELEX_typeNUMBER) { /* An error, but let normal processing handle it. */ next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); return (ffelexHandler) (*next) (t); } /* Special case: when we see "*10" as an argument to a subroutine reference, we confirm the current statement and, if not inhibited at this point, put a copy of the token into a LABTOK node. We do this instead of just resolving the label directly via ffelab and putting it into a LABTER simply to improve error reporting and consistency in ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb doesn't have to worry about killing off any tokens when retracting. */ ffest_confirmed (); if (ffest_is_inhibited ()) ffeexpr_stack_->expr = ffebld_new_labtok (NULL); else ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t)); ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE)); return (ffelexHandler) ffeexpr_token_first_rhs_4_; } /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER return ffeexpr_token_first_rhs_4_; // to lexer Collect/flush appropriate stuff, send token to callback function. */ static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t) { ffebld expr; ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken ft; expr = ffeexpr_stack_->expr; ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ft = ffeexpr_stack_->first_token; s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (ft, expr, t); ffelex_token_kill (ft); return (ffelexHandler) next; } /* ffeexpr_token_first_rhs_5_ -- PERCENT Should be NAME, or pass through original mechanism. If NAME is LOC, pass through original mechanism, otherwise must be VAL, REF, or DESCR, in which case handle the argument (in parentheses), etc. */ static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t) { ffelexHandler next; if (ffelex_token_type (t) == FFELEX_typeNAME) { ffeexprPercent_ p = ffeexpr_percent_ (t); switch (p) { case FFEEXPR_percentNONE_: case FFEEXPR_percentLOC_: break; /* Treat %LOC as any other expression. */ case FFEEXPR_percentVAL_: case FFEEXPR_percentREF_: case FFEEXPR_percentDESCR_: ffeexpr_stack_->percent = p; ffeexpr_stack_->tokens[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_first_rhs_6_; default: assert ("bad percent?!?" == NULL); break; } } switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: assert ("bad context?!?!" == NULL); break; } next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); return (ffelexHandler) (*next) (t); } /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR) Should be OPEN_PAREN, or pass through original mechanism. */ static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t) { ffelexHandler next; ffelexToken ft; if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN) { ffeexpr_stack_->tokens[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ffeexpr_stack_->context, ffeexpr_cb_end_notloc_); } switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: assert ("bad context?!?!" == NULL); break; } ft = ffeexpr_stack_->tokens[0]; next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); next = (ffelexHandler) (*next) (ft); ffelex_token_kill (ft); return (ffelexHandler) (*next) (t); } /* ffeexpr_token_namelist_ -- NAME return ffeexpr_token_namelist_; // to lexer Make sure NAME was a valid namelist object, wrap it in a SYMTER and return. */ static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t) { ffeexprCallback callback; ffeexprStack_ s; ffelexHandler next; ffelexToken ft; ffesymbol sy; ffebld expr; ffebld_pool_pop (); callback = ffeexpr_stack_->callback; ft = ffeexpr_stack_->first_token; s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; sy = ffesymbol_lookup_local (ft); if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST)) { ffebad_start (FFEBAD_EXPR_WRONG); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); expr = ffebld_new_any (); ffebld_set_info (expr, ffeinfo_new_any ()); } else { expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE, FFEINTRIN_impNONE); ffebld_set_info (expr, ffesymbol_info (sy)); } next = (ffelexHandler) (*callback) (ft, expr, t); ffelex_token_kill (ft); return (ffelexHandler) next; } /* ffeexpr_expr_kill_ -- Kill an existing internal expression object ffeexprExpr_ e; ffeexpr_expr_kill_(e); Kills the ffewhere info, if necessary, then kills the object. */ static void ffeexpr_expr_kill_ (ffeexprExpr_ e) { if (e->token != NULL) ffelex_token_kill (e->token); malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e)); } /* ffeexpr_expr_new_ -- Make a new internal expression object ffeexprExpr_ e; e = ffeexpr_expr_new_(); Allocates and initializes a new expression object, returns it. */ static ffeexprExpr_ ffeexpr_expr_new_ () { ffeexprExpr_ e; e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e)); e->previous = NULL; e->type = FFEEXPR_exprtypeUNKNOWN_; e->token = NULL; return e; } /* Verify that call to global is valid, and register whatever new information about a global might be discoverable by looking at the call. */ static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t) { int n_args; ffebld list; ffebld item; ffesymbol s; assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF) || (ffebld_op (*expr) == FFEBLD_opFUNCREF)); if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER) return; if (ffesymbol_retractable ()) return; s = ffebld_symter (ffebld_left (*expr)); if (ffesymbol_global (s) == NULL) return; for (n_args = 0, list = ffebld_right (*expr); list != NULL; list = ffebld_trail (list), ++n_args) ; if (ffeglobal_proc_ref_nargs (s, n_args, t)) { ffeglobalArgSummary as; ffeinfoBasictype bt; ffeinfoKindtype kt; bool array; bool fail = FALSE; for (n_args = 0, list = ffebld_right (*expr); list != NULL; list = ffebld_trail (list), ++n_args) { item = ffebld_head (list); if (item != NULL) { bt = ffeinfo_basictype (ffebld_info (item)); kt = ffeinfo_kindtype (ffebld_info (item)); array = (ffeinfo_rank (ffebld_info (item)) > 0); switch (ffebld_op (item)) { case FFEBLD_opLABTOK: case FFEBLD_opLABTER: as = FFEGLOBAL_argsummaryALTRTN; break; #if 0 /* No, %LOC(foo) is just like any INTEGER(KIND=7) expression, so don't treat it specially. */ case FFEBLD_opPERCENT_LOC: as = FFEGLOBAL_argsummaryPTR; break; #endif case FFEBLD_opPERCENT_VAL: as = FFEGLOBAL_argsummaryVAL; break; case FFEBLD_opPERCENT_REF: as = FFEGLOBAL_argsummaryREF; break; case FFEBLD_opPERCENT_DESCR: as = FFEGLOBAL_argsummaryDESCR; break; case FFEBLD_opFUNCREF: #if 0 /* No, LOC(foo) is just like any INTEGER(KIND=7) expression, so don't treat it specially. */ if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER) && (ffesymbol_specific (ffebld_symter (ffebld_left (item))) == FFEINTRIN_specLOC)) { as = FFEGLOBAL_argsummaryPTR; break; } #endif /* Fall through. */ default: if (ffebld_op (item) == FFEBLD_opSYMTER) { as = FFEGLOBAL_argsummaryNONE; switch (ffeinfo_kind (ffebld_info (item))) { case FFEINFO_kindFUNCTION: as = FFEGLOBAL_argsummaryFUNC; break; case FFEINFO_kindSUBROUTINE: as = FFEGLOBAL_argsummarySUBR; break; case FFEINFO_kindNONE: as = FFEGLOBAL_argsummaryPROC; break; default: break; } if (as != FFEGLOBAL_argsummaryNONE) break; } if (bt == FFEINFO_basictypeCHARACTER) as = FFEGLOBAL_argsummaryDESCR; else as = FFEGLOBAL_argsummaryREF; break; } } else { array = FALSE; as = FFEGLOBAL_argsummaryNONE; bt = FFEINFO_basictypeNONE; kt = FFEINFO_kindtypeNONE; } if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t)) fail = TRUE; } if (! fail) return; } *expr = ffebld_new_any (); ffebld_set_info (*expr, ffeinfo_new_any ()); } /* Check whether rest of string is all decimal digits. */ static bool ffeexpr_isdigits_ (const char *p) { for (; *p != '\0'; ++p) if (! ISDIGIT (*p)) return FALSE; return TRUE; } /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack ffeexprExpr_ e; ffeexpr_exprstack_push_(e); Pushes the expression onto the stack without any analysis of the existing contents of the stack. */ static void ffeexpr_exprstack_push_ (ffeexprExpr_ e) { e->previous = ffeexpr_stack_->exprstack; ffeexpr_stack_->exprstack = e; } /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce? ffeexprExpr_ e; ffeexpr_exprstack_push_operand_(e); Pushes the expression already containing an operand (a constant, variable, or more complicated expression that has already been fully resolved) after analyzing the stack and checking for possible reduction (which will never happen here since the highest precedence operator is ** and it has right- to-left associativity). */ static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e) { ffeexpr_exprstack_push_ (e); #ifdef WEIRD_NONFORTRAN_RULES if ((ffeexpr_stack_->exprstack != NULL) && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_) && (ffeexpr_stack_->exprstack->expr->u.operator.prec == FFEEXPR_operatorprecedenceHIGHEST_) && (ffeexpr_stack_->exprstack->expr->u.operator.as == FFEEXPR_operatorassociativityL2R_)) ffeexpr_reduce_ (); #endif } /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack ffeexprExpr_ e; ffeexpr_exprstack_push_unary_(e); Pushes the expression already containing a unary operator. Reduction can never happen since unary operators are themselves always R-L; that is, the top of the expression stack is not an operand, in that it is either empty, has a binary operator at the top, or a unary operator at the top. In any of these cases, reduction is impossible. */ static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e) { if ((ffe_is_pedantic () || ffe_is_warn_surprising ()) && (ffeexpr_stack_->exprstack != NULL) && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_) && (ffeexpr_stack_->exprstack->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_) && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_)) { ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses", ffe_is_pedantic () ? FFEBAD_severityPEDANTIC : FFEBAD_severityWARNING); ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); ffebad_here (1, ffelex_token_where_line (e->token), ffelex_token_where_column (e->token)); ffebad_finish (); } ffeexpr_exprstack_push_ (e); } /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce? ffeexprExpr_ e; ffeexpr_exprstack_push_binary_(e); Pushes the expression already containing a binary operator after checking whether reduction is possible. If the stack is not empty, the top of the stack must be an operand or syntactic analysis has failed somehow. If the operand is preceded by a unary operator of higher (or equal and L-R associativity) precedence than the new binary operator, then reduce that preceding operator and its operand(s) before pushing the new binary operator. */ static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e) { ffeexprExpr_ ce; if (ffe_is_warn_surprising () /* These next two are always true (see assertions below). */ && (ffeexpr_stack_->exprstack != NULL) && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_) /* If the previous operator is a unary minus, and the binary op is of higher precedence, might not do what user expects, e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would yield "4". */ && (ffeexpr_stack_->exprstack->previous != NULL) && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_) && (ffeexpr_stack_->exprstack->previous->u.operator.op == FFEEXPR_operatorSUBTRACT_) && (e->u.operator.prec < ffeexpr_stack_->exprstack->previous->u.operator.prec)) { ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING); ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token), ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token)); ffebad_here (1, ffelex_token_where_line (e->token), ffelex_token_where_column (e->token)); ffebad_finish (); } again: assert (ffeexpr_stack_->exprstack != NULL); assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_); if ((ce = ffeexpr_stack_->exprstack->previous) != NULL) { assert (ce->type != FFEEXPR_exprtypeOPERAND_); if ((ce->u.operator.prec < e->u.operator.prec) || ((ce->u.operator.prec == e->u.operator.prec) && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_))) { ffeexpr_reduce_ (); goto again; /* :::::::::::::::::::: */ } } ffeexpr_exprstack_push_ (e); } /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack ffeexpr_reduce_(); Converts operand binop operand or unop operand at top of stack to a single operand having the appropriate ffebld expression, and makes sure that the expression is proper (like not trying to add two character variables, not trying to concatenate two numbers). Also does the requisite type-assignment. */ static void ffeexpr_reduce_ () { ffeexprExpr_ operand; /* This is B in -B or A+B. */ ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */ ffeexprExpr_ operator; /* This is + in A+B. */ ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */ ffebldConstant constnode; /* For checking magical numbers (where mag == -mag). */ ffebld expr; ffebld left_expr; bool submag = FALSE; operand = ffeexpr_stack_->exprstack; assert (operand != NULL); assert (operand->type == FFEEXPR_exprtypeOPERAND_); operator = operand->previous; assert (operator != NULL); assert (operator->type != FFEEXPR_exprtypeOPERAND_); if (operator->type == FFEEXPR_exprtypeUNARY_) { expr = operand->u.operand; switch (operator->u.operator.op) { case FFEEXPR_operatorADD_: reduced = ffebld_new_uplus (expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand); reduced = ffeexpr_reduced_math1_ (reduced, operator, operand); reduced = ffeexpr_collapse_uplus (reduced, operator->token); break; case FFEEXPR_operatorSUBTRACT_: submag = TRUE; /* Ok to negate a magic number. */ reduced = ffebld_new_uminus (expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand); reduced = ffeexpr_reduced_math1_ (reduced, operator, operand); reduced = ffeexpr_collapse_uminus (reduced, operator->token); break; case FFEEXPR_operatorNOT_: reduced = ffebld_new_not (expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand); reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand); reduced = ffeexpr_collapse_not (reduced, operator->token); break; default: assert ("unexpected unary op" != NULL); reduced = NULL; break; } if (!submag && (ffebld_op (expr) == FFEBLD_opCONTER) && (ffebld_conter_orig (expr) == NULL) && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) { ffetarget_integer_bad_magical (operand->token); } ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand off stack. */ ffeexpr_expr_kill_ (operand); operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but save */ operator->u.operand = reduced; /* the line/column ffewhere info. */ ffeexpr_exprstack_push_operand_ (operator); /* Push it back on stack. */ } else { assert (operator->type == FFEEXPR_exprtypeBINARY_); left_operand = operator->previous; assert (left_operand != NULL); assert (left_operand->type == FFEEXPR_exprtypeOPERAND_); expr = operand->u.operand; left_expr = left_operand->u.operand; switch (operator->u.operator.op) { case FFEEXPR_operatorADD_: reduced = ffebld_new_add (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_add (reduced, operator->token); break; case FFEEXPR_operatorSUBTRACT_: submag = TRUE; /* Just to pick the right error if magic number. */ reduced = ffebld_new_subtract (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_subtract (reduced, operator->token); break; case FFEEXPR_operatorMULTIPLY_: reduced = ffebld_new_multiply (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_multiply (reduced, operator->token); break; case FFEEXPR_operatorDIVIDE_: reduced = ffebld_new_divide (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_divide (reduced, operator->token); break; case FFEEXPR_operatorPOWER_: reduced = ffebld_new_power (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_power (reduced, operator->token); break; case FFEEXPR_operatorCONCATENATE_: reduced = ffebld_new_concatenate (left_expr, expr); reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_concatenate (reduced, operator->token); break; case FFEEXPR_operatorLT_: reduced = ffebld_new_lt (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_lt (reduced, operator->token); break; case FFEEXPR_operatorLE_: reduced = ffebld_new_le (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_le (reduced, operator->token); break; case FFEEXPR_operatorEQ_: reduced = ffebld_new_eq (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_eq (reduced, operator->token); break; case FFEEXPR_operatorNE_: reduced = ffebld_new_ne (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_ne (reduced, operator->token); break; case FFEEXPR_operatorGT_: reduced = ffebld_new_gt (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_gt (reduced, operator->token); break; case FFEEXPR_operatorGE_: reduced = ffebld_new_ge (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_ge (reduced, operator->token); break; case FFEEXPR_operatorAND_: reduced = ffebld_new_and (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_and (reduced, operator->token); break; case FFEEXPR_operatorOR_: reduced = ffebld_new_or (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_or (reduced, operator->token); break; case FFEEXPR_operatorXOR_: reduced = ffebld_new_xor (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_xor (reduced, operator->token); break; case FFEEXPR_operatorEQV_: reduced = ffebld_new_eqv (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_eqv (reduced, operator->token); break; case FFEEXPR_operatorNEQV_: reduced = ffebld_new_neqv (left_expr, expr); if (ffe_is_ugly_logint ()) reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, operand); reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, operand); reduced = ffeexpr_collapse_neqv (reduced, operator->token); break; default: assert ("bad bin op" == NULL); reduced = expr; break; } if ((ffebld_op (left_expr) == FFEBLD_opCONTER) && (ffebld_conter_orig (expr) == NULL) && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr))) { if ((left_operand->previous != NULL) && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_) && (left_operand->previous->u.operator.op == FFEEXPR_operatorSUBTRACT_)) { if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_) ffetarget_integer_bad_magical_precedence (left_operand->token, left_operand->previous->token, operator->token); else ffetarget_integer_bad_magical_precedence_binary (left_operand->token, left_operand->previous->token, operator->token); } else ffetarget_integer_bad_magical (left_operand->token); } if ((ffebld_op (expr) == FFEBLD_opCONTER) && (ffebld_conter_orig (expr) == NULL) && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) { if (submag) ffetarget_integer_bad_magical_binary (operand->token, operator->token); else ffetarget_integer_bad_magical (operand->token); } ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op operands off stack. */ ffeexpr_expr_kill_ (left_operand); ffeexpr_expr_kill_ (operand); operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but save */ operator->u.operand = reduced; /* the line/column ffewhere info. */ ffeexpr_exprstack_push_operand_ (operator); /* Push it back on stack. */ } } /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator reduced = ffeexpr_reduced_bool1_(reduced,op,r); Makes sure the argument for reduced has basictype of LOGICAL or (ugly) INTEGER. If argument has where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. If these requirements cannot be met, generate error message. */ static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo rinfo, ninfo; ffeinfoBasictype rbt; ffeinfoKindtype rkt; ffeinfoRank rrk; ffeinfoKind rkd; ffeinfoWhere rwh, nwh; rinfo = ffebld_info (ffebld_left (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if (((rbt == FFEINFO_basictypeLOGICAL) || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER))) && (rrk == 0)) { switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); return reduced; } if ((rbt != FFEINFO_basictypeLOGICAL) && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_NOT_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_NOT_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators reduced = ffeexpr_reduced_bool2_(reduced,l,op,r); Makes sure the left and right arguments for reduced have basictype of LOGICAL or (ugly) INTEGER. Determine common basictype and size for reduction (flag expression for combined hollerith/typeless situations for later determination of effective basictype). If both left and right arguments have where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. Create CONVERT ops for args where needed. Convert typeless constants to the desired type/size explicitly. If these requirements cannot be met, generate error message. */ static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo, ninfo; ffeinfoBasictype lbt, rbt, nbt; ffeinfoKindtype lkt, rkt, nkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh, nwh; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); if (((nbt == FFEINFO_basictypeLOGICAL) || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER))) && (lrk == 0) && (rrk == 0)) { switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; default: nwh = FFEINFO_whereFLEETING; break; } ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); return reduced; } if ((lbt != FFEINFO_basictypeLOGICAL) && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER))) { if ((rbt != FFEINFO_basictypeLOGICAL) && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) { if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_BOOL_ARGS_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((lbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_finish (); } } } else if ((rbt != FFEINFO_basictypeLOGICAL) && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if (lrk != 0) { if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_BOOL_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_string ("an array"); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_BOOL_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r); Makes sure the left and right arguments for reduced have basictype of CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective size of concatenation and assign that size to reduced. If both left and right arguments have where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. If these requirements cannot be met, generate error message using the info in l, op, and r arguments and assign basictype, size, kind, and where of ANY. */ static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo, ninfo; ffeinfoBasictype lbt, rbt, nbt; ffeinfoKindtype lkt, rkt, nkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd, nkd; ffeinfoWhere lwh, rwh, nwh; ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); lszk = ffeinfo_size (linfo); /* Known size. */ lszm = ffebld_size_max (ffebld_left (reduced)); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); rszk = ffeinfo_size (rinfo); /* Known size. */ rszm = ffebld_size_max (ffebld_right (reduced)); if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER) && (lkt == rkt) && (lrk == 0) && (rrk == 0) && (((lszm != FFETARGET_charactersizeNONE) && (rszm != FFETARGET_charactersizeNONE)) || (ffeexpr_context_outer_ (ffeexpr_stack_) == FFEEXPR_contextLET) || (ffeexpr_context_outer_ (ffeexpr_stack_) == FFEEXPR_contextSFUNCDEF))) { nbt = FFEINFO_basictypeCHARACTER; nkd = FFEINFO_kindENTITY; if ((lszk == FFETARGET_charactersizeNONE) || (rszk == FFETARGET_charactersizeNONE)) nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET stmt. */ else nszk = lszk + rszk; switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; default: nwh = FFEINFO_whereFLEETING; break; } nkt = lkt; ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk); ffebld_set_info (reduced, ninfo); return reduced; } if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER)) { if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if (lbt != FFEINFO_basictypeCHARACTER) { if ((lbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_finish (); } } else if (rbt != FFEINFO_basictypeCHARACTER) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE)) { if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_CONCAT_ARG_KIND)) { const char *what; if (lrk != 0) what = "an array"; else what = "of indeterminate length"; ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_string (what); ffebad_finish (); } } else { if (ffebad_start (FFEBAD_CONCAT_ARG_KIND)) { const char *what; if (rrk != 0) what = "an array"; else what = "of indeterminate length"; ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string (what); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r); Makes sure the left and right arguments for reduced have basictype of INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and size for reduction. If both left and right arguments have where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. Create CONVERT ops for args where needed. Convert typeless constants to the desired type/size explicitly. If these requirements cannot be met, generate error message. */ static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo, ninfo; ffeinfoBasictype lbt, rbt, nbt; ffeinfoKindtype lkt, rkt, nkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh, nwh; ffetargetCharacterSize lsz, rsz; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); lsz = ffebld_size_known (ffebld_left (reduced)); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); rsz = ffebld_size_known (ffebld_right (reduced)); ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER)) && (lrk == 0) && (rrk == 0)) { switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; default: nwh = FFEINFO_whereFLEETING; break; } if ((lsz != FFETARGET_charactersizeNONE) && (rsz != FFETARGET_charactersizeNONE)) lsz = rsz = (lsz > rsz) ? lsz : rsz; ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, nbt, nkt, 0, lsz, FFEEXPR_contextLET)); ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, nbt, nkt, 0, rsz, FFEEXPR_contextLET)); return reduced; } if ((lbt == FFEINFO_basictypeLOGICAL) && (rbt == FFEINFO_basictypeLOGICAL)) { if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2", FFEBAD_severityFATAL)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER)) { if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) { if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_EQOP_ARGS_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((lbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_finish (); } } } else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if (lrk != 0) { if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_EQOP_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_string ("an array"); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_EQOP_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators reduced = ffeexpr_reduced_math1_(reduced,op,r); Makes sure the argument for reduced has basictype of INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. If these requirements cannot be met, generate error message. */ static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo rinfo, ninfo; ffeinfoBasictype rbt; ffeinfoKindtype rkt; ffeinfoRank rrk; ffeinfoKind rkd; ffeinfoWhere rwh, nwh; rinfo = ffebld_info (ffebld_left (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL) || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0)) { switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); return reduced; } if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_MATH_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators reduced = ffeexpr_reduced_math2_(reduced,l,op,r); Makes sure the left and right arguments for reduced have basictype of INTEGER, REAL, or COMPLEX. Determine common basictype and size for reduction (flag expression for combined hollerith/typeless situations for later determination of effective basictype). If both left and right arguments have where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. Create CONVERT ops for args where needed. Convert typeless constants to the desired type/size explicitly. If these requirements cannot be met, generate error message. */ static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo, ninfo; ffeinfoBasictype lbt, rbt, nbt; ffeinfoKindtype lkt, rkt, nkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh, nwh; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) { switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; default: nwh = FFEINFO_whereFLEETING; break; } ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); return reduced; } if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) && (lbt != FFEINFO_basictypeCOMPLEX)) { if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) { if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((lbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_finish (); } } } else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if (lrk != 0) { if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_MATH_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_string ("an array"); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_MATH_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator reduced = ffeexpr_reduced_power_(reduced,l,op,r); Makes sure the left and right arguments for reduced have basictype of INTEGER, REAL, or COMPLEX. Determine common basictype and size for reduction (flag expression for combined hollerith/typeless situations for later determination of effective basictype). If both left and right arguments have where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. Create CONVERT ops for args where needed. Note that real**int or complex**int comes out as int = real**int etc with no conversions. If these requirements cannot be met, generate error message using the info in l, op, and r arguments and assign basictype, size, kind, and where of ANY. */ static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo, ninfo; ffeinfoBasictype lbt, rbt, nbt; ffeinfoKindtype lkt, rkt, nkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh, nwh; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if ((rbt == FFEINFO_basictypeINTEGER) && ((lbt == FFEINFO_basictypeREAL) || (lbt == FFEINFO_basictypeCOMPLEX))) { nbt = lbt; nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT); if (nkt != FFEINFO_kindtypeREALDEFAULT) { nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE); if (nkt != FFEINFO_kindtypeREALDOUBLE) nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ } if (rkt == FFEINFO_kindtypeINTEGER4) { ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER", FFEBAD_severityWARNING); ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } if (rkt != FFEINFO_kindtypeINTEGERDEFAULT) { ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); rkt = FFEINFO_kindtypeINTEGERDEFAULT; } } else { ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); #if 0 /* INTEGER4**INTEGER4 works now. */ if ((nbt == FFEINFO_basictypeINTEGER) && (nkt != FFEINFO_kindtypeINTEGERDEFAULT)) nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */ #endif if (((nbt == FFEINFO_basictypeREAL) || (nbt == FFEINFO_basictypeCOMPLEX)) && (nkt != FFEINFO_kindtypeREALDEFAULT)) { nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE); if (nkt != FFEINFO_kindtypeREALDOUBLE) nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ } /* else Gonna turn into an error below. */ } if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) { switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; default: nwh = FFEINFO_whereFLEETING; break; } ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); if (rbt != FFEINFO_basictypeINTEGER) ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); return reduced; } if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) && (lbt != FFEINFO_basictypeCOMPLEX)) { if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) { if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((lbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_finish (); } } } else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_MATH_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if (lrk != 0) { if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_MATH_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_string ("an array"); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_MATH_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators reduced = ffeexpr_reduced_relop2_(reduced,l,op,r); Makes sure the left and right arguments for reduced have basictype of INTEGER, REAL, or CHARACTER. Determine common basictype and size for reduction. If both left and right arguments have where of CONSTANT, assign where CONSTANT to reduced, else assign where FLEETING. Create CONVERT ops for args where needed. Convert typeless constants to the desired type/size explicitly. If these requirements cannot be met, generate error message. */ static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo, ninfo; ffeinfoBasictype lbt, rbt, nbt; ffeinfoKindtype lkt, rkt, nkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh, nwh; ffetargetCharacterSize lsz, rsz; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); lsz = ffebld_size_known (ffebld_left (reduced)); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); rsz = ffebld_size_known (ffebld_right (reduced)); ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) || (nbt == FFEINFO_basictypeCHARACTER)) && (lrk == 0) && (rrk == 0)) { switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: nwh = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: nwh = FFEINFO_whereIMMEDIATE; break; default: nwh = FFEINFO_whereFLEETING; break; } break; default: nwh = FFEINFO_whereFLEETING; break; } if ((lsz != FFETARGET_charactersizeNONE) && (rsz != FFETARGET_charactersizeNONE)) lsz = rsz = (lsz > rsz) ? lsz : rsz; ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); ffebld_set_info (reduced, ninfo); ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, nbt, nkt, 0, lsz, FFEEXPR_contextLET)); ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, nbt, nkt, 0, rsz, FFEEXPR_contextLET)); return reduced; } if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) && (lbt != FFEINFO_basictypeCHARACTER)) { if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCHARACTER)) { if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_RELOP_ARGS_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else { if ((lbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_finish (); } } } else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCHARACTER)) { if ((rbt != FFEINFO_basictypeANY) && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_finish (); } } else if (lrk != 0) { if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_RELOP_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); ffebad_string ("an array"); ffebad_finish (); } } else { if ((rkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_RELOP_ARG_KIND)) { ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); ffebad_string ("an array"); ffebad_finish (); } } reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); return reduced; } /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL reduced = ffeexpr_reduced_ugly1_(reduced,op,r); Sigh. */ static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo rinfo; ffeinfoBasictype rbt; ffeinfoKindtype rkt; ffeinfoRank rrk; ffeinfoKind rkd; ffeinfoWhere rwh; rinfo = ffebld_info (ffebld_left (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if ((rbt == FFEINFO_basictypeTYPELESS) || (rbt == FFEINFO_basictypeHOLLERITH)) { ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), r->token, op->token, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); rinfo = ffebld_info (ffebld_left (reduced)); rbt = FFEINFO_basictypeINTEGER; rkt = FFEINFO_kindtypeINTEGERDEFAULT; rrk = 0; rkd = FFEINFO_kindENTITY; rwh = ffeinfo_where (rinfo); } if (rbt == FFEINFO_basictypeLOGICAL) { ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), r->token, op->token, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); } return reduced; } /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH reduced = ffeexpr_reduced_ugly1log_(reduced,op,r); Sigh. */ static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo rinfo; ffeinfoBasictype rbt; ffeinfoKindtype rkt; ffeinfoRank rrk; ffeinfoKind rkd; ffeinfoWhere rwh; rinfo = ffebld_info (ffebld_left (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if ((rbt == FFEINFO_basictypeTYPELESS) || (rbt == FFEINFO_basictypeHOLLERITH)) { ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), r->token, op->token, FFEINFO_basictypeLOGICAL, 0, FFEINFO_kindtypeLOGICALDEFAULT, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); rinfo = ffebld_info (ffebld_left (reduced)); rbt = FFEINFO_basictypeLOGICAL; rkt = FFEINFO_kindtypeLOGICALDEFAULT; rrk = 0; rkd = FFEINFO_kindENTITY; rwh = ffeinfo_where (rinfo); } return reduced; } /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r); Sigh. */ static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo; ffeinfoBasictype lbt, rbt; ffeinfoKindtype lkt, rkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if ((lbt == FFEINFO_basictypeTYPELESS) || (lbt == FFEINFO_basictypeHOLLERITH)) { if ((rbt == FFEINFO_basictypeTYPELESS) || (rbt == FFEINFO_basictypeHOLLERITH)) { ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, FFEINFO_basictypeINTEGER, 0, FFEINFO_kindtypeINTEGERDEFAULT, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); linfo = ffebld_info (ffebld_left (reduced)); rinfo = ffebld_info (ffebld_right (reduced)); lbt = rbt = FFEINFO_basictypeINTEGER; lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT; lrk = rrk = 0; lkd = rkd = FFEINFO_kindENTITY; lwh = ffeinfo_where (linfo); rwh = ffeinfo_where (rinfo); } else { ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), l->token, ffebld_right (reduced), r->token, FFEEXPR_contextLET)); linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); } } else { if ((rbt == FFEINFO_basictypeTYPELESS) || (rbt == FFEINFO_basictypeHOLLERITH)) { ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), r->token, ffebld_left (reduced), l->token, FFEEXPR_contextLET)); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); } /* else Leave it alone. */ } if (lbt == FFEINFO_basictypeLOGICAL) { ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); } if (rbt == FFEINFO_basictypeLOGICAL) { ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); } return reduced; } /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r); Sigh. */ static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, ffeexprExpr_ r) { ffeinfo linfo, rinfo; ffeinfoBasictype lbt, rbt; ffeinfoKindtype lkt, rkt; ffeinfoRank lrk, rrk; ffeinfoKind lkd, rkd; ffeinfoWhere lwh, rwh; linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); if ((lbt == FFEINFO_basictypeTYPELESS) || (lbt == FFEINFO_basictypeHOLLERITH)) { if ((rbt == FFEINFO_basictypeTYPELESS) || (rbt == FFEINFO_basictypeHOLLERITH)) { ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), l->token, op->token, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), r->token, op->token, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET)); linfo = ffebld_info (ffebld_left (reduced)); rinfo = ffebld_info (ffebld_right (reduced)); lbt = rbt = FFEINFO_basictypeLOGICAL; lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT; lrk = rrk = 0; lkd = rkd = FFEINFO_kindENTITY; lwh = ffeinfo_where (linfo); rwh = ffeinfo_where (rinfo); } else { ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), l->token, ffebld_right (reduced), r->token, FFEEXPR_contextLET)); linfo = ffebld_info (ffebld_left (reduced)); lbt = ffeinfo_basictype (linfo); lkt = ffeinfo_kindtype (linfo); lrk = ffeinfo_rank (linfo); lkd = ffeinfo_kind (linfo); lwh = ffeinfo_where (linfo); } } else { if ((rbt == FFEINFO_basictypeTYPELESS) || (rbt == FFEINFO_basictypeHOLLERITH)) { ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), r->token, ffebld_left (reduced), l->token, FFEEXPR_contextLET)); rinfo = ffebld_info (ffebld_right (reduced)); rbt = ffeinfo_basictype (rinfo); rkt = ffeinfo_kindtype (rinfo); rrk = ffeinfo_rank (rinfo); rkd = ffeinfo_kind (rinfo); rwh = ffeinfo_where (rinfo); } /* else Leave it alone. */ } return reduced; } /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON is found. The idea is to process the tokens as they would be done by normal expression processing, with the key things being telling the lexer when hollerith/character constants are about to happen, until the true closing token is found. */ static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t, ffelexHandler after) { ffeexpr_find_.after = after; ffeexpr_find_.level = 1; return (ffelexHandler) ffeexpr_nil_rhs_ (t); } static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeCLOSE_PAREN: if (--ffeexpr_find_.level == 0) return (ffelexHandler) ffeexpr_find_.after; return (ffelexHandler) ffeexpr_nil_binary_; case FFELEX_typeCOMMA: case FFELEX_typeCOLON: case FFELEX_typeEQUALS: case FFELEX_typePOINTS: return (ffelexHandler) ffeexpr_nil_rhs_; default: if (--ffeexpr_find_.level == 0) return (ffelexHandler) ffeexpr_find_.after (t); return (ffelexHandler) ffeexpr_nil_rhs_ (t); } } static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeQUOTE: if (ffe_is_vxt ()) return (ffelexHandler) ffeexpr_nil_quote_; ffelex_set_expecting_hollerith (-1, '\"', ffelex_token_where_line (t), ffelex_token_where_column (t)); return (ffelexHandler) ffeexpr_nil_apostrophe_; case FFELEX_typeAPOSTROPHE: ffelex_set_expecting_hollerith (-1, '\'', ffelex_token_where_line (t), ffelex_token_where_column (t)); return (ffelexHandler) ffeexpr_nil_apostrophe_; case FFELEX_typePERCENT: return (ffelexHandler) ffeexpr_nil_percent_; case FFELEX_typeOPEN_PAREN: ++ffeexpr_find_.level; return (ffelexHandler) ffeexpr_nil_rhs_; case FFELEX_typePLUS: case FFELEX_typeMINUS: return (ffelexHandler) ffeexpr_nil_rhs_; case FFELEX_typePERIOD: return (ffelexHandler) ffeexpr_nil_period_; case FFELEX_typeNUMBER: ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); if (ffeexpr_hollerith_count_ > 0) ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, '\0', ffelex_token_where_line (t), ffelex_token_where_column (t)); return (ffelexHandler) ffeexpr_nil_number_; case FFELEX_typeNAME: case FFELEX_typeNAMES: return (ffelexHandler) ffeexpr_nil_name_rhs_; case FFELEX_typeASTERISK: case FFELEX_typeSLASH: case FFELEX_typePOWER: case FFELEX_typeCONCAT: case FFELEX_typeREL_EQ: case FFELEX_typeREL_NE: case FFELEX_typeREL_LE: case FFELEX_typeREL_GE: return (ffelexHandler) ffeexpr_nil_rhs_; default: return (ffelexHandler) ffeexpr_nil_finished_ (t); } } static ffelexHandler ffeexpr_nil_period_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_current_dotdot_ = ffestr_other (t); switch (ffeexpr_current_dotdot_) { case FFESTR_otherNone: return (ffelexHandler) ffeexpr_nil_rhs_ (t); case FFESTR_otherTRUE: case FFESTR_otherFALSE: case FFESTR_otherNOT: return (ffelexHandler) ffeexpr_nil_end_period_; default: return (ffelexHandler) ffeexpr_nil_swallow_period_; } break; /* Nothing really reaches here. */ case FFELEX_typeNUMBER: return (ffelexHandler) ffeexpr_nil_real_; default: return (ffelexHandler) ffeexpr_nil_rhs_ (t); } } static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t) { switch (ffeexpr_current_dotdot_) { case FFESTR_otherNOT: if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_nil_rhs_ (t); return (ffelexHandler) ffeexpr_nil_rhs_; case FFESTR_otherTRUE: case FFESTR_otherFALSE: if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_binary_; default: assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL); exit (0); return NULL; } } static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_nil_rhs_ (t); return (ffelexHandler) ffeexpr_nil_rhs_; } static ffelexHandler ffeexpr_nil_real_ (ffelexToken t) { char d; const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q'))) && ffeexpr_isdigits_ (++p))) return (ffelexHandler) ffeexpr_nil_binary_ (t); if (*p == '\0') return (ffelexHandler) ffeexpr_nil_real_exponent_; return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_real_exp_sign_; } static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_number_ (ffelexToken t) { char d; const char *p; if (ffeexpr_hollerith_count_ > 0) ffelex_set_expecting_hollerith (0, '\0', ffewhere_line_unknown (), ffewhere_column_unknown ()); switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q')) && ffeexpr_isdigits_ (++p)) { if (*p == '\0') { ffeexpr_find_.t = ffelex_token_use (t); return (ffelexHandler) ffeexpr_nil_number_exponent_; } return (ffelexHandler) ffeexpr_nil_binary_; } break; case FFELEX_typePERIOD: ffeexpr_find_.t = ffelex_token_use (t); return (ffelexHandler) ffeexpr_nil_number_period_; case FFELEX_typeHOLLERITH: return (ffelexHandler) ffeexpr_nil_binary_; default: break; } return (ffelexHandler) ffeexpr_nil_binary_ (t); } /* Expects ffeexpr_find_.t. */ static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t) { ffelexHandler nexthandler; if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) { nexthandler = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) (*nexthandler) (t); } ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) ffeexpr_nil_number_exp_sign_; } static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_binary_; } /* Expects ffeexpr_find_.t. */ static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t) { ffelexHandler nexthandler; char d; const char *p; switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q')) && ffeexpr_isdigits_ (++p)) { if (*p == '\0') return (ffelexHandler) ffeexpr_nil_number_per_exp_; ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) ffeexpr_nil_binary_; } nexthandler = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) (*nexthandler) (t); case FFELEX_typeNUMBER: ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) ffeexpr_nil_number_real_; default: break; } ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) ffeexpr_nil_binary_ (t); } /* Expects ffeexpr_find_.t. */ static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) { ffelexHandler nexthandler; nexthandler = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) (*nexthandler) (t); } ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_; } static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t) { char d; const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q'))) && ffeexpr_isdigits_ (++p))) return (ffelexHandler) ffeexpr_nil_binary_ (t); if (*p == '\0') return (ffelexHandler) ffeexpr_nil_number_real_exp_; return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_; } static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typePLUS: case FFELEX_typeMINUS: case FFELEX_typeASTERISK: case FFELEX_typeSLASH: case FFELEX_typePOWER: case FFELEX_typeCONCAT: case FFELEX_typeOPEN_ANGLE: case FFELEX_typeCLOSE_ANGLE: case FFELEX_typeREL_EQ: case FFELEX_typeREL_NE: case FFELEX_typeREL_GE: case FFELEX_typeREL_LE: return (ffelexHandler) ffeexpr_nil_rhs_; case FFELEX_typePERIOD: return (ffelexHandler) ffeexpr_nil_binary_period_; default: return (ffelexHandler) ffeexpr_nil_finished_ (t); } } static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_current_dotdot_ = ffestr_other (t); switch (ffeexpr_current_dotdot_) { case FFESTR_otherTRUE: case FFESTR_otherFALSE: case FFESTR_otherNOT: return (ffelexHandler) ffeexpr_nil_binary_sw_per_; default: return (ffelexHandler) ffeexpr_nil_binary_end_per_; } break; /* Nothing really reaches here. */ default: return (ffelexHandler) ffeexpr_nil_binary_ (t); } } static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_nil_rhs_ (t); return (ffelexHandler) ffeexpr_nil_rhs_; } static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_nil_binary_ (t); return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) return (ffelexHandler) ffeexpr_nil_rhs_ (t); return (ffelexHandler) ffeexpr_nil_binary_; } static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t) { assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); return (ffelexHandler) ffeexpr_nil_apos_char_; } static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t) { char c; if ((ffelex_token_type (t) == FFELEX_typeNAME) || (ffelex_token_type (t) == FFELEX_typeNAMES)) { if ((ffelex_token_length (t) == 1) && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B', 'b') || ffesrc_char_match_init (c, 'O', 'o') || ffesrc_char_match_init (c, 'X', 'x') || ffesrc_char_match_init (c, 'Z', 'z'))) return (ffelexHandler) ffeexpr_nil_binary_; } if ((ffelex_token_type (t) == FFELEX_typeNAME) || (ffelex_token_type (t) == FFELEX_typeNAMES)) return (ffelexHandler) ffeexpr_nil_rhs_ (t); return (ffelexHandler) ffeexpr_nil_substrp_ (t); } static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeQUOTE: case FFELEX_typeAPOSTROPHE: ffelex_set_hexnum (TRUE); return (ffelexHandler) ffeexpr_nil_name_apos_; case FFELEX_typeOPEN_PAREN: ++ffeexpr_find_.level; return (ffelexHandler) ffeexpr_nil_rhs_; default: return (ffelexHandler) ffeexpr_nil_binary_ (t); } } static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t) { if (ffelex_token_type (t) == FFELEX_typeNAME) return (ffelexHandler) ffeexpr_nil_name_apos_name_; return (ffelexHandler) ffeexpr_nil_binary_ (t); } static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeAPOSTROPHE: case FFELEX_typeQUOTE: return (ffelexHandler) ffeexpr_nil_finished_; default: return (ffelexHandler) ffeexpr_nil_finished_ (t); } } static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_stack_->percent = ffeexpr_percent_ (t); ffeexpr_find_.t = ffelex_token_use (t); return (ffelexHandler) ffeexpr_nil_percent_name_; default: return (ffelexHandler) ffeexpr_nil_rhs_ (t); } } /* Expects ffeexpr_find_.t. */ static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t) { ffelexHandler nexthandler; if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) { nexthandler = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t); ffelex_token_kill (ffeexpr_find_.t); return (ffelexHandler) (*nexthandler) (t); } ffelex_token_kill (ffeexpr_find_.t); ++ffeexpr_find_.level; return (ffelexHandler) ffeexpr_nil_rhs_; } static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) return (ffelexHandler) ffeexpr_nil_binary_ (t); ++ffeexpr_find_.level; return (ffelexHandler) ffeexpr_nil_rhs_; } /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish ffelexToken t; return ffeexpr_finished_(t); Reduces expression stack to one (or zero) elements by repeatedly reducing the top operator on the stack (or, if the top element on the stack is itself an operator, issuing an error message and discarding it). Calls finishing routine with the expression, returning the ffelexHandler it returns to the caller. */ static ffelexHandler ffeexpr_finished_ (ffelexToken t) { ffeexprExpr_ operand; /* This is B in -B or A+B. */ ffebld expr; ffeexprCallback callback; ffeexprStack_ s; ffebldConstant constnode; /* For detecting magical number. */ ffelexToken ft; /* Temporary copy of first token in expression. */ ffelexHandler next; ffeinfo info; bool error = FALSE; while (((operand = ffeexpr_stack_->exprstack) != NULL) && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_))) { if (operand->type == FFEEXPR_exprtypeOPERAND_) ffeexpr_reduce_ (); else { if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); ffebad_finish (); } ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless operator. */ ffeexpr_expr_kill_ (operand); } } assert ((operand == NULL) || (operand->previous == NULL)); ffebld_pool_pop (); if (operand == NULL) expr = NULL; else { expr = operand->u.operand; info = ffebld_info (expr); if ((ffebld_op (expr) == FFEBLD_opCONTER) && (ffebld_conter_orig (expr) == NULL) && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) { ffetarget_integer_bad_magical (operand->token); } ffeexpr_expr_kill_ (operand); ffeexpr_stack_->exprstack = NULL; } ft = ffeexpr_stack_->first_token; again: /* :::::::::::::::::::: */ switch (ffeexpr_stack_->context) { case FFEEXPR_contextLET: case FFEEXPR_contextSFUNCDEF: error = (expr == NULL) || (ffeinfo_rank (info) != 0); break; case FFEEXPR_contextPAREN_: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: break; } break; case FFEEXPR_contextPARENFILENUM_: if (ffelex_token_type (t) != FFELEX_typeCOMMA) ffeexpr_stack_->context = FFEEXPR_contextPAREN_; else ffeexpr_stack_->context = FFEEXPR_contextFILENUM; goto again; /* :::::::::::::::::::: */ case FFEEXPR_contextPARENFILEUNIT_: if (ffelex_token_type (t) != FFELEX_typeCOMMA) ffeexpr_stack_->context = FFEEXPR_contextPAREN_; else ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT; goto again; /* :::::::::::::::::::: */ case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: if (!ffe_is_ugly_args () && ffebad_start (FFEBAD_ACTUALARG)) { ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } break; default: break; } error = (expr != NULL) && (ffeinfo_rank (info) != 0); break; case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextSFUNCDEFACTUALARG_: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: #if 0 /* Should never get here. */ expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); #else assert ("why hollerith/typeless in actualarg_?" == NULL); #endif break; default: break; } switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr)) { case FFEBLD_opSYMTER: case FFEBLD_opPERCENT_LOC: case FFEBLD_opPERCENT_VAL: case FFEBLD_opPERCENT_REF: case FFEBLD_opPERCENT_DESCR: error = FALSE; break; default: error = (expr != NULL) && (ffeinfo_rank (info) != 0); break; } { ffesymbol s; ffeinfoWhere where; ffeinfoKind kind; if (!error && (expr != NULL) && (ffebld_op (expr) == FFEBLD_opSYMTER) && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)), (where == FFEINFO_whereINTRINSIC) || (where == FFEINFO_whereGLOBAL) || ((where == FFEINFO_whereDUMMY) && ((kind = ffesymbol_kind (s)), (kind == FFEINFO_kindFUNCTION) || (kind == FFEINFO_kindSUBROUTINE)))) && !ffesymbol_explicitwhere (s)) { ffebad_start (where == FFEINFO_whereINTRINSIC ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_string (ffesymbol_text (s)); ffebad_finish (); ffesymbol_signal_change (s); ffesymbol_set_explicitwhere (s, TRUE); ffesymbol_signal_unreported (s); } } break; case FFEEXPR_contextINDEX_: case FFEEXPR_contextSFUNCDEFINDEX_: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeNONE: error = FALSE; break; case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeINTEGER: /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through unmolested. Leave it to downstream to handle kinds. */ break; default: error = TRUE; break; } break; /* expr==NULL ok for substring; element case caught by callback. */ case FFEEXPR_contextRETURN: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeNONE: error = FALSE; break; case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } break; case FFEEXPR_contextDO: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: error = !ffe_is_ugly_logint (); if (!ffeexpr_stack_->is_rhs) break; /* Don't convert lhs variable. */ expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, ffeinfo_kindtype (ffebld_info (expr)), 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: if (!ffeexpr_stack_->is_rhs) { error = TRUE; break; /* Don't convert lhs variable. */ } break; case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeREAL: break; default: error = TRUE; break; } if (!ffeexpr_stack_->is_rhs && (ffebld_op (expr) != FFEBLD_opSYMTER)) error = TRUE; break; case FFEEXPR_contextDOWHILE: case FFEEXPR_contextIF: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeLOGICAL: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } break; case FFEEXPR_contextASSIGN: case FFEEXPR_contextAGOTO: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: error = (ffeinfo_kindtype (info) != ffecom_label_kind ()); break; case FFEINFO_basictypeLOGICAL: error = !ffe_is_ugly_logint () || (ffeinfo_kindtype (info) != ffecom_label_kind ()); break; default: error = TRUE; break; } if ((expr == NULL) || (ffeinfo_rank (info) != 0) || (ffebld_op (expr) != FFEBLD_opSYMTER)) error = TRUE; break; case FFEEXPR_contextCGOTO: case FFEEXPR_contextFORMAT: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */ if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } break; case FFEEXPR_contextARITHIF: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeREAL: error = FALSE; break; default: error = TRUE; break; } break; case FFEEXPR_contextSTOP: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); break; case FFEINFO_basictypeCHARACTER: error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT); break; case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeNONE: error = FALSE; break; default: error = TRUE; break; } if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER) || (ffebld_conter_orig (expr) != NULL))) error = TRUE; break; case FFEEXPR_contextINCLUDE: error = (expr == NULL) || (ffeinfo_rank (info) != 0) || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER) || (ffebld_op (expr) != FFEBLD_opCONTER) || (ffebld_conter_orig (expr) != NULL); break; case FFEEXPR_contextSELECTCASE: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeCHARACTER: case FFEINFO_basictypeLOGICAL: error = FALSE; break; case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } break; case FFEEXPR_contextCASE: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeINTEGER : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeCHARACTER: case FFEINFO_basictypeLOGICAL: error = FALSE; break; case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) error = TRUE; break; case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextDIMLISTCOMMON: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) error = TRUE; break; case FFEEXPR_contextEQVINDEX_: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeNONE: error = FALSE; break; case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) error = TRUE; break; case FFEEXPR_contextPARAMETER: if (ffeexpr_stack_->is_rhs) error = (expr == NULL) || (ffeinfo_rank (info) != 0) || (ffebld_op (expr) != FFEBLD_opCONTER); else error = (expr == NULL) || (ffeinfo_rank (info) != 0) || (ffebld_op (expr) != FFEBLD_opSYMTER); break; case FFEEXPR_contextINDEXORACTUALARG_: if (ffelex_token_type (t) == FFELEX_typeCOLON) ffeexpr_stack_->context = FFEEXPR_contextINDEX_; else ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; goto again; /* :::::::::::::::::::: */ case FFEEXPR_contextINDEXORACTUALARGEXPR_: if (ffelex_token_type (t) == FFELEX_typeCOLON) ffeexpr_stack_->context = FFEEXPR_contextINDEX_; else ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; goto again; /* :::::::::::::::::::: */ case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: if (ffelex_token_type (t) == FFELEX_typeCOLON) ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; else ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; goto again; /* :::::::::::::::::::: */ case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: if (ffelex_token_type (t) == FFELEX_typeCOLON) ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; else ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; goto again; /* :::::::::::::::::::: */ case FFEEXPR_contextIMPDOCTRL_: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; if (!ffeexpr_stack_->is_rhs && (ffebld_op (expr) != FFEBLD_opSYMTER)) error = TRUE; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: if (! ffe_is_ugly_logint ()) error = TRUE; if (! ffeexpr_stack_->is_rhs) break; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, ffeinfo_kindtype (info), 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: break; case FFEINFO_basictypeREAL: if (!ffeexpr_stack_->is_rhs && ffe_is_warn_surprising () && !error) { ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_string (ffelex_token_text (ft)); ffebad_finish (); } break; default: error = TRUE; break; } break; case FFEEXPR_contextDATAIMPDOCTRL_: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; if (ffeexpr_stack_->is_rhs) { if ((ffebld_op (expr) != FFEBLD_opCONTER) && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) error = TRUE; } else if ((ffebld_op (expr) != FFEBLD_opSYMTER) || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) error = TRUE; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: if (! ffeexpr_stack_->is_rhs) break; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, ffeinfo_kindtype (info), 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeINTEGER: if (ffeexpr_stack_->is_rhs && (ffeinfo_kindtype (ffebld_info (expr)) != FFEINFO_kindtypeINTEGERDEFAULT)) expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeREAL: if (!ffeexpr_stack_->is_rhs && ffe_is_warn_surprising () && !error) { ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_string (ffelex_token_text (ft)); ffebad_finish (); } break; default: error = TRUE; break; } break; case FFEEXPR_contextIMPDOITEM_: if (ffelex_token_type (t) == FFELEX_typeEQUALS) { ffeexpr_stack_->is_rhs = FALSE; ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; goto again; /* :::::::::::::::::::: */ } /* Fall through. */ case FFEEXPR_contextIOLIST: case FFEEXPR_contextFILEVXTCODE: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: break; } error = (expr == NULL) || ((ffeinfo_rank (info) != 0) && ((ffebld_op (expr) != FFEBLD_opSYMTER) || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) == FFEBLD_opSTAR))); /* Bad if null expr, or if array that is not a SYMTER (can't happen yet, I think) or has a NULL or STAR (assumed) array size. */ break; case FFEEXPR_contextIMPDOITEMDF_: if (ffelex_token_type (t) == FFELEX_typeEQUALS) { ffeexpr_stack_->is_rhs = FALSE; ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; goto again; /* :::::::::::::::::::: */ } /* Fall through. */ case FFEEXPR_contextIOLISTDF: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: break; } error = (expr == NULL) || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER) && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)) || ((ffeinfo_rank (info) != 0) && ((ffebld_op (expr) != FFEBLD_opSYMTER) || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) == FFEBLD_opSTAR))); /* Bad if null expr, non-default-kindtype character expr, or if array that is not a SYMTER (can't happen yet, I think) or has a NULL or STAR (assumed) array size. */ break; case FFEEXPR_contextDATAIMPDOITEM_: error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opARRAYREF) || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR) && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR)); break; case FFEEXPR_contextDATAIMPDOINDEX_: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT) && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) error = TRUE; break; case FFEEXPR_contextDATA: if (expr == NULL) error = TRUE; else if (ffeexpr_stack_->is_rhs) error = (ffebld_op (expr) != FFEBLD_opCONTER); else if (ffebld_op (expr) == FFEBLD_opSYMTER) error = FALSE; else error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); break; case FFEEXPR_contextINITVAL: error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER); break; case FFEEXPR_contextEQUIVALENCE: if (expr == NULL) error = TRUE; else if (ffebld_op (expr) == FFEBLD_opSYMTER) error = FALSE; else error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); break; case FFEEXPR_contextFILEASSOC: case FFEEXPR_contextFILEINT: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: /* Maybe this should be supported someday, but, right now, g77 can't generate a call to libf2c to write to an integer other than the default size. */ error = ((! ffeexpr_stack_->is_rhs) && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); break; default: error = TRUE; break; } if ((expr == NULL) || (ffeinfo_rank (info) != 0)) error = TRUE; break; case FFEEXPR_contextFILEDFINT: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); break; default: error = TRUE; break; } if ((expr == NULL) || (ffeinfo_rank (info) != 0)) error = TRUE; break; case FFEEXPR_contextFILELOG: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: error = FALSE; break; default: error = TRUE; break; } if ((expr == NULL) || (ffeinfo_rank (info) != 0)) error = TRUE; break; case FFEEXPR_contextFILECHAR: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeCHARACTER: error = FALSE; break; default: error = TRUE; break; } if ((expr == NULL) || (ffeinfo_rank (info) != 0)) error = TRUE; break; case FFEEXPR_contextFILENUMCHAR: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeCHARACTER: error = FALSE; break; default: error = TRUE; break; } break; case FFEEXPR_contextFILEDFCHAR: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeCHARACTER: error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT); break; default: error = TRUE; break; } if (!ffeexpr_stack_->is_rhs && (ffebld_op (expr) == FFEBLD_opSUBSTR)) error = TRUE; break; case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */ switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: if ((error = (ffeinfo_rank (info) != 0))) break; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if ((error = (ffeinfo_rank (info) != 0))) break; if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: if ((error = (ffeinfo_rank (info) != 0))) break; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeCHARACTER: switch (ffebld_op (expr)) { /* As if _lhs had been called instead of _rhs. */ case FFEBLD_opSYMTER: error = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); break; case FFEBLD_opSUBSTR: error = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT_SUBOBJECT); break; case FFEBLD_opARRAYREF: error = FALSE; break; default: error = TRUE; break; } if (!error && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) || ((ffeinfo_rank (info) != 0) && ((ffebld_op (expr) != FFEBLD_opSYMTER) || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) == FFEBLD_opSTAR))))) /* Bad if non-default-kindtype character expr, or if array that is not a SYMTER (can't happen yet, I think), or has a NULL or STAR (assumed) array size. */ error = TRUE; break; default: error = TRUE; break; } break; case FFEEXPR_contextFILEFORMAT: switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: error = (expr == NULL) || ((ffeinfo_rank (info) != 0) ? ffe_is_pedantic () /* F77 C5. */ : (ffeinfo_kindtype (info) != ffecom_label_kind ())) || (ffebld_op (expr) != FFEBLD_opSYMTER); break; case FFEINFO_basictypeLOGICAL: case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: /* F77 C5 -- must be an array of hollerith. */ error = ffe_is_pedantic () || (ffeinfo_rank (info) == 0); break; case FFEINFO_basictypeCHARACTER: if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) || ((ffeinfo_rank (info) != 0) && ((ffebld_op (expr) != FFEBLD_opSYMTER) || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) == FFEBLD_opSTAR)))) /* Bad if non-default-kindtype character expr, or if array that is not a SYMTER (can't happen yet, I think), or has a NULL or STAR (assumed) array size. */ error = TRUE; else error = FALSE; break; default: error = TRUE; break; } break; case FFEEXPR_contextLOC_: /* See also ffeintrin_check_loc_. */ if ((expr == NULL) || (ffeinfo_kind (info) != FFEINFO_kindENTITY) || ((ffebld_op (expr) != FFEBLD_opSYMTER) && (ffebld_op (expr) != FFEBLD_opSUBSTR) && (ffebld_op (expr) != FFEBLD_opARRAYREF))) error = TRUE; break; default: error = FALSE; break; } if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY))) { ffebad_start (FFEBAD_EXPR_WRONG); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); expr = ffebld_new_any (); ffebld_set_info (expr, ffeinfo_new_any ()); } callback = ffeexpr_stack_->callback; s = ffeexpr_stack_->previous; malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); ffeexpr_stack_ = s; next = (ffelexHandler) (*callback) (ft, expr, t); ffelex_token_kill (ft); return (ffelexHandler) next; } /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec ffebld expr; expr = ffeexpr_finished_ambig_(expr); Replicates a bit of ffeexpr_finished_'s task when in a context of UNIT or FORMAT. */ static ffebld ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr) { ffeinfo info = ffebld_info (expr); bool error; switch (ffeexpr_stack_->context) { case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */ switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; default: error = TRUE; break; } if ((expr == NULL) || (ffeinfo_rank (info) != 0)) error = TRUE; break; case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */ if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) { error = FALSE; break; } switch ((expr == NULL) ? FFEINFO_basictypeNONE : ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); /* Fall through. */ case FFEINFO_basictypeREAL: case FFEINFO_basictypeCOMPLEX: if (ffe_is_pedantic ()) { error = TRUE; break; } /* Fall through. */ case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = (ffeinfo_rank (info) != 0); expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; case FFEINFO_basictypeCHARACTER: switch (ffebld_op (expr)) { /* As if _lhs had been called instead of _rhs. */ case FFEBLD_opSYMTER: error = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); break; case FFEBLD_opSUBSTR: error = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT_SUBOBJECT); break; case FFEBLD_opARRAYREF: error = FALSE; break; default: error = TRUE; break; } break; default: error = TRUE; break; } break; default: assert ("bad context" == NULL); error = TRUE; break; } if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY))) { ffebad_start (FFEBAD_EXPR_WRONG); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); expr = ffebld_new_any (); ffebld_set_info (expr, ffeinfo_new_any ()); } return expr; } /* ffeexpr_token_lhs_ -- Initial state for lhs expression Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Basically a smaller version of _rhs_; keep them both in sync, of course. */ static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t) { /* When changing the list of valid initial lhs tokens, check whether to update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the READ (expr) case -- it assumes it knows which tokens can be to indicate an lhs (or implied DO), which right now is the set {NAME,OPEN_PAREN}. This comment also appears in ffeexpr_token_first_lhs_. */ switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_tokens_[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_name_lhs_; default: return (ffelexHandler) ffeexpr_finished_ (t); } } /* ffeexpr_token_rhs_ -- Initial state for rhs expression Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. The initial state and the post-binary-operator state are the same and both handled here, with the expression stack used to distinguish between them. Binary operators are invalid here; unary operators, constants, subexpressions, and name references are valid. */ static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t) { ffeexprExpr_ e; switch (ffelex_token_type (t)) { case FFELEX_typeQUOTE: if (ffe_is_vxt ()) { ffeexpr_tokens_[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_quote_; } ffeexpr_tokens_[0] = ffelex_token_use (t); ffelex_set_expecting_hollerith (-1, '\"', ffelex_token_where_line (t), ffelex_token_where_column (t)); /* Don't have to unset this one. */ return (ffelexHandler) ffeexpr_token_apostrophe_; case FFELEX_typeAPOSTROPHE: ffeexpr_tokens_[0] = ffelex_token_use (t); ffelex_set_expecting_hollerith (-1, '\'', ffelex_token_where_line (t), ffelex_token_where_column (t)); /* Don't have to unset this one. */ return (ffelexHandler) ffeexpr_token_apostrophe_; case FFELEX_typePERCENT: ffeexpr_tokens_[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_percent_; case FFELEX_typeOPEN_PAREN: ffeexpr_stack_->tokens[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextPAREN_, ffeexpr_cb_close_paren_c_); case FFELEX_typePLUS: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeUNARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorADD_; e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; e->u.operator.as = FFEEXPR_operatorassociativityADD_; ffeexpr_exprstack_push_unary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeMINUS: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeUNARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorSUBTRACT_; e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; ffeexpr_exprstack_push_unary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typePERIOD: ffeexpr_tokens_[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_period_; case FFELEX_typeNUMBER: ffeexpr_tokens_[0] = ffelex_token_use (t); ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); if (ffeexpr_hollerith_count_ > 0) ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, '\0', ffelex_token_where_line (t), ffelex_token_where_column (t)); return (ffelexHandler) ffeexpr_token_number_; case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_tokens_[0] = ffelex_token_use (t); switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextINDEXORACTUALARG_: case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: return (ffelexHandler) ffeexpr_token_name_arg_; default: return (ffelexHandler) ffeexpr_token_name_rhs_; } case FFELEX_typeASTERISK: case FFELEX_typeSLASH: case FFELEX_typePOWER: case FFELEX_typeCONCAT: case FFELEX_typeREL_EQ: case FFELEX_typeREL_NE: case FFELEX_typeREL_LE: case FFELEX_typeREL_GE: if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } return (ffelexHandler) ffeexpr_token_rhs_; #if 0 case FFELEX_typeEQUALS: case FFELEX_typePOINTS: case FFELEX_typeCLOSE_ANGLE: case FFELEX_typeCLOSE_PAREN: case FFELEX_typeCOMMA: case FFELEX_typeCOLON: case FFELEX_typeEOS: case FFELEX_typeSEMICOLON: #endif default: return (ffelexHandler) ffeexpr_finished_ (t); } } /* ffeexpr_token_period_ -- Rhs PERIOD Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle a period detected at rhs (expecting unary op or operand) state. Must begin a floating-point value (as in .12) or a dot-dot name, of which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of- valid names represent binary operators, which are invalid here because there isn't an operand at the top of the stack. */ static ffelexHandler ffeexpr_token_period_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_current_dotdot_ = ffestr_other (t); switch (ffeexpr_current_dotdot_) { case FFESTR_otherNone: if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_rhs_ (t); case FFESTR_otherTRUE: case FFESTR_otherFALSE: case FFESTR_otherNOT: ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_end_period_; default: if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_swallow_period_; } break; /* Nothing really reaches here. */ case FFELEX_typeNUMBER: ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_real_; default: if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_rhs_ (t); } } /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op or operator) state. If period isn't found, issue a diagnostic but pretend we saw one. ffeexpr_current_dotdot_ must already contained the dotdot representation of the name in between the two PERIOD tokens. */ static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t) { ffeexprExpr_ e; if (ffelex_token_type (t) != FFELEX_typePERIOD) { if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); ffebad_finish (); } } ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE" token. */ e = ffeexpr_expr_new_ (); e->token = ffeexpr_tokens_[0]; switch (ffeexpr_current_dotdot_) { case FFESTR_otherNOT: e->type = FFEEXPR_exprtypeUNARY_; e->u.operator.op = FFEEXPR_operatorNOT_; e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_; e->u.operator.as = FFEEXPR_operatorassociativityNOT_; ffeexpr_exprstack_push_unary_ (e); if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_token_rhs_ (t); return (ffelexHandler) ffeexpr_token_rhs_; case FFESTR_otherTRUE: e->type = FFEEXPR_exprtypeOPERAND_; e->u.operand = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE)); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffeexpr_exprstack_push_operand_ (e); if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_token_binary_ (t); return (ffelexHandler) ffeexpr_token_binary_; case FFESTR_otherFALSE: e->type = FFEEXPR_exprtypeOPERAND_; e->u.operand = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE)); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffeexpr_exprstack_push_operand_ (e); if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_token_binary_ (t); return (ffelexHandler) ffeexpr_token_binary_; default: assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL); exit (0); return NULL; } } /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. A diagnostic has already been issued; just swallow a period if there is one, then continue with ffeexpr_token_rhs_. */ static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_token_rhs_ (t); return (ffelexHandler) ffeexpr_token_rhs_; } /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. After a period and a string of digits, check next token for possible exponent designation (D, E, or Q as first/only character) and continue real-number handling accordingly. Else form basic real constant, push onto expression stack, and enter binary state using current token (which, if it is a name not beginning with D, E, or Q, will certainly result in an error, but that's not for this routine to deal with). */ static ffelexHandler ffeexpr_token_real_ (ffelexToken t) { char d; const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q'))) && ffeexpr_isdigits_ (++p))) { #if 0 /* This code has been removed because it seems inconsistent to produce a diagnostic in this case, but not all of the other ones that look for an exponent and cannot recognize one. */ if (((ffelex_token_type (t) == FFELEX_typeNAME) || (ffelex_token_type (t) == FFELEX_typeNAMES)) && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) { char bad[2]; ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); bad[0] = *(p - 1); bad[1] = '\0'; ffebad_string (bad); ffebad_finish (); } #endif ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* Just exponent character by itself? In which case, PLUS or MINUS must surely be next, followed by a NUMBER token. */ if (*p == '\0') { ffeexpr_tokens_[2] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_real_exponent_; } ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], t, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Ensures this token is PLUS or MINUS, preserves it, goes to final state for real number (exponent digits). Else issues diagnostic, assumes a zero exponent field for number, passes token on to binary state as if previous token had been "E0" instead of "E", for example. */ static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) { if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), ffelex_token_where_column (ffeexpr_tokens_[2])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_ (t); } ffeexpr_tokens_[3] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_real_exp_sign_; } /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Make sure token is a NUMBER, make a real constant out of all we have and push it onto the expression stack. Else issue diagnostic and pretend exponent field was a zero. */ static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) { if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), ffelex_token_where_column (ffeexpr_tokens_[2])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); return (ffelexHandler) ffeexpr_token_binary_ (t); } ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], ffeexpr_tokens_[3], t); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_number_ -- Rhs NUMBER Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. If the token is a period, we may have a floating-point number, or an integer followed by a dotdot binary operator. If the token is a name beginning with D, E, or Q, we definitely have a floating-point number. If the token is a hollerith constant, that's what we've got, so push it onto the expression stack and continue with the binary state. Otherwise, we have an integer followed by something the binary state should be able to swallow. */ static ffelexHandler ffeexpr_token_number_ (ffelexToken t) { ffeexprExpr_ e; ffeinfo ni; char d; const char *p; if (ffeexpr_hollerith_count_ > 0) ffelex_set_expecting_hollerith (0, '\0', ffewhere_line_unknown (), ffewhere_column_unknown ()); /* See if we've got a floating-point number here. */ switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q')) && ffeexpr_isdigits_ (++p)) { /* Just exponent character by itself? In which case, PLUS or MINUS must surely be next, followed by a NUMBER token. */ if (*p == '\0') { ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_number_exponent_; } ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_binary_; } break; case FFELEX_typePERIOD: ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_number_period_; case FFELEX_typeHOLLERITH: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t)); ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, ffelex_token_length (t)); ffebld_set_info (e->u.operand, ni); ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_token_binary_; default: break; } /* Nothing specific we were looking for, so make an integer and pass the current token to the binary state. */ ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL, NULL, NULL, NULL); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Ensures this token is PLUS or MINUS, preserves it, goes to final state for real number (exponent digits). Else treats number as integer, passes name to binary, passes current token to subsequent handler. */ static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) { ffeexprExpr_ e; ffelexHandler nexthandler; e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault (ffeexpr_tokens_[0])); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffeexpr_exprstack_push_operand_ (e); nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) (*nexthandler) (t); } ffeexpr_tokens_[2] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_number_exp_sign_; } /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Make sure token is a NUMBER, make a real constant out of all we have and push it onto the expression stack. Else issue diagnostic and pretend exponent field was a zero. */ static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) { if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]), ffelex_token_where_column (ffeexpr_tokens_[1])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], ffeexpr_tokens_[0], NULL, NULL, ffeexpr_tokens_[1], ffeexpr_tokens_[2], NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_ (t); } ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], ffeexpr_tokens_[0], NULL, NULL, ffeexpr_tokens_[1], ffeexpr_tokens_[2], t); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle a period detected following a number at rhs state. Must begin a floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */ static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t) { ffeexprExpr_ e; ffelexHandler nexthandler; const char *p; char d; switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q')) && ffeexpr_isdigits_ (++p)) { /* Just exponent character by itself? In which case, PLUS or MINUS must surely be next, followed by a NUMBER token. */ if (*p == '\0') { ffeexpr_tokens_[2] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_number_per_exp_; } ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, t, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) ffeexpr_token_binary_; } /* A name not representing an exponent, so assume it will be something like EQ, make an integer from the number, pass the period to binary state and the current token to the resulting state. */ e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault (ffeexpr_tokens_[0])); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffeexpr_exprstack_push_operand_ (e); nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) (*nexthandler) (t); case FFELEX_typeNUMBER: ffeexpr_tokens_[2] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_number_real_; default: break; } /* Nothing specific we were looking for, so make a real number and pass the period and then the current token to the binary state. */ ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Ensures this token is PLUS or MINUS, preserves it, goes to final state for real number (exponent digits). Else treats number as real, passes name to binary, passes current token to subsequent handler. */ static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) { ffelexHandler nexthandler; ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) (*nexthandler) (t); } ffeexpr_tokens_[3] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_num_per_exp_sign_; } /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. After a number, period, and number, check next token for possible exponent designation (D, E, or Q as first/only character) and continue real-number handling accordingly. Else form basic real constant, push onto expression stack, and enter binary state using current token (which, if it is a name not beginning with D, E, or Q, will certainly result in an error, but that's not for this routine to deal with). */ static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t) { char d; const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 'D', 'd') || ffesrc_char_match_init (d, 'E', 'e') || ffesrc_char_match_init (d, 'Q', 'q'))) && ffeexpr_isdigits_ (++p))) { #if 0 /* This code has been removed because it seems inconsistent to produce a diagnostic in this case, but not all of the other ones that look for an exponent and cannot recognize one. */ if (((ffelex_token_type (t) == FFELEX_typeNAME) || (ffelex_token_type (t) == FFELEX_typeNAMES)) && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) { char bad[2]; ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); bad[0] = *(p - 1); bad[1] = '\0'; ffebad_string (bad); ffebad_finish (); } #endif ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* Just exponent character by itself? In which case, PLUS or MINUS must surely be next, followed by a NUMBER token. */ if (*p == '\0') { ffeexpr_tokens_[3] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_number_real_exp_; } ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], t, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Make sure token is a NUMBER, make a real constant out of all we have and push it onto the expression stack. Else issue diagnostic and pretend exponent field was a zero. */ static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) { if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), ffelex_token_where_column (ffeexpr_tokens_[2])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); return (ffelexHandler) ffeexpr_token_binary_ (t); } ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, ffeexpr_tokens_[2], ffeexpr_tokens_[3], t); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Ensures this token is PLUS or MINUS, preserves it, goes to final state for real number (exponent digits). Else issues diagnostic, assumes a zero exponent field for number, passes token on to binary state as if previous token had been "E0" instead of "E", for example. */ static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typePLUS) && (ffelex_token_type (t) != FFELEX_typeMINUS)) { if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), ffelex_token_where_column (ffeexpr_tokens_[3])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); return (ffelexHandler) ffeexpr_token_binary_ (t); } ffeexpr_tokens_[4] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_num_real_exp_sn_; } /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Make sure token is a NUMBER, make a real constant out of all we have and push it onto the expression stack. Else issue diagnostic and pretend exponent field was a zero. */ static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typeNUMBER) { if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), ffelex_token_where_column (ffeexpr_tokens_[3])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], NULL, NULL, NULL); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); ffelex_token_kill (ffeexpr_tokens_[4]); return (ffelexHandler) ffeexpr_token_binary_ (t); } ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0], ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], ffeexpr_tokens_[3], ffeexpr_tokens_[4], t); ffelex_token_kill (ffeexpr_tokens_[0]); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); ffelex_token_kill (ffeexpr_tokens_[3]); ffelex_token_kill (ffeexpr_tokens_[4]); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_binary_ -- Handle binary operator possibility Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. The possibility of a binary operator is handled here, meaning the previous token was an operand. */ static ffelexHandler ffeexpr_token_binary_ (ffelexToken t) { ffeexprExpr_ e; if (!ffeexpr_stack_->is_rhs) return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */ switch (ffelex_token_type (t)) { case FFELEX_typePLUS: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorADD_; e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; e->u.operator.as = FFEEXPR_operatorassociativityADD_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeMINUS: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorSUBTRACT_; e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeASTERISK: switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: return (ffelexHandler) ffeexpr_finished_ (t); default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorMULTIPLY_; e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_; e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeSLASH: switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATA: return (ffelexHandler) ffeexpr_finished_ (t); default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorDIVIDE_; e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_; e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typePOWER: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorPOWER_; e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_; e->u.operator.as = FFEEXPR_operatorassociativityPOWER_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeCONCAT: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorCONCATENATE_; e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeOPEN_ANGLE: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFORMAT: ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); break; default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorLT_; e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; e->u.operator.as = FFEEXPR_operatorassociativityLT_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeCLOSE_ANGLE: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFORMAT: return ffeexpr_finished_ (t); default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorGT_; e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; e->u.operator.as = FFEEXPR_operatorassociativityGT_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeREL_EQ: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFORMAT: ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); break; default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorEQ_; e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; e->u.operator.as = FFEEXPR_operatorassociativityEQ_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeREL_NE: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFORMAT: ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); break; default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorNE_; e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; e->u.operator.as = FFEEXPR_operatorassociativityNE_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeREL_LE: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFORMAT: ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); break; default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorLE_; e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; e->u.operator.as = FFEEXPR_operatorassociativityLE_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typeREL_GE: switch (ffeexpr_stack_->context) { case FFEEXPR_contextFORMAT: ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); break; default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorGE_; e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; e->u.operator.as = FFEEXPR_operatorassociativityGE_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_; case FFELEX_typePERIOD: ffeexpr_tokens_[0] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_binary_period_; #if 0 case FFELEX_typeOPEN_PAREN: case FFELEX_typeCLOSE_PAREN: case FFELEX_typeEQUALS: case FFELEX_typePOINTS: case FFELEX_typeCOMMA: case FFELEX_typeCOLON: case FFELEX_typeEOS: case FFELEX_typeSEMICOLON: case FFELEX_typeNAME: case FFELEX_typeNAMES: #endif default: return (ffelexHandler) ffeexpr_finished_ (t); } } /* ffeexpr_token_binary_period_ -- Binary PERIOD Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle a period detected at binary (expecting binary op or end) state. Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not valid. */ static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t) { ffeexprExpr_ operand; switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_current_dotdot_ = ffestr_other (t); switch (ffeexpr_current_dotdot_) { case FFESTR_otherTRUE: case FFESTR_otherFALSE: case FFESTR_otherNOT: if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR)) { operand = ffeexpr_stack_->exprstack; assert (operand != NULL); assert (operand->type == FFEEXPR_exprtypeOPERAND_); ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token)); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_binary_sw_per_; default: ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_binary_end_per_; } break; /* Nothing really reaches here. */ default: if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_binary_ (t); } } /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Expecting a period to close a dot-dot at binary (binary op or operator) state. If period isn't found, issue a diagnostic but pretend we saw one. ffeexpr_current_dotdot_ must already contained the dotdot representation of the name in between the two PERIOD tokens. */ static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t) { ffeexprExpr_ e; e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffeexpr_tokens_[0]; switch (ffeexpr_current_dotdot_) { case FFESTR_otherAND: e->u.operator.op = FFEEXPR_operatorAND_; e->u.operator.prec = FFEEXPR_operatorprecedenceAND_; e->u.operator.as = FFEEXPR_operatorassociativityAND_; break; case FFESTR_otherOR: e->u.operator.op = FFEEXPR_operatorOR_; e->u.operator.prec = FFEEXPR_operatorprecedenceOR_; e->u.operator.as = FFEEXPR_operatorassociativityOR_; break; case FFESTR_otherXOR: e->u.operator.op = FFEEXPR_operatorXOR_; e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_; e->u.operator.as = FFEEXPR_operatorassociativityXOR_; break; case FFESTR_otherEQV: e->u.operator.op = FFEEXPR_operatorEQV_; e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_; e->u.operator.as = FFEEXPR_operatorassociativityEQV_; break; case FFESTR_otherNEQV: e->u.operator.op = FFEEXPR_operatorNEQV_; e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_; e->u.operator.as = FFEEXPR_operatorassociativityNEQV_; break; case FFESTR_otherLT: e->u.operator.op = FFEEXPR_operatorLT_; e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; e->u.operator.as = FFEEXPR_operatorassociativityLT_; break; case FFESTR_otherLE: e->u.operator.op = FFEEXPR_operatorLE_; e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; e->u.operator.as = FFEEXPR_operatorassociativityLE_; break; case FFESTR_otherEQ: e->u.operator.op = FFEEXPR_operatorEQ_; e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; e->u.operator.as = FFEEXPR_operatorassociativityEQ_; break; case FFESTR_otherNE: e->u.operator.op = FFEEXPR_operatorNE_; e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; e->u.operator.as = FFEEXPR_operatorassociativityNE_; break; case FFESTR_otherGT: e->u.operator.op = FFEEXPR_operatorGT_; e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; e->u.operator.as = FFEEXPR_operatorassociativityGT_; break; case FFESTR_otherGE: e->u.operator.op = FFEEXPR_operatorGE_; e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; e->u.operator.as = FFEEXPR_operatorassociativityGE_; break; default: if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); ffebad_finish (); } e->u.operator.op = FFEEXPR_operatorEQ_; e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; e->u.operator.as = FFEEXPR_operatorassociativityEQ_; break; } ffeexpr_exprstack_push_binary_ (e); if (ffelex_token_type (t) != FFELEX_typePERIOD) { if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ return (ffelexHandler) ffeexpr_token_rhs_ (t); } ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ return (ffelexHandler) ffeexpr_token_rhs_; } /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. A diagnostic has already been issued; just swallow a period if there is one, then continue with ffeexpr_token_binary_. */ static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t) { if (ffelex_token_type (t) != FFELEX_typePERIOD) return (ffelexHandler) ffeexpr_token_binary_ (t); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_quote_ -- Rhs QUOTE Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Expecting a NUMBER that we'll treat as an octal integer. */ static ffelexHandler ffeexpr_token_quote_ (ffelexToken t) { ffeexprExpr_ e; ffebld anyexpr; if (ffelex_token_type (t) != FFELEX_typeNUMBER) { if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_rhs_ (t); } /* This is kind of a kludge to prevent any whining about magical numbers that start out as these octal integers, so "20000000000 (on a 32-bit 2's-complement machine) by itself won't produce an error. */ anyexpr = ffebld_new_any (); ffebld_set_info (anyexpr, ffeinfo_new_any ()); e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; e->u.operand = ffebld_new_conter_with_orig (ffebld_constant_new_integeroctal (t), anyexpr); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_token_binary_; } /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle an open-apostrophe, which begins either a character ('char-const'), typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or 'hex-const'X) constant. */ static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t) { assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0)) { ffebad_start (FFEBAD_NULL_CHAR_CONST); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_apos_char_; } /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Close-apostrophe is implicit; if this token is NAME, it is a possible typeless-constant radix specifier. */ static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t) { ffeexprExpr_ e; ffeinfo ni; char c; ffetargetCharacterSize size; if ((ffelex_token_type (t) == FFELEX_typeNAME) || (ffelex_token_type (t) == FFELEX_typeNAMES)) { if ((ffelex_token_length (t) == 1) && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B', 'b') || ffesrc_char_match_init (c, 'O', 'o') || ffesrc_char_match_init (c, 'X', 'x') || ffesrc_char_match_init (c, 'Z', 'z'))) { e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; switch (c) { case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1])); size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]); break; case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1])); size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]); break; case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1])); size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); break; case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1])); size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); break; default: no_match: /* :::::::::::::::::::: */ assert ("not BOXZ!" == NULL); size = 0; break; } ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); ffeexpr_exprstack_push_operand_ (e); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) ffeexpr_token_binary_; } } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault (ffeexpr_tokens_[1])); ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, ffelex_token_length (ffeexpr_tokens_[1])); ffebld_set_info (e->u.operand, ni); ffelex_token_kill (ffeexpr_tokens_[1]); ffeexpr_exprstack_push_operand_ (e); if ((ffelex_token_type (t) == FFELEX_typeNAME) || (ffelex_token_type (t) == FFELEX_typeNAMES)) { if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) { ffebad_string (ffelex_token_text (t)); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_finish (); } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeBINARY_; e->token = ffelex_token_use (t); e->u.operator.op = FFEEXPR_operatorCONCATENATE_; e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; ffeexpr_exprstack_push_binary_ (e); return (ffelexHandler) ffeexpr_token_rhs_ (t); } ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */ return (ffelexHandler) ffeexpr_token_substrp_ (t); } /* ffeexpr_token_name_lhs_ -- Lhs NAME Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle a name followed by open-paren, period (RECORD.MEMBER), percent (RECORD%MEMBER), or nothing at all. */ static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t) { ffeexprExpr_ e; ffeexprParenType_ paren_type; ffesymbol s; ffebld expr; ffeinfo info; switch (ffelex_token_type (t)) { case FFELEX_typeOPEN_PAREN: switch (ffeexpr_stack_->context) { case FFEEXPR_contextASSIGN: case FFEEXPR_contextAGOTO: case FFEEXPR_contextFILEUNIT_DF: goto just_name; /* :::::::::::::::::::: */ default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffelex_token_use (ffeexpr_tokens_[0]); s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE, &paren_type); switch (ffesymbol_where (s)) { case FFEINFO_whereLOCAL: if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */ break; case FFEINFO_whereINTRINSIC: case FFEINFO_whereGLOBAL: if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ break; case FFEINFO_whereCOMMON: case FFEINFO_whereDUMMY: case FFEINFO_whereRESULT: break; case FFEINFO_whereNONE: case FFEINFO_whereANY: break; default: ffesymbol_error (s, ffeexpr_tokens_[0]); break; } if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) { e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); } else { e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s), ffesymbol_specific (s), ffesymbol_implementation (s)); ffebld_set_info (e->u.operand, ffesymbol_info (s)); } ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; switch (paren_type) { case FFEEXPR_parentypeSUBROUTINE_: ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextACTUALARG_, ffeexpr_token_arguments_); case FFEEXPR_parentypeARRAY_: ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); ffeexpr_stack_->bound_list = ffesymbol_dims (s); ffeexpr_stack_->rank = 0; ffeexpr_stack_->constant = TRUE; ffeexpr_stack_->immediate = TRUE; switch (ffeexpr_stack_->context) { case FFEEXPR_contextDATAIMPDOITEM_: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextDATAIMPDOINDEX_, ffeexpr_token_elements_); case FFEEXPR_contextEQUIVALENCE: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextEQVINDEX_, ffeexpr_token_elements_); default: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextINDEX_, ffeexpr_token_elements_); } case FFEEXPR_parentypeSUBSTRING_: e->u.operand = ffeexpr_collapse_symter (e->u.operand, ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextINDEX_, ffeexpr_token_substring_); case FFEEXPR_parentypeEQUIVALENCE_: ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); ffeexpr_stack_->bound_list = ffesymbol_dims (s); ffeexpr_stack_->rank = 0; ffeexpr_stack_->constant = TRUE; ffeexpr_stack_->immediate = TRUE; return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextEQVINDEX_, ffeexpr_token_equivalence_); case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */ case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */ ffesymbol_error (s, ffeexpr_tokens_[0]); /* Fall through. */ case FFEEXPR_parentypeANY_: e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextACTUALARG_, ffeexpr_token_anything_); default: assert ("bad paren type" == NULL); break; } case FFELEX_typeEQUALS: /* As in "VAR=". */ switch (ffeexpr_stack_->context) { case FFEEXPR_contextIMPDOITEM_: /* within "(,VAR=start,end[,incr])". */ case FFEEXPR_contextIMPDOITEMDF_: ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; break; case FFEEXPR_contextDATAIMPDOITEM_: ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_; break; default: break; } break; #if 0 case FFELEX_typePERIOD: case FFELEX_typePERCENT: assert ("FOO%, FOO. not yet supported!~~" == NULL); break; #endif default: break; } just_name: /* :::::::::::::::::::: */ e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)); switch (ffesymbol_where (s)) { case FFEINFO_whereCONSTANT: if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER) || (ffesymbol_kind (s) != FFEINFO_kindENTITY)) ffesymbol_error (s, ffeexpr_tokens_[0]); break; case FFEINFO_whereIMMEDIATE: if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_) && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_)) ffesymbol_error (s, ffeexpr_tokens_[0]); break; case FFEINFO_whereLOCAL: if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */ break; case FFEINFO_whereINTRINSIC: if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ break; default: break; } if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) { expr = ffebld_new_any (); info = ffeinfo_new_any (); ffebld_set_info (expr, info); } else { expr = ffebld_new_symter (s, ffesymbol_generic (s), ffesymbol_specific (s), ffesymbol_implementation (s)); info = ffesymbol_info (s); ffebld_set_info (expr, info); if (ffesymbol_is_doiter (s)) { ffebad_start (FFEBAD_DOITER); ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffest_ffebad_here_doiter (1, s); ffebad_string (ffesymbol_text (s)); ffebad_finish (); } expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]); } if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) { if (ffebld_op (expr) == FFEBLD_opANY) { expr = ffebld_new_any (); ffebld_set_info (expr, ffeinfo_new_any ()); } else { expr = ffebld_new_subrref (expr, NULL); /* No argument list. */ if (ffesymbol_generic (s) != FFEINTRIN_genNONE) ffeintrin_fulfill_generic (&expr, &info, e->token); else if (ffesymbol_specific (s) != FFEINTRIN_specNONE) ffeintrin_fulfill_specific (&expr, &info, NULL, e->token); else ffeexpr_fulfill_call_ (&expr, e->token); if (ffebld_op (expr) != FFEBLD_opANY) ffebld_set_info (expr, ffeinfo_new (ffeinfo_basictype (info), ffeinfo_kindtype (info), 0, FFEINFO_kindENTITY, FFEINFO_whereFLEETING, ffeinfo_size (info))); else ffebld_set_info (expr, ffeinfo_new_any ()); } } e->u.operand = expr; ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_finished_ (t); } /* ffeexpr_token_name_arg_ -- Rhs NAME Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle first token in an actual-arg (or possible actual-arg) context being a NAME, and use second token to refine the context. */ static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeCLOSE_PAREN: case FFELEX_typeCOMMA: switch (ffeexpr_stack_->context) { case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; break; default: break; } break; default: switch (ffeexpr_stack_->context) { case FFEEXPR_contextACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; break; case FFEEXPR_contextINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; break; case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; break; default: assert ("bad context in _name_arg_" == NULL); break; } break; } return (ffelexHandler) ffeexpr_token_name_rhs_ (t); } /* ffeexpr_token_name_rhs_ -- Rhs NAME Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle a name followed by open-paren, apostrophe (O'octal-const', Z'hex-const', or X'hex-const'), period (RECORD.MEMBER). 26-Nov-91 JCB 1.2 When followed by apostrophe or quote, set lex hexnum flag on so [0-9] as first char of next token seen as starting a potentially hex number (NAME). 04-Oct-91 JCB 1.1 In case of intrinsic, decorate its SYMTER with the type info for the specific intrinsic. */ static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t) { ffeexprExpr_ e; ffeexprParenType_ paren_type; ffesymbol s; bool sfdef; switch (ffelex_token_type (t)) { case FFELEX_typeQUOTE: case FFELEX_typeAPOSTROPHE: ffeexpr_tokens_[1] = ffelex_token_use (t); ffelex_set_hexnum (TRUE); return (ffelexHandler) ffeexpr_token_name_apos_; case FFELEX_typeOPEN_PAREN: e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffelex_token_use (ffeexpr_tokens_[0]); s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE, &paren_type); if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) e->u.operand = ffebld_new_any (); else e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s), ffesymbol_specific (s), ffesymbol_implementation (s)); ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: sfdef = TRUE; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: assert ("weird context!" == NULL); sfdef = FALSE; break; default: sfdef = FALSE; break; } switch (paren_type) { case FFEEXPR_parentypeFUNCTION_: ffebld_set_info (e->u.operand, ffesymbol_info (s)); ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) { /* A statement function. */ ffeexpr_stack_->num_args = ffebld_list_length (ffeexpr_stack_->next_dummy = ffesymbol_dummyargs (s)); ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */ } else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC) && !ffe_is_pedantic_not_90 () && ((ffesymbol_implementation (s) == FFEINTRIN_impICHAR) || (ffesymbol_implementation (s) == FFEINTRIN_impIACHAR) || (ffesymbol_implementation (s) == FFEINTRIN_impLEN))) { /* Allow arbitrary concatenations. */ return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, sfdef ? FFEEXPR_contextSFUNCDEF : FFEEXPR_contextLET, ffeexpr_token_arguments_); } return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, sfdef ? FFEEXPR_contextSFUNCDEFACTUALARG_ : FFEEXPR_contextACTUALARG_, ffeexpr_token_arguments_); case FFEEXPR_parentypeARRAY_: ffebld_set_info (e->u.operand, ffesymbol_info (ffebld_symter (e->u.operand))); ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); ffeexpr_stack_->bound_list = ffesymbol_dims (s); ffeexpr_stack_->rank = 0; ffeexpr_stack_->constant = TRUE; ffeexpr_stack_->immediate = TRUE; return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, sfdef ? FFEEXPR_contextSFUNCDEFINDEX_ : FFEEXPR_contextINDEX_, ffeexpr_token_elements_); case FFEEXPR_parentypeSUBSTRING_: ffebld_set_info (e->u.operand, ffesymbol_info (ffebld_symter (e->u.operand))); e->u.operand = ffeexpr_collapse_symter (e->u.operand, ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, sfdef ? FFEEXPR_contextSFUNCDEFINDEX_ : FFEEXPR_contextINDEX_, ffeexpr_token_substring_); case FFEEXPR_parentypeFUNSUBSTR_: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, sfdef ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_ : FFEEXPR_contextINDEXORACTUALARG_, ffeexpr_token_funsubstr_); case FFEEXPR_parentypeANY_: ffebld_set_info (e->u.operand, ffesymbol_info (s)); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, sfdef ? FFEEXPR_contextSFUNCDEFACTUALARG_ : FFEEXPR_contextACTUALARG_, ffeexpr_token_anything_); default: assert ("bad paren type" == NULL); break; } case FFELEX_typeEQUALS: /* As in "VAR=". */ switch (ffeexpr_stack_->context) { case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */ case FFEEXPR_contextIMPDOITEMDF_: ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */ ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; break; default: break; } break; #if 0 case FFELEX_typePERIOD: case FFELEX_typePERCENT: ~~Support these two someday, though not required assert ("FOO%, FOO. not yet supported!~~" == NULL); break; #endif default: break; } switch (ffeexpr_stack_->context) { case FFEEXPR_contextINDEXORACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: assert ("strange context" == NULL); break; default: break; } e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE); if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) { e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); } else { e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE, ffesymbol_specific (s), ffesymbol_implementation (s)); if (ffesymbol_specific (s) == FFEINTRIN_specNONE) ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s))); else { /* Decorate the SYMTER with the actual type of the intrinsic. */ ffebld_set_info (e->u.operand, ffeinfo_new (ffeintrin_basictype (ffesymbol_specific (s)), ffeintrin_kindtype (ffesymbol_specific (s)), 0, ffesymbol_kind (s), ffesymbol_where (s), FFETARGET_charactersizeNONE)); } if (ffesymbol_is_doiter (s)) ffebld_symter_set_is_doiter (e->u.operand, TRUE); e->u.operand = ffeexpr_collapse_symter (e->u.operand, ffeexpr_tokens_[0]); } ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Expecting a NAME token, analyze the previous NAME token to see what kind, if any, typeless constant we've got. 01-Sep-90 JCB 1.1 Expect a NAME instead of CHARACTER in this situation. */ static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t) { ffeexprExpr_ e; ffelex_set_hexnum (FALSE); switch (ffelex_token_type (t)) { case FFELEX_typeNAME: ffeexpr_tokens_[2] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_name_apos_name_; default: break; } if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) { ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[1]); e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); e->token = ffeexpr_tokens_[0]; ffeexpr_exprstack_push_operand_ (e); return (ffelexHandler) ffeexpr_token_binary_ (t); } /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Expecting an APOSTROPHE token, analyze the previous NAME token to see what kind, if any, typeless constant we've got. */ static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t) { ffeexprExpr_ e; char c; e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; e->token = ffeexpr_tokens_[0]; if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1])) && (ffelex_token_length (ffeexpr_tokens_[0]) == 1) && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]), 'B', 'b') || ffesrc_char_match_init (c, 'O', 'o') || ffesrc_char_match_init (c, 'X', 'x') || ffesrc_char_match_init (c, 'Z', 'z'))) { ffetargetCharacterSize size; if (!ffe_is_typeless_boz ()) { switch (c) { case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch): e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary (ffeexpr_tokens_[2])); break; case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch): e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal (ffeexpr_tokens_[2])); break; case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch): e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex (ffeexpr_tokens_[2])); break; case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch): e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex (ffeexpr_tokens_[2])); break; default: no_imatch: /* :::::::::::::::::::: */ assert ("not BOXZ!" == NULL); abort (); } ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffeexpr_exprstack_push_operand_ (e); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_; } switch (c) { case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm (ffeexpr_tokens_[2])); size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]); break; case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om (ffeexpr_tokens_[2])); size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]); break; case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm (ffeexpr_tokens_[2])); size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); break; case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm (ffeexpr_tokens_[2])); size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); break; default: no_match: /* :::::::::::::::::::: */ assert ("not BOXZ!" == NULL); e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm (ffeexpr_tokens_[2])); size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); break; } ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); ffeexpr_exprstack_push_operand_ (e); ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); return (ffelexHandler) ffeexpr_token_binary_; } if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) { ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[2]); e->type = FFEEXPR_exprtypeOPERAND_; e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); e->token = ffeexpr_tokens_[0]; ffeexpr_exprstack_push_operand_ (e); switch (ffelex_token_type (t)) { case FFELEX_typeAPOSTROPHE: case FFELEX_typeQUOTE: return (ffelexHandler) ffeexpr_token_binary_; default: return (ffelexHandler) ffeexpr_token_binary_ (t); } } /* ffeexpr_token_percent_ -- Rhs PERCENT Handle a percent sign possibly followed by "LOC". If followed instead by "VAL", "REF", or "DESCR", issue an error message and substitute "LOC". If followed by something else, treat the percent sign as a spurious incorrect token and reprocess the token via _rhs_. */ static ffelexHandler ffeexpr_token_percent_ (ffelexToken t) { switch (ffelex_token_type (t)) { case FFELEX_typeNAME: case FFELEX_typeNAMES: ffeexpr_stack_->percent = ffeexpr_percent_ (t); ffeexpr_tokens_[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_token_percent_name_; default: if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_rhs_ (t); } } /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME Make sure the token is OPEN_PAREN and prepare for the one-item list of LHS expressions. Else display an error message. */ static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t) { ffelexHandler nexthandler; if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) { if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), ffelex_token_where_column (ffeexpr_stack_->first_token)); ffebad_finish (); } ffelex_token_kill (ffeexpr_tokens_[0]); nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]); ffelex_token_kill (ffeexpr_tokens_[1]); return (ffelexHandler) (*nexthandler) (t); } switch (ffeexpr_stack_->percent) { default: if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), ffelex_token_where_column (ffeexpr_tokens_[0])); ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); ffebad_finish (); } ffeexpr_stack_->percent = FFEEXPR_percentLOC_; /* Fall through. */ case FFEEXPR_percentLOC_: ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; ffelex_token_kill (ffeexpr_tokens_[1]); ffeexpr_stack_->tokens[1] = ffelex_token_use (t); return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextLOC_, ffeexpr_cb_end_loc_); } } /* ffeexpr_make_float_const_ -- Make a floating-point constant See prototype. Pass 'E', 'D', or 'Q' for exponent letter. */ static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign, ffelexToken exponent_digits) { ffeexprExpr_ e; e = ffeexpr_expr_new_ (); e->type = FFEEXPR_exprtypeOPERAND_; if (integer != NULL) e->token = ffelex_token_use (integer); else { assert (decimal != NULL); e->token = ffelex_token_use (decimal); } switch (exp_letter) { #if !FFETARGET_okREALQUAD case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED)) { ffebad_here (0, ffelex_token_where_line (e->token), ffelex_token_where_column (e->token)); ffebad_finish (); } goto match_d; /* The FFESRC_CASE_* macros don't allow fall-through! */ #endif case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; #if FFETARGET_okREALQUAD case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; #endif case 'I': /* Make an integer. */ e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault (ffeexpr_tokens_[0])); ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); break; default: no_match: /* :::::::::::::::::::: */ assert ("Lost the exponent letter!" == NULL); } ffeexpr_exprstack_push_operand_ (e); } /* Just like ffesymbol_declare_local, except performs any implicit info assignment necessary. */ static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin) { ffesymbol s; ffeinfoKind k; bool bad; s = ffesymbol_declare_local (t, maybe_intrin); switch (ffeexpr_context_outer_ (ffeexpr_stack_)) /* Special-case these since they can involve a different concept of "state" (in the stmtfunc name space). */ { case FFEEXPR_contextDATAIMPDOINDEX_: case FFEEXPR_contextDATAIMPDOCTRL_: if (ffeexpr_context_outer_ (ffeexpr_stack_) == FFEEXPR_contextDATAIMPDOINDEX_) s = ffeexpr_sym_impdoitem_ (s, t); else if (ffeexpr_stack_->is_rhs) s = ffeexpr_sym_impdoitem_ (s, t); else s = ffeexpr_sym_lhs_impdoctrl_ (s, t); bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY) || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT) && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE)); if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY)) ffesymbol_error (s, t); return s; default: break; } switch ((ffesymbol_sfdummyparent (s) == NULL) ? ffesymbol_state (s) : FFESYMBOL_stateUNDERSTOOD) { case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr context. */ if (!ffest_seen_first_exec ()) goto seen; /* :::::::::::::::::::: */ /* Fall through. */ case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextSUBROUTINEREF: s = ffeexpr_sym_lhs_call_ (s, t); break; case FFEEXPR_contextFILEEXTFUNC: s = ffeexpr_sym_lhs_extfunc_ (s, t); break; case FFEEXPR_contextSFUNCDEFACTUALARG_: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ /* Fall through. */ case FFEEXPR_contextACTUALARG_: s = ffeexpr_sym_rhs_actualarg_ (s, t); break; case FFEEXPR_contextDATA: if (ffeexpr_stack_->is_rhs) s = ffeexpr_sym_rhs_let_ (s, t); else s = ffeexpr_sym_lhs_data_ (s, t); break; case FFEEXPR_contextDATAIMPDOITEM_: s = ffeexpr_sym_lhs_data_ (s, t); break; case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ /* Fall through. */ case FFEEXPR_contextLET: case FFEEXPR_contextPAREN_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextASSIGN: case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextDO: case FFEEXPR_contextDOWHILE: case FFEEXPR_contextAGOTO: case FFEEXPR_contextCGOTO: case FFEEXPR_contextIF: case FFEEXPR_contextARITHIF: case FFEEXPR_contextFORMAT: case FFEEXPR_contextSTOP: case FFEEXPR_contextRETURN: case FFEEXPR_contextSELECTCASE: case FFEEXPR_contextCASE: case FFEEXPR_contextFILEASSOC: case FFEEXPR_contextFILEINT: case FFEEXPR_contextFILEDFINT: case FFEEXPR_contextFILELOG: case FFEEXPR_contextFILENUM: case FFEEXPR_contextFILENUMAMBIG: case FFEEXPR_contextFILECHAR: case FFEEXPR_contextFILENUMCHAR: case FFEEXPR_contextFILEDFCHAR: case FFEEXPR_contextFILEKEY: case FFEEXPR_contextFILEUNIT: case FFEEXPR_contextFILEUNIT_DF: case FFEEXPR_contextFILEUNITAMBIG: case FFEEXPR_contextFILEFORMAT: case FFEEXPR_contextFILENAMELIST: case FFEEXPR_contextFILEVXTCODE: case FFEEXPR_contextINDEX_: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: case FFEEXPR_contextIMPDOCTRL_: case FFEEXPR_contextLOC_: if (ffeexpr_stack_->is_rhs) s = ffeexpr_sym_rhs_let_ (s, t); else s = ffeexpr_sym_lhs_let_ (s, t); break; case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextEQUIVALENCE: case FFEEXPR_contextINCLUDE: case FFEEXPR_contextPARAMETER: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: break; /* Will turn into errors below. */ default: ffesymbol_error (s, t); break; } /* Fall through. */ case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ understood: /* :::::::::::::::::::: */ k = ffesymbol_kind (s); switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextSUBROUTINEREF: bad = ((k != FFEINFO_kindSUBROUTINE) && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) || (k != FFEINFO_kindNONE))); break; case FFEEXPR_contextFILEEXTFUNC: bad = (k != FFEINFO_kindFUNCTION) || (ffesymbol_where (s) != FFEINFO_whereGLOBAL); break; case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextACTUALARG_: switch (k) { case FFEINFO_kindENTITY: bad = FALSE; break; case FFEINFO_kindFUNCTION: case FFEINFO_kindSUBROUTINE: bad = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL) && (ffesymbol_where (s) != FFEINFO_whereDUMMY) && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) || !ffeintrin_is_actualarg (ffesymbol_specific (s)))); break; case FFEINFO_kindNONE: if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) { bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s))); break; } /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY, and in the former case, attrsTYPE is set, so we see this as an error as we should, since CHAR*(*) cannot be actually referenced in a main/block data program unit. */ if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE)) == FFESYMBOL_attrsEXTERNAL) bad = FALSE; else bad = TRUE; break; default: bad = TRUE; break; } break; case FFEEXPR_contextDATA: if (ffeexpr_stack_->is_rhs) bad = (k != FFEINFO_kindENTITY) || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); else bad = (k != FFEINFO_kindENTITY) || ((ffesymbol_where (s) != FFEINFO_whereNONE) && (ffesymbol_where (s) != FFEINFO_whereLOCAL) && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); break; case FFEEXPR_contextDATAIMPDOITEM_: bad = TRUE; /* Unadorned item never valid. */ break; case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: case FFEEXPR_contextLET: case FFEEXPR_contextPAREN_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextASSIGN: case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextDO: case FFEEXPR_contextDOWHILE: case FFEEXPR_contextAGOTO: case FFEEXPR_contextCGOTO: case FFEEXPR_contextIF: case FFEEXPR_contextARITHIF: case FFEEXPR_contextFORMAT: case FFEEXPR_contextSTOP: case FFEEXPR_contextRETURN: case FFEEXPR_contextSELECTCASE: case FFEEXPR_contextCASE: case FFEEXPR_contextFILEASSOC: case FFEEXPR_contextFILEINT: case FFEEXPR_contextFILEDFINT: case FFEEXPR_contextFILELOG: case FFEEXPR_contextFILENUM: case FFEEXPR_contextFILENUMAMBIG: case FFEEXPR_contextFILECHAR: case FFEEXPR_contextFILENUMCHAR: case FFEEXPR_contextFILEDFCHAR: case FFEEXPR_contextFILEKEY: case FFEEXPR_contextFILEUNIT: case FFEEXPR_contextFILEUNIT_DF: case FFEEXPR_contextFILEUNITAMBIG: case FFEEXPR_contextFILEFORMAT: case FFEEXPR_contextFILENAMELIST: case FFEEXPR_contextFILEVXTCODE: case FFEEXPR_contextINDEX_: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: case FFEEXPR_contextIMPDOCTRL_: case FFEEXPR_contextLOC_: bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE X(A);EXTERNAL A;CALL Y(A);B=A", for example. */ break; case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextEQUIVALENCE: case FFEEXPR_contextPARAMETER: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: bad = (k != FFEINFO_kindENTITY) || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); break; case FFEEXPR_contextINCLUDE: bad = TRUE; break; default: bad = TRUE; break; } if (bad && (k != FFEINFO_kindANY)) ffesymbol_error (s, t); return s; case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ seen: /* :::::::::::::::::::: */ switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextPARAMETER: if (ffeexpr_stack_->is_rhs) ffesymbol_error (s, t); else s = ffeexpr_sym_lhs_parameter_ (s, t); break; case FFEEXPR_contextDATA: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ if (ffeexpr_stack_->is_rhs) ffesymbol_error (s, t); else s = ffeexpr_sym_lhs_data_ (s, t); goto understood; /* :::::::::::::::::::: */ case FFEEXPR_contextDATAIMPDOITEM_: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ s = ffeexpr_sym_lhs_data_ (s, t); goto understood; /* :::::::::::::::::::: */ case FFEEXPR_contextEQUIVALENCE: s = ffeexpr_sym_lhs_equivalence_ (s, t); break; case FFEEXPR_contextDIMLIST: s = ffeexpr_sym_rhs_dimlist_ (s, t); break; case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: ffesymbol_error (s, t); break; case FFEEXPR_contextINCLUDE: ffesymbol_error (s, t); break; case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */ case FFEEXPR_contextSFUNCDEFACTUALARG_: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ s = ffeexpr_sym_rhs_actualarg_ (s, t); goto understood; /* :::::::::::::::::::: */ case FFEEXPR_contextINDEX_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: assert (ffeexpr_stack_->is_rhs); s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ s = ffeexpr_sym_rhs_let_ (s, t); goto understood; /* :::::::::::::::::::: */ default: ffesymbol_error (s, t); break; } return s; default: assert ("bad symbol state" == NULL); return NULL; break; } } /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH). Could be found via the "statement-function" name space (in which case it should become an iterator) or the local name space (in which case it should be either a named constant, or a variable that will have an sfunc name space sibling that should become an iterator). */ static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t) { ffesymbol s; ffesymbolAttrs sa; ffesymbolAttrs na; ffesymbolState ss; ffesymbolState ns; ffeinfoKind kind; ffeinfoWhere where; ss = ffesymbol_state (sp); if (ffesymbol_sfdummyparent (sp) != NULL) { /* Have symbol in sfunc name space. */ switch (ss) { case FFESYMBOL_stateNONE: /* Used as iterator already. */ if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) ffesymbol_error (sp, t); /* Can't use dead iterator. */ else { /* Can use dead iterator because we're at at least an innermore (higher-numbered) level than the iterator's outermost (lowest-numbered) level. */ ffesymbol_signal_change (sp); ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); ffesymbol_set_maxentrynum (sp, ffeexpr_level_); ffesymbol_signal_unreported (sp); } break; case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. Set symbol level number to outermost value, as that tells us we can see it as iterator at that level at the innermost. */ if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) { ffesymbol_signal_change (sp); ffesymbol_set_maxentrynum (sp, ffeexpr_level_); ffesymbol_signal_unreported (sp); } break; case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp)); ffesymbol_error (sp, t); /* (,,,I=I,10). */ break; case FFESYMBOL_stateUNDERSTOOD: break; /* ANY. */ default: assert ("Foo Bar!!" == NULL); break; } return sp; } /* Got symbol in local name space, so we haven't seen it in impdo yet. First, if it is brand-new and we're in executable statements, set the attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD. Second, if it is now a constant (PARAMETER), then just return it, it can't be an implied-do iterator. If it is understood, complain if it is not a valid variable, but make the inner name space iterator anyway and return that. If it is not understood, improve understanding of the symbol accordingly, complain accordingly, in either case make the inner name space iterator and return that. */ sa = ffesymbol_attrs (sp); if (ffesymbol_state_is_specable (ss) && ffest_seen_first_exec ()) { assert (sa == FFESYMBOL_attrsetNONE); ffesymbol_signal_change (sp); ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); ffesymbol_resolve_intrin (sp); if (ffeimplic_establish_symbol (sp)) ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG); else ffesymbol_error (sp, t); /* After the exec transition, the state will either be UNCERTAIN (could be a dummy or local var) or UNDERSTOOD (local var, because this is a PROGRAM/BLOCKDATA program unit). */ sp = ffecom_sym_exec_transition (sp); sa = ffesymbol_attrs (sp); ss = ffesymbol_state (sp); } ns = ss; kind = ffesymbol_kind (sp); where = ffesymbol_where (sp); if (ss == FFESYMBOL_stateUNDERSTOOD) { if (kind != FFEINFO_kindENTITY) ffesymbol_error (sp, t); if (where == FFEINFO_whereCONSTANT) return sp; } else { /* Enhance understanding of local symbol. This used to imply exec transition, but that doesn't seem necessary, since the local symbol doesn't actually get put into an ffebld tree here -- we just learn more about it, just like when we see a local symbol's name in the dummy-arg list of a statement function. */ if (ss != FFESYMBOL_stateUNCERTAIN) { /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ ns = FFESYMBOL_stateSEEN; if (sa & FFESYMBOL_attrsANY) na = sa; else if (!(sa & ~(FFESYMBOL_attrsADJUSTS | FFESYMBOL_attrsANY | FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEQUIV | FFESYMBOL_attrsINIT | FFESYMBOL_attrsNAMELIST | FFESYMBOL_attrsRESULT | FFESYMBOL_attrsSAVE | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))) na = sa | FFESYMBOL_attrsSFARG; else na = FFESYMBOL_attrsetNONE; } else { /* stateUNCERTAIN. */ na = sa | FFESYMBOL_attrsSFARG; ns = FFESYMBOL_stateUNDERSTOOD; assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); na = FFESYMBOL_attrsetNONE; } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); kind = FFEINFO_kindENTITY; } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); na = FFESYMBOL_attrsetNONE; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); ns = FFESYMBOL_stateUNCERTAIN; } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); kind = FFEINFO_kindENTITY; if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) na = FFESYMBOL_attrsetNONE; else if (ffest_is_entry_valid ()) ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */ else where = FFEINFO_whereLOCAL; } else na = FFESYMBOL_attrsetNONE; /* Error. */ } /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (na == FFESYMBOL_attrsetNONE) ffesymbol_error (sp, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (sp); /* May need to back up to previous version. */ if (!ffeimplic_establish_symbol (sp)) ffesymbol_error (sp, t); else { ffesymbol_set_info (sp, ffeinfo_new (ffesymbol_basictype (sp), ffesymbol_kindtype (sp), ffesymbol_rank (sp), kind, where, ffesymbol_size (sp))); ffesymbol_set_attrs (sp, na); ffesymbol_set_state (sp, ns); ffesymbol_resolve_intrin (sp); if (!ffesymbol_state_is_specable (ns)) sp = ffecom_sym_learned (sp); ffesymbol_signal_unreported (sp); /* For debugging purposes. */ } } } /* Here we create the sfunc-name-space symbol representing what should become an iterator in this name space at this or an outermore (lower- numbered) expression level, else the implied-DO construct is in error. */ s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj; also sets sfa_dummy_parent to parent symbol. */ assert (sp == ffesymbol_sfdummyparent (s)); ffesymbol_signal_change (s); ffesymbol_set_state (s, FFESYMBOL_stateSEEN); ffesymbol_set_maxentrynum (s, ffeexpr_level_); ffesymbol_set_info (s, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereIMMEDIATE, FFETARGET_charactersizeNONE)); ffesymbol_signal_unreported (s); if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER) && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY)) || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT) && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY))) ffesymbol_error (s, t); return s; } /* Have FOO in CALL FOO. Local name space, executable context only. */ static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; ffeintrinGen gen; ffeintrinSpec spec; ffeintrinImp imp; bool error = FALSE; assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); na = sa = ffesymbol_attrs (s); assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); kind = ffesymbol_kind (s); where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsTYPE) error = TRUE; else /* Not TYPE. */ { kind = FFEINFO_kindSUBROUTINE; if (sa & FFESYMBOL_attrsDUMMY) ; /* Not TYPE. */ else if (sa & FFESYMBOL_attrsACTUALARG) ; /* Not DUMMY or TYPE. */ else /* Not ACTUALARG, DUMMY, or TYPE. */ where = FFEINFO_whereGLOBAL; } } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsTYPE) error = TRUE; else kind = FFEINFO_kindSUBROUTINE; } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); error = TRUE; } else if (sa == FFESYMBOL_attrsetNONE) { assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, &gen, &spec, &imp)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ ffesymbol_set_generic (s, gen); ffesymbol_set_specific (s, spec); ffesymbol_set_implementation (s, imp); ffesymbol_set_info (s, ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindSUBROUTINE, FFEINFO_whereINTRINSIC, FFETARGET_charactersizeNONE)); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); ffesymbol_reference (s, t, FALSE); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ return s; } kind = FFEINFO_kindSUBROUTINE; where = FFEINFO_whereGLOBAL; } else error = TRUE; /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (error) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, /* SUBROUTINE. */ where, /* GLOBAL or DUMMY. */ ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); ffesymbol_reference (s, t, FALSE); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in DATA FOO/.../. Local name space and executable context only. (This will change in the future when DATA FOO may be followed by COMMON FOO or even INTEGER FOO(10), etc.) */ static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; bool error = FALSE; assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); na = sa = ffesymbol_attrs (s); assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); kind = ffesymbol_kind (s); where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsADJUSTABLE) error = TRUE; where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) error = TRUE; else { kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; } } else if (sa == FFESYMBOL_attrsetNONE) { assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; } else error = TRUE; /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (error) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (!ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, /* ENTITY. */ where, /* LOCAL. */ ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include EQUIVALENCE (...,BAR(FOO),...). */ static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; na = sa = ffesymbol_attrs (s); kind = FFEINFO_kindENTITY; where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (!(sa & ~(FFESYMBOL_attrsADJUSTS | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsEQUIV | FFESYMBOL_attrsINIT | FFESYMBOL_attrsNAMELIST | FFESYMBOL_attrsSAVE | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))) na = sa | FFESYMBOL_attrsEQUIV; else na = FFESYMBOL_attrsetNONE; /* Don't know why we're bothering to set kind and where in this code, but added the following to make it complete, in case it's really important. Generally this is left up to symbol exec transition. */ if (where == FFEINFO_whereNONE) { if (na & (FFESYMBOL_attrsADJUSTS | FFESYMBOL_attrsCOMMON)) where = FFEINFO_whereCOMMON; else if (na & FFESYMBOL_attrsSAVE) where = FFEINFO_whereLOCAL; } /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (na == FFESYMBOL_attrsetNONE) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, /* Always ENTITY. */ where, /* NONE, COMMON, or LOCAL. */ ffesymbol_size (s))); ffesymbol_set_attrs (s, na); ffesymbol_set_state (s, FFESYMBOL_stateSEEN); ffesymbol_resolve_intrin (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only. Note that I think this should be considered semantically similar to doing CALL XYZ(FOO), in that it should be considered like an ACTUALARG context. In particular, without EXTERNAL being specified, it should not be allowed. */ static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; bool needs_type = FALSE; bool error = FALSE; assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); na = sa = ffesymbol_attrs (s); assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); kind = ffesymbol_kind (s); where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsTYPE) where = FFEINFO_whereGLOBAL; else /* Not TYPE. */ { kind = FFEINFO_kindFUNCTION; needs_type = TRUE; if (sa & FFESYMBOL_attrsDUMMY) ; /* Not TYPE. */ else if (sa & FFESYMBOL_attrsACTUALARG) ; /* Not DUMMY or TYPE. */ else /* Not ACTUALARG, DUMMY, or TYPE. */ where = FFEINFO_whereGLOBAL; } } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); kind = FFEINFO_kindFUNCTION; if (!(sa & FFESYMBOL_attrsTYPE)) needs_type = TRUE; } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) error = TRUE; else { kind = FFEINFO_kindFUNCTION; where = FFEINFO_whereGLOBAL; } } else if (sa == FFESYMBOL_attrsetNONE) { assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); kind = FFEINFO_kindFUNCTION; where = FFEINFO_whereGLOBAL; needs_type = TRUE; } else error = TRUE; /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (error) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (needs_type && !ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } if (!ffesymbol_explicitwhere (s)) { ffebad_start (FFEBAD_NEED_EXTERNAL); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_string (ffesymbol_text (s)); ffebad_finish (); ffesymbol_set_explicitwhere (s, TRUE); } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, /* FUNCTION. */ where, /* GLOBAL or DUMMY. */ ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); ffesymbol_reference (s, t, FALSE); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in DATA (stuff,FOO=1,10)/.../. */ static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t) { ffesymbolState ss; /* If the symbol isn't in the sfunc name space, pretend as though we saw a reference to it already within the imp-DO construct at this level, so as to get a symbol that is in the sfunc name space. But this is an erroneous construct, and should be caught elsewhere. */ if (ffesymbol_sfdummyparent (s) == NULL) { s = ffeexpr_sym_impdoitem_ (s, t); if (ffesymbol_sfdummyparent (s) == NULL) { /* PARAMETER FOO...DATA (A(I),FOO=...). */ ffesymbol_error (s, t); return s; } } ss = ffesymbol_state (s); switch (ss) { case FFESYMBOL_stateNONE: /* Used as iterator already. */ if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows this; F77 allows it but it is a stupid feature. */ else { /* Can use dead iterator because we're at at least a innermore (higher-numbered) level than the iterator's outermost (lowest-numbered) level. This should be diagnosed later, because it means an item in this list didn't reference this iterator. */ #if 1 ffesymbol_error (s, t); /* For now, complain. */ #else /* Someday will detect all cases where initializer doesn't reference all applicable iterators, in which case reenable this code. */ ffesymbol_signal_change (s); ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN); ffesymbol_set_maxentrynum (s, ffeexpr_level_); ffesymbol_signal_unreported (s); #endif } break; case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. If seen in outermore level, can't be an iterator here, so complain. If not seen at current level, complain for now, because that indicates something F90 rejects (though we currently don't detect all such cases for now). */ if (ffeexpr_level_ <= ffesymbol_maxentrynum (s)) { ffesymbol_signal_change (s); ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN); ffesymbol_signal_unreported (s); } else ffesymbol_error (s, t); break; case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */ assert ("DATA implied-DO control var seen twice!!" == NULL); ffesymbol_error (s, t); break; case FFESYMBOL_stateUNDERSTOOD: break; /* ANY. */ default: assert ("Foo Bletch!!" == NULL); break; } return s; } /* Have FOO in PARAMETER (FOO=...). */ static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; sa = ffesymbol_attrs (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (sa & ~(FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsTYPE)) { if (!(sa & FFESYMBOL_attrsANY)) ffesymbol_error (s, t); } else { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (!ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */ static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; ffesymbolState ns; bool needs_type = FALSE; assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); na = sa = ffesymbol_attrs (s); assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); kind = ffesymbol_kind (s); where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ ns = FFESYMBOL_stateUNDERSTOOD; if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsTYPE) where = FFEINFO_whereGLOBAL; else /* Not TYPE. */ { ns = FFESYMBOL_stateUNCERTAIN; if (sa & FFESYMBOL_attrsDUMMY) assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */ else if (sa & FFESYMBOL_attrsACTUALARG) ; /* Not DUMMY or TYPE. */ else /* Not ACTUALARG, DUMMY, or TYPE. */ { assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */ na |= FFESYMBOL_attrsACTUALARG; where = FFEINFO_whereGLOBAL; } } } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); kind = FFEINFO_kindENTITY; if (!(sa & FFESYMBOL_attrsTYPE)) needs_type = TRUE; } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); if (sa & FFESYMBOL_attrsANYLEN) ns = FFESYMBOL_stateNONE; else { kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; } } else if (sa == FFESYMBOL_attrsetNONE) { /* New state is left empty because there isn't any state flag to set for this case, and it's UNDERSTOOD after all. */ assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; needs_type = TRUE; } else ns = FFESYMBOL_stateNONE; /* Error. */ /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (ns == FFESYMBOL_stateNONE) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (needs_type && !ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, where, ffesymbol_size (s))); ffesymbol_set_attrs (s, na); ffesymbol_set_state (s, ns); s = ffecom_sym_learned (s); ffesymbol_reference (s, t, FALSE); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing a reference to FOO. */ static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; na = sa = ffesymbol_attrs (s); kind = FFEINFO_kindENTITY; where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (!(sa & ~(FFESYMBOL_attrsADJUSTS | FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEQUIV | FFESYMBOL_attrsINIT | FFESYMBOL_attrsNAMELIST | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))) na = sa | FFESYMBOL_attrsADJUSTS; else na = FFESYMBOL_attrsetNONE; /* Since this symbol definitely is going into an expression (the dimension-list for some dummy array, presumably), figure out WHERE if possible. */ if (where == FFEINFO_whereNONE) { if (na & (FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsEQUIV | FFESYMBOL_attrsINIT | FFESYMBOL_attrsNAMELIST)) where = FFEINFO_whereCOMMON; else if (na & FFESYMBOL_attrsDUMMY) where = FFEINFO_whereDUMMY; } /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (na == FFESYMBOL_attrsetNONE) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (!ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, /* Always ENTITY. */ where, /* NONE, COMMON, or DUMMY. */ ffesymbol_size (s))); ffesymbol_set_attrs (s, na); ffesymbol_set_state (s, FFESYMBOL_stateSEEN); ffesymbol_resolve_intrin (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in XYZ = BAR(FOO), as such cases are handled elsewhere. */ static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; bool error = FALSE; assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); na = sa = ffesymbol_attrs (s); assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); kind = ffesymbol_kind (s); where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); error = TRUE; } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); kind = FFEINFO_kindENTITY; } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); if (sa & FFESYMBOL_attrsANYLEN) error = TRUE; else { kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; } } else if (sa == FFESYMBOL_attrsetNONE) { assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; } else error = TRUE; /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (error) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (!ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, /* ENTITY. */ where, /* LOCAL. */ ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand ffelexToken t; bool maybe_intrin; ffeexprParenType_ paren_type; ffesymbol s; s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type); Just like ffesymbol_declare_local, except performs any implicit info assignment necessary, and it returns the type of the parenthesized list (list of function args, list of array args, or substring spec). */ static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin, ffeexprParenType_ *paren_type) { ffesymbol s; ffesymbolState st; /* Effective state. */ ffeinfoKind k; bool bad; if (maybe_intrin && ffesrc_check_symbol ()) { /* Knock off some easy cases. */ switch (ffeexpr_stack_->context) { case FFEEXPR_contextSUBROUTINEREF: case FFEEXPR_contextDATA: case FFEEXPR_contextDATAIMPDOINDEX_: case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: case FFEEXPR_contextLET: case FFEEXPR_contextPAREN_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextDO: case FFEEXPR_contextDOWHILE: case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextCGOTO: case FFEEXPR_contextIF: case FFEEXPR_contextARITHIF: case FFEEXPR_contextFORMAT: case FFEEXPR_contextSTOP: case FFEEXPR_contextRETURN: case FFEEXPR_contextSELECTCASE: case FFEEXPR_contextCASE: case FFEEXPR_contextFILEASSOC: case FFEEXPR_contextFILEINT: case FFEEXPR_contextFILEDFINT: case FFEEXPR_contextFILELOG: case FFEEXPR_contextFILENUM: case FFEEXPR_contextFILENUMAMBIG: case FFEEXPR_contextFILECHAR: case FFEEXPR_contextFILENUMCHAR: case FFEEXPR_contextFILEDFCHAR: case FFEEXPR_contextFILEKEY: case FFEEXPR_contextFILEUNIT: case FFEEXPR_contextFILEUNIT_DF: case FFEEXPR_contextFILEUNITAMBIG: case FFEEXPR_contextFILEFORMAT: case FFEEXPR_contextFILENAMELIST: case FFEEXPR_contextFILEVXTCODE: case FFEEXPR_contextINDEX_: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: case FFEEXPR_contextIMPDOCTRL_: case FFEEXPR_contextDATAIMPDOCTRL_: case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextPARAMETER: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: break; /* These could be intrinsic invocations. */ case FFEEXPR_contextAGOTO: case FFEEXPR_contextFILEFORMATNML: case FFEEXPR_contextALLOCATE: case FFEEXPR_contextDEALLOCATE: case FFEEXPR_contextHEAPSTAT: case FFEEXPR_contextNULLIFY: case FFEEXPR_contextINCLUDE: case FFEEXPR_contextDATAIMPDOITEM_: case FFEEXPR_contextLOC_: case FFEEXPR_contextINDEXORACTUALARG_: case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: case FFEEXPR_contextPARENFILENUM_: case FFEEXPR_contextPARENFILEUNIT_: maybe_intrin = FALSE; break; /* Can't be intrinsic invocation. */ default: assert ("blah! blah! waaauuggh!" == NULL); break; } } s = ffesymbol_declare_local (t, maybe_intrin); switch (ffeexpr_context_outer_ (ffeexpr_stack_)) /* Special-case these since they can involve a different concept of "state" (in the stmtfunc name space). */ { case FFEEXPR_contextDATAIMPDOINDEX_: case FFEEXPR_contextDATAIMPDOCTRL_: if (ffeexpr_context_outer_ (ffeexpr_stack_) == FFEEXPR_contextDATAIMPDOINDEX_) s = ffeexpr_sym_impdoitem_ (s, t); else if (ffeexpr_stack_->is_rhs) s = ffeexpr_sym_impdoitem_ (s, t); else s = ffeexpr_sym_lhs_impdoctrl_ (s, t); if (ffesymbol_kind (s) != FFEINFO_kindANY) ffesymbol_error (s, t); return s; default: break; } switch ((ffesymbol_sfdummyparent (s) == NULL) ? ffesymbol_state (s) : FFESYMBOL_stateUNDERSTOOD) { case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr context. */ if (!ffest_seen_first_exec ()) goto seen; /* :::::::::::::::::::: */ /* Fall through. */ case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextSUBROUTINEREF: s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL FOO(...)". */ break; case FFEEXPR_contextDATA: if (ffeexpr_stack_->is_rhs) s = ffeexpr_sym_rhs_let_ (s, t); else s = ffeexpr_sym_lhs_data_ (s, t); break; case FFEEXPR_contextDATAIMPDOITEM_: s = ffeexpr_sym_lhs_data_ (s, t); break; case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ /* Fall through. */ case FFEEXPR_contextLET: case FFEEXPR_contextPAREN_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextDO: case FFEEXPR_contextDOWHILE: case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextCGOTO: case FFEEXPR_contextIF: case FFEEXPR_contextARITHIF: case FFEEXPR_contextFORMAT: case FFEEXPR_contextSTOP: case FFEEXPR_contextRETURN: case FFEEXPR_contextSELECTCASE: case FFEEXPR_contextCASE: case FFEEXPR_contextFILEASSOC: case FFEEXPR_contextFILEINT: case FFEEXPR_contextFILEDFINT: case FFEEXPR_contextFILELOG: case FFEEXPR_contextFILENUM: case FFEEXPR_contextFILENUMAMBIG: case FFEEXPR_contextFILECHAR: case FFEEXPR_contextFILENUMCHAR: case FFEEXPR_contextFILEDFCHAR: case FFEEXPR_contextFILEKEY: case FFEEXPR_contextFILEUNIT: case FFEEXPR_contextFILEUNIT_DF: case FFEEXPR_contextFILEUNITAMBIG: case FFEEXPR_contextFILEFORMAT: case FFEEXPR_contextFILENAMELIST: case FFEEXPR_contextFILEVXTCODE: case FFEEXPR_contextINDEX_: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: case FFEEXPR_contextIMPDOCTRL_: case FFEEXPR_contextLOC_: if (ffeexpr_stack_->is_rhs) s = ffeexpr_paren_rhs_let_ (s, t); else s = ffeexpr_paren_lhs_let_ (s, t); break; case FFEEXPR_contextASSIGN: case FFEEXPR_contextAGOTO: case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextEQUIVALENCE: case FFEEXPR_contextINCLUDE: case FFEEXPR_contextPARAMETER: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: break; /* Will turn into errors below. */ default: ffesymbol_error (s, t); break; } /* Fall through. */ case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ understood: /* :::::::::::::::::::: */ /* State might have changed, update it. */ st = ((ffesymbol_sfdummyparent (s) == NULL) ? ffesymbol_state (s) : FFESYMBOL_stateUNDERSTOOD); k = ffesymbol_kind (s); switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextSUBROUTINEREF: bad = ((k != FFEINFO_kindSUBROUTINE) && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) || (k != FFEINFO_kindNONE))); break; case FFEEXPR_contextDATA: if (ffeexpr_stack_->is_rhs) bad = (k != FFEINFO_kindENTITY) || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); else bad = (k != FFEINFO_kindENTITY) || ((ffesymbol_where (s) != FFEINFO_whereNONE) && (ffesymbol_where (s) != FFEINFO_whereLOCAL) && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); break; case FFEEXPR_contextDATAIMPDOITEM_: bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0) || ((ffesymbol_where (s) != FFEINFO_whereNONE) && (ffesymbol_where (s) != FFEINFO_whereLOCAL) && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); break; case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: case FFEEXPR_contextLET: case FFEEXPR_contextPAREN_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextIOLIST: case FFEEXPR_contextIOLISTDF: case FFEEXPR_contextDO: case FFEEXPR_contextDOWHILE: case FFEEXPR_contextACTUALARG_: case FFEEXPR_contextCGOTO: case FFEEXPR_contextIF: case FFEEXPR_contextARITHIF: case FFEEXPR_contextFORMAT: case FFEEXPR_contextSTOP: case FFEEXPR_contextRETURN: case FFEEXPR_contextSELECTCASE: case FFEEXPR_contextCASE: case FFEEXPR_contextFILEASSOC: case FFEEXPR_contextFILEINT: case FFEEXPR_contextFILEDFINT: case FFEEXPR_contextFILELOG: case FFEEXPR_contextFILENUM: case FFEEXPR_contextFILENUMAMBIG: case FFEEXPR_contextFILECHAR: case FFEEXPR_contextFILENUMCHAR: case FFEEXPR_contextFILEDFCHAR: case FFEEXPR_contextFILEKEY: case FFEEXPR_contextFILEUNIT: case FFEEXPR_contextFILEUNIT_DF: case FFEEXPR_contextFILEUNITAMBIG: case FFEEXPR_contextFILEFORMAT: case FFEEXPR_contextFILENAMELIST: case FFEEXPR_contextFILEVXTCODE: case FFEEXPR_contextINDEX_: case FFEEXPR_contextIMPDOITEM_: case FFEEXPR_contextIMPDOITEMDF_: case FFEEXPR_contextIMPDOCTRL_: case FFEEXPR_contextLOC_: bad = FALSE; /* Let paren-switch handle the cases. */ break; case FFEEXPR_contextASSIGN: case FFEEXPR_contextAGOTO: case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextEQUIVALENCE: case FFEEXPR_contextPARAMETER: case FFEEXPR_contextDIMLIST: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: bad = (k != FFEINFO_kindENTITY) || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); break; case FFEEXPR_contextINCLUDE: bad = TRUE; break; default: bad = TRUE; break; } switch (bad ? FFEINFO_kindANY : k) { case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) { if (ffeexpr_context_outer_ (ffeexpr_stack_) == FFEEXPR_contextSUBROUTINEREF) *paren_type = FFEEXPR_parentypeSUBROUTINE_; else *paren_type = FFEEXPR_parentypeFUNCTION_; break; } if (st == FFESYMBOL_stateUNDERSTOOD) { bad = TRUE; *paren_type = FFEEXPR_parentypeANY_; } else *paren_type = FFEEXPR_parentypeFUNSUBSTR_; break; case FFEINFO_kindFUNCTION: *paren_type = FFEEXPR_parentypeFUNCTION_; switch (ffesymbol_where (s)) { case FFEINFO_whereLOCAL: bad = TRUE; /* Attempt to recurse! */ break; case FFEINFO_whereCONSTANT: bad = ((ffesymbol_sfexpr (s) == NULL) || (ffebld_op (ffesymbol_sfexpr (s)) == FFEBLD_opANY)); /* Attempt to recurse! */ break; default: break; } break; case FFEINFO_kindSUBROUTINE: if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) || (ffeexpr_stack_->previous != NULL)) { bad = TRUE; *paren_type = FFEEXPR_parentypeANY_; break; } *paren_type = FFEEXPR_parentypeSUBROUTINE_; switch (ffesymbol_where (s)) { case FFEINFO_whereLOCAL: case FFEINFO_whereCONSTANT: bad = TRUE; /* Attempt to recurse! */ break; default: break; } break; case FFEINFO_kindENTITY: if (ffesymbol_rank (s) == 0) { if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) *paren_type = FFEEXPR_parentypeSUBSTRING_; else { bad = TRUE; *paren_type = FFEEXPR_parentypeANY_; } } else *paren_type = FFEEXPR_parentypeARRAY_; break; default: case FFEINFO_kindANY: bad = TRUE; *paren_type = FFEEXPR_parentypeANY_; break; } if (bad) { if (k == FFEINFO_kindANY) ffest_shutdown (); else ffesymbol_error (s, t); } return s; case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ seen: /* :::::::::::::::::::: */ bad = TRUE; switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextPARAMETER: if (ffeexpr_stack_->is_rhs) ffesymbol_error (s, t); else s = ffeexpr_sym_lhs_parameter_ (s, t); break; case FFEEXPR_contextDATA: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ if (ffeexpr_stack_->is_rhs) ffesymbol_error (s, t); else s = ffeexpr_sym_lhs_data_ (s, t); goto understood; /* :::::::::::::::::::: */ case FFEEXPR_contextDATAIMPDOITEM_: s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ s = ffeexpr_sym_lhs_data_ (s, t); goto understood; /* :::::::::::::::::::: */ case FFEEXPR_contextEQUIVALENCE: s = ffeexpr_sym_lhs_equivalence_ (s, t); bad = FALSE; break; case FFEEXPR_contextDIMLIST: s = ffeexpr_sym_rhs_dimlist_ (s, t); break; case FFEEXPR_contextCHARACTERSIZE: case FFEEXPR_contextKINDTYPE: case FFEEXPR_contextDIMLISTCOMMON: case FFEEXPR_contextINITVAL: case FFEEXPR_contextEQVINDEX_: break; case FFEEXPR_contextINCLUDE: break; case FFEEXPR_contextINDEX_: case FFEEXPR_contextACTUALARGEXPR_: case FFEEXPR_contextINDEXORACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: assert (ffeexpr_stack_->is_rhs); s = ffecom_sym_exec_transition (s); if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) goto understood; /* :::::::::::::::::::: */ s = ffeexpr_paren_rhs_let_ (s, t); goto understood; /* :::::::::::::::::::: */ default: break; } k = ffesymbol_kind (s); switch (bad ? FFEINFO_kindANY : k) { case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ *paren_type = FFEEXPR_parentypeFUNSUBSTR_; break; case FFEINFO_kindFUNCTION: *paren_type = FFEEXPR_parentypeFUNCTION_; switch (ffesymbol_where (s)) { case FFEINFO_whereLOCAL: bad = TRUE; /* Attempt to recurse! */ break; case FFEINFO_whereCONSTANT: bad = ((ffesymbol_sfexpr (s) == NULL) || (ffebld_op (ffesymbol_sfexpr (s)) == FFEBLD_opANY)); /* Attempt to recurse! */ break; default: break; } break; case FFEINFO_kindSUBROUTINE: *paren_type = FFEEXPR_parentypeANY_; bad = TRUE; /* Cannot possibly be in contextSUBROUTINEREF. */ break; case FFEINFO_kindENTITY: if (ffesymbol_rank (s) == 0) { if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE) *paren_type = FFEEXPR_parentypeEQUIVALENCE_; else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) *paren_type = FFEEXPR_parentypeSUBSTRING_; else { bad = TRUE; *paren_type = FFEEXPR_parentypeANY_; } } else *paren_type = FFEEXPR_parentypeARRAY_; break; default: case FFEINFO_kindANY: bad = TRUE; *paren_type = FFEEXPR_parentypeANY_; break; } if (bad) { if (k == FFEINFO_kindANY) ffest_shutdown (); else ffesymbol_error (s, t); } return s; default: assert ("bad symbol state" == NULL); return NULL; } } /* Have FOO in XYZ = ...FOO(...).... Executable context only. */ static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t) { ffesymbolAttrs sa; ffesymbolAttrs na; ffeinfoKind kind; ffeinfoWhere where; ffeintrinGen gen; ffeintrinSpec spec; ffeintrinImp imp; bool maybe_ambig = FALSE; bool error = FALSE; assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); na = sa = ffesymbol_attrs (s); assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); kind = ffesymbol_kind (s); where = ffesymbol_where (s); /* Figure out what kind of object we've got based on previous declarations of or references to the object. */ if (sa & FFESYMBOL_attrsEXTERNAL) { assert (!(sa & ~(FFESYMBOL_attrsACTUALARG | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); if (sa & FFESYMBOL_attrsTYPE) where = FFEINFO_whereGLOBAL; else /* Not TYPE. */ { kind = FFEINFO_kindFUNCTION; if (sa & FFESYMBOL_attrsDUMMY) ; /* Not TYPE. */ else if (sa & FFESYMBOL_attrsACTUALARG) ; /* Not DUMMY or TYPE. */ else /* Not ACTUALARG, DUMMY, or TYPE. */ where = FFEINFO_whereGLOBAL; } } else if (sa & FFESYMBOL_attrsDUMMY) { assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsTYPE))); kind = FFEINFO_kindFUNCTION; maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind could be ENTITY w/substring ref. */ } else if (sa & FFESYMBOL_attrsARRAY) { assert (!(sa & ~(FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; } else if (sa & FFESYMBOL_attrsSFARG) { assert (!(sa & ~(FFESYMBOL_attrsSFARG | FFESYMBOL_attrsTYPE))); where = FFEINFO_whereLOCAL; /* Actually an error, but at least we know it's a local var. */ } else if (sa & FFESYMBOL_attrsTYPE) { assert (!(sa & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); /* Handled above. */ assert (!(sa & ~(FFESYMBOL_attrsTYPE | FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY | FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsEXTERNAL | FFESYMBOL_attrsSFARG))); if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, &gen, &spec, &imp)) { if (!(sa & FFESYMBOL_attrsANYLEN) && (ffeimplic_peek_symbol_type (s, NULL) == FFEINFO_basictypeCHARACTER)) return s; /* Haven't learned anything yet. */ ffesymbol_signal_change (s); /* May need to back up to previous version. */ ffesymbol_set_generic (s, gen); ffesymbol_set_specific (s, spec); ffesymbol_set_implementation (s, imp); ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), 0, FFEINFO_kindFUNCTION, FFEINFO_whereINTRINSIC, ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); ffesymbol_reference (s, t, FALSE); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ return s; } if (sa & FFESYMBOL_attrsANYLEN) error = TRUE; /* Error, since the only way we can, given CHARACTER*(*) FOO, accept FOO(...) is for FOO to be a dummy arg or constant, but it can't become either now. */ else if (sa & FFESYMBOL_attrsADJUSTABLE) { kind = FFEINFO_kindENTITY; where = FFEINFO_whereLOCAL; } else { kind = FFEINFO_kindFUNCTION; where = FFEINFO_whereGLOBAL; maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; could be ENTITY/LOCAL w/substring ref. */ } } else if (sa == FFESYMBOL_attrsetNONE) { assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, &gen, &spec, &imp)) { if (ffeimplic_peek_symbol_type (s, NULL) == FFEINFO_basictypeCHARACTER) return s; /* Haven't learned anything yet. */ ffesymbol_signal_change (s); /* May need to back up to previous version. */ ffesymbol_set_generic (s, gen); ffesymbol_set_specific (s, spec); ffesymbol_set_implementation (s, imp); ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), 0, FFEINFO_kindFUNCTION, FFEINFO_whereINTRINSIC, ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_reference (s, t, FALSE); ffesymbol_signal_unreported (s); /* For debugging purposes. */ return s; } kind = FFEINFO_kindFUNCTION; where = FFEINFO_whereGLOBAL; maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; could be ENTITY/LOCAL w/substring ref. */ } else error = TRUE; /* Now see what we've got for a new object: NONE means a new error cropped up; ANY means an old error to be ignored; otherwise, everything's ok, update the object (symbol) and continue on. */ if (error) ffesymbol_error (s, t); else if (!(na & FFESYMBOL_attrsANY)) { ffesymbol_signal_change (s); /* May need to back up to previous version. */ if (!ffeimplic_establish_symbol (s)) { ffesymbol_error (s, t); return s; } if (maybe_ambig && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) return s; /* Still not sure, let caller deal with it based on (...). */ ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), kind, where, ffesymbol_size (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_reference (s, t, FALSE); ffesymbol_signal_unreported (s); /* For debugging purposes. */ } return s; } /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle expression (which might be null) and COMMA or CLOSE_PAREN. */ static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprExpr_ procedure; ffebld reduced; ffeinfo info; ffeexprContext ctx; bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */ procedure = ffeexpr_stack_->exprstack; info = ffebld_info (procedure->u.operand); /* Is there an expression to add? If the expression is nil, it might still be an argument. It is if: - The current token is comma, or - The -fugly-comma flag was specified *and* the procedure being invoked is external. Otherwise, if neither of the above is the case, just ignore this (nil) expression. */ if ((expr != NULL) || (ffelex_token_type (t) == FFELEX_typeCOMMA) || (ffe_is_ugly_comma () && (ffeinfo_where (info) == FFEINFO_whereGLOBAL))) { /* This expression, even if nil, is apparently intended as an argument. */ /* Internal procedure (CONTAINS, or statement function)? */ if (ffeinfo_where (info) == FFEINFO_whereCONSTANT) { if ((expr == NULL) && ffebad_start (FFEBAD_NULL_ARGUMENT)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } if (expr == NULL) ; else { if (ffeexpr_stack_->next_dummy == NULL) { /* Report later which was the first extra argument. */ if (ffeexpr_stack_->tokens[1] == NULL) { ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); ffeexpr_stack_->num_args = 0; } ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */ } else { if ((ffeinfo_rank (ffebld_info (expr)) != 0) && ffebad_start (FFEBAD_ARRAY_AS_SFARG)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_here (1, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter (ffebld_head (ffeexpr_stack_->next_dummy))))); ffebad_finish (); } else { expr = ffeexpr_convert_expr (expr, ft, ffebld_head (ffeexpr_stack_->next_dummy), ffeexpr_stack_->tokens[0], FFEEXPR_contextLET); ffebld_append_item (&ffeexpr_stack_->bottom, expr); } --ffeexpr_stack_->num_args; /* Count down # of args. */ ffeexpr_stack_->next_dummy = ffebld_trail (ffeexpr_stack_->next_dummy); } } } else { if ((expr == NULL) && ffe_is_pedantic () && ffebad_start (FFEBAD_NULL_ARGUMENT_W)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } ffebld_append_item (&ffeexpr_stack_->bottom, expr); } } switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: case FFEEXPR_contextSFUNCDEFINDEX_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: ctx = FFEEXPR_contextSFUNCDEFACTUALARG_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: assert ("bad context" == NULL); ctx = FFEEXPR_context; break; default: ctx = FFEEXPR_contextACTUALARG_; break; } return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_token_arguments_); default: break; } if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) && (ffeexpr_stack_->next_dummy != NULL)) { /* Too few arguments. */ if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS)) { char num[10]; sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_string (num); ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter (ffebld_head (ffeexpr_stack_->next_dummy))))); ffebad_finish (); } for (; ffeexpr_stack_->next_dummy != NULL; ffeexpr_stack_->next_dummy = ffebld_trail (ffeexpr_stack_->next_dummy)) { expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0)); ffebld_set_info (expr, ffeinfo_new_any ()); ffebld_append_item (&ffeexpr_stack_->bottom, expr); } } if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) && (ffeexpr_stack_->tokens[1] != NULL)) { /* Too many arguments to statement function. */ if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS)) { char num[10]; sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), ffelex_token_where_column (ffeexpr_stack_->tokens[1])); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_string (num); ffebad_finish (); } ffelex_token_kill (ffeexpr_stack_->tokens[1]); } ffebld_end_list (&ffeexpr_stack_->bottom); if (ffebld_op (procedure->u.operand) == FFEBLD_opANY) { reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); } else { if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) reduced = ffebld_new_funcref (procedure->u.operand, ffeexpr_stack_->expr); else reduced = ffebld_new_subrref (procedure->u.operand, ffeexpr_stack_->expr); if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE) ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]); else if (ffebld_symter_specific (procedure->u.operand) != FFEINTRIN_specNONE) ffeintrin_fulfill_specific (&reduced, &info, &check_intrin, ffeexpr_stack_->tokens[0]); else ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]); if (ffebld_op (reduced) != FFEBLD_opANY) ffebld_set_info (reduced, ffeinfo_new (ffeinfo_basictype (info), ffeinfo_kindtype (info), 0, FFEINFO_kindENTITY, FFEINFO_whereFLEETING, ffeinfo_size (info))); else ffebld_set_info (reduced, ffeinfo_new_any ()); } if (ffebld_op (reduced) == FFEBLD_opFUNCREF) reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]); ffeexpr_stack_->exprstack = procedure->previous; /* Pops not-quite-operand off stack. */ procedure->u.operand = reduced; /* Save the line/column ffewhere info. */ ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */ if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) { ffelex_token_kill (ffeexpr_stack_->tokens[0]); ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */ /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where Z is DOUBLE COMPLEX), and a command-line option doesn't already establish interpretation, probably complain. */ if (check_intrin && !ffe_is_90 () && !ffe_is_ugly_complex ()) { /* If the outer expression is REAL(me...), issue diagnostic only if next token isn't the close-paren for REAL(me). */ if ((ffeexpr_stack_->previous != NULL) && (ffeexpr_stack_->previous->exprstack != NULL) && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_) && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL) && (ffebld_op (reduced) == FFEBLD_opSYMTER) && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL)) return (ffelexHandler) ffeexpr_token_intrincheck_; /* Diagnose the ambiguity now. */ if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) { ffebad_string (ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (ffeexpr_stack_->exprstack->u.operand)))); ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); ffebad_finish (); } } return (ffelexHandler) ffeexpr_token_substrp_; } if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } ffelex_token_kill (ffeexpr_stack_->tokens[0]); ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */ return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_token_substrp_); } /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr Return a pointer to this array to the lexer (ffelex), which will invoke it for the next token. Handle expression and COMMA or CLOSE_PAREN. */ static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprExpr_ array; ffebld reduced; ffeinfo info; ffeinfoWhere where; ffetargetIntegerDefault val; ffetargetIntegerDefault lval = 0; ffetargetIntegerDefault uval = 0; ffebld lbound; ffebld ubound; bool lcheck; bool ucheck; array = ffeexpr_stack_->exprstack; info = ffebld_info (array->u.operand); if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) || (ffelex_token_type(t) == FFELEX_typeCOMMA)) */ ) { if (ffebad_start (FFEBAD_NULL_ELEMENT)) { ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_finish (); } if (ffeexpr_stack_->rank < ffeinfo_rank (info)) { /* Don't bother if we're going to complain later! */ expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); ffebld_set_info (expr, ffeinfo_new_any ()); } } if (expr == NULL) ; else if (ffeinfo_rank (info) == 0) { /* In EQUIVALENCE context, ffeinfo_rank(info) may == 0. */ ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT feature. */ ffebld_append_item (&ffeexpr_stack_->bottom, expr); } else { ++ffeexpr_stack_->rank; if (ffeexpr_stack_->rank > ffeinfo_rank (info)) { /* Report later which was the first extra element. */ if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1) ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); } else { switch (ffeinfo_where (ffebld_info (expr))) { case FFEINFO_whereCONSTANT: break; case FFEINFO_whereIMMEDIATE: ffeexpr_stack_->constant = FALSE; break; default: ffeexpr_stack_->constant = FALSE; ffeexpr_stack_->immediate = FALSE; break; } if (ffebld_op (expr) == FFEBLD_opCONTER && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT) { val = ffebld_constant_integerdefault (ffebld_conter (expr)); lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list)); if (lbound == NULL) { lcheck = TRUE; lval = 1; } else if (ffebld_op (lbound) == FFEBLD_opCONTER) { lcheck = TRUE; lval = ffebld_constant_integerdefault (ffebld_conter (lbound)); } else lcheck = FALSE; ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list)); assert (ubound != NULL); if (ffebld_op (ubound) == FFEBLD_opCONTER) { ucheck = TRUE; uval = ffebld_constant_integerdefault (ffebld_conter (ubound)); } else ucheck = FALSE; if ((lcheck && (val < lval)) || (ucheck && (val > uval))) { ffebad_start (FFEBAD_RANGE_ARRAY); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } } ffebld_append_item (&ffeexpr_stack_->bottom, expr); ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list); } } switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: switch (ffeexpr_context_outer_ (ffeexpr_stack_)) { case FFEEXPR_contextDATAIMPDOITEM_: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextDATAIMPDOINDEX_, ffeexpr_token_elements_); case FFEEXPR_contextEQUIVALENCE: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextEQVINDEX_, ffeexpr_token_elements_); case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextSFUNCDEFINDEX_, ffeexpr_token_elements_); case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: assert ("bad context" == NULL); break; default: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextINDEX_, ffeexpr_token_elements_); } default: break; } if ((ffeexpr_stack_->rank != ffeinfo_rank (info)) && (ffeinfo_rank (info) != 0)) { char num[10]; if (ffeexpr_stack_->rank < ffeinfo_rank (info)) { if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS)) { sprintf (num, "%d", (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank)); ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_string (num); ffebad_finish (); } } else { if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS)) { sprintf (num, "%d", (int) (ffeexpr_stack_->rank - ffeinfo_rank (info))); ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), ffelex_token_where_column (ffeexpr_stack_->tokens[1])); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_string (num); ffebad_finish (); } ffelex_token_kill (ffeexpr_stack_->tokens[1]); } while (ffeexpr_stack_->rank++ < ffeinfo_rank (info)) { expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); ffebld_append_item (&ffeexpr_stack_->bottom, expr); } } ffebld_end_list (&ffeexpr_stack_->bottom); if (ffebld_op (array->u.operand) == FFEBLD_opANY) { reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); } else { reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr); if (ffeexpr_stack_->constant) where = FFEINFO_whereFLEETING_CADDR; else if (ffeexpr_stack_->immediate) where = FFEINFO_whereFLEETING_IADDR; else where = FFEINFO_whereFLEETING; ffebld_set_info (reduced, ffeinfo_new (ffeinfo_basictype (info), ffeinfo_kindtype (info), 0, FFEINFO_kindENTITY, where, ffeinfo_size (info))); reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]); } ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off stack. */ array->u.operand = reduced; /* Save the line/column ffewhere info. */ ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */ switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeCHARACTER: ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */ break; case FFEINFO_basictypeNONE: ffeexpr_is_substr_ok_ = TRUE; assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE); break; default: ffeexpr_is_substr_ok_ = FALSE; break; } if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) { ffelex_token_kill (ffeexpr_stack_->tokens[0]); return (ffelexHandler) ffeexpr_token_substrp_; } if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } ffelex_token_kill (ffeexpr_stack_->tokens[0]); return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_token_substrp_); } /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr Return a pointer to this array to the lexer (ffelex), which will invoke it for the next token. If token is COLON, pass off to _substr_, else init list and pass off to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where ? marks the token, and where FOO's rank/type has not yet been established, meaning we could be in a list of indices or in a substring specification. */ static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t) { if (ffelex_token_type (t) == FFELEX_typeCOLON) return ffeexpr_token_substring_ (ft, expr, t); ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return ffeexpr_token_elements_ (ft, expr, t); } /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle expression (which may be null) and COLON. */ static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeexprExpr_ string; ffeinfo info; ffetargetIntegerDefault i; ffeexprContext ctx; ffetargetCharacterSize size; string = ffeexpr_stack_->exprstack; info = ffebld_info (string->u.operand); size = ffebld_size_max (string->u.operand); if (ffelex_token_type (t) == FFELEX_typeCOLON) { if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opCONTER) && (((i = ffebld_constant_integerdefault (ffebld_conter (expr))) < 1) || ((size != FFETARGET_charactersizeNONE) && (i > size)))) { ffebad_start (FFEBAD_RANGE_SUBSTR); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } ffeexpr_stack_->expr = expr; switch (ffeexpr_stack_->context) { case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: ctx = FFEEXPR_contextSFUNCDEFINDEX_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: assert ("bad context" == NULL); ctx = FFEEXPR_context; break; default: ctx = FFEEXPR_contextINDEX_; break; } return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_token_substring_1_); } if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } ffeexpr_stack_->expr = NULL; return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t); } /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. Handle expression (which might be null) and CLOSE_PAREN. */ static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t) { ffeexprExpr_ string; ffebld reduced; ffebld substrlist; ffebld first = ffeexpr_stack_->expr; ffebld strop; ffeinfo info; ffeinfoWhere lwh; ffeinfoWhere rwh; ffeinfoWhere where; ffeinfoKindtype first_kt; ffeinfoKindtype last_kt; ffetargetIntegerDefault first_val; ffetargetIntegerDefault last_val; ffetargetCharacterSize size; ffetargetCharacterSize strop_size_max; bool first_known; string = ffeexpr_stack_->exprstack; strop = string->u.operand; info = ffebld_info (strop); if (first == NULL || (ffebld_op (first) == FFEBLD_opCONTER && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT)) { /* The starting point is known. */ first_val = (first == NULL) ? 1 : ffebld_constant_integerdefault (ffebld_conter (first)); first_known = TRUE; } else { /* Assume start of the entity. */ first_val = 1; first_known = FALSE; } if (last != NULL && (ffebld_op (last) == FFEBLD_opCONTER && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT)) { /* The ending point is known. */ last_val = ffebld_constant_integerdefault (ffebld_conter (last)); if (first_known) { /* The beginning point is a constant. */ if (first_val <= last_val) size = last_val - first_val + 1; else { if (0 && ffe_is_90 ()) size = 0; else { size = 1; ffebad_start (FFEBAD_ZERO_SIZE); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } } } else size = FFETARGET_charactersizeNONE; strop_size_max = ffebld_size_max (strop); if ((strop_size_max != FFETARGET_charactersizeNONE) && (last_val > strop_size_max)) { /* Beyond maximum possible end of string. */ ffebad_start (FFEBAD_RANGE_SUBSTR); ffebad_here (0, ffelex_token_where_line (ft), ffelex_token_where_column (ft)); ffebad_finish (); } } else size = FFETARGET_charactersizeNONE; /* The size is not known. */ #if 0 /* Don't do this, or "is size of target known?" would no longer be easily answerable. To see if there is a max size, use ffebld_size_max; to get only the known size, else NONE, use ffebld_size_known; use ffebld_size if values are sure to be the same (not opSUBSTR or opCONCATENATE or known to have known length). By getting rid of this "useful info" stuff, we don't end up blank-padding the constant in the assignment "A(I:J)='XYZ'" to the known length of A. */ if (size == FFETARGET_charactersizeNONE) size = strop_size_max; /* Assume we use the entire string. */ #endif substrlist = ffebld_new_item (first, ffebld_new_item (last, NULL ) ) ; if (first == NULL) lwh = FFEINFO_whereCONSTANT; else lwh = ffeinfo_where (ffebld_info (first)); if (last == NULL) rwh = FFEINFO_whereCONSTANT; else rwh = ffeinfo_where (ffebld_info (last)); switch (lwh) { case FFEINFO_whereCONSTANT: switch (rwh) { case FFEINFO_whereCONSTANT: where = FFEINFO_whereCONSTANT; break; case FFEINFO_whereIMMEDIATE: where = FFEINFO_whereIMMEDIATE; break; default: where = FFEINFO_whereFLEETING; break; } break; case FFEINFO_whereIMMEDIATE: switch (rwh) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: where = FFEINFO_whereIMMEDIATE; break; default: where = FFEINFO_whereFLEETING; break; } break; default: where = FFEINFO_whereFLEETING; break; } if (first == NULL) first_kt = FFEINFO_kindtypeINTEGERDEFAULT; else first_kt = ffeinfo_kindtype (ffebld_info (first)); if (last == NULL) last_kt = FFEINFO_kindtypeINTEGERDEFAULT; else last_kt = ffeinfo_kindtype (ffebld_info (last)); switch (where) { case FFEINFO_whereCONSTANT: switch (ffeinfo_where (info)) { case FFEINFO_whereCONSTANT: break; case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ where = FFEINFO_whereIMMEDIATE; break; default: where = FFEINFO_whereFLEETING_CADDR; break; } break; case FFEINFO_whereIMMEDIATE: switch (ffeinfo_where (info)) { case FFEINFO_whereCONSTANT: case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ break; default: where = FFEINFO_whereFLEETING_IADDR; break; } break; default: switch (ffeinfo_where (info)) { case FFEINFO_whereCONSTANT: where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */ break; case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ default: where = FFEINFO_whereFLEETING; break; } break; } if (ffebld_op (strop) == FFEBLD_opANY) { reduced = ffebld_new_any (); ffebld_set_info (reduced, ffeinfo_new_any ()); } else { reduced = ffebld_new_substr (strop, substrlist); ffebld_set_info (reduced, ffeinfo_new (FFEINFO_basictypeCHARACTER, ffeinfo_kindtype (info), 0, FFEINFO_kindENTITY, where, size)); reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]); } ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off stack. */ string->u.operand = reduced; /* Save the line/column ffewhere info. */ ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */ if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) { ffelex_token_kill (ffeexpr_stack_->tokens[0]); ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */ return (ffelexHandler) ffeexpr_token_substrp_; } if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), ffelex_token_where_column (ffeexpr_stack_->tokens[0])); ffebad_finish (); } ffelex_token_kill (ffeexpr_stack_->tokens[0]); ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */ return (ffelexHandler) ffeexpr_find_close_paren_ (t, (ffelexHandler) ffeexpr_token_substrp_); } /* ffeexpr_token_substrp_ -- Rhs Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and issue error message if flag (serves as argument) is set. Else, just forward token to binary_. */ static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t) { ffeexprContext ctx; if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) return (ffelexHandler) ffeexpr_token_binary_ (t); ffeexpr_stack_->tokens[0] = ffelex_token_use (t); switch (ffeexpr_stack_->context) { case FFEEXPR_contextSFUNCDEF: case FFEEXPR_contextSFUNCDEFINDEX_: ctx = FFEEXPR_contextSFUNCDEFINDEX_; break; case FFEEXPR_contextSFUNCDEFACTUALARG_: case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: assert ("bad context" == NULL); ctx = FFEEXPR_context; break; default: ctx = FFEEXPR_contextINDEX_; break; } if (!ffeexpr_is_substr_ok_) { if (ffebad_start (FFEBAD_BAD_SUBSTR)) { ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); ffebad_finish (); } return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_token_anything_); } return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, ffeexpr_token_substring_); } static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t) { if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) { ffebad_string (ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (ffeexpr_stack_->exprstack->u.operand)))); ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); ffebad_finish (); } return (ffelexHandler) ffeexpr_token_substrp_ (t); } /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr Return a pointer to this function to the lexer (ffelex), which will invoke it for the next token. If COLON, do everything we would have done since _parenthesized_ if we had known NAME represented a kindENTITY instead of a kindFUNCTION. If not COLON, do likewise for kindFUNCTION instead. */ static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t) { ffeinfoWhere where; ffesymbol s; ffesymbolAttrs sa; ffebld symter = ffeexpr_stack_->exprstack->u.operand; bool needs_type; ffeintrinGen gen; ffeintrinSpec spec; ffeintrinImp imp; s = ffebld_symter (symter); sa = ffesymbol_attrs (s); where = ffesymbol_where (s); /* We get here only if we don't already know enough about FOO when seeing a FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If "stuff" is a substring reference, then FOO is a CHARACTER scalar type. Else FOO is a function, either intrinsic or external. If intrinsic, it wouldn't necessarily be CHARACTER type, so unless it has already been declared DUMMY, it hasn't had its type established yet. It can't be CHAR*(*) in any case, though it can have an explicit CHAR*n type. */ assert (!(sa & ~(FFESYMBOL_attrsDUMMY | FFESYMBOL_attrsTYPE))); needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY); ffesymbol_signal_change (s); /* Probably already done, but in case.... */ if (ffelex_token_type (t) == FFELEX_typeCOLON) { /* Definitely an ENTITY (char substring). */ if (needs_type && !ffeimplic_establish_symbol (s)) { ffesymbol_error (s, ffeexpr_stack_->tokens[0]); return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), FFEINFO_kindENTITY, (where == FFEINFO_whereNONE) ? FFEINFO_whereLOCAL : where, ffesymbol_size (s))); ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_signal_unreported (s); /* For debugging purposes. */ ffeexpr_stack_->exprstack->u.operand = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]); return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t); } /* The "stuff" isn't a substring notation, so we now know the overall reference is to a function. */ if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0], FALSE, &gen, &spec, &imp)) { ffebld_symter_set_generic (symter, gen); ffebld_symter_set_specific (symter, spec); ffebld_symter_set_implementation (symter, imp); ffesymbol_set_generic (s, gen); ffesymbol_set_specific (s, spec); ffesymbol_set_implementation (s, imp); ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), 0, FFEINFO_kindFUNCTION, FFEINFO_whereINTRINSIC, ffesymbol_size (s))); } else { /* Not intrinsic, now needs CHAR type. */ if (!ffeimplic_establish_symbol (s)) { ffesymbol_error (s, ffeexpr_stack_->tokens[0]); return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); } ffesymbol_set_info (s, ffeinfo_new (ffesymbol_basictype (s), ffesymbol_kindtype (s), ffesymbol_rank (s), FFEINFO_kindFUNCTION, (where == FFEINFO_whereNONE) ? FFEINFO_whereGLOBAL : where, ffesymbol_size (s))); } ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s))); ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); ffesymbol_resolve_intrin (s); s = ffecom_sym_learned (s); ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE); ffesymbol_signal_unreported (s); /* For debugging purposes. */ ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); } /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr Handle basically any expression, looking for CLOSE_PAREN. */ static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED, ffelexToken t) { ffeexprExpr_ e = ffeexpr_stack_->exprstack; switch (ffelex_token_type (t)) { case FFELEX_typeCOMMA: case FFELEX_typeCOLON: return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, FFEEXPR_contextACTUALARG_, ffeexpr_token_anything_); default: e->u.operand = ffebld_new_any (); ffebld_set_info (e->u.operand, ffeinfo_new_any ()); ffelex_token_kill (ffeexpr_stack_->tokens[0]); ffeexpr_is_substr_ok_ = FALSE; if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) return (ffelexHandler) ffeexpr_token_substrp_; return (ffelexHandler) ffeexpr_token_substrp_ (t); } } /* Terminate module. */ void ffeexpr_terminate_2 () { assert (ffeexpr_stack_ == NULL); assert (ffeexpr_level_ == 0); }