diff options
Diffstat (limited to 'gcc/f/expr.c')
| -rw-r--r-- | gcc/f/expr.c | 19405 |
1 files changed, 19405 insertions, 0 deletions
diff --git a/gcc/f/expr.c b/gcc/f/expr.c new file mode 100644 index 00000000000..057293b0eef --- /dev/null +++ b/gcc/f/expr.c @@ -0,0 +1,19405 @@ +/* expr.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +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 <ctype.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 "target.h" +#include "where.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFEEXPR_dotdotNONE_, + FFEEXPR_dotdotTRUE_, + FFEEXPR_dotdotFALSE_, + FFEEXPR_dotdotNOT_, + FFEEXPR_dotdotAND_, + FFEEXPR_dotdotOR_, + FFEEXPR_dotdotXOR_, + FFEEXPR_dotdotEQV_, + FFEEXPR_dotdotNEQV_, + FFEEXPR_dotdotLT_, + FFEEXPR_dotdotLE_, + FFEEXPR_dotdotEQ_, + FFEEXPR_dotdotNE_, + FFEEXPR_dotdotGT_, + FFEEXPR_dotdotGE_, + FFEEXPR_dotdot + } ffeexprDotdot_; + +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 ffeexprDotdot_ 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 ffeexprDotdot_ ffeexpr_dotdot_ (ffelexToken t); +static ffeexprExpr_ ffeexpr_expr_new_ (void); +static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); +static bool ffeexpr_isdigits_ (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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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; + } + + 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 = ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr)); + ffeinfoBasictype rty = ffeinfo_basictype (ffebld_info (expr)); + ffeinfoKindtype lkt; + ffeinfoKindtype rkt; + ffeinfoKindtype nkt; + bool ok = TRUE; + ffebld orig; + + if ((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_dotdot_ -- Look up name in list of .FOO. possibilities + + ffeexprDotdot_ d; + ffelexToken t; + d = ffeexpr_dotdot_(t); + + Returns the identifier for the name, or the NONE identifier. */ + +static ffeexprDotdot_ +ffeexpr_dotdot_ (ffelexToken t) +{ + char *p; + + switch (ffelex_token_length (t)) + { + case 2: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('E', 'e', match_2e, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'Q', 'q')) + return FFEEXPR_dotdotEQ_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('G', 'g', match_2g, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'E', 'e')) + return FFEEXPR_dotdotGE_; + if (ffesrc_char_match_noninit (*p, 'T', 't')) + return FFEEXPR_dotdotGT_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('L', 'l', match_2l, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'E', 'e')) + return FFEEXPR_dotdotLE_; + if (ffesrc_char_match_noninit (*p, 'T', 't')) + return FFEEXPR_dotdotLT_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('N', 'n', match_2n, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'E', 'e')) + return FFEEXPR_dotdotNE_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('O', 'o', match_2o, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'R', 'r')) + return FFEEXPR_dotdotOR_; + return FFEEXPR_dotdotNONE_; + + default: + no_match_2: /* :::::::::::::::::::: */ + return FFEEXPR_dotdotNONE_; + } + + case 3: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('A', 'a', match_3a, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'N', 'n')) + && (ffesrc_char_match_noninit (*++p, 'D', 'd'))) + return FFEEXPR_dotdotAND_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('E', 'e', match_3e, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'Q', 'q')) + && (ffesrc_char_match_noninit (*++p, 'V', 'v'))) + return FFEEXPR_dotdotEQV_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('N', 'n', match_3n, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) + && (ffesrc_char_match_noninit (*++p, 'T', 't'))) + return FFEEXPR_dotdotNOT_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('X', 'x', match_3x, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) + && (ffesrc_char_match_noninit (*++p, 'R', 'r'))) + return FFEEXPR_dotdotXOR_; + return FFEEXPR_dotdotNONE_; + + default: + no_match_3: /* :::::::::::::::::::: */ + return FFEEXPR_dotdotNONE_; + } + + case 4: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('N', 'n', match_4n, no_match_4): + if ((ffesrc_char_match_noninit (*++p, 'E', 'e')) + && (ffesrc_char_match_noninit (*++p, 'Q', 'q')) + && (ffesrc_char_match_noninit (*++p, 'V', 'v'))) + return FFEEXPR_dotdotNEQV_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('T', 't', match_4t, no_match_4): + if ((ffesrc_char_match_noninit (*++p, 'R', 'r')) + && (ffesrc_char_match_noninit (*++p, 'U', 'u')) + && (ffesrc_char_match_noninit (*++p, 'E', 'e'))) + return FFEEXPR_dotdotTRUE_; + return FFEEXPR_dotdotNONE_; + + default: + no_match_4: /* :::::::::::::::::::: */ + return FFEEXPR_dotdotNONE_; + } + + case 5: + if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "FALSE", + "false", "False") + == 0) + return FFEEXPR_dotdotFALSE_; + return FFEEXPR_dotdotNONE_; + + default: + return FFEEXPR_dotdotNONE_; + } +} + +/* 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) +{ + 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) <token> case -- it assumes it knows which tokens <token> 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; + + case FFEBLD_opPERCENT_LOC: + as = FFEGLOBAL_argsummaryPTR; + break; + + 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 ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER) + && (ffesymbol_specific (ffebld_symter (ffebld_left (item))) + == FFEINTRIN_specLOC)) + { + as = FFEGLOBAL_argsummaryPTR; + break; + } + /* 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_ (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)) + { + 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)) + { + 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) && (lbt != 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) + && (lbt != 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_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotNONE_: + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + 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 FFEEXPR_dotdotNOT_: + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + return (ffelexHandler) ffeexpr_nil_rhs_; + + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + 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; + 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; + 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; + 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; + 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_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + 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) && ffe_is_pedantic ()) + || ((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_: + 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; /* expr==NULL ok for substring; element case + caught by callback. */ + + 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: + error = 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_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: + error = error + && (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT); + if (!ffeexpr_stack_->is_rhs) + break; /* Don't convert lhs variable. */ + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeINTEGER: + error = error && + (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); + 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: + error = FALSE; + 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) <token> case -- it assumes it knows which tokens <token> 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_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotNONE_: + 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 FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + 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 FFEEXPR_dotdotNOT_: + 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 FFEEXPR_dotdotTRUE_: + 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 FFEEXPR_dotdotFALSE_: + 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; + 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; + 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. */ + + 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); + 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; + 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; + 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_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + 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_; + + case FFEEXPR_dotdotNONE_: + if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT)) + { + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_finish (); + } + ffeexpr_current_dotdot_ = FFEEXPR_dotdotEQ_; + /* Fall through here, pretending we got a .EQ. operator. */ + 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; + + 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. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffeexpr_tokens_[0]; + + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotAND_: + e->u.operator.op = FFEEXPR_operatorAND_; + e->u.operator.prec = FFEEXPR_operatorprecedenceAND_; + e->u.operator.as = FFEEXPR_operatorassociativityAND_; + break; + + case FFEEXPR_dotdotOR_: + e->u.operator.op = FFEEXPR_operatorOR_; + e->u.operator.prec = FFEEXPR_operatorprecedenceOR_; + e->u.operator.as = FFEEXPR_operatorassociativityOR_; + break; + + case FFEEXPR_dotdotXOR_: + e->u.operator.op = FFEEXPR_operatorXOR_; + e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_; + e->u.operator.as = FFEEXPR_operatorassociativityXOR_; + break; + + case FFEEXPR_dotdotEQV_: + e->u.operator.op = FFEEXPR_operatorEQV_; + e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_; + e->u.operator.as = FFEEXPR_operatorassociativityEQV_; + break; + + case FFEEXPR_dotdotNEQV_: + e->u.operator.op = FFEEXPR_operatorNEQV_; + e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_; + e->u.operator.as = FFEEXPR_operatorassociativityNEQV_; + break; + + case FFEEXPR_dotdotLT_: + e->u.operator.op = FFEEXPR_operatorLT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; + e->u.operator.as = FFEEXPR_operatorassociativityLT_; + break; + + case FFEEXPR_dotdotLE_: + e->u.operator.op = FFEEXPR_operatorLE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; + e->u.operator.as = FFEEXPR_operatorassociativityLE_; + break; + + case FFEEXPR_dotdotEQ_: + e->u.operator.op = FFEEXPR_operatorEQ_; + e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; + e->u.operator.as = FFEEXPR_operatorassociativityEQ_; + break; + + case FFEEXPR_dotdotNE_: + e->u.operator.op = FFEEXPR_operatorNE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; + e->u.operator.as = FFEEXPR_operatorassociativityNE_; + break; + + case FFEEXPR_dotdotGT_: + e->u.operator.op = FFEEXPR_operatorGT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; + e->u.operator.as = FFEEXPR_operatorassociativityGT_; + break; + + case FFEEXPR_dotdotGE_: + e->u.operator.op = FFEEXPR_operatorGE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; + e->u.operator.as = FFEEXPR_operatorassociativityGE_; + break; + + default: + assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL); + } + + ffeexpr_exprstack_push_binary_ (e); + + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_rhs_ (t); + 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 + + 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); + 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); + + if (ffeinfo_where (info) == FFEINFO_whereCONSTANT) + { /* Statement function (or subroutine, if + there was such a thing). */ + if ((expr == NULL) + && ((ffe_is_pedantic () + && (ffeexpr_stack_->expr != NULL)) + || (ffelex_token_type (t) == FFELEX_typeCOMMA))) + { + if (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 (ffeexpr_stack_->next_dummy != NULL) + { /* Don't bother if we're going to complain + later! */ + expr = ffebld_new_conter + (ffebld_constant_new_integerdefault_val (0)); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + } + + 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) + { + if (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_ugly_comma () + || (ffelex_token_type (t) == FFELEX_typeCOMMA)) + 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->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) + { + 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; + + string = ffeexpr_stack_->exprstack; + strop = string->u.operand; + info = ffebld_info (strop); + + if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER)) + { /* The starting point is known. */ + first_val = (first == NULL) ? 1 + : ffebld_constant_integerdefault (ffebld_conter (first)); + } + else + { /* Assume start of the entity. */ + first_val = 1; + } + + if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER)) + { /* The ending point is known. */ + last_val = ffebld_constant_integerdefault (ffebld_conter (last)); + + if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER)) + { /* 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 <character entity> + + 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); +} |