diff options
Diffstat (limited to 'contrib/gcc/f/expr.c')
| -rw-r--r-- | contrib/gcc/f/expr.c | 18571 |
1 files changed, 0 insertions, 18571 deletions
diff --git a/contrib/gcc/f/expr.c b/contrib/gcc/f/expr.c deleted file mode 100644 index ef7661d..0000000 --- a/contrib/gcc/f/expr.c +++ /dev/null @@ -1,18571 +0,0 @@ -/* expr.c -- Implementation File (module.c template V1.0) - Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003 - Free Software Foundation, Inc. - Contributed by James Craig Burley. - -This file is part of GNU Fortran. - -GNU Fortran is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Fortran is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Fortran; see the file COPYING. If not, write to -the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. - - Related Modules: - None. - - Description: - Handles syntactic and semantic analysis of Fortran expressions. - - Modifications: -*/ - -/* Include files. */ - -#include "proj.h" -#include "expr.h" -#include "bad.h" -#include "bld.h" -#include "com.h" -#include "global.h" -#include "implic.h" -#include "intrin.h" -#include "info.h" -#include "lex.h" -#include "malloc.h" -#include "src.h" -#include "st.h" -#include "symbol.h" -#include "str.h" -#include "target.h" -#include "where.h" -#include "real.h" - -/* Externals defined here. */ - - -/* Simple definitions and enumerations. */ - -typedef enum - { - FFEEXPR_exprtypeUNKNOWN_, - FFEEXPR_exprtypeOPERAND_, - FFEEXPR_exprtypeUNARY_, - FFEEXPR_exprtypeBINARY_, - FFEEXPR_exprtype_ - } ffeexprExprtype_; - -typedef enum - { - FFEEXPR_operatorPOWER_, - FFEEXPR_operatorMULTIPLY_, - FFEEXPR_operatorDIVIDE_, - FFEEXPR_operatorADD_, - FFEEXPR_operatorSUBTRACT_, - FFEEXPR_operatorCONCATENATE_, - FFEEXPR_operatorLT_, - FFEEXPR_operatorLE_, - FFEEXPR_operatorEQ_, - FFEEXPR_operatorNE_, - FFEEXPR_operatorGT_, - FFEEXPR_operatorGE_, - FFEEXPR_operatorNOT_, - FFEEXPR_operatorAND_, - FFEEXPR_operatorOR_, - FFEEXPR_operatorXOR_, - FFEEXPR_operatorEQV_, - FFEEXPR_operatorNEQV_, - FFEEXPR_operator_ - } ffeexprOperator_; - -typedef enum - { - FFEEXPR_operatorprecedenceHIGHEST_ = 1, - FFEEXPR_operatorprecedencePOWER_ = 1, - FFEEXPR_operatorprecedenceMULTIPLY_ = 2, - FFEEXPR_operatorprecedenceDIVIDE_ = 2, - FFEEXPR_operatorprecedenceADD_ = 3, - FFEEXPR_operatorprecedenceSUBTRACT_ = 3, - FFEEXPR_operatorprecedenceLOWARITH_ = 3, - FFEEXPR_operatorprecedenceCONCATENATE_ = 3, - FFEEXPR_operatorprecedenceLT_ = 4, - FFEEXPR_operatorprecedenceLE_ = 4, - FFEEXPR_operatorprecedenceEQ_ = 4, - FFEEXPR_operatorprecedenceNE_ = 4, - FFEEXPR_operatorprecedenceGT_ = 4, - FFEEXPR_operatorprecedenceGE_ = 4, - FFEEXPR_operatorprecedenceNOT_ = 5, - FFEEXPR_operatorprecedenceAND_ = 6, - FFEEXPR_operatorprecedenceOR_ = 7, - FFEEXPR_operatorprecedenceXOR_ = 8, - FFEEXPR_operatorprecedenceEQV_ = 8, - FFEEXPR_operatorprecedenceNEQV_ = 8, - FFEEXPR_operatorprecedenceLOWEST_ = 8, - FFEEXPR_operatorprecedence_ - } ffeexprOperatorPrecedence_; - -#define FFEEXPR_operatorassociativityL2R_ TRUE -#define FFEEXPR_operatorassociativityR2L_ FALSE -#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_ -#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_ -#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_ - -typedef enum - { - FFEEXPR_parentypeFUNCTION_, - FFEEXPR_parentypeSUBROUTINE_, - FFEEXPR_parentypeARRAY_, - FFEEXPR_parentypeSUBSTRING_, - FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */ - FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */ - FFEEXPR_parentypeANY_, /* Allow basically anything. */ - FFEEXPR_parentype_ - } ffeexprParenType_; - -typedef enum - { - FFEEXPR_percentNONE_, - FFEEXPR_percentLOC_, - FFEEXPR_percentVAL_, - FFEEXPR_percentREF_, - FFEEXPR_percentDESCR_, - FFEEXPR_percent_ - } ffeexprPercent_; - -/* Internal typedefs. */ - -typedef struct _ffeexpr_expr_ *ffeexprExpr_; -typedef bool ffeexprOperatorAssociativity_; -typedef struct _ffeexpr_stack_ *ffeexprStack_; - -/* Private include files. */ - - -/* Internal structure definitions. */ - -struct _ffeexpr_expr_ - { - ffeexprExpr_ previous; - ffelexToken token; - ffeexprExprtype_ type; - union - { - struct - { - ffeexprOperator_ op; - ffeexprOperatorPrecedence_ prec; - ffeexprOperatorAssociativity_ as; - } - operator; - ffebld operand; - } - u; - }; - -struct _ffeexpr_stack_ - { - ffeexprStack_ previous; - mallocPool pool; - ffeexprContext context; - ffeexprCallback callback; - ffelexToken first_token; - ffeexprExpr_ exprstack; - ffelexToken tokens[10]; /* Used in certain cases, like (unary) - open-paren. */ - ffebld expr; /* For first of - complex/implied-do/substring/array-elements - / actual-args expression. */ - ffebld bound_list; /* For tracking dimension bounds list of - array. */ - ffebldListBottom bottom; /* For building lists. */ - ffeinfoRank rank; /* For elements in an array reference. */ - bool constant; /* TRUE while elements seen so far are - constants. */ - bool immediate; /* TRUE while elements seen so far are - immediate/constants. */ - ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */ - ffebldListLength num_args; /* Number of dummy args expected in arg list. */ - bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */ - ffeexprPercent_ percent; /* Current %FOO keyword. */ - }; - -struct _ffeexpr_find_ - { - ffelexToken t; - ffelexHandler after; - int level; - }; - -/* Static objects accessed by functions in this module. */ - -static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */ -static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */ -static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */ -static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */ -static int ffeexpr_level_; /* Level of DATA implied-DO construct. */ -static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */ -static struct _ffeexpr_find_ ffeexpr_find_; - -/* Static functions (internal). */ - -static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, - ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t); -static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft, - ffebld expr, ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft, - ffebld expr, ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t); -static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t); -static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s); -static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, - ffebld dovar, ffelexToken dovar_t); -static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar); -static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar); -static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s); -static ffeexprExpr_ ffeexpr_expr_new_ (void); -static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); -static bool ffeexpr_isdigits_ (const char *p); -static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t); -static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t); -static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t); -static void ffeexpr_expr_kill_ (ffeexprExpr_ e); -static void ffeexpr_exprstack_push_ (ffeexprExpr_ e); -static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e); -static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e); -static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e); -static void ffeexpr_reduce_ (void); -static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, - ffeexprExpr_ r); -static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, - ffeexprExpr_ r); -static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, - ffeexprExpr_ r); -static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r); -static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, - ffeexprExpr_ op, ffeexprExpr_ r, - bool *); -static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t, - ffelexHandler after); -static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_period_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_real_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t); -static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t); -static ffelexHandler ffeexpr_finished_ (ffelexToken t); -static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr); -static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t); -static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t); -static ffelexHandler ffeexpr_token_binary_ (ffelexToken t); -static ffelexHandler ffeexpr_token_period_ (ffelexToken t); -static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t); -static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t); -static ffelexHandler ffeexpr_token_real_ (ffelexToken t); -static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t); -static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t); -static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t); -static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t); -static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t); -static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t); -static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t); -static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t); -static ffelexHandler ffeexpr_token_quote_ (ffelexToken t); -static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t); -static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t); -static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t); -static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t); -static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t); -static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t); -static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t); -static ffelexHandler ffeexpr_token_percent_ (ffelexToken t); -static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t); -static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t); -static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t); -static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr, - ffelexToken t); -static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, - ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, - ffelexToken exponent_sign, ffelexToken exponent_digits); -static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin); -static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t); -static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t, - bool maybe_intrin, - ffeexprParenType_ *paren_type); -static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t); - -/* Internal macros. */ - -#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) -#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) - -/* ffeexpr_collapse_convert -- Collapse convert expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_convert(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_convert (ffebld expr, ffelexToken t) -{ - ffebad error = FFEBAD; - ffebld l; - ffebldConstantUnion u; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffetargetCharacterSize sz; - ffetargetCharacterSize sz2; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - l = ffebld_left (expr); - - if (ffebld_op (l) != FFEBLD_opCONTER) - return expr; - - switch (bt = ffeinfo_basictype (ffebld_info (expr))) - { - case FFEINFO_basictypeANY: - return expr; - - case FFEINFO_basictypeINTEGER: - sz = FFETARGET_charactersizeNONE; - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_integer1_integer2 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_integer1_integer3 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_integer1_integer4 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER1/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer1_real1 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer1_real2 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer1_real3 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER1/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer1_complex1 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer1_complex2 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer1_complex3 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER1/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_integer1_logical1 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_integer1_logical2 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_integer1_logical3 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_integer1_logical4 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER1/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_integer1_character1 - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_integer1_hollerith - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_integer1_typeless - (ffebld_cu_ptr_integer1 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("INTEGER1 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_integer1_val - (ffebld_cu_val_integer1 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_integer2_integer1 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_integer2_integer3 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_integer2_integer4 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER2/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer2_real1 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer2_real2 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer2_real3 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER2/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer2_complex1 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer2_complex2 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer2_complex3 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER2/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_integer2_logical1 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_integer2_logical2 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_integer2_logical3 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_integer2_logical4 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER2/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_integer2_character1 - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_integer2_hollerith - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_integer2_typeless - (ffebld_cu_ptr_integer2 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("INTEGER2 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_integer2_val - (ffebld_cu_val_integer2 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_integer3_integer1 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_integer3_integer2 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_integer3_integer4 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER3/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer3_real1 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer3_real2 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer3_real3 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER3/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer3_complex1 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer3_complex2 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer3_complex3 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER3/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_integer3_logical1 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_integer3_logical2 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_integer3_logical3 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_integer3_logical4 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER3/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_integer3_character1 - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_integer3_hollerith - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_integer3_typeless - (ffebld_cu_ptr_integer3 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("INTEGER3 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_integer3_val - (ffebld_cu_val_integer3 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_integer4_integer1 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_integer4_integer2 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_integer4_integer3 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER4/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer4_real1 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer4_real2 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer4_real3 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER4/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_integer4_complex1 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_integer4_complex2 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_integer4_complex3 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER3/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_integer4_logical1 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_integer4_logical2 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_integer4_logical3 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_integer4_logical4 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("INTEGER4/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_integer4_character1 - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_integer4_hollerith - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_integer4_typeless - (ffebld_cu_ptr_integer4 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("INTEGER4 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_integer4_val - (ffebld_cu_val_integer4 (u)), expr); - break; -#endif - - default: - assert ("bad integer kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - sz = FFETARGET_charactersizeNONE; - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_logical1_logical2 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_logical1_logical3 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_logical1_logical4 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL1/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_logical1_integer1 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_logical1_integer2 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_logical1_integer3 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_logical1_integer4 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL1/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_logical1_character1 - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_logical1_hollerith - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_logical1_typeless - (ffebld_cu_ptr_logical1 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("LOGICAL1 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_logical1_val - (ffebld_cu_val_logical1 (u)), expr); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_logical2_logical1 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_logical2_logical3 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_logical2_logical4 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL2/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_logical2_integer1 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_logical2_integer2 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_logical2_integer3 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_logical2_integer4 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL2/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_logical2_character1 - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_logical2_hollerith - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_logical2_typeless - (ffebld_cu_ptr_logical2 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("LOGICAL2 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_logical2_val - (ffebld_cu_val_logical2 (u)), expr); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_logical3_logical1 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_logical3_logical2 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_convert_logical3_logical4 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_logical4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL3/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_logical3_integer1 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_logical3_integer2 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_logical3_integer3 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_logical3_integer4 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL3/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_logical3_character1 - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_logical3_hollerith - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_logical3_typeless - (ffebld_cu_ptr_logical3 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("LOGICAL3 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_logical3_val - (ffebld_cu_val_logical3 (u)), expr); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_convert_logical4_logical1 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_logical1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_convert_logical4_logical2 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_logical2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_convert_logical4_logical3 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_logical3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL4/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_logical4_integer1 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_logical4_integer2 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_logical4_integer3 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_logical4_integer4 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("LOGICAL4/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_logical4_character1 - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_logical4_hollerith - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_logical4_typeless - (ffebld_cu_ptr_logical4 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("LOGICAL4 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_logical4_val - (ffebld_cu_val_logical4 (u)), expr); - break; -#endif - - default: - assert ("bad logical kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - sz = FFETARGET_charactersizeNONE; - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_real1_integer1 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_real1_integer2 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_real1_integer3 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_real1_integer4 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL1/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_real1_real2 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_real1_real3 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL1/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_real1_complex1 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_real1_complex2 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_real1_complex3 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL1/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_real1_character1 - (ffebld_cu_ptr_real1 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_real1_hollerith - (ffebld_cu_ptr_real1 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_real1_typeless - (ffebld_cu_ptr_real1 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("REAL1 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_real1_val - (ffebld_cu_val_real1 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_real2_integer1 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_real2_integer2 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_real2_integer3 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_real2_integer4 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL2/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_real2_real1 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_real2_real3 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL2/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_real2_complex1 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_real2_complex2 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_real2_complex3 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL2/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_real2_character1 - (ffebld_cu_ptr_real2 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_real2_hollerith - (ffebld_cu_ptr_real2 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_real2_typeless - (ffebld_cu_ptr_real2 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("REAL2 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_real2_val - (ffebld_cu_val_real2 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_real3_integer1 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_real3_integer2 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_real3_integer3 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_real3_integer4 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL3/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_real3_real1 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_real3_real2 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL3/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_real3_complex1 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_real3_complex2 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_real3_complex3 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("REAL3/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_real3_character1 - (ffebld_cu_ptr_real3 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_real3_hollerith - (ffebld_cu_ptr_real3 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_real3_typeless - (ffebld_cu_ptr_real3 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("REAL3 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_real3_val - (ffebld_cu_val_real3 (u)), expr); - break; -#endif - - default: - assert ("bad real kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - sz = FFETARGET_charactersizeNONE; - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_complex1_integer1 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_complex1_integer2 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_complex1_integer3 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_complex1_integer4 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX1/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_complex1_real1 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_complex1_real2 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_complex1_real3 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX1/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_complex1_complex2 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_complex1_complex3 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX1/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_complex1_character1 - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_complex1_hollerith - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_complex1_typeless - (ffebld_cu_ptr_complex1 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("COMPLEX1 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_complex1_val - (ffebld_cu_val_complex1 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_complex2_integer1 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_complex2_integer2 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_complex2_integer3 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_complex2_integer4 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX2/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_complex2_real1 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_complex2_real2 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_complex2_real3 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX2/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_complex2_complex1 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_complex2_complex3 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_complex3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX2/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_complex2_character1 - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_complex2_hollerith - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_complex2_typeless - (ffebld_cu_ptr_complex2 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("COMPLEX2 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_complex2_val - (ffebld_cu_val_complex2 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_convert_complex3_integer1 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_integer1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_convert_complex3_integer2 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_integer2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_convert_complex3_integer3 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_integer3 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_convert_complex3_integer4 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_integer4 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX3/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_complex3_real1 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_real1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_complex3_real2 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_real2 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_convert_complex3_real3 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_real3 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX3/REAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_convert_complex3_complex1 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_complex1 (ffebld_conter (l))); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_convert_complex3_complex2 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_complex2 (ffebld_conter (l))); - break; -#endif - - default: - assert ("COMPLEX3/COMPLEX bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - error = ffetarget_convert_complex3_character1 - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_character1 (ffebld_conter (l))); - break; - - case FFEINFO_basictypeHOLLERITH: - error = ffetarget_convert_complex3_hollerith - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_hollerith (ffebld_conter (l))); - break; - - case FFEINFO_basictypeTYPELESS: - error = ffetarget_convert_complex3_typeless - (ffebld_cu_ptr_complex3 (u), - ffebld_constant_typeless (ffebld_conter (l))); - break; - - default: - assert ("COMPLEX3 bad type" == NULL); - break; - } - - /* If conversion operation is not implemented, return original expr. */ - if (error == FFEBAD_NOCANDO) - return expr; - - expr = ffebld_new_conter_with_orig - (ffebld_constant_new_complex3_val - (ffebld_cu_val_complex3 (u)), expr); - break; -#endif - - default: - assert ("bad complex kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCHARACTER: - if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE) - return expr; - kt = ffeinfo_kindtype (ffebld_info (expr)); - switch (kt) - { -#if FFETARGET_okCHARACTER1 - case FFEINFO_kindtypeCHARACTER1: - switch (ffeinfo_basictype (ffebld_info (l))) - { - case FFEINFO_basictypeCHARACTER: - if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE) - return expr; - assert (kt == ffeinfo_kindtype (ffebld_info (l))); - assert (sz2 == ffetarget_length_character1 - (ffebld_constant_character1 - (ffebld_conter (l)))); - error - = ffetarget_convert_character1_character1 - (ffebld_cu_ptr_character1 (u), sz, - ffebld_constant_character1 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; - - case FFEINFO_basictypeINTEGER: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error - = ffetarget_convert_character1_integer1 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_integer1 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error - = ffetarget_convert_character1_integer2 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_integer2 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error - = ffetarget_convert_character1_integer3 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_integer3 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error - = ffetarget_convert_character1_integer4 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_integer4 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - - default: - assert ("CHARACTER1/INTEGER bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - switch (ffeinfo_kindtype (ffebld_info (l))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error - = ffetarget_convert_character1_logical1 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_logical1 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error - = ffetarget_convert_character1_logical2 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_logical2 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error - = ffetarget_convert_character1_logical3 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_logical3 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error - = ffetarget_convert_character1_logical4 - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_logical4 (ffebld_conter (l)), - ffebld_constant_pool ()); - break; -#endif - - default: - assert ("CHARACTER1/LOGICAL bad source kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeHOLLERITH: - error - = ffetarget_convert_character1_hollerith - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_hollerith (ffebld_conter (l)), - ffebld_constant_pool ()); - break; - - case FFEINFO_basictypeTYPELESS: - error - = ffetarget_convert_character1_typeless - (ffebld_cu_ptr_character1 (u), - sz, - ffebld_constant_typeless (ffebld_conter (l)), - ffebld_constant_pool ()); - break; - - default: - assert ("CHARACTER1 bad type" == NULL); - } - - expr - = ffebld_new_conter_with_orig - (ffebld_constant_new_character1_val - (ffebld_cu_val_character1 (u)), - expr); - break; -#endif - - default: - assert ("bad character kind type" == NULL); - break; - } - break; - - default: - assert ("bad type" == NULL); - return expr; - } - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - sz)); - - if ((error != FFEBAD) - && ffebad_start (error)) - { - assert (t != NULL); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - return expr; -} - -/* ffeexpr_collapse_paren -- Collapse paren expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_paren(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED) -{ - ffebld r; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffetargetCharacterSize len; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - r = ffebld_left (expr); - - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - bt = ffeinfo_basictype (ffebld_info (r)); - kt = ffeinfo_kindtype (ffebld_info (r)); - len = ffebld_size (r); - - expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), - expr); - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - len)); - - return expr; -} - -/* ffeexpr_collapse_uplus -- Collapse uplus expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_uplus(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED) -{ - ffebld r; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - ffetargetCharacterSize len; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - r = ffebld_left (expr); - - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - bt = ffeinfo_basictype (ffebld_info (r)); - kt = ffeinfo_kindtype (ffebld_info (r)); - len = ffebld_size (r); - - expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), - expr); - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - len)); - - return expr; -} - -/* ffeexpr_collapse_uminus -- Collapse uminus expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_uminus(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_uminus (ffebld expr, ffelexToken t) -{ - ffebad error = FFEBAD; - ffebld r; - ffebldConstantUnion u; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - r = ffebld_left (expr); - - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - switch (bt = ffeinfo_basictype (ffebld_info (expr))) - { - case FFEINFO_basictypeANY: - return expr; - - case FFEINFO_basictypeINTEGER: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val - (ffebld_cu_val_integer1 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val - (ffebld_cu_val_integer2 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val - (ffebld_cu_val_integer3 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer4 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val - (ffebld_cu_val_integer4 (u)), expr); - break; -#endif - - default: - assert ("bad integer kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u), - ffebld_constant_real1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val - (ffebld_cu_val_real1 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u), - ffebld_constant_real2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val - (ffebld_cu_val_real2 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u), - ffebld_constant_real3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val - (ffebld_cu_val_real3 (u)), expr); - break; -#endif - - default: - assert ("bad real kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u), - ffebld_constant_complex1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val - (ffebld_cu_val_complex1 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u), - ffebld_constant_complex2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val - (ffebld_cu_val_complex2 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u), - ffebld_constant_complex3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val - (ffebld_cu_val_complex3 (u)), expr); - break; -#endif - - default: - assert ("bad complex kind type" == NULL); - break; - } - break; - - default: - assert ("bad type" == NULL); - return expr; - } - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - - if ((error != FFEBAD) - && ffebad_start (error)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - return expr; -} - -/* ffeexpr_collapse_not -- Collapse not expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_not(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_not (ffebld expr, ffelexToken t) -{ - ffebad error = FFEBAD; - ffebld r; - ffebldConstantUnion u; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - r = ffebld_left (expr); - - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - switch (bt = ffeinfo_basictype (ffebld_info (expr))) - { - case FFEINFO_basictypeANY: - return expr; - - case FFEINFO_basictypeINTEGER: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val - (ffebld_cu_val_integer1 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val - (ffebld_cu_val_integer2 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val - (ffebld_cu_val_integer3 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer4 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val - (ffebld_cu_val_integer4 (u)), expr); - break; -#endif - - default: - assert ("bad integer kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeLOGICAL: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okLOGICAL1 - case FFEINFO_kindtypeLOGICAL1: - error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u), - ffebld_constant_logical1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val - (ffebld_cu_val_logical1 (u)), expr); - break; -#endif - -#if FFETARGET_okLOGICAL2 - case FFEINFO_kindtypeLOGICAL2: - error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u), - ffebld_constant_logical2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val - (ffebld_cu_val_logical2 (u)), expr); - break; -#endif - -#if FFETARGET_okLOGICAL3 - case FFEINFO_kindtypeLOGICAL3: - error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u), - ffebld_constant_logical3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val - (ffebld_cu_val_logical3 (u)), expr); - break; -#endif - -#if FFETARGET_okLOGICAL4 - case FFEINFO_kindtypeLOGICAL4: - error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u), - ffebld_constant_logical4 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val - (ffebld_cu_val_logical4 (u)), expr); - break; -#endif - - default: - assert ("bad logical kind type" == NULL); - break; - } - break; - - default: - assert ("bad type" == NULL); - return expr; - } - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - - if ((error != FFEBAD) - && ffebad_start (error)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - return expr; -} - -/* ffeexpr_collapse_add -- Collapse add expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_add(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_add (ffebld expr, ffelexToken t) -{ - ffebad error = FFEBAD; - ffebld l; - ffebld r; - ffebldConstantUnion u; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - l = ffebld_left (expr); - r = ffebld_right (expr); - - if (ffebld_op (l) != FFEBLD_opCONTER) - return expr; - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - switch (bt = ffeinfo_basictype (ffebld_info (expr))) - { - case FFEINFO_basictypeANY: - return expr; - - case FFEINFO_basictypeINTEGER: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer1 (ffebld_conter (l)), - ffebld_constant_integer1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val - (ffebld_cu_val_integer1 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer2 (ffebld_conter (l)), - ffebld_constant_integer2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val - (ffebld_cu_val_integer2 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer3 (ffebld_conter (l)), - ffebld_constant_integer3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val - (ffebld_cu_val_integer3 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer4 (ffebld_conter (l)), - ffebld_constant_integer4 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val - (ffebld_cu_val_integer4 (u)), expr); - break; -#endif - - default: - assert ("bad integer kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u), - ffebld_constant_real1 (ffebld_conter (l)), - ffebld_constant_real1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val - (ffebld_cu_val_real1 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u), - ffebld_constant_real2 (ffebld_conter (l)), - ffebld_constant_real2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val - (ffebld_cu_val_real2 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u), - ffebld_constant_real3 (ffebld_conter (l)), - ffebld_constant_real3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val - (ffebld_cu_val_real3 (u)), expr); - break; -#endif - - default: - assert ("bad real kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u), - ffebld_constant_complex1 (ffebld_conter (l)), - ffebld_constant_complex1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val - (ffebld_cu_val_complex1 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u), - ffebld_constant_complex2 (ffebld_conter (l)), - ffebld_constant_complex2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val - (ffebld_cu_val_complex2 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u), - ffebld_constant_complex3 (ffebld_conter (l)), - ffebld_constant_complex3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val - (ffebld_cu_val_complex3 (u)), expr); - break; -#endif - - default: - assert ("bad complex kind type" == NULL); - break; - } - break; - - default: - assert ("bad type" == NULL); - return expr; - } - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - - if ((error != FFEBAD) - && ffebad_start (error)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - return expr; -} - -/* ffeexpr_collapse_subtract -- Collapse subtract expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_subtract(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_subtract (ffebld expr, ffelexToken t) -{ - ffebad error = FFEBAD; - ffebld l; - ffebld r; - ffebldConstantUnion u; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - l = ffebld_left (expr); - r = ffebld_right (expr); - - if (ffebld_op (l) != FFEBLD_opCONTER) - return expr; - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - switch (bt = ffeinfo_basictype (ffebld_info (expr))) - { - case FFEINFO_basictypeANY: - return expr; - - case FFEINFO_basictypeINTEGER: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer1 (ffebld_conter (l)), - ffebld_constant_integer1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val - (ffebld_cu_val_integer1 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer2 (ffebld_conter (l)), - ffebld_constant_integer2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val - (ffebld_cu_val_integer2 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER3 - case FFEINFO_kindtypeINTEGER3: - error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u), - ffebld_constant_integer3 (ffebld_conter (l)), - ffebld_constant_integer3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val - (ffebld_cu_val_integer3 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER4 - case FFEINFO_kindtypeINTEGER4: - error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u), - ffebld_constant_integer4 (ffebld_conter (l)), - ffebld_constant_integer4 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val - (ffebld_cu_val_integer4 (u)), expr); - break; -#endif - - default: - assert ("bad integer kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeREAL: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okREAL1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u), - ffebld_constant_real1 (ffebld_conter (l)), - ffebld_constant_real1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val - (ffebld_cu_val_real1 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u), - ffebld_constant_real2 (ffebld_conter (l)), - ffebld_constant_real2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val - (ffebld_cu_val_real2 (u)), expr); - break; -#endif - -#if FFETARGET_okREAL3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u), - ffebld_constant_real3 (ffebld_conter (l)), - ffebld_constant_real3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val - (ffebld_cu_val_real3 (u)), expr); - break; -#endif - - default: - assert ("bad real kind type" == NULL); - break; - } - break; - - case FFEINFO_basictypeCOMPLEX: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u), - ffebld_constant_complex1 (ffebld_conter (l)), - ffebld_constant_complex1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val - (ffebld_cu_val_complex1 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u), - ffebld_constant_complex2 (ffebld_conter (l)), - ffebld_constant_complex2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val - (ffebld_cu_val_complex2 (u)), expr); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u), - ffebld_constant_complex3 (ffebld_conter (l)), - ffebld_constant_complex3 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val - (ffebld_cu_val_complex3 (u)), expr); - break; -#endif - - default: - assert ("bad complex kind type" == NULL); - break; - } - break; - - default: - assert ("bad type" == NULL); - return expr; - } - - ffebld_set_info (expr, ffeinfo_new - (bt, - kt, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - - if ((error != FFEBAD) - && ffebad_start (error)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - return expr; -} - -/* ffeexpr_collapse_multiply -- Collapse multiply expr - - ffebld expr; - ffelexToken token; - expr = ffeexpr_collapse_multiply(expr,token); - - If the result of the expr is a constant, replaces the expr with the - computed constant. */ - -ffebld -ffeexpr_collapse_multiply (ffebld expr, ffelexToken t) -{ - ffebad error = FFEBAD; - ffebld l; - ffebld r; - ffebldConstantUnion u; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - - if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) - return expr; - - l = ffebld_left (expr); - r = ffebld_right (expr); - - if (ffebld_op (l) != FFEBLD_opCONTER) - return expr; - if (ffebld_op (r) != FFEBLD_opCONTER) - return expr; - - switch (bt = ffeinfo_basictype (ffebld_info (expr))) - { - case FFEINFO_basictypeANY: - return expr; - - case FFEINFO_basictypeINTEGER: - switch (kt = ffeinfo_kindtype (ffebld_info (expr))) - { -#if FFETARGET_okINTEGER1 - case FFEINFO_kindtypeINTEGER1: - error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u), - ffebld_constant_integer1 (ffebld_conter (l)), - ffebld_constant_integer1 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val - (ffebld_cu_val_integer1 (u)), expr); - break; -#endif - -#if FFETARGET_okINTEGER2 - case FFEINFO_kindtypeINTEGER2: - error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u), - ffebld_constant_integer2 (ffebld_conter (l)), - ffebld_constant_integer2 (ffebld_conter (r))); - expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val - (ffebld_cu_val_integer2 (u)), expr); - break; -#endif - -#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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 (void) -{ - ffeexpr_stack_ = NULL; - ffeexpr_level_ = 0; -} - -/* ffeexpr_lhs -- Begin processing left-hand-side-context expression - - Prepares cluster for delivery of lexer tokens representing an expression - in a left-hand-side context (A in A=B, for example). ffebld is used - to build expressions in the given pool. The appropriate lexer-token - handling routine within ffeexpr is returned. When the end of the - expression is detected, mycallbackroutine is called with the resulting - single ffebld object specifying the entire expression and the first - lexer token that is not considered part of the expression. This caller- - supplied routine itself returns a lexer-token handling routine. Thus, - if necessary, ffeexpr can return several tokens as end-of-expression - tokens if it needs to scan forward more than one in any instance. */ - -ffelexHandler -ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) -{ - ffeexprStack_ s; - - ffebld_pool_push (pool); - s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); - s->previous = ffeexpr_stack_; - s->pool = pool; - s->context = context; - s->callback = callback; - s->first_token = NULL; - s->exprstack = NULL; - s->is_rhs = FALSE; - ffeexpr_stack_ = s; - return (ffelexHandler) ffeexpr_token_first_lhs_; -} - -/* ffeexpr_rhs -- Begin processing right-hand-side-context expression - - return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer. - - Prepares cluster for delivery of lexer tokens representing an expression - in a right-hand-side context (B in A=B, for example). ffebld is used - to build expressions in the given pool. The appropriate lexer-token - handling routine within ffeexpr is returned. When the end of the - expression is detected, mycallbackroutine is called with the resulting - single ffebld object specifying the entire expression and the first - lexer token that is not considered part of the expression. This caller- - supplied routine itself returns a lexer-token handling routine. Thus, - if necessary, ffeexpr can return several tokens as end-of-expression - tokens if it needs to scan forward more than one in any instance. */ - -ffelexHandler -ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) -{ - ffeexprStack_ s; - - ffebld_pool_push (pool); - s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); - s->previous = ffeexpr_stack_; - s->pool = pool; - s->context = context; - s->callback = callback; - s->first_token = NULL; - s->exprstack = NULL; - s->is_rhs = TRUE; - ffeexpr_stack_ = s; - return (ffelexHandler) ffeexpr_token_first_rhs_; -} - -/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr - - Pass it to ffeexpr_rhs as the callback routine. - - Makes sure the end token is close-paren and swallows it, else issues - an error message and doesn't swallow the token (passing it along instead). - In either case wraps up subexpression construction by enclosing the - ffebld expression in a paren. */ - -static ffelexHandler -ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ e; - - if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) - { - /* Oops, naughty user didn't specify the close paren! */ - - if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - ffeexpr_exprstack_push_operand_ (e); - - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_token_binary_); - } - - if (expr->op == FFEBLD_opIMPDO) - { - if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - } - else - { - expr = ffebld_new_paren (expr); - ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr)))); - } - - /* Now push the (parenthesized) expression as an operand onto the - expression stack. */ - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->u.operand = expr; - e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft); - e->token = ffeexpr_stack_->tokens[0]; - ffeexpr_exprstack_push_operand_ (e); - - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr - - Pass it to ffeexpr_rhs as the callback routine. - - We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" - with the next token in t. If the next token is possibly a binary - operator, continue processing the outer expression. If the next - token is COMMA, then the expression is a unit specifier, and - parentheses should not be added to it because it surrounds the - I/O control list that starts with the unit specifier (and continues - on from here -- we haven't seen the CLOSE_PAREN that matches the - OPEN_PAREN, it is up to the callback function to expect to see it - at some point). In this case, we notify the callback function that - the COMMA is inside, not outside, the parens by wrapping the expression - in an opITEM (with a NULL trail) -- the callback function presumably - unwraps it after seeing this kludgey indicator. - - If the next token is CLOSE_PAREN, then we go to the _1_ state to - decide what to do with the token after that. - - 15-Feb-91 JCB 1.1 - Use an extra state for the CLOSE_PAREN case to make READ &co really - work right. */ - -static ffelexHandler -ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprCallback callback; - ffeexprStack_ s; - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - { /* Need to see the next token before we - decide anything. */ - ffeexpr_stack_->expr = expr; - ffeexpr_tokens_[0] = ffelex_token_use (ft); - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_; - } - - expr = ffeexpr_finished_ambig_ (ft, expr); - - /* Let the callback function handle the case where t isn't COMMA. */ - - /* Here is a kludge whereby we tell the callback function the OPEN_PAREN - that preceded the expression starts a list of expressions, and the expr - hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN - node. The callback function should extract the real expr from the head - of this opITEM node after testing it. */ - - expr = ffebld_new_item (expr, NULL); - - ffebld_pool_pop (); - callback = ffeexpr_stack_->callback; - ffelex_token_kill (ffeexpr_stack_->first_token); - s = ffeexpr_stack_->previous; - malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); - ffeexpr_stack_ = s; - return (ffelexHandler) (*callback) (ft, expr, t); -} - -/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN - - See ffeexpr_cb_close_paren_ambig_. - - We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" - with the next token in t. If the next token is possibly a binary - operator, continue processing the outer expression. If the next - token is COMMA, the expression is a parenthesized format specifier. - If the next token is not EOS or SEMICOLON, then because it is not a - binary operator (it is NAME, OPEN_PAREN, &c), the expression is - a unit specifier, and parentheses should not be added to it because - they surround the I/O control list that consists of only the unit - specifier. If the next token is EOS or SEMICOLON, the statement - must be disambiguated by looking at the type of the expression -- a - character expression is a parenthesized format specifier, while a - non-character expression is a unit specifier. - - Another issue is how to do the callback so the recipient of the - next token knows how to handle it if it is a COMMA. In all other - cases, disambiguation is straightforward: the same approach as the - above is used. - - EXTENSION: in COMMA case, if not pedantic, use same disambiguation - as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]" - and apparently other compilers do, as well, and some code out there - uses this "feature". - - 19-Feb-91 JCB 1.1 - Extend to allow COMMA as nondisambiguating by itself. Remember - to not try and check info field for opSTAR, since that expr doesn't - have a valid info field. */ - -static ffelexHandler -ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t) -{ - ffeexprCallback callback; - ffeexprStack_ s; - ffelexHandler next; - ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers - these. */ - ffelexToken orig_t = ffeexpr_tokens_[1]; - ffebld expr = ffeexpr_stack_->expr; - - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */ - if (ffe_is_pedantic ()) - goto pedantic_comma; /* :::::::::::::::::::: */ - /* Fall through. */ - case FFELEX_typeEOS: /* Ambiguous; use type of expr to - disambiguate. */ - case FFELEX_typeSEMICOLON: - if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY) - || (ffebld_op (expr) == FFEBLD_opSTAR) - || (ffeinfo_basictype (ffebld_info (expr)) - != FFEINFO_basictypeCHARACTER)) - break; /* Not a valid CHARACTER entity, can't be a - format spec. */ - /* Fall through. */ - default: /* Binary op (we assume; error otherwise); - format specifier. */ - - pedantic_comma: /* :::::::::::::::::::: */ - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFILENUMAMBIG: - ffeexpr_stack_->context = FFEEXPR_contextFILENUM; - break; - - case FFEEXPR_contextFILEUNITAMBIG: - ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; - break; - - default: - assert ("bad context" == NULL); - break; - } - - ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); - next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t); - ffelex_token_kill (orig_ft); - ffelex_token_kill (orig_t); - return (ffelexHandler) (*next) (t); - - case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */ - case FFELEX_typeNAME: - break; - } - - expr = ffeexpr_finished_ambig_ (orig_ft, expr); - - /* Here is a kludge whereby we tell the callback function the OPEN_PAREN - that preceded the expression starts a list of expressions, and the expr - hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN - node. The callback function should extract the real expr from the head - of this opITEM node after testing it. */ - - expr = ffebld_new_item (expr, NULL); - - ffebld_pool_pop (); - callback = ffeexpr_stack_->callback; - ffelex_token_kill (ffeexpr_stack_->first_token); - s = ffeexpr_stack_->previous; - malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); - ffeexpr_stack_ = s; - next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t); - ffelex_token_kill (orig_ft); - ffelex_token_kill (orig_t); - return (ffelexHandler) (*next) (t); -} - -/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex) - - Pass it to ffeexpr_rhs as the callback routine. - - Makes sure the end token is close-paren and swallows it, or a comma - and handles complex/implied-do possibilities, else issues - an error message and doesn't swallow the token (passing it along instead). */ - -static ffelexHandler -ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - /* First check to see if this is a possible complex entity. It is if the - token is a comma. */ - - if (ffelex_token_type (t) == FFELEX_typeCOMMA) - { - ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); - ffeexpr_stack_->expr = expr; - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_); - } - - return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); -} - -/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr - - Pass it to ffeexpr_rhs as the callback routine. - - If this token is not a comma, we have a complex constant (or an attempt - at one), so handle it accordingly, displaying error messages if the token - is not a close-paren. */ - -static ffelexHandler -ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ e; - ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL) - ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr)); - ffeinfoBasictype rty = (expr == NULL) - ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr)); - ffeinfoKindtype lkt; - ffeinfoKindtype rkt; - ffeinfoKindtype nkt; - bool ok = TRUE; - ffebld orig; - - if ((ffeexpr_stack_->expr == NULL) - || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER) - || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL) - && (((ffebld_op (orig) != FFEBLD_opUMINUS) - && (ffebld_op (orig) != FFEBLD_opUPLUS)) - || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) - || ((lty != FFEINFO_basictypeINTEGER) - && (lty != FFEINFO_basictypeREAL))) - { - if ((lty != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), - ffelex_token_where_column (ffeexpr_stack_->tokens[1])); - ffebad_string ("Real"); - ffebad_finish (); - } - ok = FALSE; - } - if ((expr == NULL) - || (ffebld_op (expr) != FFEBLD_opCONTER) - || (((orig = ffebld_conter_orig (expr)) != NULL) - && (((ffebld_op (orig) != FFEBLD_opUMINUS) - && (ffebld_op (orig) != FFEBLD_opUPLUS)) - || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) - || ((rty != FFEINFO_basictypeINTEGER) - && (rty != FFEINFO_basictypeREAL))) - { - if ((rty != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) - { - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_string ("Imaginary"); - ffebad_finish (); - } - ok = FALSE; - } - - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - - /* Push the (parenthesized) expression as an operand onto the expression - stack. */ - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_stack_->tokens[0]; - - if (ok) - { - if (lty == FFEINFO_basictypeINTEGER) - lkt = FFEINFO_kindtypeREALDEFAULT; - else - lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr)); - if (rty == FFEINFO_basictypeINTEGER) - rkt = FFEINFO_kindtypeREALDEFAULT; - else - rkt = ffeinfo_kindtype (ffebld_info (expr)); - - nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt); - ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr, - ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], - FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - expr = ffeexpr_convert (expr, - ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], - FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - } - else - nkt = FFEINFO_kindtypeANY; - - switch (nkt) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: - e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1 - (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, - FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - break; -#endif - -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: - e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2 - (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, - FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - break; -#endif - -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: - e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3 - (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, - FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - break; -#endif - - default: - if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) - ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - /* Fall through. */ - case FFEINFO_kindtypeANY: - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - break; - } - ffeexpr_exprstack_push_operand_ (e); - - /* Now, if the token is a close parenthese, we're in great shape so return - the next handler. */ - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_token_binary_; - - /* Oops, naughty user didn't specify the close paren! */ - - if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_token_binary_); -} - -/* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or - implied-DO construct) - - Pass it to ffeexpr_rhs as the callback routine. - - Makes sure the end token is close-paren and swallows it, or a comma - and handles complex/implied-do possibilities, else issues - an error message and doesn't swallow the token (passing it along instead). */ - -static ffelexHandler -ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprContext ctx; - - /* First check to see if this is a possible complex or implied-DO entity. - It is if the token is a comma. */ - - if (ffelex_token_type (t) == FFELEX_typeCOMMA) - { - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIMPDOITEM_: - ctx = FFEEXPR_contextIMPDOITEM_; - break; - - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextIMPDOITEMDF_: - ctx = FFEEXPR_contextIMPDOITEMDF_; - break; - - default: - assert ("bad context" == NULL); - ctx = FFEEXPR_contextIMPDOITEM_; - break; - } - - ffeexpr_stack_->tokens[0] = ffelex_token_use (ft); - ffeexpr_stack_->expr = expr; - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - ctx, ffeexpr_cb_comma_ci_); - } - - ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); - return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); -} - -/* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr - - Pass it to ffeexpr_rhs as the callback routine. - - If this token is not a comma, we have a complex constant (or an attempt - at one), so handle it accordingly, displaying error messages if the token - is not a close-paren. If we have a comma here, it is an attempt at an - implied-DO, so start making a list accordingly. Oh, it might be an - equal sign also, meaning an implied-DO with only one item in its list. */ - -static ffelexHandler -ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffebld fexpr; - - /* First check to see if this is a possible complex constant. It is if the - token is not a comma or an equals sign, in which case it should be a - close-paren. */ - - if ((ffelex_token_type (t) != FFELEX_typeCOMMA) - && (ffelex_token_type (t) != FFELEX_typeEQUALS)) - { - ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0]; - ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); - return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t); - } - - /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO - construct. Make a list and handle accordingly. */ - - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - fexpr = ffeexpr_stack_->expr; - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - ffebld_append_item (&ffeexpr_stack_->bottom, fexpr); - return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); -} - -/* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr - - Pass it to ffeexpr_rhs as the callback routine. - - Handle first item in an implied-DO construct. */ - -static ffelexHandler -ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeCOMMA) - { - if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffebld_end_list (&ffeexpr_stack_->bottom); - ffeexpr_stack_->expr = ffebld_new_any (); - ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); - if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); - return (ffelexHandler) ffeexpr_cb_comma_i_5_; - } - - return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); -} - -/* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr - - Pass it to ffeexpr_rhs as the callback routine. - - Handle first item in an implied-DO construct. */ - -static ffelexHandler -ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprContext ctxi; - ffeexprContext ctxc; - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATA: - case FFEEXPR_contextDATAIMPDOITEM_: - ctxi = FFEEXPR_contextDATAIMPDOITEM_; - ctxc = FFEEXPR_contextDATAIMPDOCTRL_; - break; - - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIMPDOITEM_: - ctxi = FFEEXPR_contextIMPDOITEM_; - ctxc = FFEEXPR_contextIMPDOCTRL_; - break; - - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextIMPDOITEMDF_: - ctxi = FFEEXPR_contextIMPDOITEMDF_; - ctxc = FFEEXPR_contextIMPDOCTRL_; - break; - - default: - assert ("bad context" == NULL); - ctxi = FFEEXPR_context; - ctxc = FFEEXPR_context; - break; - } - - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - if (ffeexpr_stack_->is_rhs) - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - ctxi, ffeexpr_cb_comma_i_1_); - return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, - ctxi, ffeexpr_cb_comma_i_1_); - - case FFELEX_typeEQUALS: - ffebld_end_list (&ffeexpr_stack_->bottom); - - /* Complain if implied-DO variable in list of items to be read. */ - - if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs) - ffeexpr_check_impdo_ (ffeexpr_stack_->expr, - ffeexpr_stack_->first_token, expr, ft); - - /* Set doiter flag for all appropriate SYMTERs. */ - - ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr); - - ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL); - ffebld_set_info (ffeexpr_stack_->expr, - ffeinfo_new (FFEINFO_basictypeNONE, - FFEINFO_kindtypeNONE, - 0, - FFEINFO_kindNONE, - FFEINFO_whereNONE, - FFETARGET_charactersizeNONE)); - ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)), - &ffeexpr_stack_->bottom); - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - ctxc, ffeexpr_cb_comma_i_2_); - - default: - if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffebld_end_list (&ffeexpr_stack_->bottom); - ffeexpr_stack_->expr = ffebld_new_any (); - ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); - if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); - return (ffelexHandler) ffeexpr_cb_comma_i_5_; - } -} - -/* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr - - Pass it to ffeexpr_rhs as the callback routine. - - Handle start-value in an implied-DO construct. */ - -static ffelexHandler -ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) -{ - ffeexprContext ctx; - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATA: - case FFEEXPR_contextDATAIMPDOITEM_: - ctx = FFEEXPR_contextDATAIMPDOCTRL_; - break; - - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextIMPDOITEM_: - case FFEEXPR_contextIMPDOITEMDF_: - ctx = FFEEXPR_contextIMPDOCTRL_; - break; - - default: - assert ("bad context" == NULL); - ctx = FFEEXPR_context; - break; - } - - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - ctx, ffeexpr_cb_comma_i_3_); - break; - - default: - if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffebld_end_list (&ffeexpr_stack_->bottom); - ffeexpr_stack_->expr = ffebld_new_any (); - ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); - if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); - return (ffelexHandler) ffeexpr_cb_comma_i_5_; - } -} - -/* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr - - Pass it to ffeexpr_rhs as the callback routine. - - Handle end-value in an implied-DO construct. */ - -static ffelexHandler -ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) -{ - ffeexprContext ctx; - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATA: - case FFEEXPR_contextDATAIMPDOITEM_: - ctx = FFEEXPR_contextDATAIMPDOCTRL_; - break; - - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextIMPDOITEM_: - case FFEEXPR_contextIMPDOITEMDF_: - ctx = FFEEXPR_contextIMPDOCTRL_; - break; - - default: - assert ("bad context" == NULL); - ctx = FFEEXPR_context; - break; - } - - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - ctx, ffeexpr_cb_comma_i_4_); - break; - - case FFELEX_typeCLOSE_PAREN: - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t); - break; - - default: - if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffebld_end_list (&ffeexpr_stack_->bottom); - ffeexpr_stack_->expr = ffebld_new_any (); - ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); - if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); - return (ffelexHandler) ffeexpr_cb_comma_i_5_; - } -} - -/* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr - [COMMA expr] - - Pass it to ffeexpr_rhs as the callback routine. - - Handle incr-value in an implied-DO construct. */ - -static ffelexHandler -ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeCLOSE_PAREN: - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - ffebld_end_list (&ffeexpr_stack_->bottom); - { - ffebld item; - - for (item = ffebld_left (ffeexpr_stack_->expr); - item != NULL; - item = ffebld_trail (item)) - if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY) - goto replace_with_any; /* :::::::::::::::::::: */ - - for (item = ffebld_right (ffeexpr_stack_->expr); - item != NULL; - item = ffebld_trail (item)) - if ((ffebld_head (item) != NULL) /* Increment may be NULL. */ - && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)) - goto replace_with_any; /* :::::::::::::::::::: */ - } - break; - - default: - if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffebld_end_list (&ffeexpr_stack_->bottom); - - replace_with_any: /* :::::::::::::::::::: */ - - ffeexpr_stack_->expr = ffebld_new_any (); - ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); - break; - } - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_cb_comma_i_5_; - return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); -} - -/* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr - [COMMA expr] CLOSE_PAREN - - Pass it to ffeexpr_rhs as the callback routine. - - Collects token following implied-DO construct for callback function. */ - -static ffelexHandler -ffeexpr_cb_comma_i_5_ (ffelexToken t) -{ - ffeexprCallback callback; - ffeexprStack_ s; - ffelexHandler next; - ffelexToken ft; - ffebld expr; - bool terminate; - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATA: - case FFEEXPR_contextDATAIMPDOITEM_: - terminate = TRUE; - break; - - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextIMPDOITEM_: - case FFEEXPR_contextIMPDOITEMDF_: - terminate = FALSE; - break; - - default: - assert ("bad context" == NULL); - terminate = FALSE; - break; - } - - ffebld_pool_pop (); - callback = ffeexpr_stack_->callback; - ft = ffeexpr_stack_->first_token; - expr = ffeexpr_stack_->expr; - s = ffeexpr_stack_->previous; - malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, - sizeof (*ffeexpr_stack_)); - ffeexpr_stack_ = s; - next = (ffelexHandler) (*callback) (ft, expr, t); - ffelex_token_kill (ft); - if (terminate) - { - ffesymbol_drive_sfnames (ffeexpr_check_impctrl_); - --ffeexpr_level_; - if (ffeexpr_level_ == 0) - ffe_terminate_4 (); - } - return (ffelexHandler) next; -} - -/* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression - - Makes sure the end token is close-paren and swallows it, else issues - an error message and doesn't swallow the token (passing it along instead). - In either case wraps up subexpression construction by enclosing the - ffebld expression in a %LOC. */ - -static ffelexHandler -ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ e; - - /* First push the (%LOC) expression as an operand onto the expression - stack. */ - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_stack_->tokens[0]; - e->u.operand = ffebld_new_percent_loc (expr); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeINTEGER, - ffecom_pointer_kind (), - 0, - FFEINFO_kindENTITY, - FFEINFO_whereFLEETING, - FFETARGET_charactersizeNONE)); -#if 0 /* ~~ */ - e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft); -#endif - ffeexpr_exprstack_push_operand_ (e); - - /* Now, if the token is a close parenthese, we're in great shape so return - the next handler. */ - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - { - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - return (ffelexHandler) ffeexpr_token_binary_; - } - - /* Oops, naughty user didn't specify the close paren! */ - - if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), - ffelex_token_where_column (ffeexpr_stack_->tokens[1])); - ffebad_finish (); - } - - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_token_binary_); -} - -/* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr - - Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */ - -static ffelexHandler -ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ e; - ffebldOp op; - - /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all - such things until the lowest-level expression is reached. */ - - op = ffebld_op (expr); - if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) - || (op == FFEBLD_opPERCENT_DESCR)) - { - if (ffebad_start (FFEBAD_NESTED_PERCENT)) - { - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_finish (); - } - - do - { - expr = ffebld_left (expr); - op = ffebld_op (expr); - } - while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) - || (op == FFEBLD_opPERCENT_DESCR)); - } - - /* Push the expression as an operand onto the expression stack. */ - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_stack_->tokens[0]; - switch (ffeexpr_stack_->percent) - { - case FFEEXPR_percentVAL_: - e->u.operand = ffebld_new_percent_val (expr); - break; - - case FFEEXPR_percentREF_: - e->u.operand = ffebld_new_percent_ref (expr); - break; - - case FFEEXPR_percentDESCR_: - e->u.operand = ffebld_new_percent_descr (expr); - break; - - default: - assert ("%lossage" == NULL); - e->u.operand = expr; - break; - } - ffebld_set_info (e->u.operand, ffebld_info (expr)); -#if 0 /* ~~ */ - e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft); -#endif - ffeexpr_exprstack_push_operand_ (e); - - /* Now, if the token is a close parenthese, we're in great shape so return - the next handler. */ - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - return (ffelexHandler) ffeexpr_cb_end_notloc_1_; - - /* Oops, naughty user didn't specify the close paren! */ - - if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) - { - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), - ffelex_token_where_column (ffeexpr_stack_->tokens[1])); - ffebad_finish (); - } - - ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC); - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; - break; - - case FFEEXPR_contextINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; - break; - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; - break; - - default: - assert ("bad context?!?!" == NULL); - break; - } - - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_cb_end_notloc_1_); -} - -/* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr - CLOSE_PAREN - - Should be COMMA or CLOSE_PAREN, else change back to %LOC. */ - -static ffelexHandler -ffeexpr_cb_end_notloc_1_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: - case FFELEX_typeCLOSE_PAREN: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextACTUALARG_: - case FFEEXPR_contextSFUNCDEFACTUALARG_: - break; - - case FFEEXPR_contextINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; - break; - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; - break; - - default: - assert ("bad context?!?!" == NULL); - break; - } - break; - - default: - if (ffebad_start (FFEBAD_INVALID_PERCENT)) - { - ffebad_here (0, - ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1])); - ffebad_finish (); - } - - ffebld_set_op (ffeexpr_stack_->exprstack->u.operand, - FFEBLD_opPERCENT_LOC); - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; - break; - - case FFEEXPR_contextINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; - break; - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; - break; - - default: - assert ("bad context?!?!" == NULL); - break; - } - } - - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - return - (ffelexHandler) ffeexpr_token_binary_ (t); -} - -/* Process DATA implied-DO iterator variables as this implied-DO level - terminates. At this point, ffeexpr_level_ == 1 when we see the - last right-paren in "DATA (A(I),I=1,10)/.../". */ - -static ffesymbol -ffeexpr_check_impctrl_ (ffesymbol s) -{ - assert (s != NULL); - assert (ffesymbol_sfdummyparent (s) != NULL); - - switch (ffesymbol_state (s)) - { - case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol - be used as iterator at any level at or - innermore than the outermost of the - current level and the symbol's current - level. */ - if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) - { - ffesymbol_signal_change (s); - ffesymbol_set_maxentrynum (s, ffeexpr_level_); - ffesymbol_signal_unreported (s); - } - break; - - case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. - Error if at outermost level, else it can - still become an iterator. */ - if ((ffeexpr_level_ == 1) - && ffebad_start (FFEBAD_BAD_IMPDCL)) - { - ffebad_string (ffesymbol_text (s)); - ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); - ffebad_finish (); - } - break; - - case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ - assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s)); - ffesymbol_signal_change (s); - ffesymbol_set_state (s, FFESYMBOL_stateNONE); - ffesymbol_signal_unreported (s); - break; - - case FFESYMBOL_stateUNDERSTOOD: - break; /* ANY. */ - - default: - assert ("Sasha Foo!!" == NULL); - break; - } - - return s; -} - -/* Issue diagnostic if implied-DO variable appears in list of lhs - expressions (as in "READ *, (I,I=1,10)"). */ - -static void -ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, - ffebld dovar, ffelexToken dovar_t) -{ - ffebld item; - ffesymbol dovar_sym; - int itemnum; - - if (ffebld_op (dovar) != FFEBLD_opSYMTER) - return; /* Presumably opANY. */ - - dovar_sym = ffebld_symter (dovar); - - for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum) - { - if (((item = ffebld_head (list)) != NULL) - && (ffebld_op (item) == FFEBLD_opSYMTER) - && (ffebld_symter (item) == dovar_sym)) - { - char itemno[20]; - - sprintf (&itemno[0], "%d", itemnum); - if (ffebad_start (FFEBAD_DOITER_IMPDO)) - { - ffebad_here (0, ffelex_token_where_line (list_t), - ffelex_token_where_column (list_t)); - ffebad_here (1, ffelex_token_where_line (dovar_t), - ffelex_token_where_column (dovar_t)); - ffebad_string (ffesymbol_text (dovar_sym)); - ffebad_string (itemno); - ffebad_finish (); - } - } - } -} - -/* Decorate any SYMTERs referencing the DO variable with the "doiter" - flag. */ - -static void -ffeexpr_update_impdo_ (ffebld list, ffebld dovar) -{ - ffesymbol dovar_sym; - - if (ffebld_op (dovar) != FFEBLD_opSYMTER) - return; /* Presumably opANY. */ - - dovar_sym = ffebld_symter (dovar); - - ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */ -} - -/* Recursive function to update any expr so SYMTERs have "doiter" flag - if they refer to the given variable. */ - -static void -ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar) -{ - tail_recurse: /* :::::::::::::::::::: */ - - if (expr == NULL) - return; - - switch (ffebld_op (expr)) - { - case FFEBLD_opSYMTER: - if (ffebld_symter (expr) == dovar) - ffebld_symter_set_is_doiter (expr, TRUE); - break; - - case FFEBLD_opITEM: - ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar); - expr = ffebld_trail (expr); - goto tail_recurse; /* :::::::::::::::::::: */ - - default: - break; - } - - switch (ffebld_arity (expr)) - { - case 2: - ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar); - expr = ffebld_right (expr); - goto tail_recurse; /* :::::::::::::::::::: */ - - case 1: - expr = ffebld_left (expr); - goto tail_recurse; /* :::::::::::::::::::: */ - - default: - break; - } - - return; -} - -/* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs - - if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF) - // After zero or more PAREN_ contexts, an IF context exists */ - -static ffeexprContext -ffeexpr_context_outer_ (ffeexprStack_ s) -{ - assert (s != NULL); - - for (;;) - { - switch (s->context) - { - case FFEEXPR_contextPAREN_: - case FFEEXPR_contextPARENFILENUM_: - case FFEEXPR_contextPARENFILEUNIT_: - break; - - default: - return s->context; - } - s = s->previous; - assert (s != NULL); - } -} - -/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities - - ffeexprPercent_ p; - ffelexToken t; - p = ffeexpr_percent_(t); - - Returns the identifier for the name, or the NONE identifier. */ - -static ffeexprPercent_ -ffeexpr_percent_ (ffelexToken t) -{ - const char *p; - - switch (ffelex_token_length (t)) - { - case 3: - switch (*(p = ffelex_token_text (t))) - { - case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3): - if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) - && (ffesrc_char_match_noninit (*++p, 'C', 'c'))) - return FFEEXPR_percentLOC_; - return FFEEXPR_percentNONE_; - - case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3): - if ((ffesrc_char_match_noninit (*++p, 'E', 'e')) - && (ffesrc_char_match_noninit (*++p, 'F', 'f'))) - return FFEEXPR_percentREF_; - return FFEEXPR_percentNONE_; - - case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3): - if ((ffesrc_char_match_noninit (*++p, 'A', 'a')) - && (ffesrc_char_match_noninit (*++p, 'L', 'l'))) - return FFEEXPR_percentVAL_; - return FFEEXPR_percentNONE_; - - default: - no_match_3: /* :::::::::::::::::::: */ - return FFEEXPR_percentNONE_; - } - - case 5: - if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR", - "descr", "Descr") == 0) - return FFEEXPR_percentDESCR_; - return FFEEXPR_percentNONE_; - - default: - return FFEEXPR_percentNONE_; - } -} - -/* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX - - See prototype. - - If combining the two basictype/kindtype pairs produces a COMPLEX with an - unsupported kind type, complain and use the default kind type for - COMPLEX. */ - -void -ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt, - ffeinfoBasictype lbt, ffeinfoKindtype lkt, - ffeinfoBasictype rbt, ffeinfoKindtype rkt, - ffelexToken t) -{ - ffeinfoBasictype nbt; - ffeinfoKindtype nkt; - - nbt = ffeinfo_basictype_combine (lbt, rbt); - if ((nbt == FFEINFO_basictypeCOMPLEX) - && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL)) - && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL))) - { - nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); - if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE)) - nkt = FFEINFO_kindtypeNONE; /* Force error. */ - switch (nkt) - { -#if FFETARGET_okCOMPLEX1 - case FFEINFO_kindtypeREAL1: -#endif -#if FFETARGET_okCOMPLEX2 - case FFEINFO_kindtypeREAL2: -#endif -#if FFETARGET_okCOMPLEX3 - case FFEINFO_kindtypeREAL3: -#endif - 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_ (void) -{ - ffeexprExpr_ e; - - e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e)); - e->previous = NULL; - e->type = FFEEXPR_exprtypeUNKNOWN_; - e->token = NULL; - return e; -} - -/* Verify that call to global is valid, and register whatever - new information about a global might be discoverable by looking - at the call. */ - -static void -ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t) -{ - int n_args; - ffebld list; - ffebld item; - ffesymbol s; - - assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF) - || (ffebld_op (*expr) == FFEBLD_opFUNCREF)); - - if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER) - return; - - if (ffesymbol_retractable ()) - return; - - s = ffebld_symter (ffebld_left (*expr)); - if (ffesymbol_global (s) == NULL) - return; - - for (n_args = 0, list = ffebld_right (*expr); - list != NULL; - list = ffebld_trail (list), ++n_args) - ; - - if (ffeglobal_proc_ref_nargs (s, n_args, t)) - { - ffeglobalArgSummary as; - ffeinfoBasictype bt; - ffeinfoKindtype kt; - bool array; - bool fail = FALSE; - - for (n_args = 0, list = ffebld_right (*expr); - list != NULL; - list = ffebld_trail (list), ++n_args) - { - item = ffebld_head (list); - if (item != NULL) - { - bt = ffeinfo_basictype (ffebld_info (item)); - kt = ffeinfo_kindtype (ffebld_info (item)); - array = (ffeinfo_rank (ffebld_info (item)) > 0); - switch (ffebld_op (item)) - { - case FFEBLD_opLABTOK: - case FFEBLD_opLABTER: - as = FFEGLOBAL_argsummaryALTRTN; - break; - -#if 0 - /* No, %LOC(foo) is just like any INTEGER(KIND=7) - expression, so don't treat it specially. */ - case FFEBLD_opPERCENT_LOC: - as = FFEGLOBAL_argsummaryPTR; - break; -#endif - - case FFEBLD_opPERCENT_VAL: - as = FFEGLOBAL_argsummaryVAL; - break; - - case FFEBLD_opPERCENT_REF: - as = FFEGLOBAL_argsummaryREF; - break; - - case FFEBLD_opPERCENT_DESCR: - as = FFEGLOBAL_argsummaryDESCR; - break; - - case FFEBLD_opFUNCREF: -#if 0 - /* No, LOC(foo) is just like any INTEGER(KIND=7) - expression, so don't treat it specially. */ - if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER) - && (ffesymbol_specific (ffebld_symter (ffebld_left (item))) - == FFEINTRIN_specLOC)) - { - as = FFEGLOBAL_argsummaryPTR; - break; - } -#endif - /* Fall through. */ - default: - if (ffebld_op (item) == FFEBLD_opSYMTER) - { - as = FFEGLOBAL_argsummaryNONE; - - switch (ffeinfo_kind (ffebld_info (item))) - { - case FFEINFO_kindFUNCTION: - as = FFEGLOBAL_argsummaryFUNC; - break; - - case FFEINFO_kindSUBROUTINE: - as = FFEGLOBAL_argsummarySUBR; - break; - - case FFEINFO_kindNONE: - as = FFEGLOBAL_argsummaryPROC; - break; - - default: - break; - } - - if (as != FFEGLOBAL_argsummaryNONE) - break; - } - - if (bt == FFEINFO_basictypeCHARACTER) - as = FFEGLOBAL_argsummaryDESCR; - else - as = FFEGLOBAL_argsummaryREF; - break; - } - } - else - { - array = FALSE; - as = FFEGLOBAL_argsummaryNONE; - bt = FFEINFO_basictypeNONE; - kt = FFEINFO_kindtypeNONE; - } - - if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t)) - fail = TRUE; - } - if (! fail) - return; - } - - *expr = ffebld_new_any (); - ffebld_set_info (*expr, ffeinfo_new_any ()); -} - -/* Check whether rest of string is all decimal digits. */ - -static bool -ffeexpr_isdigits_ (const char *p) -{ - for (; *p != '\0'; ++p) - if (! ISDIGIT (*p)) - return FALSE; - return TRUE; -} - -/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack - - ffeexprExpr_ e; - ffeexpr_exprstack_push_(e); - - Pushes the expression onto the stack without any analysis of the existing - contents of the stack. */ - -static void -ffeexpr_exprstack_push_ (ffeexprExpr_ e) -{ - e->previous = ffeexpr_stack_->exprstack; - ffeexpr_stack_->exprstack = e; -} - -/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce? - - ffeexprExpr_ e; - ffeexpr_exprstack_push_operand_(e); - - Pushes the expression already containing an operand (a constant, variable, - or more complicated expression that has already been fully resolved) after - analyzing the stack and checking for possible reduction (which will never - happen here since the highest precedence operator is ** and it has right- - to-left associativity). */ - -static void -ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e) -{ - ffeexpr_exprstack_push_ (e); -} - -/* 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_)) - { - /* xgettext:no-c-format */ - 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)) - { - /* xgettext:no-c-format */ - 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_ (void) -{ - 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; - bool bothlogical; - - 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, &bothlogical); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_and (reduced, operator->token); - if (ffe_is_ugly_logint() && bothlogical) - reduced = ffeexpr_convert (reduced, left_operand->token, - operator->token, - FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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, &bothlogical); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_or (reduced, operator->token); - if (ffe_is_ugly_logint() && bothlogical) - reduced = ffeexpr_convert (reduced, left_operand->token, - operator->token, - FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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, &bothlogical); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_xor (reduced, operator->token); - if (ffe_is_ugly_logint() && bothlogical) - reduced = ffeexpr_convert (reduced, left_operand->token, - operator->token, - FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - 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, NULL); - 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, NULL); - reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, - operand); - reduced = ffeexpr_collapse_neqv (reduced, operator->token); - break; - - default: - assert ("bad bin op" == NULL); - reduced = expr; - break; - } - if ((ffebld_op (left_expr) == FFEBLD_opCONTER) - && (ffebld_conter_orig (expr) == NULL) - && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr))) - { - if ((left_operand->previous != NULL) - && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_) - && (left_operand->previous->u.operator.op - == FFEEXPR_operatorSUBTRACT_)) - { - if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_) - ffetarget_integer_bad_magical_precedence (left_operand->token, - left_operand->previous->token, - operator->token); - else - ffetarget_integer_bad_magical_precedence_binary - (left_operand->token, - left_operand->previous->token, - operator->token); - } - else - ffetarget_integer_bad_magical (left_operand->token); - } - if ((ffebld_op (expr) == FFEBLD_opCONTER) - && (ffebld_conter_orig (expr) == NULL) - && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) - { - if (submag) - ffetarget_integer_bad_magical_binary (operand->token, - operator->token); - else - ffetarget_integer_bad_magical (operand->token); - } - ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op - operands off stack. */ - ffeexpr_expr_kill_ (left_operand); - ffeexpr_expr_kill_ (operand); - operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but - save */ - operator->u.operand = reduced; /* the line/column ffewhere info. */ - ffeexpr_exprstack_push_operand_ (operator); /* Push it back on - stack. */ - } -} - -/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator - - reduced = ffeexpr_reduced_bool1_(reduced,op,r); - - Makes sure the argument for reduced has basictype of - LOGICAL or (ugly) INTEGER. If - argument has where of CONSTANT, assign where CONSTANT to - reduced, else assign where FLEETING. - - If these requirements cannot be met, generate error message. */ - -static ffebld -ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) -{ - ffeinfo rinfo, ninfo; - ffeinfoBasictype rbt; - ffeinfoKindtype rkt; - ffeinfoRank rrk; - ffeinfoKind rkd; - ffeinfoWhere rwh, nwh; - - rinfo = ffebld_info (ffebld_left (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - if (((rbt == FFEINFO_basictypeLOGICAL) - || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER))) - && (rrk == 0)) - { - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, - FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - return reduced; - } - - if ((rbt != FFEINFO_basictypeLOGICAL) - && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_NOT_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_NOT_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators - - reduced = ffeexpr_reduced_bool2_(reduced,l,op,r); - - Makes sure the left and right arguments for reduced have basictype of - LOGICAL or (ugly) INTEGER. Determine common basictype and - size for reduction (flag expression for combined hollerith/typeless - situations for later determination of effective basictype). If both left - and right arguments have where of CONSTANT, assign where CONSTANT to - reduced, else assign where FLEETING. Create CONVERT ops for args where - needed. Convert typeless - constants to the desired type/size explicitly. - - If these requirements cannot be met, generate error message. */ - -static ffebld -ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo, ninfo; - ffeinfoBasictype lbt, rbt, nbt; - ffeinfoKindtype lkt, rkt, nkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd; - ffeinfoWhere lwh, rwh, nwh; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); - - if (((nbt == FFEINFO_basictypeLOGICAL) - || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER))) - && (lrk == 0) && (rrk == 0)) - { - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, - FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - return reduced; - } - - if ((lbt != FFEINFO_basictypeLOGICAL) - && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER))) - { - if ((rbt != FFEINFO_basictypeLOGICAL) - && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) - { - if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_BOOL_ARGS_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((lbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_finish (); - } - } - } - else if ((rbt != FFEINFO_basictypeLOGICAL) - && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if (lrk != 0) - { - if ((lkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_BOOL_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_BOOL_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator - - reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r); - - Makes sure the left and right arguments for reduced have basictype of - CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign - basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective - size of concatenation and assign that size to reduced. If both left and - right arguments have where of CONSTANT, assign where CONSTANT to reduced, - else assign where FLEETING. - - If these requirements cannot be met, generate error message using the - info in l, op, and r arguments and assign basictype, size, kind, and where - of ANY. */ - -static ffebld -ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo, ninfo; - ffeinfoBasictype lbt, rbt, nbt; - ffeinfoKindtype lkt, rkt, nkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd, nkd; - ffeinfoWhere lwh, rwh, nwh; - ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - lszk = ffeinfo_size (linfo); /* Known size. */ - lszm = ffebld_size_max (ffebld_left (reduced)); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - rszk = ffeinfo_size (rinfo); /* Known size. */ - rszm = ffebld_size_max (ffebld_right (reduced)); - - if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER) - && (lkt == rkt) && (lrk == 0) && (rrk == 0) - && (((lszm != FFETARGET_charactersizeNONE) - && (rszm != FFETARGET_charactersizeNONE)) - || (ffeexpr_context_outer_ (ffeexpr_stack_) - == FFEEXPR_contextLET) - || (ffeexpr_context_outer_ (ffeexpr_stack_) - == FFEEXPR_contextSFUNCDEF))) - { - nbt = FFEINFO_basictypeCHARACTER; - nkd = FFEINFO_kindENTITY; - if ((lszk == FFETARGET_charactersizeNONE) - || (rszk == FFETARGET_charactersizeNONE)) - nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET - stmt. */ - else - nszk = lszk + rszk; - - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - nkt = lkt; - ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk); - ffebld_set_info (reduced, ninfo); - return reduced; - } - - if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER)) - { - if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if (lbt != FFEINFO_basictypeCHARACTER) - { - if ((lbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_finish (); - } - } - else if (rbt != FFEINFO_basictypeCHARACTER) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE)) - { - if ((lkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_CONCAT_ARG_KIND)) - { - const char *what; - - if (lrk != 0) - what = "an array"; - else - what = "of indeterminate length"; - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_string (what); - ffebad_finish (); - } - } - else - { - if (ffebad_start (FFEBAD_CONCAT_ARG_KIND)) - { - const char *what; - - if (rrk != 0) - what = "an array"; - else - what = "of indeterminate length"; - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string (what); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators - - reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r); - - Makes sure the left and right arguments for reduced have basictype of - INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and - size for reduction. If both left - and right arguments have where of CONSTANT, assign where CONSTANT to - reduced, else assign where FLEETING. Create CONVERT ops for args where - needed. Convert typeless - constants to the desired type/size explicitly. - - If these requirements cannot be met, generate error message. */ - -static ffebld -ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo, ninfo; - ffeinfoBasictype lbt, rbt, nbt; - ffeinfoKindtype lkt, rkt, nkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd; - ffeinfoWhere lwh, rwh, nwh; - ffetargetCharacterSize lsz, rsz; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - lsz = ffebld_size_known (ffebld_left (reduced)); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - rsz = ffebld_size_known (ffebld_right (reduced)); - - ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); - - if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) - || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER)) - && (lrk == 0) && (rrk == 0)) - { - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - if ((lsz != FFETARGET_charactersizeNONE) - && (rsz != FFETARGET_charactersizeNONE)) - lsz = rsz = (lsz > rsz) ? lsz : rsz; - - ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, - 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, nbt, nkt, 0, lsz, - FFEEXPR_contextLET)); - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, nbt, nkt, 0, rsz, - FFEEXPR_contextLET)); - return reduced; - } - - if ((lbt == FFEINFO_basictypeLOGICAL) - && (rbt == FFEINFO_basictypeLOGICAL)) - { - /* xgettext:no-c-format */ - if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2", - FFEBAD_severityFATAL)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) - && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER)) - { - if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) - { - if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_EQOP_ARGS_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((lbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_finish (); - } - } - } - else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if (lrk != 0) - { - if ((lkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_EQOP_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_EQOP_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators - - reduced = ffeexpr_reduced_math1_(reduced,op,r); - - Makes sure the argument for reduced has basictype of - INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT, - assign where CONSTANT to - reduced, else assign where FLEETING. - - If these requirements cannot be met, generate error message. */ - -static ffebld -ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) -{ - ffeinfo rinfo, ninfo; - ffeinfoBasictype rbt; - ffeinfoKindtype rkt; - ffeinfoRank rrk; - ffeinfoKind rkd; - ffeinfoWhere rwh, nwh; - - rinfo = ffebld_info (ffebld_left (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL) - || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0)) - { - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, - FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - return reduced; - } - - if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCOMPLEX)) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_MATH_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators - - reduced = ffeexpr_reduced_math2_(reduced,l,op,r); - - Makes sure the left and right arguments for reduced have basictype of - INTEGER, REAL, or COMPLEX. Determine common basictype and - size for reduction (flag expression for combined hollerith/typeless - situations for later determination of effective basictype). If both left - and right arguments have where of CONSTANT, assign where CONSTANT to - reduced, else assign where FLEETING. Create CONVERT ops for args where - needed. Convert typeless - constants to the desired type/size explicitly. - - If these requirements cannot be met, generate error message. */ - -static ffebld -ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo, ninfo; - ffeinfoBasictype lbt, rbt, nbt; - ffeinfoKindtype lkt, rkt, nkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd; - ffeinfoWhere lwh, rwh, nwh; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); - - if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) - || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) - { - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, - FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - return reduced; - } - - if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) - && (lbt != FFEINFO_basictypeCOMPLEX)) - { - if ((rbt != FFEINFO_basictypeINTEGER) - && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) - { - if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((lbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_finish (); - } - } - } - else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCOMPLEX)) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if (lrk != 0) - { - if ((lkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_MATH_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_MATH_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator - - reduced = ffeexpr_reduced_power_(reduced,l,op,r); - - Makes sure the left and right arguments for reduced have basictype of - INTEGER, REAL, or COMPLEX. Determine common basictype and - size for reduction (flag expression for combined hollerith/typeless - situations for later determination of effective basictype). If both left - and right arguments have where of CONSTANT, assign where CONSTANT to - reduced, else assign where FLEETING. Create CONVERT ops for args where - needed. Note that real**int or complex**int - comes out as int = real**int etc with no conversions. - - If these requirements cannot be met, generate error message using the - info in l, op, and r arguments and assign basictype, size, kind, and where - of ANY. */ - -static ffebld -ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo, ninfo; - ffeinfoBasictype lbt, rbt, nbt; - ffeinfoKindtype lkt, rkt, nkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd; - ffeinfoWhere lwh, rwh, nwh; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - if ((rbt == FFEINFO_basictypeINTEGER) - && ((lbt == FFEINFO_basictypeREAL) - || (lbt == FFEINFO_basictypeCOMPLEX))) - { - nbt = lbt; - nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT); - if (nkt != FFEINFO_kindtypeREALDEFAULT) - { - nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE); - if (nkt != FFEINFO_kindtypeREALDOUBLE) - nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ - } - if (rkt == FFEINFO_kindtypeINTEGER4) - { - /* xgettext:no-c-format */ - ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER", - FFEBAD_severityWARNING); - ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - if (rkt != FFEINFO_kindtypeINTEGERDEFAULT) - { - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, - FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - rkt = FFEINFO_kindtypeINTEGERDEFAULT; - } - } - else - { - ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); - -#if 0 /* INTEGER4**INTEGER4 works now. */ - if ((nbt == FFEINFO_basictypeINTEGER) - && (nkt != FFEINFO_kindtypeINTEGERDEFAULT)) - nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */ -#endif - if (((nbt == FFEINFO_basictypeREAL) - || (nbt == FFEINFO_basictypeCOMPLEX)) - && (nkt != FFEINFO_kindtypeREALDEFAULT)) - { - nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE); - if (nkt != FFEINFO_kindtypeREALDOUBLE) - nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ - } - /* else Gonna turn into an error below. */ - } - - if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) - || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) - { - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, - FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - if (rbt != FFEINFO_basictypeINTEGER) - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - return reduced; - } - - if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) - && (lbt != FFEINFO_basictypeCOMPLEX)) - { - if ((rbt != FFEINFO_basictypeINTEGER) - && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) - { - if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((lbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_finish (); - } - } - } - else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCOMPLEX)) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_MATH_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if (lrk != 0) - { - if ((lkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_MATH_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_MATH_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators - - reduced = ffeexpr_reduced_relop2_(reduced,l,op,r); - - Makes sure the left and right arguments for reduced have basictype of - INTEGER, REAL, or CHARACTER. Determine common basictype and - size for reduction. If both left - and right arguments have where of CONSTANT, assign where CONSTANT to - reduced, else assign where FLEETING. Create CONVERT ops for args where - needed. Convert typeless - constants to the desired type/size explicitly. - - If these requirements cannot be met, generate error message. */ - -static ffebld -ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo, ninfo; - ffeinfoBasictype lbt, rbt, nbt; - ffeinfoKindtype lkt, rkt, nkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd; - ffeinfoWhere lwh, rwh, nwh; - ffetargetCharacterSize lsz, rsz; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - lsz = ffebld_size_known (ffebld_left (reduced)); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - rsz = ffebld_size_known (ffebld_right (reduced)); - - ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); - - if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) - || (nbt == FFEINFO_basictypeCHARACTER)) - && (lrk == 0) && (rrk == 0)) - { - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - nwh = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - nwh = FFEINFO_whereIMMEDIATE; - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - break; - - default: - nwh = FFEINFO_whereFLEETING; - break; - } - - if ((lsz != FFETARGET_charactersizeNONE) - && (rsz != FFETARGET_charactersizeNONE)) - lsz = rsz = (lsz > rsz) ? lsz : rsz; - - ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, - 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); - ffebld_set_info (reduced, ninfo); - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, nbt, nkt, 0, lsz, - FFEEXPR_contextLET)); - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, nbt, nkt, 0, rsz, - FFEEXPR_contextLET)); - return reduced; - } - - if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) - && (lbt != FFEINFO_basictypeCHARACTER)) - { - if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCHARACTER)) - { - if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_RELOP_ARGS_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else - { - if ((lbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_finish (); - } - } - } - else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) - && (rbt != FFEINFO_basictypeCHARACTER)) - { - if ((rbt != FFEINFO_basictypeANY) - && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_finish (); - } - } - else if (lrk != 0) - { - if ((lkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_RELOP_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - else - { - if ((rkd != FFEINFO_kindANY) - && ffebad_start (FFEBAD_RELOP_ARG_KIND)) - { - ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); - ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); - ffebad_string ("an array"); - ffebad_finish (); - } - } - - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - return reduced; -} - -/* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL - - reduced = ffeexpr_reduced_ugly1_(reduced,op,r); - - Sigh. */ - -static ffebld -ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) -{ - ffeinfo rinfo; - ffeinfoBasictype rbt; - ffeinfoKindtype rkt; - ffeinfoRank rrk; - ffeinfoKind rkd; - ffeinfoWhere rwh; - - rinfo = ffebld_info (ffebld_left (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - if ((rbt == FFEINFO_basictypeTYPELESS) - || (rbt == FFEINFO_basictypeHOLLERITH)) - { - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - r->token, op->token, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - rinfo = ffebld_info (ffebld_left (reduced)); - rbt = FFEINFO_basictypeINTEGER; - rkt = FFEINFO_kindtypeINTEGERDEFAULT; - rrk = 0; - rkd = FFEINFO_kindENTITY; - rwh = ffeinfo_where (rinfo); - } - - if (rbt == FFEINFO_basictypeLOGICAL) - { - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - r->token, op->token, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - } - - return reduced; -} - -/* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH - - reduced = ffeexpr_reduced_ugly1log_(reduced,op,r); - - Sigh. */ - -static ffebld -ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) -{ - ffeinfo rinfo; - ffeinfoBasictype rbt; - ffeinfoKindtype rkt; - ffeinfoRank rrk; - ffeinfoKind rkd; - ffeinfoWhere rwh; - - rinfo = ffebld_info (ffebld_left (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - if ((rbt == FFEINFO_basictypeTYPELESS) - || (rbt == FFEINFO_basictypeHOLLERITH)) - { - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - r->token, op->token, FFEINFO_basictypeLOGICAL, 0, - FFEINFO_kindtypeLOGICALDEFAULT, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - rinfo = ffebld_info (ffebld_left (reduced)); - rbt = FFEINFO_basictypeLOGICAL; - rkt = FFEINFO_kindtypeLOGICALDEFAULT; - rrk = 0; - rkd = FFEINFO_kindENTITY; - rwh = ffeinfo_where (rinfo); - } - - return reduced; -} - -/* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL - - reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r); - - Sigh. */ - -static ffebld -ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r) -{ - ffeinfo linfo, rinfo; - ffeinfoBasictype lbt, rbt; - ffeinfoKindtype lkt, rkt; - ffeinfoRank lrk, rrk; - ffeinfoKind lkd, rkd; - ffeinfoWhere lwh, rwh; - - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - - if ((lbt == FFEINFO_basictypeTYPELESS) - || (lbt == FFEINFO_basictypeHOLLERITH)) - { - if ((rbt == FFEINFO_basictypeTYPELESS) - || (rbt == FFEINFO_basictypeHOLLERITH)) - { - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, FFEINFO_basictypeINTEGER, 0, - FFEINFO_kindtypeINTEGERDEFAULT, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - linfo = ffebld_info (ffebld_left (reduced)); - rinfo = ffebld_info (ffebld_right (reduced)); - lbt = rbt = FFEINFO_basictypeINTEGER; - lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT; - lrk = rrk = 0; - lkd = rkd = FFEINFO_kindENTITY; - lwh = ffeinfo_where (linfo); - rwh = ffeinfo_where (rinfo); - } - else - { - ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), - l->token, ffebld_right (reduced), r->token, - FFEEXPR_contextLET)); - linfo = ffebld_info (ffebld_left (reduced)); - lbt = ffeinfo_basictype (linfo); - lkt = ffeinfo_kindtype (linfo); - lrk = ffeinfo_rank (linfo); - lkd = ffeinfo_kind (linfo); - lwh = ffeinfo_where (linfo); - } - } - else - { - if ((rbt == FFEINFO_basictypeTYPELESS) - || (rbt == FFEINFO_basictypeHOLLERITH)) - { - ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), - r->token, ffebld_left (reduced), l->token, - FFEEXPR_contextLET)); - rinfo = ffebld_info (ffebld_right (reduced)); - rbt = ffeinfo_basictype (rinfo); - rkt = ffeinfo_kindtype (rinfo); - rrk = ffeinfo_rank (rinfo); - rkd = ffeinfo_kind (rinfo); - rwh = ffeinfo_where (rinfo); - } - /* else Leave it alone. */ - } - - if (lbt == FFEINFO_basictypeLOGICAL) - { - ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), - l->token, op->token, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - } - - if (rbt == FFEINFO_basictypeLOGICAL) - { - ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), - r->token, op->token, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET)); - } - - return reduced; -} - -/* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH - - reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r); - - Sigh. */ - -static ffebld -ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, - ffeexprExpr_ r, bool *bothlogical) -{ - 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. */ - } - - 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)); - } - - if (bothlogical != NULL) - *bothlogical = (lbt == FFEINFO_basictypeLOGICAL - && rbt == FFEINFO_basictypeLOGICAL); - - return reduced; -} - -/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON - is found. - - The idea is to process the tokens as they would be done by normal - expression processing, with the key things being telling the lexer - when hollerith/character constants are about to happen, until the - true closing token is found. */ - -static ffelexHandler -ffeexpr_find_close_paren_ (ffelexToken t, - ffelexHandler after) -{ - ffeexpr_find_.after = after; - ffeexpr_find_.level = 1; - return (ffelexHandler) ffeexpr_nil_rhs_ (t); -} - -static ffelexHandler -ffeexpr_nil_finished_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeCLOSE_PAREN: - if (--ffeexpr_find_.level == 0) - return (ffelexHandler) ffeexpr_find_.after; - return (ffelexHandler) ffeexpr_nil_binary_; - - case FFELEX_typeCOMMA: - case FFELEX_typeCOLON: - case FFELEX_typeEQUALS: - case FFELEX_typePOINTS: - return (ffelexHandler) ffeexpr_nil_rhs_; - - default: - if (--ffeexpr_find_.level == 0) - return (ffelexHandler) ffeexpr_find_.after (t); - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_rhs_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeQUOTE: - if (ffe_is_vxt ()) - return (ffelexHandler) ffeexpr_nil_quote_; - ffelex_set_expecting_hollerith (-1, '\"', - ffelex_token_where_line (t), - ffelex_token_where_column (t)); - return (ffelexHandler) ffeexpr_nil_apostrophe_; - - case FFELEX_typeAPOSTROPHE: - ffelex_set_expecting_hollerith (-1, '\'', - ffelex_token_where_line (t), - ffelex_token_where_column (t)); - return (ffelexHandler) ffeexpr_nil_apostrophe_; - - case FFELEX_typePERCENT: - return (ffelexHandler) ffeexpr_nil_percent_; - - case FFELEX_typeOPEN_PAREN: - ++ffeexpr_find_.level; - return (ffelexHandler) ffeexpr_nil_rhs_; - - case FFELEX_typePLUS: - case FFELEX_typeMINUS: - return (ffelexHandler) ffeexpr_nil_rhs_; - - case FFELEX_typePERIOD: - return (ffelexHandler) ffeexpr_nil_period_; - - case FFELEX_typeNUMBER: - ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); - if (ffeexpr_hollerith_count_ > 0) - ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, - '\0', - ffelex_token_where_line (t), - ffelex_token_where_column (t)); - return (ffelexHandler) ffeexpr_nil_number_; - - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - return (ffelexHandler) ffeexpr_nil_name_rhs_; - - case FFELEX_typeASTERISK: - case FFELEX_typeSLASH: - case FFELEX_typePOWER: - case FFELEX_typeCONCAT: - case FFELEX_typeREL_EQ: - case FFELEX_typeREL_NE: - case FFELEX_typeREL_LE: - case FFELEX_typeREL_GE: - return (ffelexHandler) ffeexpr_nil_rhs_; - - default: - return (ffelexHandler) ffeexpr_nil_finished_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_period_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - ffeexpr_current_dotdot_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherNone: - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - return (ffelexHandler) ffeexpr_nil_end_period_; - - default: - return (ffelexHandler) ffeexpr_nil_swallow_period_; - } - break; /* Nothing really reaches here. */ - - case FFELEX_typeNUMBER: - return (ffelexHandler) ffeexpr_nil_real_; - - default: - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_end_period_ (ffelexToken t) -{ - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherNOT: - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - return (ffelexHandler) ffeexpr_nil_rhs_; - - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - return (ffelexHandler) ffeexpr_nil_binary_; - - default: - assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL); - exit (0); - return NULL; - } -} - -static ffelexHandler -ffeexpr_nil_swallow_period_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - return (ffelexHandler) ffeexpr_nil_rhs_; -} - -static ffelexHandler -ffeexpr_nil_real_ (ffelexToken t) -{ - char d; - const char *p; - - if (((ffelex_token_type (t) != FFELEX_typeNAME) - && (ffelex_token_type (t) != FFELEX_typeNAMES)) - || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q'))) - && ffeexpr_isdigits_ (++p))) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - - if (*p == '\0') - return (ffelexHandler) ffeexpr_nil_real_exponent_; - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_real_exponent_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - - return (ffelexHandler) ffeexpr_nil_real_exp_sign_; -} - -static ffelexHandler -ffeexpr_nil_real_exp_sign_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_number_ (ffelexToken t) -{ - char d; - const char *p; - - if (ffeexpr_hollerith_count_ > 0) - ffelex_set_expecting_hollerith (0, '\0', - ffewhere_line_unknown (), - ffewhere_column_unknown ()); - - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q')) - && ffeexpr_isdigits_ (++p)) - { - if (*p == '\0') - { - ffeexpr_find_.t = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_nil_number_exponent_; - } - return (ffelexHandler) ffeexpr_nil_binary_; - } - break; - - case FFELEX_typePERIOD: - ffeexpr_find_.t = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_nil_number_period_; - - case FFELEX_typeHOLLERITH: - return (ffelexHandler) ffeexpr_nil_binary_; - - default: - break; - } - return (ffelexHandler) ffeexpr_nil_binary_ (t); -} - -/* Expects ffeexpr_find_.t. */ - -static ffelexHandler -ffeexpr_nil_number_exponent_ (ffelexToken t) -{ - ffelexHandler nexthandler; - - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - { - nexthandler - = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) (*nexthandler) (t); - } - - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) ffeexpr_nil_number_exp_sign_; -} - -static ffelexHandler -ffeexpr_nil_number_exp_sign_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - - return (ffelexHandler) ffeexpr_nil_binary_; -} - -/* Expects ffeexpr_find_.t. */ - -static ffelexHandler -ffeexpr_nil_number_period_ (ffelexToken t) -{ - ffelexHandler nexthandler; - char d; - const char *p; - - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q')) - && ffeexpr_isdigits_ (++p)) - { - if (*p == '\0') - return (ffelexHandler) ffeexpr_nil_number_per_exp_; - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) ffeexpr_nil_binary_; - } - nexthandler - = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) (*nexthandler) (t); - - case FFELEX_typeNUMBER: - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) ffeexpr_nil_number_real_; - - default: - break; - } - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) ffeexpr_nil_binary_ (t); -} - -/* Expects ffeexpr_find_.t. */ - -static ffelexHandler -ffeexpr_nil_number_per_exp_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - { - ffelexHandler nexthandler; - - nexthandler - = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) (*nexthandler) (t); - } - - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_; -} - -static ffelexHandler -ffeexpr_nil_number_real_ (ffelexToken t) -{ - char d; - const char *p; - - if (((ffelex_token_type (t) != FFELEX_typeNAME) - && (ffelex_token_type (t) != FFELEX_typeNAMES)) - || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q'))) - && ffeexpr_isdigits_ (++p))) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - - if (*p == '\0') - return (ffelexHandler) ffeexpr_nil_number_real_exp_; - - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_num_per_exp_sign_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_number_real_exp_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_; -} - -static ffelexHandler -ffeexpr_nil_num_real_exp_sn_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_binary_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typePLUS: - case FFELEX_typeMINUS: - case FFELEX_typeASTERISK: - case FFELEX_typeSLASH: - case FFELEX_typePOWER: - case FFELEX_typeCONCAT: - case FFELEX_typeOPEN_ANGLE: - case FFELEX_typeCLOSE_ANGLE: - case FFELEX_typeREL_EQ: - case FFELEX_typeREL_NE: - case FFELEX_typeREL_GE: - case FFELEX_typeREL_LE: - return (ffelexHandler) ffeexpr_nil_rhs_; - - case FFELEX_typePERIOD: - return (ffelexHandler) ffeexpr_nil_binary_period_; - - default: - return (ffelexHandler) ffeexpr_nil_finished_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_binary_period_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - ffeexpr_current_dotdot_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - return (ffelexHandler) ffeexpr_nil_binary_sw_per_; - - default: - return (ffelexHandler) ffeexpr_nil_binary_end_per_; - } - break; /* Nothing really reaches here. */ - - default: - return (ffelexHandler) ffeexpr_nil_binary_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_binary_end_per_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - return (ffelexHandler) ffeexpr_nil_rhs_; -} - -static ffelexHandler -ffeexpr_nil_binary_sw_per_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_quote_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - return (ffelexHandler) ffeexpr_nil_binary_; -} - -static ffelexHandler -ffeexpr_nil_apostrophe_ (ffelexToken t) -{ - assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); - return (ffelexHandler) ffeexpr_nil_apos_char_; -} - -static ffelexHandler -ffeexpr_nil_apos_char_ (ffelexToken t) -{ - char c; - - if ((ffelex_token_type (t) == FFELEX_typeNAME) - || (ffelex_token_type (t) == FFELEX_typeNAMES)) - { - if ((ffelex_token_length (t) == 1) - && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), - 'B', 'b') - || ffesrc_char_match_init (c, 'O', 'o') - || ffesrc_char_match_init (c, 'X', 'x') - || ffesrc_char_match_init (c, 'Z', 'z'))) - return (ffelexHandler) ffeexpr_nil_binary_; - } - if ((ffelex_token_type (t) == FFELEX_typeNAME) - || (ffelex_token_type (t) == FFELEX_typeNAMES)) - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - return (ffelexHandler) ffeexpr_nil_substrp_ (t); -} - -static ffelexHandler -ffeexpr_nil_name_rhs_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeQUOTE: - case FFELEX_typeAPOSTROPHE: - ffelex_set_hexnum (TRUE); - return (ffelexHandler) ffeexpr_nil_name_apos_; - - case FFELEX_typeOPEN_PAREN: - ++ffeexpr_find_.level; - return (ffelexHandler) ffeexpr_nil_rhs_; - - default: - return (ffelexHandler) ffeexpr_nil_binary_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_name_apos_ (ffelexToken t) -{ - if (ffelex_token_type (t) == FFELEX_typeNAME) - return (ffelexHandler) ffeexpr_nil_name_apos_name_; - return (ffelexHandler) ffeexpr_nil_binary_ (t); -} - -static ffelexHandler -ffeexpr_nil_name_apos_name_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeAPOSTROPHE: - case FFELEX_typeQUOTE: - return (ffelexHandler) ffeexpr_nil_finished_; - - default: - return (ffelexHandler) ffeexpr_nil_finished_ (t); - } -} - -static ffelexHandler -ffeexpr_nil_percent_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - ffeexpr_stack_->percent = ffeexpr_percent_ (t); - ffeexpr_find_.t = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_nil_percent_name_; - - default: - return (ffelexHandler) ffeexpr_nil_rhs_ (t); - } -} - -/* Expects ffeexpr_find_.t. */ - -static ffelexHandler -ffeexpr_nil_percent_name_ (ffelexToken t) -{ - ffelexHandler nexthandler; - - if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) - { - nexthandler - = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t); - ffelex_token_kill (ffeexpr_find_.t); - return (ffelexHandler) (*nexthandler) (t); - } - - ffelex_token_kill (ffeexpr_find_.t); - ++ffeexpr_find_.level; - return (ffelexHandler) ffeexpr_nil_rhs_; -} - -static ffelexHandler -ffeexpr_nil_substrp_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) - return (ffelexHandler) ffeexpr_nil_binary_ (t); - - ++ffeexpr_find_.level; - return (ffelexHandler) ffeexpr_nil_rhs_; -} - -/* ffeexpr_finished_ -- Reduce expression stack to one expr, finish - - ffelexToken t; - return ffeexpr_finished_(t); - - Reduces expression stack to one (or zero) elements by repeatedly reducing - the top operator on the stack (or, if the top element on the stack is - itself an operator, issuing an error message and discarding it). Calls - finishing routine with the expression, returning the ffelexHandler it - returns to the caller. */ - -static ffelexHandler -ffeexpr_finished_ (ffelexToken t) -{ - ffeexprExpr_ operand; /* This is B in -B or A+B. */ - ffebld expr; - ffeexprCallback callback; - ffeexprStack_ s; - ffebldConstant constnode; /* For detecting magical number. */ - ffelexToken ft; /* Temporary copy of first token in - expression. */ - ffelexHandler next; - ffeinfo info; - bool error = FALSE; - - while (((operand = ffeexpr_stack_->exprstack) != NULL) - && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_))) - { - if (operand->type == FFEEXPR_exprtypeOPERAND_) - ffeexpr_reduce_ (); - else - { - if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), - ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); - ffebad_finish (); - } - ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless - operator. */ - ffeexpr_expr_kill_ (operand); - } - } - - assert ((operand == NULL) || (operand->previous == NULL)); - - ffebld_pool_pop (); - if (operand == NULL) - expr = NULL; - else - { - expr = operand->u.operand; - info = ffebld_info (expr); - if ((ffebld_op (expr) == FFEBLD_opCONTER) - && (ffebld_conter_orig (expr) == NULL) - && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) - { - ffetarget_integer_bad_magical (operand->token); - } - ffeexpr_expr_kill_ (operand); - ffeexpr_stack_->exprstack = NULL; - } - - ft = ffeexpr_stack_->first_token; - -again: /* :::::::::::::::::::: */ - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextLET: - case FFEEXPR_contextSFUNCDEF: - error = (expr == NULL) - || (ffeinfo_rank (info) != 0); - break; - - case FFEEXPR_contextPAREN_: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - break; - } - break; - - case FFEEXPR_contextPARENFILENUM_: - if (ffelex_token_type (t) != FFELEX_typeCOMMA) - ffeexpr_stack_->context = FFEEXPR_contextPAREN_; - else - ffeexpr_stack_->context = FFEEXPR_contextFILENUM; - goto again; /* :::::::::::::::::::: */ - - case FFEEXPR_contextPARENFILEUNIT_: - if (ffelex_token_type (t) != FFELEX_typeCOMMA) - ffeexpr_stack_->context = FFEEXPR_contextPAREN_; - else - ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT; - goto again; /* :::::::::::::::::::: */ - - case FFEEXPR_contextACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - if (!ffe_is_ugly_args () - && ffebad_start (FFEBAD_ACTUALARG)) - { - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_finish (); - } - break; - - default: - break; - } - error = (expr != NULL) && (ffeinfo_rank (info) != 0); - break; - - case FFEEXPR_contextACTUALARG_: - case FFEEXPR_contextSFUNCDEFACTUALARG_: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: -#if 0 /* Should never get here. */ - expr = ffeexpr_convert (expr, ft, ft, - FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, - 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); -#else - assert ("why hollerith/typeless in actualarg_?" == NULL); -#endif - break; - - default: - break; - } - switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr)) - { - case FFEBLD_opSYMTER: - case FFEBLD_opPERCENT_LOC: - case FFEBLD_opPERCENT_VAL: - case FFEBLD_opPERCENT_REF: - case FFEBLD_opPERCENT_DESCR: - error = FALSE; - break; - - default: - error = (expr != NULL) && (ffeinfo_rank (info) != 0); - break; - } - { - ffesymbol s; - ffeinfoWhere where; - ffeinfoKind kind; - - if (!error - && (expr != NULL) - && (ffebld_op (expr) == FFEBLD_opSYMTER) - && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)), - (where == FFEINFO_whereINTRINSIC) - || (where == FFEINFO_whereGLOBAL) - || ((where == FFEINFO_whereDUMMY) - && ((kind = ffesymbol_kind (s)), - (kind == FFEINFO_kindFUNCTION) - || (kind == FFEINFO_kindSUBROUTINE)))) - && !ffesymbol_explicitwhere (s)) - { - ffebad_start (where == FFEINFO_whereINTRINSIC - ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL); - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_string (ffesymbol_text (s)); - ffebad_finish (); - ffesymbol_signal_change (s); - ffesymbol_set_explicitwhere (s, TRUE); - ffesymbol_signal_unreported (s); - } - } - break; - - case FFEEXPR_contextINDEX_: - case FFEEXPR_contextSFUNCDEFINDEX_: - if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) - break; - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeNONE: - error = FALSE; - break; - - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeINTEGER: - /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through - unmolested. Leave it to downstream to handle kinds. */ - break; - - default: - error = TRUE; - break; - } - break; /* expr==NULL ok for substring; element case - caught by callback. */ - - case FFEEXPR_contextRETURN: - if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) - break; - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeNONE: - error = FALSE; - break; - - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextDO: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - error = !ffe_is_ugly_logint (); - if (!ffeexpr_stack_->is_rhs) - break; /* Don't convert lhs variable. */ - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - ffeinfo_kindtype (ffebld_info (expr)), 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - if (!ffeexpr_stack_->is_rhs) - { - error = TRUE; - break; /* Don't convert lhs variable. */ - } - break; - - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeREAL: - break; - - default: - error = TRUE; - break; - } - if (!ffeexpr_stack_->is_rhs - && (ffebld_op (expr) != FFEBLD_opSYMTER)) - error = TRUE; - break; - - case FFEEXPR_contextDOWHILE: - case FFEEXPR_contextIF: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeLOGICAL: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextASSIGN: - case FFEEXPR_contextAGOTO: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - error = (ffeinfo_kindtype (info) != ffecom_label_kind ()); - break; - - case FFEINFO_basictypeLOGICAL: - error = !ffe_is_ugly_logint () - || (ffeinfo_kindtype (info) != ffecom_label_kind ()); - break; - - default: - error = TRUE; - break; - } - if ((expr == NULL) || (ffeinfo_rank (info) != 0) - || (ffebld_op (expr) != FFEBLD_opSYMTER)) - error = TRUE; - break; - - case FFEEXPR_contextCGOTO: - case FFEEXPR_contextFORMAT: - case FFEEXPR_contextDIMLIST: - case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */ - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextARITHIF: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeREAL: - error = FALSE; - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextSTOP: - if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) - break; - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); - break; - - case FFEINFO_basictypeCHARACTER: - error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT); - break; - - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeNONE: - error = FALSE; - break; - - default: - error = TRUE; - break; - } - if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER) - || (ffebld_conter_orig (expr) != NULL))) - error = TRUE; - break; - - case FFEEXPR_contextINCLUDE: - error = (expr == NULL) || (ffeinfo_rank (info) != 0) - || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER) - || (ffebld_op (expr) != FFEBLD_opCONTER) - || (ffebld_conter_orig (expr) != NULL); - break; - - case FFEEXPR_contextSELECTCASE: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeCHARACTER: - case FFEINFO_basictypeLOGICAL: - error = FALSE; - break; - - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextCASE: - if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) - break; - switch ((expr == NULL) ? FFEINFO_basictypeINTEGER - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeCHARACTER: - case FFEINFO_basictypeLOGICAL: - error = FALSE; - break; - - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) - error = TRUE; - break; - - case FFEEXPR_contextCHARACTERSIZE: - case FFEEXPR_contextKINDTYPE: - case FFEEXPR_contextDIMLISTCOMMON: - if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) - break; - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) - error = TRUE; - break; - - case FFEEXPR_contextEQVINDEX_: - if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) - break; - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeNONE: - error = FALSE; - break; - - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) - error = TRUE; - break; - - case FFEEXPR_contextPARAMETER: - if (ffeexpr_stack_->is_rhs) - error = (expr == NULL) || (ffeinfo_rank (info) != 0) - || (ffebld_op (expr) != FFEBLD_opCONTER); - else - error = (expr == NULL) || (ffeinfo_rank (info) != 0) - || (ffebld_op (expr) != FFEBLD_opSYMTER); - break; - - case FFEEXPR_contextINDEXORACTUALARG_: - if (ffelex_token_type (t) == FFELEX_typeCOLON) - ffeexpr_stack_->context = FFEEXPR_contextINDEX_; - else - ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; - goto again; /* :::::::::::::::::::: */ - - case FFEEXPR_contextINDEXORACTUALARGEXPR_: - if (ffelex_token_type (t) == FFELEX_typeCOLON) - ffeexpr_stack_->context = FFEEXPR_contextINDEX_; - else - ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; - goto again; /* :::::::::::::::::::: */ - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - if (ffelex_token_type (t) == FFELEX_typeCOLON) - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; - else - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; - goto again; /* :::::::::::::::::::: */ - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - if (ffelex_token_type (t) == FFELEX_typeCOLON) - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; - else - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; - goto again; /* :::::::::::::::::::: */ - - case FFEEXPR_contextIMPDOCTRL_: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - if (!ffeexpr_stack_->is_rhs - && (ffebld_op (expr) != FFEBLD_opSYMTER)) - error = TRUE; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - if (! ffe_is_ugly_logint ()) - error = TRUE; - if (! ffeexpr_stack_->is_rhs) - break; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - ffeinfo_kindtype (info), 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - break; - - case FFEINFO_basictypeREAL: - if (!ffeexpr_stack_->is_rhs - && ffe_is_warn_surprising () - && !error) - { - ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_string (ffelex_token_text (ft)); - ffebad_finish (); - } - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextDATAIMPDOCTRL_: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - if (ffeexpr_stack_->is_rhs) - { - if ((ffebld_op (expr) != FFEBLD_opCONTER) - && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) - error = TRUE; - } - else if ((ffebld_op (expr) != FFEBLD_opSYMTER) - || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) - error = TRUE; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - if (! ffeexpr_stack_->is_rhs) - break; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - ffeinfo_kindtype (info), 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - if (ffeexpr_stack_->is_rhs - && (ffeinfo_kindtype (ffebld_info (expr)) - != FFEINFO_kindtypeINTEGERDEFAULT)) - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeREAL: - if (!ffeexpr_stack_->is_rhs - && ffe_is_warn_surprising () - && !error) - { - ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_string (ffelex_token_text (ft)); - ffebad_finish (); - } - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextIMPDOITEM_: - if (ffelex_token_type (t) == FFELEX_typeEQUALS) - { - ffeexpr_stack_->is_rhs = FALSE; - ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; - goto again; /* :::::::::::::::::::: */ - } - /* Fall through. */ - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextFILEVXTCODE: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - break; - } - error = (expr == NULL) - || ((ffeinfo_rank (info) != 0) - && ((ffebld_op (expr) != FFEBLD_opSYMTER) - || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) - || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) - == FFEBLD_opSTAR))); /* Bad if null expr, or if - array that is not a SYMTER - (can't happen yet, I - think) or has a NULL or - STAR (assumed) array - size. */ - break; - - case FFEEXPR_contextIMPDOITEMDF_: - if (ffelex_token_type (t) == FFELEX_typeEQUALS) - { - ffeexpr_stack_->is_rhs = FALSE; - ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; - goto again; /* :::::::::::::::::::: */ - } - /* Fall through. */ - case FFEEXPR_contextIOLISTDF: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - break; - } - error - = (expr == NULL) - || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER) - && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)) - || ((ffeinfo_rank (info) != 0) - && ((ffebld_op (expr) != FFEBLD_opSYMTER) - || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) - || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) - == FFEBLD_opSTAR))); /* Bad if null expr, - non-default-kindtype - character expr, or if - array that is not a SYMTER - (can't happen yet, I - think) or has a NULL or - STAR (assumed) array - size. */ - break; - - case FFEEXPR_contextDATAIMPDOITEM_: - error = (expr == NULL) - || (ffebld_op (expr) != FFEBLD_opARRAYREF) - || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR) - && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR)); - break; - - case FFEEXPR_contextDATAIMPDOINDEX_: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - error = FALSE; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - default: - error = TRUE; - break; - } - if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT) - && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) - error = TRUE; - break; - - case FFEEXPR_contextDATA: - if (expr == NULL) - error = TRUE; - else if (ffeexpr_stack_->is_rhs) - error = (ffebld_op (expr) != FFEBLD_opCONTER); - else if (ffebld_op (expr) == FFEBLD_opSYMTER) - error = FALSE; - else - error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); - break; - - case FFEEXPR_contextINITVAL: - error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER); - break; - - case FFEEXPR_contextEQUIVALENCE: - if (expr == NULL) - error = TRUE; - else if (ffebld_op (expr) == FFEBLD_opSYMTER) - error = FALSE; - else - error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); - break; - - case FFEEXPR_contextFILEASSOC: - case FFEEXPR_contextFILEINT: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - /* Maybe this should be supported someday, but, right now, - g77 can't generate a call to libf2c to write to an - integer other than the default size. */ - error = ((! ffeexpr_stack_->is_rhs) - && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); - break; - - default: - error = TRUE; - break; - } - if ((expr == NULL) || (ffeinfo_rank (info) != 0)) - error = TRUE; - break; - - case FFEEXPR_contextFILEDFINT: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); - break; - - default: - error = TRUE; - break; - } - if ((expr == NULL) || (ffeinfo_rank (info) != 0)) - error = TRUE; - break; - - case FFEEXPR_contextFILELOG: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - error = FALSE; - break; - - default: - error = TRUE; - break; - } - if ((expr == NULL) || (ffeinfo_rank (info) != 0)) - error = TRUE; - break; - - case FFEEXPR_contextFILECHAR: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeCHARACTER: - error = FALSE; - break; - - default: - error = TRUE; - break; - } - if ((expr == NULL) || (ffeinfo_rank (info) != 0)) - error = TRUE; - break; - - case FFEEXPR_contextFILENUMCHAR: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeCHARACTER: - error = FALSE; - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextFILEDFCHAR: - if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) - break; - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeCHARACTER: - error - = (ffeinfo_kindtype (info) - != FFEINFO_kindtypeCHARACTERDEFAULT); - break; - - default: - error = TRUE; - break; - } - if (!ffeexpr_stack_->is_rhs - && (ffebld_op (expr) == FFEBLD_opSUBSTR)) - error = TRUE; - break; - - case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */ - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeLOGICAL: - if ((error = (ffeinfo_rank (info) != 0))) - break; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, - FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - /* Fall through. */ - case FFEINFO_basictypeREAL: - case FFEINFO_basictypeCOMPLEX: - if ((error = (ffeinfo_rank (info) != 0))) - break; - if (ffe_is_pedantic ()) - { - error = TRUE; - break; - } - /* Fall through. */ - case FFEINFO_basictypeINTEGER: - case FFEINFO_basictypeHOLLERITH: - case FFEINFO_basictypeTYPELESS: - if ((error = (ffeinfo_rank (info) != 0))) - break; - expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, - FFEEXPR_contextLET); - break; - - case FFEINFO_basictypeCHARACTER: - switch (ffebld_op (expr)) - { /* As if _lhs had been called instead of - _rhs. */ - case FFEBLD_opSYMTER: - error - = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); - break; - - case FFEBLD_opSUBSTR: - error = (ffeinfo_where (ffebld_info (expr)) - == FFEINFO_whereCONSTANT_SUBOBJECT); - break; - - case FFEBLD_opARRAYREF: - error = FALSE; - break; - - default: - error = TRUE; - break; - } - if (!error - && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) - || ((ffeinfo_rank (info) != 0) - && ((ffebld_op (expr) != FFEBLD_opSYMTER) - || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) - || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) - == FFEBLD_opSTAR))))) /* Bad if - non-default-kindtype - character expr, or if - array that is not a SYMTER - (can't happen yet, I - think), or has a NULL or - STAR (assumed) array - size. */ - error = TRUE; - break; - - default: - error = TRUE; - break; - } - break; - - case FFEEXPR_contextFILEFORMAT: - switch ((expr == NULL) ? FFEINFO_basictypeNONE - : ffeinfo_basictype (info)) - { - case FFEINFO_basictypeINTEGER: - error = (expr == NULL) - || ((ffeinfo_rank (info) != 0) ? - ffe_is_pedantic () /* F77 C5. */ - : (bool) (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_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherNone: - if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_rhs_ (t); - - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_end_period_; - - default: - if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_swallow_period_; - } - break; /* Nothing really reaches here. */ - - case FFELEX_typeNUMBER: - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_real_; - - default: - if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_rhs_ (t); - } -} - -/* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op - or operator) state. If period isn't found, issue a diagnostic but - pretend we saw one. ffeexpr_current_dotdot_ must already contained the - dotdot representation of the name in between the two PERIOD tokens. */ - -static ffelexHandler -ffeexpr_token_end_period_ (ffelexToken t) -{ - ffeexprExpr_ e; - - if (ffelex_token_type (t) != FFELEX_typePERIOD) - { - if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); - ffebad_finish (); - } - } - - ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE" - token. */ - - e = ffeexpr_expr_new_ (); - e->token = ffeexpr_tokens_[0]; - - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherNOT: - e->type = FFEEXPR_exprtypeUNARY_; - e->u.operator.op = FFEEXPR_operatorNOT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_; - e->u.operator.as = FFEEXPR_operatorassociativityNOT_; - ffeexpr_exprstack_push_unary_ (e); - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_token_rhs_ (t); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFESTR_otherTRUE: - e->type = FFEEXPR_exprtypeOPERAND_; - e->u.operand - = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE)); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - ffeexpr_exprstack_push_operand_ (e); - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_token_binary_ (t); - return (ffelexHandler) ffeexpr_token_binary_; - - case FFESTR_otherFALSE: - e->type = FFEEXPR_exprtypeOPERAND_; - e->u.operand - = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE)); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - ffeexpr_exprstack_push_operand_ (e); - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_token_binary_ (t); - return (ffelexHandler) ffeexpr_token_binary_; - - default: - assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL); - exit (0); - return NULL; - } -} - -/* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - A diagnostic has already been issued; just swallow a period if there is - one, then continue with ffeexpr_token_rhs_. */ - -static ffelexHandler -ffeexpr_token_swallow_period_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_token_rhs_ (t); - - return (ffelexHandler) ffeexpr_token_rhs_; -} - -/* ffeexpr_token_real_ -- Rhs PERIOD NUMBER - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - After a period and a string of digits, check next token for possible - exponent designation (D, E, or Q as first/only character) and continue - real-number handling accordingly. Else form basic real constant, push - onto expression stack, and enter binary state using current token (which, - if it is a name not beginning with D, E, or Q, will certainly result - in an error, but that's not for this routine to deal with). */ - -static ffelexHandler -ffeexpr_token_real_ (ffelexToken t) -{ - char d; - const char *p; - - if (((ffelex_token_type (t) != FFELEX_typeNAME) - && (ffelex_token_type (t) != FFELEX_typeNAMES)) - || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q'))) - && ffeexpr_isdigits_ (++p))) - { -#if 0 - /* This code has been removed because it seems inconsistent to - produce a diagnostic in this case, but not all of the other - ones that look for an exponent and cannot recognize one. */ - if (((ffelex_token_type (t) == FFELEX_typeNAME) - || (ffelex_token_type (t) == FFELEX_typeNAMES)) - && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) - { - char bad[2]; - - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - bad[0] = *(p - 1); - bad[1] = '\0'; - ffebad_string (bad); - ffebad_finish (); - } -#endif - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - /* Just exponent character by itself? In which case, PLUS or MINUS must - surely be next, followed by a NUMBER token. */ - - if (*p == '\0') - { - ffeexpr_tokens_[2] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_real_exponent_; - } - - ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], - t, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Ensures this token is PLUS or MINUS, preserves it, goes to final state - for real number (exponent digits). Else issues diagnostic, assumes a - zero exponent field for number, passes token on to binary state as if - previous token had been "E0" instead of "E", for example. */ - -static ffelexHandler -ffeexpr_token_real_exponent_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - { - if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), - ffelex_token_where_column (ffeexpr_tokens_[2])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - ffeexpr_tokens_[3] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_real_exp_sign_; -} - -/* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Make sure token is a NUMBER, make a real constant out of all we have and - push it onto the expression stack. Else issue diagnostic and pretend - exponent field was a zero. */ - -static ffelexHandler -ffeexpr_token_real_exp_sign_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - { - if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), - ffelex_token_where_column (ffeexpr_tokens_[2])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL, - ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], - ffeexpr_tokens_[3], t); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_number_ -- Rhs NUMBER - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - If the token is a period, we may have a floating-point number, or an - integer followed by a dotdot binary operator. If the token is a name - beginning with D, E, or Q, we definitely have a floating-point number. - If the token is a hollerith constant, that's what we've got, so push - it onto the expression stack and continue with the binary state. - - Otherwise, we have an integer followed by something the binary state - should be able to swallow. */ - -static ffelexHandler -ffeexpr_token_number_ (ffelexToken t) -{ - ffeexprExpr_ e; - ffeinfo ni; - char d; - const char *p; - - if (ffeexpr_hollerith_count_ > 0) - ffelex_set_expecting_hollerith (0, '\0', - ffewhere_line_unknown (), - ffewhere_column_unknown ()); - - /* See if we've got a floating-point number here. */ - - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q')) - && ffeexpr_isdigits_ (++p)) - { - - /* Just exponent character by itself? In which case, PLUS or MINUS - must surely be next, followed by a NUMBER token. */ - - if (*p == '\0') - { - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_number_exponent_; - } - ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t, - NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_binary_; - } - break; - - case FFELEX_typePERIOD: - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_number_period_; - - case FFELEX_typeHOLLERITH: - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t)); - ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - ffelex_token_length (t)); - ffebld_set_info (e->u.operand, ni); - ffeexpr_exprstack_push_operand_ (e); - return (ffelexHandler) ffeexpr_token_binary_; - - default: - break; - } - - /* Nothing specific we were looking for, so make an integer and pass the - current token to the binary state. */ - - ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL, - NULL, NULL, NULL); - return (ffelexHandler) ffeexpr_token_binary_ (t); -} - -/* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Ensures this token is PLUS or MINUS, preserves it, goes to final state - for real number (exponent digits). Else treats number as integer, passes - name to binary, passes current token to subsequent handler. */ - -static ffelexHandler -ffeexpr_token_number_exponent_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - { - ffeexprExpr_ e; - ffelexHandler nexthandler; - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault - (ffeexpr_tokens_[0])); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - ffeexpr_exprstack_push_operand_ (e); - nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) (*nexthandler) (t); - } - - ffeexpr_tokens_[2] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_number_exp_sign_; -} - -/* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Make sure token is a NUMBER, make a real constant out of all we have and - push it onto the expression stack. Else issue diagnostic and pretend - exponent field was a zero. */ - -static ffelexHandler -ffeexpr_token_number_exp_sign_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - { - if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]), - ffelex_token_where_column (ffeexpr_tokens_[1])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], - ffeexpr_tokens_[0], NULL, NULL, - ffeexpr_tokens_[1], ffeexpr_tokens_[2], - NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], - ffeexpr_tokens_[0], NULL, NULL, - ffeexpr_tokens_[1], ffeexpr_tokens_[2], t); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle a period detected following a number at rhs state. Must begin a - floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */ - -static ffelexHandler -ffeexpr_token_number_period_ (ffelexToken t) -{ - ffeexprExpr_ e; - ffelexHandler nexthandler; - const char *p; - char d; - - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q')) - && ffeexpr_isdigits_ (++p)) - { - - /* Just exponent character by itself? In which case, PLUS or MINUS - must surely be next, followed by a NUMBER token. */ - - if (*p == '\0') - { - ffeexpr_tokens_[2] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_number_per_exp_; - } - ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], - ffeexpr_tokens_[1], NULL, t, NULL, - NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) ffeexpr_token_binary_; - } - /* A name not representing an exponent, so assume it will be something - like EQ, make an integer from the number, pass the period to binary - state and the current token to the resulting state. */ - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault - (ffeexpr_tokens_[0])); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - ffeexpr_exprstack_push_operand_ (e); - nexthandler = (ffelexHandler) ffeexpr_token_binary_ - (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) (*nexthandler) (t); - - case FFELEX_typeNUMBER: - ffeexpr_tokens_[2] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_number_real_; - - default: - break; - } - - /* Nothing specific we were looking for, so make a real number and pass the - period and then the current token to the binary state. */ - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - NULL, NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) ffeexpr_token_binary_ (t); -} - -/* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Ensures this token is PLUS or MINUS, preserves it, goes to final state - for real number (exponent digits). Else treats number as real, passes - name to binary, passes current token to subsequent handler. */ - -static ffelexHandler -ffeexpr_token_number_per_exp_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - { - ffelexHandler nexthandler; - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - NULL, NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) (*nexthandler) (t); - } - - ffeexpr_tokens_[3] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_num_per_exp_sign_; -} - -/* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - After a number, period, and number, check next token for possible - exponent designation (D, E, or Q as first/only character) and continue - real-number handling accordingly. Else form basic real constant, push - onto expression stack, and enter binary state using current token (which, - if it is a name not beginning with D, E, or Q, will certainly result - in an error, but that's not for this routine to deal with). */ - -static ffelexHandler -ffeexpr_token_number_real_ (ffelexToken t) -{ - char d; - const char *p; - - if (((ffelex_token_type (t) != FFELEX_typeNAME) - && (ffelex_token_type (t) != FFELEX_typeNAMES)) - || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), - 'D', 'd') - || ffesrc_char_match_init (d, 'E', 'e') - || ffesrc_char_match_init (d, 'Q', 'q'))) - && ffeexpr_isdigits_ (++p))) - { -#if 0 - /* This code has been removed because it seems inconsistent to - produce a diagnostic in this case, but not all of the other - ones that look for an exponent and cannot recognize one. */ - if (((ffelex_token_type (t) == FFELEX_typeNAME) - || (ffelex_token_type (t) == FFELEX_typeNAMES)) - && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) - { - char bad[2]; - - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - bad[0] = *(p - 1); - bad[1] = '\0'; - ffebad_string (bad); - ffebad_finish (); - } -#endif - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - ffeexpr_tokens_[2], NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - /* Just exponent character by itself? In which case, PLUS or MINUS must - surely be next, followed by a NUMBER token. */ - - if (*p == '\0') - { - ffeexpr_tokens_[3] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_number_real_exp_; - } - - ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1], - ffeexpr_tokens_[2], t, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Make sure token is a NUMBER, make a real constant out of all we have and - push it onto the expression stack. Else issue diagnostic and pretend - exponent field was a zero. */ - -static ffelexHandler -ffeexpr_token_num_per_exp_sign_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - { - if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), - ffelex_token_where_column (ffeexpr_tokens_[2])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - NULL, NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], - ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, - ffeexpr_tokens_[2], ffeexpr_tokens_[3], t); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Ensures this token is PLUS or MINUS, preserves it, goes to final state - for real number (exponent digits). Else issues diagnostic, assumes a - zero exponent field for number, passes token on to binary state as if - previous token had been "E0" instead of "E", for example. */ - -static ffelexHandler -ffeexpr_token_number_real_exp_ (ffelexToken t) -{ - if ((ffelex_token_type (t) != FFELEX_typePLUS) - && (ffelex_token_type (t) != FFELEX_typeMINUS)) - { - if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), - ffelex_token_where_column (ffeexpr_tokens_[3])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - ffeexpr_tokens_[2], NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - ffeexpr_tokens_[4] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_num_real_exp_sn_; -} - -/* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q) - PLUS/MINUS - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Make sure token is a NUMBER, make a real constant out of all we have and - push it onto the expression stack. Else issue diagnostic and pretend - exponent field was a zero. */ - -static ffelexHandler -ffeexpr_token_num_real_exp_sn_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - { - if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), - ffelex_token_where_column (ffeexpr_tokens_[3])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - ffeexpr_tokens_[2], NULL, NULL, NULL); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - ffelex_token_kill (ffeexpr_tokens_[4]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } - - ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0], - ffeexpr_tokens_[0], ffeexpr_tokens_[1], - ffeexpr_tokens_[2], ffeexpr_tokens_[3], - ffeexpr_tokens_[4], t); - - ffelex_token_kill (ffeexpr_tokens_[0]); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - ffelex_token_kill (ffeexpr_tokens_[3]); - ffelex_token_kill (ffeexpr_tokens_[4]); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_binary_ -- Handle binary operator possibility - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - The possibility of a binary operator is handled here, meaning the previous - token was an operand. */ - -static ffelexHandler -ffeexpr_token_binary_ (ffelexToken t) -{ - ffeexprExpr_ e; - - if (!ffeexpr_stack_->is_rhs) - return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */ - - switch (ffelex_token_type (t)) - { - case FFELEX_typePLUS: - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorADD_; - e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; - e->u.operator.as = FFEEXPR_operatorassociativityADD_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeMINUS: - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorSUBTRACT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; - e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeASTERISK: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATA: - return (ffelexHandler) ffeexpr_finished_ (t); - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorMULTIPLY_; - e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_; - e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeSLASH: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATA: - return (ffelexHandler) ffeexpr_finished_ (t); - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorDIVIDE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_; - e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typePOWER: - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorPOWER_; - e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_; - e->u.operator.as = FFEEXPR_operatorassociativityPOWER_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeCONCAT: - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorCONCATENATE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; - e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeOPEN_ANGLE: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFORMAT: - ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - break; - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorLT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; - e->u.operator.as = FFEEXPR_operatorassociativityLT_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeCLOSE_ANGLE: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFORMAT: - return ffeexpr_finished_ (t); - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorGT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; - e->u.operator.as = FFEEXPR_operatorassociativityGT_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeREL_EQ: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFORMAT: - ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - break; - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorEQ_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; - e->u.operator.as = FFEEXPR_operatorassociativityEQ_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeREL_NE: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFORMAT: - ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - break; - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorNE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; - e->u.operator.as = FFEEXPR_operatorassociativityNE_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeREL_LE: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFORMAT: - ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - break; - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorLE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; - e->u.operator.as = FFEEXPR_operatorassociativityLE_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typeREL_GE: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextFORMAT: - ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - break; - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorGE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; - e->u.operator.as = FFEEXPR_operatorassociativityGE_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_; - - case FFELEX_typePERIOD: - ffeexpr_tokens_[0] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_binary_period_; - -#if 0 - case FFELEX_typeOPEN_PAREN: - case FFELEX_typeCLOSE_PAREN: - case FFELEX_typeEQUALS: - case FFELEX_typePOINTS: - case FFELEX_typeCOMMA: - case FFELEX_typeCOLON: - case FFELEX_typeEOS: - case FFELEX_typeSEMICOLON: - case FFELEX_typeNAME: - case FFELEX_typeNAMES: -#endif - default: - return (ffelexHandler) ffeexpr_finished_ (t); - } -} - -/* ffeexpr_token_binary_period_ -- Binary PERIOD - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle a period detected at binary (expecting binary op or end) state. - Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not - valid. */ - -static ffelexHandler -ffeexpr_token_binary_period_ (ffelexToken t) -{ - ffeexprExpr_ operand; - - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - ffeexpr_current_dotdot_ = ffestr_other (t); - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherTRUE: - case FFESTR_otherFALSE: - case FFESTR_otherNOT: - if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR)) - { - operand = ffeexpr_stack_->exprstack; - assert (operand != NULL); - assert (operand->type == FFEEXPR_exprtypeOPERAND_); - ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token)); - ffebad_here (1, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_binary_sw_per_; - - default: - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_binary_end_per_; - } - break; /* Nothing really reaches here. */ - - default: - if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_binary_ (t); - } -} - -/* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Expecting a period to close a dot-dot at binary (binary op - or operator) state. If period isn't found, issue a diagnostic but - pretend we saw one. ffeexpr_current_dotdot_ must already contained the - dotdot representation of the name in between the two PERIOD tokens. */ - -static ffelexHandler -ffeexpr_token_binary_end_per_ (ffelexToken t) -{ - ffeexprExpr_ e; - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffeexpr_tokens_[0]; - - switch (ffeexpr_current_dotdot_) - { - case FFESTR_otherAND: - e->u.operator.op = FFEEXPR_operatorAND_; - e->u.operator.prec = FFEEXPR_operatorprecedenceAND_; - e->u.operator.as = FFEEXPR_operatorassociativityAND_; - break; - - case FFESTR_otherOR: - e->u.operator.op = FFEEXPR_operatorOR_; - e->u.operator.prec = FFEEXPR_operatorprecedenceOR_; - e->u.operator.as = FFEEXPR_operatorassociativityOR_; - break; - - case FFESTR_otherXOR: - e->u.operator.op = FFEEXPR_operatorXOR_; - e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_; - e->u.operator.as = FFEEXPR_operatorassociativityXOR_; - break; - - case FFESTR_otherEQV: - e->u.operator.op = FFEEXPR_operatorEQV_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_; - e->u.operator.as = FFEEXPR_operatorassociativityEQV_; - break; - - case FFESTR_otherNEQV: - e->u.operator.op = FFEEXPR_operatorNEQV_; - e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_; - e->u.operator.as = FFEEXPR_operatorassociativityNEQV_; - break; - - case FFESTR_otherLT: - e->u.operator.op = FFEEXPR_operatorLT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; - e->u.operator.as = FFEEXPR_operatorassociativityLT_; - break; - - case FFESTR_otherLE: - e->u.operator.op = FFEEXPR_operatorLE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; - e->u.operator.as = FFEEXPR_operatorassociativityLE_; - break; - - case FFESTR_otherEQ: - e->u.operator.op = FFEEXPR_operatorEQ_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; - e->u.operator.as = FFEEXPR_operatorassociativityEQ_; - break; - - case FFESTR_otherNE: - e->u.operator.op = FFEEXPR_operatorNE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; - e->u.operator.as = FFEEXPR_operatorassociativityNE_; - break; - - case FFESTR_otherGT: - e->u.operator.op = FFEEXPR_operatorGT_; - e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; - e->u.operator.as = FFEEXPR_operatorassociativityGT_; - break; - - case FFESTR_otherGE: - e->u.operator.op = FFEEXPR_operatorGE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; - e->u.operator.as = FFEEXPR_operatorassociativityGE_; - break; - - default: - if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); - ffebad_finish (); - } - e->u.operator.op = FFEEXPR_operatorEQ_; - e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; - e->u.operator.as = FFEEXPR_operatorassociativityEQ_; - break; - } - - ffeexpr_exprstack_push_binary_ (e); - - if (ffelex_token_type (t) != FFELEX_typePERIOD) - { - if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ - return (ffelexHandler) ffeexpr_token_rhs_ (t); - } - - ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ - return (ffelexHandler) ffeexpr_token_rhs_; -} - -/* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - A diagnostic has already been issued; just swallow a period if there is - one, then continue with ffeexpr_token_binary_. */ - -static ffelexHandler -ffeexpr_token_binary_sw_per_ (ffelexToken t) -{ - if (ffelex_token_type (t) != FFELEX_typePERIOD) - return (ffelexHandler) ffeexpr_token_binary_ (t); - - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_quote_ -- Rhs QUOTE - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Expecting a NUMBER that we'll treat as an octal integer. */ - -static ffelexHandler -ffeexpr_token_quote_ (ffelexToken t) -{ - ffeexprExpr_ e; - ffebld anyexpr; - - if (ffelex_token_type (t) != FFELEX_typeNUMBER) - { - if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_rhs_ (t); - } - - /* This is kind of a kludge to prevent any whining about magical numbers - that start out as these octal integers, so "20000000000 (on a 32-bit - 2's-complement machine) by itself won't produce an error. */ - - anyexpr = ffebld_new_any (); - ffebld_set_info (anyexpr, ffeinfo_new_any ()); - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - e->u.operand = ffebld_new_conter_with_orig - (ffebld_constant_new_integeroctal (t), anyexpr); - ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - ffeexpr_exprstack_push_operand_ (e); - return (ffelexHandler) ffeexpr_token_binary_; -} - -/* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle an open-apostrophe, which begins either a character ('char-const'), - typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or - 'hex-const'X) constant. */ - -static ffelexHandler -ffeexpr_token_apostrophe_ (ffelexToken t) -{ - assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); - if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0)) - { - ffebad_start (FFEBAD_NULL_CHAR_CONST); - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_apos_char_; -} - -/* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Close-apostrophe is implicit; if this token is NAME, it is a possible - typeless-constant radix specifier. */ - -static ffelexHandler -ffeexpr_token_apos_char_ (ffelexToken t) -{ - ffeexprExpr_ e; - ffeinfo ni; - char c; - ffetargetCharacterSize size; - - if ((ffelex_token_type (t) == FFELEX_typeNAME) - || (ffelex_token_type (t) == FFELEX_typeNAMES)) - { - if ((ffelex_token_length (t) == 1) - && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B', - 'b') - || ffesrc_char_match_init (c, 'O', 'o') - || ffesrc_char_match_init (c, 'X', 'x') - || ffesrc_char_match_init (c, 'Z', 'z'))) - { - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - switch (c) - { - case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): - e->u.operand = ffebld_new_conter - (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1])); - size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]); - break; - - case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): - e->u.operand = ffebld_new_conter - (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1])); - size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]); - break; - - case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): - e->u.operand = ffebld_new_conter - (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1])); - size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); - break; - - case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): - e->u.operand = ffebld_new_conter - (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1])); - size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); - break; - - default: - no_match: /* :::::::::::::::::::: */ - assert ("not BOXZ!" == NULL); - size = 0; - break; - } - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); - ffeexpr_exprstack_push_operand_ (e); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) ffeexpr_token_binary_; - } - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault - (ffeexpr_tokens_[1])); - ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - ffelex_token_length (ffeexpr_tokens_[1])); - ffebld_set_info (e->u.operand, ni); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffeexpr_exprstack_push_operand_ (e); - if ((ffelex_token_type (t) == FFELEX_typeNAME) - || (ffelex_token_type (t) == FFELEX_typeNAMES)) - { - if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) - { - ffebad_string (ffelex_token_text (t)); - ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_finish (); - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeBINARY_; - e->token = ffelex_token_use (t); - e->u.operator.op = FFEEXPR_operatorCONCATENATE_; - e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; - e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; - ffeexpr_exprstack_push_binary_ (e); - return (ffelexHandler) ffeexpr_token_rhs_ (t); - } - ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */ - return (ffelexHandler) ffeexpr_token_substrp_ (t); -} - -/* ffeexpr_token_name_lhs_ -- Lhs NAME - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle a name followed by open-paren, period (RECORD.MEMBER), percent - (RECORD%MEMBER), or nothing at all. */ - -static ffelexHandler -ffeexpr_token_name_lhs_ (ffelexToken t) -{ - ffeexprExpr_ e; - ffeexprParenType_ paren_type; - ffesymbol s; - ffebld expr; - ffeinfo info; - - switch (ffelex_token_type (t)) - { - case FFELEX_typeOPEN_PAREN: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextASSIGN: - case FFEEXPR_contextAGOTO: - case FFEEXPR_contextFILEUNIT_DF: - goto just_name; /* :::::::::::::::::::: */ - - default: - break; - } - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffelex_token_use (ffeexpr_tokens_[0]); - s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE, - &paren_type); - - switch (ffesymbol_where (s)) - { - case FFEINFO_whereLOCAL: - if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) - ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */ - break; - - case FFEINFO_whereINTRINSIC: - case FFEINFO_whereGLOBAL: - if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) - ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ - break; - - case FFEINFO_whereCOMMON: - case FFEINFO_whereDUMMY: - case FFEINFO_whereRESULT: - break; - - case FFEINFO_whereNONE: - case FFEINFO_whereANY: - break; - - default: - ffesymbol_error (s, ffeexpr_tokens_[0]); - break; - } - - if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) - { - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - } - else - { - e->u.operand = ffebld_new_symter (s, - ffesymbol_generic (s), - ffesymbol_specific (s), - ffesymbol_implementation (s)); - ffebld_set_info (e->u.operand, ffesymbol_info (s)); - } - ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ - ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; - switch (paren_type) - { - case FFEEXPR_parentypeSUBROUTINE_: - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextACTUALARG_, - ffeexpr_token_arguments_); - - case FFEEXPR_parentypeARRAY_: - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - ffeexpr_stack_->bound_list = ffesymbol_dims (s); - ffeexpr_stack_->rank = 0; - ffeexpr_stack_->constant = TRUE; - ffeexpr_stack_->immediate = TRUE; - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextDATAIMPDOITEM_: - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextDATAIMPDOINDEX_, - ffeexpr_token_elements_); - - case FFEEXPR_contextEQUIVALENCE: - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextEQVINDEX_, - ffeexpr_token_elements_); - - default: - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextINDEX_, - ffeexpr_token_elements_); - } - - case FFEEXPR_parentypeSUBSTRING_: - e->u.operand = ffeexpr_collapse_symter (e->u.operand, - ffeexpr_tokens_[0]); - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextINDEX_, - ffeexpr_token_substring_); - - case FFEEXPR_parentypeEQUIVALENCE_: - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - ffeexpr_stack_->bound_list = ffesymbol_dims (s); - ffeexpr_stack_->rank = 0; - ffeexpr_stack_->constant = TRUE; - ffeexpr_stack_->immediate = TRUE; - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextEQVINDEX_, - ffeexpr_token_equivalence_); - - case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */ - case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */ - ffesymbol_error (s, ffeexpr_tokens_[0]); - /* Fall through. */ - case FFEEXPR_parentypeANY_: - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextACTUALARG_, - ffeexpr_token_anything_); - - default: - assert ("bad paren type" == NULL); - break; - } - - case FFELEX_typeEQUALS: /* As in "VAR=". */ - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextIMPDOITEM_: /* within - "(,VAR=start,end[,incr])". */ - case FFEEXPR_contextIMPDOITEMDF_: - ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; - break; - - case FFEEXPR_contextDATAIMPDOITEM_: - ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_; - break; - - default: - break; - } - break; - -#if 0 - case FFELEX_typePERIOD: - case FFELEX_typePERCENT: - assert ("FOO%, FOO. not yet supported!~~" == NULL); - break; -#endif - - default: - break; - } - -just_name: /* :::::::::::::::::::: */ - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], - (ffeexpr_stack_->context - == FFEEXPR_contextSUBROUTINEREF)); - - switch (ffesymbol_where (s)) - { - case FFEINFO_whereCONSTANT: - if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER) - || (ffesymbol_kind (s) != FFEINFO_kindENTITY)) - ffesymbol_error (s, ffeexpr_tokens_[0]); - break; - - case FFEINFO_whereIMMEDIATE: - if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_) - && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_)) - ffesymbol_error (s, ffeexpr_tokens_[0]); - break; - - case FFEINFO_whereLOCAL: - if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) - ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */ - break; - - case FFEINFO_whereINTRINSIC: - if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) - ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ - break; - - default: - break; - } - - if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) - { - expr = ffebld_new_any (); - info = ffeinfo_new_any (); - ffebld_set_info (expr, info); - } - else - { - expr = ffebld_new_symter (s, - ffesymbol_generic (s), - ffesymbol_specific (s), - ffesymbol_implementation (s)); - info = ffesymbol_info (s); - ffebld_set_info (expr, info); - if (ffesymbol_is_doiter (s)) - { - ffebad_start (FFEBAD_DOITER); - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffest_ffebad_here_doiter (1, s); - ffebad_string (ffesymbol_text (s)); - ffebad_finish (); - } - expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]); - } - - if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) - { - if (ffebld_op (expr) == FFEBLD_opANY) - { - expr = ffebld_new_any (); - ffebld_set_info (expr, ffeinfo_new_any ()); - } - else - { - expr = ffebld_new_subrref (expr, NULL); /* No argument list. */ - if (ffesymbol_generic (s) != FFEINTRIN_genNONE) - ffeintrin_fulfill_generic (&expr, &info, e->token); - else if (ffesymbol_specific (s) != FFEINTRIN_specNONE) - ffeintrin_fulfill_specific (&expr, &info, NULL, e->token); - else - ffeexpr_fulfill_call_ (&expr, e->token); - - if (ffebld_op (expr) != FFEBLD_opANY) - ffebld_set_info (expr, - ffeinfo_new (ffeinfo_basictype (info), - ffeinfo_kindtype (info), - 0, - FFEINFO_kindENTITY, - FFEINFO_whereFLEETING, - ffeinfo_size (info))); - else - ffebld_set_info (expr, ffeinfo_new_any ()); - } - } - - e->u.operand = expr; - ffeexpr_exprstack_push_operand_ (e); - return (ffelexHandler) ffeexpr_finished_ (t); -} - -/* ffeexpr_token_name_arg_ -- Rhs NAME - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle first token in an actual-arg (or possible actual-arg) context - being a NAME, and use second token to refine the context. */ - -static ffelexHandler -ffeexpr_token_name_arg_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeCLOSE_PAREN: - case FFELEX_typeCOMMA: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; - break; - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; - break; - - default: - break; - } - break; - - default: - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; - break; - - case FFEEXPR_contextINDEXORACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; - break; - - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - ffeexpr_stack_->context - = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; - break; - - default: - assert ("bad context in _name_arg_" == NULL); - break; - } - break; - } - - return (ffelexHandler) ffeexpr_token_name_rhs_ (t); -} - -/* ffeexpr_token_name_rhs_ -- Rhs NAME - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle a name followed by open-paren, apostrophe (O'octal-const', - Z'hex-const', or X'hex-const'), period (RECORD.MEMBER). - - 26-Nov-91 JCB 1.2 - When followed by apostrophe or quote, set lex hexnum flag on so - [0-9] as first char of next token seen as starting a potentially - hex number (NAME). - 04-Oct-91 JCB 1.1 - In case of intrinsic, decorate its SYMTER with the type info for - the specific intrinsic. */ - -static ffelexHandler -ffeexpr_token_name_rhs_ (ffelexToken t) -{ - ffeexprExpr_ e; - ffeexprParenType_ paren_type; - ffesymbol s; - bool sfdef; - - switch (ffelex_token_type (t)) - { - case FFELEX_typeQUOTE: - case FFELEX_typeAPOSTROPHE: - ffeexpr_tokens_[1] = ffelex_token_use (t); - ffelex_set_hexnum (TRUE); - return (ffelexHandler) ffeexpr_token_name_apos_; - - case FFELEX_typeOPEN_PAREN: - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffelex_token_use (ffeexpr_tokens_[0]); - s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE, - &paren_type); - if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) - e->u.operand = ffebld_new_any (); - else - e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s), - ffesymbol_specific (s), - ffesymbol_implementation (s)); - ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ - ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - { - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - sfdef = TRUE; - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - assert ("weird context!" == NULL); - sfdef = FALSE; - break; - - default: - sfdef = FALSE; - break; - } - switch (paren_type) - { - case FFEEXPR_parentypeFUNCTION_: - ffebld_set_info (e->u.operand, ffesymbol_info (s)); - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) - { /* A statement function. */ - ffeexpr_stack_->num_args - = ffebld_list_length - (ffeexpr_stack_->next_dummy - = ffesymbol_dummyargs (s)); - ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */ - } - else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC) - && !ffe_is_pedantic_not_90 () - && ((ffesymbol_implementation (s) - == FFEINTRIN_impICHAR) - || (ffesymbol_implementation (s) - == FFEINTRIN_impIACHAR) - || (ffesymbol_implementation (s) - == FFEINTRIN_impLEN))) - { /* Allow arbitrary concatenations. */ - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - sfdef - ? FFEEXPR_contextSFUNCDEF - : FFEEXPR_contextLET, - ffeexpr_token_arguments_); - } - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - sfdef - ? FFEEXPR_contextSFUNCDEFACTUALARG_ - : FFEEXPR_contextACTUALARG_, - ffeexpr_token_arguments_); - - case FFEEXPR_parentypeARRAY_: - ffebld_set_info (e->u.operand, - ffesymbol_info (ffebld_symter (e->u.operand))); - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - ffeexpr_stack_->bound_list = ffesymbol_dims (s); - ffeexpr_stack_->rank = 0; - ffeexpr_stack_->constant = TRUE; - ffeexpr_stack_->immediate = TRUE; - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - sfdef - ? FFEEXPR_contextSFUNCDEFINDEX_ - : FFEEXPR_contextINDEX_, - ffeexpr_token_elements_); - - case FFEEXPR_parentypeSUBSTRING_: - ffebld_set_info (e->u.operand, - ffesymbol_info (ffebld_symter (e->u.operand))); - e->u.operand = ffeexpr_collapse_symter (e->u.operand, - ffeexpr_tokens_[0]); - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - sfdef - ? FFEEXPR_contextSFUNCDEFINDEX_ - : FFEEXPR_contextINDEX_, - ffeexpr_token_substring_); - - case FFEEXPR_parentypeFUNSUBSTR_: - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - sfdef - ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_ - : FFEEXPR_contextINDEXORACTUALARG_, - ffeexpr_token_funsubstr_); - - case FFEEXPR_parentypeANY_: - ffebld_set_info (e->u.operand, ffesymbol_info (s)); - return - (ffelexHandler) - ffeexpr_rhs (ffeexpr_stack_->pool, - sfdef - ? FFEEXPR_contextSFUNCDEFACTUALARG_ - : FFEEXPR_contextACTUALARG_, - ffeexpr_token_anything_); - - default: - assert ("bad paren type" == NULL); - break; - } - - case FFELEX_typeEQUALS: /* As in "VAR=". */ - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */ - case FFEEXPR_contextIMPDOITEMDF_: - ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */ - ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; - break; - - default: - break; - } - break; - -#if 0 - case FFELEX_typePERIOD: - case FFELEX_typePERCENT: - ~~Support these two someday, though not required - assert ("FOO%, FOO. not yet supported!~~" == NULL); - break; -#endif - - default: - break; - } - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextINDEXORACTUALARG_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - assert ("strange context" == NULL); - break; - - default: - break; - } - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE); - if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) - { - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - } - else - { - e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE, - ffesymbol_specific (s), - ffesymbol_implementation (s)); - if (ffesymbol_specific (s) == FFEINTRIN_specNONE) - ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s))); - else - { /* Decorate the SYMTER with the actual type - of the intrinsic. */ - ffebld_set_info (e->u.operand, ffeinfo_new - (ffeintrin_basictype (ffesymbol_specific (s)), - ffeintrin_kindtype (ffesymbol_specific (s)), - 0, - ffesymbol_kind (s), - ffesymbol_where (s), - FFETARGET_charactersizeNONE)); - } - if (ffesymbol_is_doiter (s)) - ffebld_symter_set_is_doiter (e->u.operand, TRUE); - e->u.operand = ffeexpr_collapse_symter (e->u.operand, - ffeexpr_tokens_[0]); - } - ffeexpr_exprstack_push_operand_ (e); - return (ffelexHandler) ffeexpr_token_binary_ (t); -} - -/* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Expecting a NAME token, analyze the previous NAME token to see what kind, - if any, typeless constant we've got. - - 01-Sep-90 JCB 1.1 - Expect a NAME instead of CHARACTER in this situation. */ - -static ffelexHandler -ffeexpr_token_name_apos_ (ffelexToken t) -{ - ffeexprExpr_ e; - - ffelex_set_hexnum (FALSE); - - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - ffeexpr_tokens_[2] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_name_apos_name_; - - default: - break; - } - - if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) - { - ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffelex_token_kill (ffeexpr_tokens_[1]); - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - e->token = ffeexpr_tokens_[0]; - ffeexpr_exprstack_push_operand_ (e); - - return (ffelexHandler) ffeexpr_token_binary_ (t); -} - -/* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Expecting an APOSTROPHE token, analyze the previous NAME token to see - what kind, if any, typeless constant we've got. */ - -static ffelexHandler -ffeexpr_token_name_apos_name_ (ffelexToken t) -{ - ffeexprExpr_ e; - char c; - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - e->token = ffeexpr_tokens_[0]; - - if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1])) - && (ffelex_token_length (ffeexpr_tokens_[0]) == 1) - && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]), - 'B', 'b') - || ffesrc_char_match_init (c, 'O', 'o') - || ffesrc_char_match_init (c, 'X', 'x') - || ffesrc_char_match_init (c, 'Z', 'z'))) - { - ffetargetCharacterSize size; - - if (!ffe_is_typeless_boz ()) { - - switch (c) - { - case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch): - e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary - (ffeexpr_tokens_[2])); - break; - - case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch): - e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal - (ffeexpr_tokens_[2])); - break; - - case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch): - e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex - (ffeexpr_tokens_[2])); - break; - - case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch): - e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex - (ffeexpr_tokens_[2])); - break; - - default: - no_imatch: /* :::::::::::::::::::: */ - assert ("not BOXZ!" == NULL); - abort (); - } - - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - ffeexpr_exprstack_push_operand_ (e); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_; - } - - switch (c) - { - case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm - (ffeexpr_tokens_[2])); - size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]); - break; - - case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om - (ffeexpr_tokens_[2])); - size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]); - break; - - case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm - (ffeexpr_tokens_[2])); - size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); - break; - - case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm - (ffeexpr_tokens_[2])); - size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); - break; - - default: - no_match: /* :::::::::::::::::::: */ - assert ("not BOXZ!" == NULL); - e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm - (ffeexpr_tokens_[2])); - size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); - break; - } - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); - ffeexpr_exprstack_push_operand_ (e); - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - return (ffelexHandler) ffeexpr_token_binary_; - } - - if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) - { - ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); - ffebad_finish (); - } - - ffelex_token_kill (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[2]); - - e->type = FFEEXPR_exprtypeOPERAND_; - e->u.operand = ffebld_new_any (); - ffebld_set_info (e->u.operand, ffeinfo_new_any ()); - e->token = ffeexpr_tokens_[0]; - ffeexpr_exprstack_push_operand_ (e); - - switch (ffelex_token_type (t)) - { - case FFELEX_typeAPOSTROPHE: - case FFELEX_typeQUOTE: - return (ffelexHandler) ffeexpr_token_binary_; - - default: - return (ffelexHandler) ffeexpr_token_binary_ (t); - } -} - -/* ffeexpr_token_percent_ -- Rhs PERCENT - - Handle a percent sign possibly followed by "LOC". If followed instead - by "VAL", "REF", or "DESCR", issue an error message and substitute - "LOC". If followed by something else, treat the percent sign as a - spurious incorrect token and reprocess the token via _rhs_. */ - -static ffelexHandler -ffeexpr_token_percent_ (ffelexToken t) -{ - switch (ffelex_token_type (t)) - { - case FFELEX_typeNAME: - case FFELEX_typeNAMES: - ffeexpr_stack_->percent = ffeexpr_percent_ (t); - ffeexpr_tokens_[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_token_percent_name_; - - default: - if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - return (ffelexHandler) ffeexpr_token_rhs_ (t); - } -} - -/* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME - - Make sure the token is OPEN_PAREN and prepare for the one-item list of - LHS expressions. Else display an error message. */ - -static ffelexHandler -ffeexpr_token_percent_name_ (ffelexToken t) -{ - ffelexHandler nexthandler; - - if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) - { - if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), - ffelex_token_where_column (ffeexpr_stack_->first_token)); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_tokens_[0]); - nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]); - ffelex_token_kill (ffeexpr_tokens_[1]); - return (ffelexHandler) (*nexthandler) (t); - } - - switch (ffeexpr_stack_->percent) - { - default: - if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), - ffelex_token_where_column (ffeexpr_tokens_[0])); - ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); - ffebad_finish (); - } - ffeexpr_stack_->percent = FFEEXPR_percentLOC_; - /* Fall through. */ - case FFEEXPR_percentLOC_: - ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; - ffelex_token_kill (ffeexpr_tokens_[1]); - ffeexpr_stack_->tokens[1] = ffelex_token_use (t); - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextLOC_, - ffeexpr_cb_end_loc_); - } -} - -/* ffeexpr_make_float_const_ -- Make a floating-point constant - - See prototype. - - Pass 'E', 'D', or 'Q' for exponent letter. */ - -static void -ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, - ffelexToken decimal, ffelexToken fraction, - ffelexToken exponent, ffelexToken exponent_sign, - ffelexToken exponent_digits) -{ - ffeexprExpr_ e; - - e = ffeexpr_expr_new_ (); - e->type = FFEEXPR_exprtypeOPERAND_; - if (integer != NULL) - e->token = ffelex_token_use (integer); - else - { - assert (decimal != NULL); - e->token = ffelex_token_use (decimal); - } - - switch (exp_letter) - { -#if !FFETARGET_okREALQUAD - case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): - if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED)) - { - ffebad_here (0, ffelex_token_where_line (e->token), - ffelex_token_where_column (e->token)); - ffebad_finish (); - } - goto match_d; /* The FFESRC_CASE_* macros don't - allow fall-through! */ -#endif - - case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble - (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - break; - - case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault - (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); - ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL, - FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - break; - -#if FFETARGET_okREALQUAD - case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): - e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad - (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD, - 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); - break; -#endif - - case 'I': /* Make an integer. */ - e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault - (ffeexpr_tokens_[0])); - ffebld_set_info (e->u.operand, - ffeinfo_new (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, - FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - break; - - default: - no_match: /* :::::::::::::::::::: */ - assert ("Lost the exponent letter!" == NULL); - } - - ffeexpr_exprstack_push_operand_ (e); -} - -/* Just like ffesymbol_declare_local, except performs any implicit info - assignment necessary. */ - -static ffesymbol -ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin) -{ - ffesymbol s; - ffeinfoKind k; - bool bad; - - s = ffesymbol_declare_local (t, maybe_intrin); - - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - /* Special-case these since they can involve a different concept - of "state" (in the stmtfunc name space). */ - { - case FFEEXPR_contextDATAIMPDOINDEX_: - case FFEEXPR_contextDATAIMPDOCTRL_: - if (ffeexpr_context_outer_ (ffeexpr_stack_) - == FFEEXPR_contextDATAIMPDOINDEX_) - s = ffeexpr_sym_impdoitem_ (s, t); - else - if (ffeexpr_stack_->is_rhs) - s = ffeexpr_sym_impdoitem_ (s, t); - else - s = ffeexpr_sym_lhs_impdoctrl_ (s, t); - bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY) - || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT) - && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE)); - if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY)) - ffesymbol_error (s, t); - return s; - - default: - break; - } - - switch ((ffesymbol_sfdummyparent (s) == NULL) - ? ffesymbol_state (s) - : FFESYMBOL_stateUNDERSTOOD) - { - case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr - context. */ - if (!ffest_seen_first_exec ()) - goto seen; /* :::::::::::::::::::: */ - /* Fall through. */ - case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - { - case FFEEXPR_contextSUBROUTINEREF: - s = ffeexpr_sym_lhs_call_ (s, t); - break; - - case FFEEXPR_contextFILEEXTFUNC: - s = ffeexpr_sym_lhs_extfunc_ (s, t); - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - /* Fall through. */ - case FFEEXPR_contextACTUALARG_: - s = ffeexpr_sym_rhs_actualarg_ (s, t); - break; - - case FFEEXPR_contextDATA: - if (ffeexpr_stack_->is_rhs) - s = ffeexpr_sym_rhs_let_ (s, t); - else - s = ffeexpr_sym_lhs_data_ (s, t); - break; - - case FFEEXPR_contextDATAIMPDOITEM_: - s = ffeexpr_sym_lhs_data_ (s, t); - break; - - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - /* Fall through. */ - case FFEEXPR_contextLET: - case FFEEXPR_contextPAREN_: - case FFEEXPR_contextACTUALARGEXPR_: - case FFEEXPR_contextINDEXORACTUALARGEXPR_: - case FFEEXPR_contextASSIGN: - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextDO: - case FFEEXPR_contextDOWHILE: - case FFEEXPR_contextAGOTO: - case FFEEXPR_contextCGOTO: - case FFEEXPR_contextIF: - case FFEEXPR_contextARITHIF: - case FFEEXPR_contextFORMAT: - case FFEEXPR_contextSTOP: - case FFEEXPR_contextRETURN: - case FFEEXPR_contextSELECTCASE: - case FFEEXPR_contextCASE: - case FFEEXPR_contextFILEASSOC: - case FFEEXPR_contextFILEINT: - case FFEEXPR_contextFILEDFINT: - case FFEEXPR_contextFILELOG: - case FFEEXPR_contextFILENUM: - case FFEEXPR_contextFILENUMAMBIG: - case FFEEXPR_contextFILECHAR: - case FFEEXPR_contextFILENUMCHAR: - case FFEEXPR_contextFILEDFCHAR: - case FFEEXPR_contextFILEKEY: - case FFEEXPR_contextFILEUNIT: - case FFEEXPR_contextFILEUNIT_DF: - case FFEEXPR_contextFILEUNITAMBIG: - case FFEEXPR_contextFILEFORMAT: - case FFEEXPR_contextFILENAMELIST: - case FFEEXPR_contextFILEVXTCODE: - case FFEEXPR_contextINDEX_: - case FFEEXPR_contextIMPDOITEM_: - case FFEEXPR_contextIMPDOITEMDF_: - case FFEEXPR_contextIMPDOCTRL_: - case FFEEXPR_contextLOC_: - if (ffeexpr_stack_->is_rhs) - s = ffeexpr_sym_rhs_let_ (s, t); - else - s = ffeexpr_sym_lhs_let_ (s, t); - break; - - case FFEEXPR_contextCHARACTERSIZE: - case FFEEXPR_contextEQUIVALENCE: - case FFEEXPR_contextINCLUDE: - case FFEEXPR_contextPARAMETER: - case FFEEXPR_contextDIMLIST: - case FFEEXPR_contextDIMLISTCOMMON: - case FFEEXPR_contextKINDTYPE: - case FFEEXPR_contextINITVAL: - case FFEEXPR_contextEQVINDEX_: - break; /* Will turn into errors below. */ - - default: - ffesymbol_error (s, t); - break; - } - /* Fall through. */ - case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ - understood: /* :::::::::::::::::::: */ - k = ffesymbol_kind (s); - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - { - case FFEEXPR_contextSUBROUTINEREF: - bad = ((k != FFEINFO_kindSUBROUTINE) - && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) - || (k != FFEINFO_kindNONE))); - break; - - case FFEEXPR_contextFILEEXTFUNC: - bad = (k != FFEINFO_kindFUNCTION) - || (ffesymbol_where (s) != FFEINFO_whereGLOBAL); - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - case FFEEXPR_contextACTUALARG_: - switch (k) - { - case FFEINFO_kindENTITY: - bad = FALSE; - break; - - case FFEINFO_kindFUNCTION: - case FFEINFO_kindSUBROUTINE: - bad - = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL) - && (ffesymbol_where (s) != FFEINFO_whereDUMMY) - && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) - || !ffeintrin_is_actualarg (ffesymbol_specific (s)))); - break; - - case FFEINFO_kindNONE: - if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) - { - bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s))); - break; - } - - /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY, - and in the former case, attrsTYPE is set, so we - see this as an error as we should, since CHAR*(*) - cannot be actually referenced in a main/block data - program unit. */ - - if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsTYPE)) - == FFESYMBOL_attrsEXTERNAL) - bad = FALSE; - else - bad = TRUE; - break; - - default: - bad = TRUE; - break; - } - break; - - case FFEEXPR_contextDATA: - if (ffeexpr_stack_->is_rhs) - bad = (k != FFEINFO_kindENTITY) - || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); - else - bad = (k != FFEINFO_kindENTITY) - || ((ffesymbol_where (s) != FFEINFO_whereNONE) - && (ffesymbol_where (s) != FFEINFO_whereLOCAL) - && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); - break; - - case FFEEXPR_contextDATAIMPDOITEM_: - bad = TRUE; /* Unadorned item never valid. */ - break; - - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - case FFEEXPR_contextLET: - case FFEEXPR_contextPAREN_: - case FFEEXPR_contextACTUALARGEXPR_: - case FFEEXPR_contextINDEXORACTUALARGEXPR_: - case FFEEXPR_contextASSIGN: - case FFEEXPR_contextIOLIST: - case FFEEXPR_contextIOLISTDF: - case FFEEXPR_contextDO: - case FFEEXPR_contextDOWHILE: - case FFEEXPR_contextAGOTO: - case FFEEXPR_contextCGOTO: - case FFEEXPR_contextIF: - case FFEEXPR_contextARITHIF: - case FFEEXPR_contextFORMAT: - case FFEEXPR_contextSTOP: - case FFEEXPR_contextRETURN: - case FFEEXPR_contextSELECTCASE: - case FFEEXPR_contextCASE: - case FFEEXPR_contextFILEASSOC: - case FFEEXPR_contextFILEINT: - case FFEEXPR_contextFILEDFINT: - case FFEEXPR_contextFILELOG: - case FFEEXPR_contextFILENUM: - case FFEEXPR_contextFILENUMAMBIG: - case FFEEXPR_contextFILECHAR: - case FFEEXPR_contextFILENUMCHAR: - case FFEEXPR_contextFILEDFCHAR: - case FFEEXPR_contextFILEKEY: - case FFEEXPR_contextFILEUNIT: - case FFEEXPR_contextFILEUNIT_DF: - case FFEEXPR_contextFILEUNITAMBIG: - case FFEEXPR_contextFILEFORMAT: - case FFEEXPR_contextFILENAMELIST: - case FFEEXPR_contextFILEVXTCODE: - case FFEEXPR_contextINDEX_: - case FFEEXPR_contextIMPDOITEM_: - case FFEEXPR_contextIMPDOITEMDF_: - case FFEEXPR_contextIMPDOCTRL_: - case FFEEXPR_contextLOC_: - bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE - X(A);EXTERNAL A;CALL - Y(A);B=A", for example. */ - break; - - case FFEEXPR_contextCHARACTERSIZE: - case FFEEXPR_contextEQUIVALENCE: - case FFEEXPR_contextPARAMETER: - case FFEEXPR_contextDIMLIST: - case FFEEXPR_contextDIMLISTCOMMON: - case FFEEXPR_contextKINDTYPE: - case FFEEXPR_contextINITVAL: - case FFEEXPR_contextEQVINDEX_: - bad = (k != FFEINFO_kindENTITY) - || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); - break; - - case FFEEXPR_contextINCLUDE: - bad = TRUE; - break; - - default: - bad = TRUE; - break; - } - if (bad && (k != FFEINFO_kindANY)) - ffesymbol_error (s, t); - return s; - - case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ - seen: /* :::::::::::::::::::: */ - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - { - case FFEEXPR_contextPARAMETER: - if (ffeexpr_stack_->is_rhs) - ffesymbol_error (s, t); - else - s = ffeexpr_sym_lhs_parameter_ (s, t); - break; - - case FFEEXPR_contextDATA: - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - if (ffeexpr_stack_->is_rhs) - ffesymbol_error (s, t); - else - s = ffeexpr_sym_lhs_data_ (s, t); - goto understood; /* :::::::::::::::::::: */ - - case FFEEXPR_contextDATAIMPDOITEM_: - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - s = ffeexpr_sym_lhs_data_ (s, t); - goto understood; /* :::::::::::::::::::: */ - - case FFEEXPR_contextEQUIVALENCE: - s = ffeexpr_sym_lhs_equivalence_ (s, t); - break; - - case FFEEXPR_contextDIMLIST: - s = ffeexpr_sym_rhs_dimlist_ (s, t); - break; - - case FFEEXPR_contextCHARACTERSIZE: - case FFEEXPR_contextKINDTYPE: - case FFEEXPR_contextDIMLISTCOMMON: - case FFEEXPR_contextINITVAL: - case FFEEXPR_contextEQVINDEX_: - ffesymbol_error (s, t); - break; - - case FFEEXPR_contextINCLUDE: - ffesymbol_error (s, t); - break; - - case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */ - case FFEEXPR_contextSFUNCDEFACTUALARG_: - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - s = ffeexpr_sym_rhs_actualarg_ (s, t); - goto understood; /* :::::::::::::::::::: */ - - case FFEEXPR_contextINDEX_: - case FFEEXPR_contextACTUALARGEXPR_: - case FFEEXPR_contextINDEXORACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - assert (ffeexpr_stack_->is_rhs); - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - s = ffeexpr_sym_rhs_let_ (s, t); - goto understood; /* :::::::::::::::::::: */ - - default: - ffesymbol_error (s, t); - break; - } - return s; - - default: - assert ("bad symbol state" == NULL); - return NULL; - break; - } -} - -/* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH). - Could be found via the "statement-function" name space (in which case - it should become an iterator) or the local name space (in which case - it should be either a named constant, or a variable that will have an - sfunc name space sibling that should become an iterator). */ - -static ffesymbol -ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t) -{ - ffesymbol s; - ffesymbolAttrs sa; - ffesymbolAttrs na; - ffesymbolState ss; - ffesymbolState ns; - ffeinfoKind kind; - ffeinfoWhere where; - - ss = ffesymbol_state (sp); - - if (ffesymbol_sfdummyparent (sp) != NULL) - { /* Have symbol in sfunc name space. */ - switch (ss) - { - case FFESYMBOL_stateNONE: /* Used as iterator already. */ - if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) - ffesymbol_error (sp, t); /* Can't use dead iterator. */ - else - { /* Can use dead iterator because we're at at - least an innermore (higher-numbered) level - than the iterator's outermost - (lowest-numbered) level. */ - ffesymbol_signal_change (sp); - ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); - ffesymbol_set_maxentrynum (sp, ffeexpr_level_); - ffesymbol_signal_unreported (sp); - } - break; - - case FFESYMBOL_stateSEEN: /* Seen already in this or other - implied-DO. Set symbol level - number to outermost value, as that - tells us we can see it as iterator - at that level at the innermost. */ - if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) - { - ffesymbol_signal_change (sp); - ffesymbol_set_maxentrynum (sp, ffeexpr_level_); - ffesymbol_signal_unreported (sp); - } - break; - - case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ - assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp)); - ffesymbol_error (sp, t); /* (,,,I=I,10). */ - break; - - case FFESYMBOL_stateUNDERSTOOD: - break; /* ANY. */ - - default: - assert ("Foo Bar!!" == NULL); - break; - } - - return sp; - } - - /* Got symbol in local name space, so we haven't seen it in impdo yet. - First, if it is brand-new and we're in executable statements, set the - attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD. - Second, if it is now a constant (PARAMETER), then just return it, it - can't be an implied-do iterator. If it is understood, complain if it is - not a valid variable, but make the inner name space iterator anyway and - return that. If it is not understood, improve understanding of the - symbol accordingly, complain accordingly, in either case make the inner - name space iterator and return that. */ - - sa = ffesymbol_attrs (sp); - - if (ffesymbol_state_is_specable (ss) - && ffest_seen_first_exec ()) - { - assert (sa == FFESYMBOL_attrsetNONE); - ffesymbol_signal_change (sp); - ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); - ffesymbol_resolve_intrin (sp); - if (ffeimplic_establish_symbol (sp)) - ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG); - else - ffesymbol_error (sp, t); - - /* After the exec transition, the state will either be UNCERTAIN (could - be a dummy or local var) or UNDERSTOOD (local var, because this is a - PROGRAM/BLOCKDATA program unit). */ - - sp = ffecom_sym_exec_transition (sp); - sa = ffesymbol_attrs (sp); - ss = ffesymbol_state (sp); - } - - ns = ss; - kind = ffesymbol_kind (sp); - where = ffesymbol_where (sp); - - if (ss == FFESYMBOL_stateUNDERSTOOD) - { - if (kind != FFEINFO_kindENTITY) - ffesymbol_error (sp, t); - if (where == FFEINFO_whereCONSTANT) - return sp; - } - else - { - /* Enhance understanding of local symbol. This used to imply exec - transition, but that doesn't seem necessary, since the local symbol - doesn't actually get put into an ffebld tree here -- we just learn - more about it, just like when we see a local symbol's name in the - dummy-arg list of a statement function. */ - - if (ss != FFESYMBOL_stateUNCERTAIN) - { - /* Figure out what kind of object we've got based on previous - declarations of or references to the object. */ - - ns = FFESYMBOL_stateSEEN; - - if (sa & FFESYMBOL_attrsANY) - na = sa; - else if (!(sa & ~(FFESYMBOL_attrsADJUSTS - | FFESYMBOL_attrsANY - | FFESYMBOL_attrsCOMMON - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEQUIV - | FFESYMBOL_attrsINIT - | FFESYMBOL_attrsNAMELIST - | FFESYMBOL_attrsRESULT - | FFESYMBOL_attrsSAVE - | FFESYMBOL_attrsSFARG - | FFESYMBOL_attrsTYPE))) - na = sa | FFESYMBOL_attrsSFARG; - else - na = FFESYMBOL_attrsetNONE; - } - else - { /* stateUNCERTAIN. */ - na = sa | FFESYMBOL_attrsSFARG; - ns = FFESYMBOL_stateUNDERSTOOD; - - assert (!(sa & ~(FFESYMBOL_attrsACTUALARG - | FFESYMBOL_attrsADJUSTABLE - | FFESYMBOL_attrsANYLEN - | FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsSFARG - | FFESYMBOL_attrsTYPE))); - - if (sa & FFESYMBOL_attrsEXTERNAL) - { - assert (!(sa & ~(FFESYMBOL_attrsACTUALARG - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsTYPE))); - - na = FFESYMBOL_attrsetNONE; - } - else if (sa & FFESYMBOL_attrsDUMMY) - { - assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ - assert (!(sa & ~(FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsTYPE))); - - kind = FFEINFO_kindENTITY; - } - else if (sa & FFESYMBOL_attrsARRAY) - { - assert (!(sa & ~(FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsADJUSTABLE - | FFESYMBOL_attrsTYPE))); - - na = FFESYMBOL_attrsetNONE; - } - else if (sa & FFESYMBOL_attrsSFARG) - { - assert (!(sa & ~(FFESYMBOL_attrsSFARG - | FFESYMBOL_attrsTYPE))); - - ns = FFESYMBOL_stateUNCERTAIN; - } - else if (sa & FFESYMBOL_attrsTYPE) - { - assert (!(sa & (FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsSFARG))); /* Handled above. */ - assert (!(sa & ~(FFESYMBOL_attrsTYPE - | FFESYMBOL_attrsADJUSTABLE - | FFESYMBOL_attrsANYLEN - | FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsSFARG))); - - kind = FFEINFO_kindENTITY; - - if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) - na = FFESYMBOL_attrsetNONE; - else if (ffest_is_entry_valid ()) - ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */ - else - where = FFEINFO_whereLOCAL; - } - else - na = FFESYMBOL_attrsetNONE; /* Error. */ - } - - /* Now see what we've got for a new object: NONE means a new error - cropped up; ANY means an old error to be ignored; otherwise, - everything's ok, update the object (symbol) and continue on. */ - - if (na == FFESYMBOL_attrsetNONE) - ffesymbol_error (sp, t); - else if (!(na & FFESYMBOL_attrsANY)) - { - ffesymbol_signal_change (sp); /* May need to back up to previous - version. */ - if (!ffeimplic_establish_symbol (sp)) - ffesymbol_error (sp, t); - else - { - ffesymbol_set_info (sp, - ffeinfo_new (ffesymbol_basictype (sp), - ffesymbol_kindtype (sp), - ffesymbol_rank (sp), - kind, - where, - ffesymbol_size (sp))); - ffesymbol_set_attrs (sp, na); - ffesymbol_set_state (sp, ns); - ffesymbol_resolve_intrin (sp); - if (!ffesymbol_state_is_specable (ns)) - sp = ffecom_sym_learned (sp); - ffesymbol_signal_unreported (sp); /* For debugging purposes. */ - } - } - } - - /* Here we create the sfunc-name-space symbol representing what should - become an iterator in this name space at this or an outermore (lower- - numbered) expression level, else the implied-DO construct is in error. */ - - s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj; - also sets sfa_dummy_parent to - parent symbol. */ - assert (sp == ffesymbol_sfdummyparent (s)); - - ffesymbol_signal_change (s); - ffesymbol_set_state (s, FFESYMBOL_stateSEEN); - ffesymbol_set_maxentrynum (s, ffeexpr_level_); - ffesymbol_set_info (s, - ffeinfo_new (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, - 0, - FFEINFO_kindENTITY, - FFEINFO_whereIMMEDIATE, - FFETARGET_charactersizeNONE)); - ffesymbol_signal_unreported (s); - - if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER) - && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY)) - ffesymbol_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_attrsARRAY - | 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); - bad = FALSE; - break; - - case FFEEXPR_contextCHARACTERSIZE: - case FFEEXPR_contextKINDTYPE: - case FFEEXPR_contextDIMLISTCOMMON: - case FFEEXPR_contextINITVAL: - case FFEEXPR_contextEQVINDEX_: - break; - - case FFEEXPR_contextINCLUDE: - break; - - case FFEEXPR_contextINDEX_: - case FFEEXPR_contextACTUALARGEXPR_: - case FFEEXPR_contextINDEXORACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - assert (ffeexpr_stack_->is_rhs); - s = ffecom_sym_exec_transition (s); - if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) - goto understood; /* :::::::::::::::::::: */ - s = ffeexpr_paren_rhs_let_ (s, t); - goto understood; /* :::::::::::::::::::: */ - - default: - break; - } - k = ffesymbol_kind (s); - switch (bad ? FFEINFO_kindANY : k) - { - case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ - *paren_type = FFEEXPR_parentypeFUNSUBSTR_; - break; - - case FFEINFO_kindFUNCTION: - *paren_type = FFEEXPR_parentypeFUNCTION_; - switch (ffesymbol_where (s)) - { - case FFEINFO_whereLOCAL: - bad = TRUE; /* Attempt to recurse! */ - break; - - case FFEINFO_whereCONSTANT: - bad = ((ffesymbol_sfexpr (s) == NULL) - || (ffebld_op (ffesymbol_sfexpr (s)) - == FFEBLD_opANY)); /* Attempt to recurse! */ - break; - - default: - break; - } - break; - - case FFEINFO_kindSUBROUTINE: - *paren_type = FFEEXPR_parentypeANY_; - bad = TRUE; /* Cannot possibly be in - contextSUBROUTINEREF. */ - break; - - case FFEINFO_kindENTITY: - if (ffesymbol_rank (s) == 0) - { - if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE) - *paren_type = FFEEXPR_parentypeEQUIVALENCE_; - else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) - *paren_type = FFEEXPR_parentypeSUBSTRING_; - else - { - bad = TRUE; - *paren_type = FFEEXPR_parentypeANY_; - } - } - else - *paren_type = FFEEXPR_parentypeARRAY_; - break; - - default: - case FFEINFO_kindANY: - bad = TRUE; - *paren_type = FFEEXPR_parentypeANY_; - break; - } - - if (bad) - { - if (k == FFEINFO_kindANY) - ffest_shutdown (); - else - ffesymbol_error (s, t); - } - - return s; - - default: - assert ("bad symbol state" == NULL); - return NULL; - } -} - -/* Have FOO in XYZ = ...FOO(...).... Executable context only. */ - -static ffesymbol -ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t) -{ - ffesymbolAttrs sa; - ffesymbolAttrs na; - ffeinfoKind kind; - ffeinfoWhere where; - ffeintrinGen gen; - ffeintrinSpec spec; - ffeintrinImp imp; - bool maybe_ambig = FALSE; - bool error = FALSE; - - assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) - || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); - - na = sa = ffesymbol_attrs (s); - - assert (!(sa & ~(FFESYMBOL_attrsACTUALARG - | FFESYMBOL_attrsADJUSTABLE - | FFESYMBOL_attrsANYLEN - | FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsSFARG - | FFESYMBOL_attrsTYPE))); - - kind = ffesymbol_kind (s); - where = ffesymbol_where (s); - - /* Figure out what kind of object we've got based on previous declarations - of or references to the object. */ - - if (sa & FFESYMBOL_attrsEXTERNAL) - { - assert (!(sa & ~(FFESYMBOL_attrsACTUALARG - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsTYPE))); - - if (sa & FFESYMBOL_attrsTYPE) - where = FFEINFO_whereGLOBAL; - else - /* Not TYPE. */ - { - kind = FFEINFO_kindFUNCTION; - - if (sa & FFESYMBOL_attrsDUMMY) - ; /* Not TYPE. */ - else if (sa & FFESYMBOL_attrsACTUALARG) - ; /* Not DUMMY or TYPE. */ - else /* Not ACTUALARG, DUMMY, or TYPE. */ - where = FFEINFO_whereGLOBAL; - } - } - else if (sa & FFESYMBOL_attrsDUMMY) - { - assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ - assert (!(sa & ~(FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsTYPE))); - - kind = FFEINFO_kindFUNCTION; - maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind - could be ENTITY w/substring ref. */ - } - else if (sa & FFESYMBOL_attrsARRAY) - { - assert (!(sa & ~(FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsADJUSTABLE - | FFESYMBOL_attrsTYPE))); - - where = FFEINFO_whereLOCAL; - } - else if (sa & FFESYMBOL_attrsSFARG) - { - assert (!(sa & ~(FFESYMBOL_attrsSFARG - | FFESYMBOL_attrsTYPE))); - - where = FFEINFO_whereLOCAL; /* Actually an error, but at least we - know it's a local var. */ - } - else if (sa & FFESYMBOL_attrsTYPE) - { - assert (!(sa & (FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsSFARG))); /* Handled above. */ - assert (!(sa & ~(FFESYMBOL_attrsTYPE - | FFESYMBOL_attrsADJUSTABLE - | FFESYMBOL_attrsANYLEN - | FFESYMBOL_attrsARRAY - | FFESYMBOL_attrsDUMMY - | FFESYMBOL_attrsEXTERNAL - | FFESYMBOL_attrsSFARG))); - - if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, - &gen, &spec, &imp)) - { - if (!(sa & FFESYMBOL_attrsANYLEN) - && (ffeimplic_peek_symbol_type (s, NULL) - == FFEINFO_basictypeCHARACTER)) - return s; /* Haven't learned anything yet. */ - - ffesymbol_signal_change (s); /* May need to back up to previous - version. */ - ffesymbol_set_generic (s, gen); - ffesymbol_set_specific (s, spec); - ffesymbol_set_implementation (s, imp); - ffesymbol_set_info (s, - ffeinfo_new (ffesymbol_basictype (s), - ffesymbol_kindtype (s), - 0, - FFEINFO_kindFUNCTION, - FFEINFO_whereINTRINSIC, - ffesymbol_size (s))); - ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); - ffesymbol_resolve_intrin (s); - ffesymbol_reference (s, t, FALSE); - s = ffecom_sym_learned (s); - ffesymbol_signal_unreported (s); /* For debugging purposes. */ - - return s; - } - if (sa & FFESYMBOL_attrsANYLEN) - error = TRUE; /* Error, since the only way we can, - given CHARACTER*(*) FOO, accept - FOO(...) is for FOO to be a dummy - arg or constant, but it can't - become either now. */ - else if (sa & FFESYMBOL_attrsADJUSTABLE) - { - kind = FFEINFO_kindENTITY; - where = FFEINFO_whereLOCAL; - } - else - { - kind = FFEINFO_kindFUNCTION; - where = FFEINFO_whereGLOBAL; - maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; - could be ENTITY/LOCAL w/substring ref. */ - } - } - else if (sa == FFESYMBOL_attrsetNONE) - { - assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); - - if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, - &gen, &spec, &imp)) - { - if (ffeimplic_peek_symbol_type (s, NULL) - == FFEINFO_basictypeCHARACTER) - return s; /* Haven't learned anything yet. */ - - ffesymbol_signal_change (s); /* May need to back up to previous - version. */ - ffesymbol_set_generic (s, gen); - ffesymbol_set_specific (s, spec); - ffesymbol_set_implementation (s, imp); - ffesymbol_set_info (s, - ffeinfo_new (ffesymbol_basictype (s), - ffesymbol_kindtype (s), - 0, - FFEINFO_kindFUNCTION, - FFEINFO_whereINTRINSIC, - ffesymbol_size (s))); - ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); - ffesymbol_resolve_intrin (s); - s = ffecom_sym_learned (s); - ffesymbol_reference (s, t, FALSE); - ffesymbol_signal_unreported (s); /* For debugging purposes. */ - return s; - } - - kind = FFEINFO_kindFUNCTION; - where = FFEINFO_whereGLOBAL; - maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; - could be ENTITY/LOCAL w/substring ref. */ - } - else - error = TRUE; - - /* Now see what we've got for a new object: NONE means a new error cropped - up; ANY means an old error to be ignored; otherwise, everything's ok, - update the object (symbol) and continue on. */ - - if (error) - ffesymbol_error (s, t); - else if (!(na & FFESYMBOL_attrsANY)) - { - ffesymbol_signal_change (s); /* May need to back up to previous - version. */ - if (!ffeimplic_establish_symbol (s)) - { - ffesymbol_error (s, t); - return s; - } - if (maybe_ambig - && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) - return s; /* Still not sure, let caller deal with it - based on (...). */ - - ffesymbol_set_info (s, - ffeinfo_new (ffesymbol_basictype (s), - ffesymbol_kindtype (s), - ffesymbol_rank (s), - kind, - where, - ffesymbol_size (s))); - ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); - ffesymbol_resolve_intrin (s); - s = ffecom_sym_learned (s); - ffesymbol_reference (s, t, FALSE); - ffesymbol_signal_unreported (s); /* For debugging purposes. */ - } - - return s; -} - -/* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle expression (which might be null) and COMMA or CLOSE_PAREN. */ - -static ffelexHandler -ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ procedure; - ffebld reduced; - ffeinfo info; - ffeexprContext ctx; - bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */ - - procedure = ffeexpr_stack_->exprstack; - info = ffebld_info (procedure->u.operand); - - /* Is there an expression to add? If the expression is nil, - it might still be an argument. It is if: - - - The current token is comma, or - - - The -fugly-comma flag was specified *and* the procedure - being invoked is external. - - Otherwise, if neither of the above is the case, just - ignore this (nil) expression. */ - - if ((expr != NULL) - || (ffelex_token_type (t) == FFELEX_typeCOMMA) - || (ffe_is_ugly_comma () - && (ffeinfo_where (info) == FFEINFO_whereGLOBAL))) - { - /* This expression, even if nil, is apparently intended as an argument. */ - - /* Internal procedure (CONTAINS, or statement function)? */ - - if (ffeinfo_where (info) == FFEINFO_whereCONSTANT) - { - if ((expr == NULL) - && ffebad_start (FFEBAD_NULL_ARGUMENT)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_here (1, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - - if (expr == NULL) - ; - else - { - if (ffeexpr_stack_->next_dummy == NULL) - { /* Report later which was the first extra argument. */ - if (ffeexpr_stack_->tokens[1] == NULL) - { - ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); - ffeexpr_stack_->num_args = 0; - } - ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */ - } - else - { - if ((ffeinfo_rank (ffebld_info (expr)) != 0) - && ffebad_start (FFEBAD_ARRAY_AS_SFARG)) - { - ffebad_here (0, - ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_here (1, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent - (ffebld_symter (ffebld_head - (ffeexpr_stack_->next_dummy))))); - ffebad_finish (); - } - else - { - expr = ffeexpr_convert_expr (expr, ft, - ffebld_head (ffeexpr_stack_->next_dummy), - ffeexpr_stack_->tokens[0], - FFEEXPR_contextLET); - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - } - --ffeexpr_stack_->num_args; /* Count down # of args. */ - ffeexpr_stack_->next_dummy - = ffebld_trail (ffeexpr_stack_->next_dummy); - } - } - } - else - { - if ((expr == NULL) - && ffe_is_pedantic () - && ffebad_start (FFEBAD_NULL_ARGUMENT_W)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_here (1, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - } - } - - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - { - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: - case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: - ctx = FFEEXPR_contextSFUNCDEFACTUALARG_; - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - assert ("bad context" == NULL); - ctx = FFEEXPR_context; - break; - - default: - ctx = FFEEXPR_contextACTUALARG_; - break; - } - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, - ffeexpr_token_arguments_); - - default: - break; - } - - if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) - && (ffeexpr_stack_->next_dummy != NULL)) - { /* Too few arguments. */ - if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS)) - { - char num[10]; - - sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); - - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_string (num); - ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter - (ffebld_head (ffeexpr_stack_->next_dummy))))); - ffebad_finish (); - } - for (; - ffeexpr_stack_->next_dummy != NULL; - ffeexpr_stack_->next_dummy - = ffebld_trail (ffeexpr_stack_->next_dummy)) - { - expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0)); - ffebld_set_info (expr, ffeinfo_new_any ()); - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - } - } - - if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) - && (ffeexpr_stack_->tokens[1] != NULL)) - { /* Too many arguments to statement function. */ - if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS)) - { - char num[10]; - - sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); - - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), - ffelex_token_where_column (ffeexpr_stack_->tokens[1])); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_string (num); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - } - ffebld_end_list (&ffeexpr_stack_->bottom); - - if (ffebld_op (procedure->u.operand) == FFEBLD_opANY) - { - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - } - else - { - if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) - reduced = ffebld_new_funcref (procedure->u.operand, - ffeexpr_stack_->expr); - else - reduced = ffebld_new_subrref (procedure->u.operand, - ffeexpr_stack_->expr); - if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE) - ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]); - else if (ffebld_symter_specific (procedure->u.operand) - != FFEINTRIN_specNONE) - ffeintrin_fulfill_specific (&reduced, &info, &check_intrin, - ffeexpr_stack_->tokens[0]); - else - ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]); - - if (ffebld_op (reduced) != FFEBLD_opANY) - ffebld_set_info (reduced, - ffeinfo_new (ffeinfo_basictype (info), - ffeinfo_kindtype (info), - 0, - FFEINFO_kindENTITY, - FFEINFO_whereFLEETING, - ffeinfo_size (info))); - else - ffebld_set_info (reduced, ffeinfo_new_any ()); - } - if (ffebld_op (reduced) == FFEBLD_opFUNCREF) - reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]); - ffeexpr_stack_->exprstack = procedure->previous; /* Pops - not-quite-operand off - stack. */ - procedure->u.operand = reduced; /* Save the line/column ffewhere - info. */ - ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */ - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - { - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */ - - /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where - Z is DOUBLE COMPLEX), and a command-line option doesn't already - establish interpretation, probably complain. */ - - if (check_intrin - && !ffe_is_90 () - && !ffe_is_ugly_complex ()) - { - /* If the outer expression is REAL(me...), issue diagnostic - only if next token isn't the close-paren for REAL(me). */ - - if ((ffeexpr_stack_->previous != NULL) - && (ffeexpr_stack_->previous->exprstack != NULL) - && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_) - && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL) - && (ffebld_op (reduced) == FFEBLD_opSYMTER) - && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL)) - return (ffelexHandler) ffeexpr_token_intrincheck_; - - /* Diagnose the ambiguity now. */ - - if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) - { - ffebad_string (ffeintrin_name_implementation - (ffebld_symter_implementation - (ffebld_left - (ffeexpr_stack_->exprstack->u.operand)))); - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), - ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); - ffebad_finish (); - } - } - return (ffelexHandler) ffeexpr_token_substrp_; - } - - if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */ - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_token_substrp_); -} - -/* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr - - Return a pointer to this array to the lexer (ffelex), which will - invoke it for the next token. - - Handle expression and COMMA or CLOSE_PAREN. */ - -static ffelexHandler -ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ array; - ffebld reduced; - ffeinfo info; - ffeinfoWhere where; - ffetargetIntegerDefault val; - ffetargetIntegerDefault lval = 0; - ffetargetIntegerDefault uval = 0; - ffebld lbound; - ffebld ubound; - bool lcheck; - bool ucheck; - - array = ffeexpr_stack_->exprstack; - info = ffebld_info (array->u.operand); - - if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) || - (ffelex_token_type(t) == - FFELEX_typeCOMMA)) */ ) - { - if (ffebad_start (FFEBAD_NULL_ELEMENT)) - { - ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_here (1, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_finish (); - } - if (ffeexpr_stack_->rank < ffeinfo_rank (info)) - { /* Don't bother if we're going to complain - later! */ - expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); - ffebld_set_info (expr, ffeinfo_new_any ()); - } - } - - if (expr == NULL) - ; - else if (ffeinfo_rank (info) == 0) - { /* In EQUIVALENCE context, ffeinfo_rank(info) - may == 0. */ - ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT - feature. */ - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - } - else - { - ++ffeexpr_stack_->rank; - if (ffeexpr_stack_->rank > ffeinfo_rank (info)) - { /* Report later which was the first extra - element. */ - if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1) - ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); - } - else - { - switch (ffeinfo_where (ffebld_info (expr))) - { - case FFEINFO_whereCONSTANT: - break; - - case FFEINFO_whereIMMEDIATE: - ffeexpr_stack_->constant = FALSE; - break; - - default: - ffeexpr_stack_->constant = FALSE; - ffeexpr_stack_->immediate = FALSE; - break; - } - if (ffebld_op (expr) == FFEBLD_opCONTER - && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT) - { - val = ffebld_constant_integerdefault (ffebld_conter (expr)); - - lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list)); - if (lbound == NULL) - { - lcheck = TRUE; - lval = 1; - } - else if (ffebld_op (lbound) == FFEBLD_opCONTER) - { - lcheck = TRUE; - lval = ffebld_constant_integerdefault (ffebld_conter (lbound)); - } - else - lcheck = FALSE; - - ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list)); - assert (ubound != NULL); - if (ffebld_op (ubound) == FFEBLD_opCONTER) - { - ucheck = TRUE; - uval = ffebld_constant_integerdefault (ffebld_conter (ubound)); - } - else - ucheck = FALSE; - - if ((lcheck && (val < lval)) || (ucheck && (val > uval))) - { - ffebad_start (FFEBAD_RANGE_ARRAY); - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_finish (); - } - } - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list); - } - } - - switch (ffelex_token_type (t)) - { - case FFELEX_typeCOMMA: - switch (ffeexpr_context_outer_ (ffeexpr_stack_)) - { - case FFEEXPR_contextDATAIMPDOITEM_: - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextDATAIMPDOINDEX_, - ffeexpr_token_elements_); - - case FFEEXPR_contextEQUIVALENCE: - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextEQVINDEX_, - ffeexpr_token_elements_); - - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextSFUNCDEFINDEX_, - ffeexpr_token_elements_); - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - assert ("bad context" == NULL); - break; - - default: - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, - FFEEXPR_contextINDEX_, - ffeexpr_token_elements_); - } - - default: - break; - } - - if ((ffeexpr_stack_->rank != ffeinfo_rank (info)) - && (ffeinfo_rank (info) != 0)) - { - char num[10]; - - if (ffeexpr_stack_->rank < ffeinfo_rank (info)) - { - if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS)) - { - sprintf (num, "%d", - (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank)); - - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, - ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_string (num); - ffebad_finish (); - } - } - else - { - if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS)) - { - sprintf (num, "%d", - (int) (ffeexpr_stack_->rank - ffeinfo_rank (info))); - - ffebad_here (0, - ffelex_token_where_line (ffeexpr_stack_->tokens[1]), - ffelex_token_where_column (ffeexpr_stack_->tokens[1])); - ffebad_here (1, - ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_string (num); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_stack_->tokens[1]); - } - while (ffeexpr_stack_->rank++ < ffeinfo_rank (info)) - { - expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); - ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, - 0, FFEINFO_kindENTITY, - FFEINFO_whereCONSTANT, - FFETARGET_charactersizeNONE)); - ffebld_append_item (&ffeexpr_stack_->bottom, expr); - } - } - ffebld_end_list (&ffeexpr_stack_->bottom); - - if (ffebld_op (array->u.operand) == FFEBLD_opANY) - { - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - } - else - { - reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr); - if (ffeexpr_stack_->constant) - where = FFEINFO_whereFLEETING_CADDR; - else if (ffeexpr_stack_->immediate) - where = FFEINFO_whereFLEETING_IADDR; - else - where = FFEINFO_whereFLEETING; - ffebld_set_info (reduced, - ffeinfo_new (ffeinfo_basictype (info), - ffeinfo_kindtype (info), - 0, - FFEINFO_kindENTITY, - where, - ffeinfo_size (info))); - reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]); - } - - ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off - stack. */ - array->u.operand = reduced; /* Save the line/column ffewhere info. */ - ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */ - - switch (ffeinfo_basictype (info)) - { - case FFEINFO_basictypeCHARACTER: - ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */ - break; - - case FFEINFO_basictypeNONE: - ffeexpr_is_substr_ok_ = TRUE; - assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE); - break; - - default: - ffeexpr_is_substr_ok_ = FALSE; - break; - } - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - { - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - return (ffelexHandler) ffeexpr_token_substrp_; - } - - if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_token_substrp_); -} - -/* ffeexpr_token_equivalence_ -- OPEN_PAREN expr - - Return a pointer to this array to the lexer (ffelex), which will - invoke it for the next token. - - If token is COLON, pass off to _substr_, else init list and pass off - to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where - ? marks the token, and where FOO's rank/type has not yet been established, - meaning we could be in a list of indices or in a substring - specification. */ - -static ffelexHandler -ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - if (ffelex_token_type (t) == FFELEX_typeCOLON) - return ffeexpr_token_substring_ (ft, expr, t); - - ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); - return ffeexpr_token_elements_ (ft, expr, t); -} - -/* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle expression (which may be null) and COLON. */ - -static ffelexHandler -ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t) -{ - ffeexprExpr_ string; - ffeinfo info; - ffetargetIntegerDefault i; - ffeexprContext ctx; - ffetargetCharacterSize size; - - string = ffeexpr_stack_->exprstack; - info = ffebld_info (string->u.operand); - size = ffebld_size_max (string->u.operand); - - if (ffelex_token_type (t) == FFELEX_typeCOLON) - { - if ((expr != NULL) - && (ffebld_op (expr) == FFEBLD_opCONTER) - && (((i = ffebld_constant_integerdefault (ffebld_conter (expr))) - < 1) - || ((size != FFETARGET_charactersizeNONE) && (i > size)))) - { - ffebad_start (FFEBAD_RANGE_SUBSTR); - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_finish (); - } - ffeexpr_stack_->expr = expr; - - switch (ffeexpr_stack_->context) - { - case FFEEXPR_contextSFUNCDEF: - case FFEEXPR_contextSFUNCDEFINDEX_: - ctx = FFEEXPR_contextSFUNCDEFINDEX_; - break; - - case FFEEXPR_contextSFUNCDEFACTUALARG_: - case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: - assert ("bad context" == NULL); - ctx = FFEEXPR_context; - break; - - default: - ctx = FFEEXPR_contextINDEX_; - break; - } - - return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, - ffeexpr_token_substring_1_); - } - - if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - - ffeexpr_stack_->expr = NULL; - return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t); -} - -/* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr - - Return a pointer to this function to the lexer (ffelex), which will - invoke it for the next token. - - Handle expression (which might be null) and CLOSE_PAREN. */ - -static ffelexHandler -ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t) -{ - ffeexprExpr_ string; - ffebld reduced; - ffebld substrlist; - ffebld first = ffeexpr_stack_->expr; - ffebld strop; - ffeinfo info; - ffeinfoWhere lwh; - ffeinfoWhere rwh; - ffeinfoWhere where; - ffeinfoKindtype first_kt; - ffeinfoKindtype last_kt; - ffetargetIntegerDefault first_val; - ffetargetIntegerDefault last_val; - ffetargetCharacterSize size; - ffetargetCharacterSize strop_size_max; - bool first_known; - - string = ffeexpr_stack_->exprstack; - strop = string->u.operand; - info = ffebld_info (strop); - - if (first == NULL - || (ffebld_op (first) == FFEBLD_opCONTER - && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT)) - { /* The starting point is known. */ - first_val = (first == NULL) ? 1 - : ffebld_constant_integerdefault (ffebld_conter (first)); - first_known = TRUE; - } - else - { /* Assume start of the entity. */ - first_val = 1; - first_known = FALSE; - } - - if (last != NULL - && (ffebld_op (last) == FFEBLD_opCONTER - && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT)) - { /* The ending point is known. */ - last_val = ffebld_constant_integerdefault (ffebld_conter (last)); - - if (first_known) - { /* The beginning point is a constant. */ - if (first_val <= last_val) - size = last_val - first_val + 1; - else - { - if (0 && ffe_is_90 ()) - size = 0; - else - { - size = 1; - ffebad_start (FFEBAD_ZERO_SIZE); - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_finish (); - } - } - } - else - size = FFETARGET_charactersizeNONE; - - strop_size_max = ffebld_size_max (strop); - - if ((strop_size_max != FFETARGET_charactersizeNONE) - && (last_val > strop_size_max)) - { /* Beyond maximum possible end of string. */ - ffebad_start (FFEBAD_RANGE_SUBSTR); - ffebad_here (0, ffelex_token_where_line (ft), - ffelex_token_where_column (ft)); - ffebad_finish (); - } - } - else - size = FFETARGET_charactersizeNONE; /* The size is not known. */ - -#if 0 /* Don't do this, or "is size of target - known?" would no longer be easily - answerable. To see if there is a max - size, use ffebld_size_max; to get only the - known size, else NONE, use - ffebld_size_known; use ffebld_size if - values are sure to be the same (not - opSUBSTR or opCONCATENATE or known to have - known length). By getting rid of this - "useful info" stuff, we don't end up - blank-padding the constant in the - assignment "A(I:J)='XYZ'" to the known - length of A. */ - if (size == FFETARGET_charactersizeNONE) - size = strop_size_max; /* Assume we use the entire string. */ -#endif - - substrlist - = ffebld_new_item - (first, - ffebld_new_item - (last, - NULL - ) - ) - ; - - if (first == NULL) - lwh = FFEINFO_whereCONSTANT; - else - lwh = ffeinfo_where (ffebld_info (first)); - if (last == NULL) - rwh = FFEINFO_whereCONSTANT; - else - rwh = ffeinfo_where (ffebld_info (last)); - - switch (lwh) - { - case FFEINFO_whereCONSTANT: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - where = FFEINFO_whereCONSTANT; - break; - - case FFEINFO_whereIMMEDIATE: - where = FFEINFO_whereIMMEDIATE; - break; - - default: - where = FFEINFO_whereFLEETING; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (rwh) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: - where = FFEINFO_whereIMMEDIATE; - break; - - default: - where = FFEINFO_whereFLEETING; - break; - } - break; - - default: - where = FFEINFO_whereFLEETING; - break; - } - - if (first == NULL) - first_kt = FFEINFO_kindtypeINTEGERDEFAULT; - else - first_kt = ffeinfo_kindtype (ffebld_info (first)); - if (last == NULL) - last_kt = FFEINFO_kindtypeINTEGERDEFAULT; - else - last_kt = ffeinfo_kindtype (ffebld_info (last)); - - switch (where) - { - case FFEINFO_whereCONSTANT: - switch (ffeinfo_where (info)) - { - case FFEINFO_whereCONSTANT: - break; - - case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ - where = FFEINFO_whereIMMEDIATE; - break; - - default: - where = FFEINFO_whereFLEETING_CADDR; - break; - } - break; - - case FFEINFO_whereIMMEDIATE: - switch (ffeinfo_where (info)) - { - case FFEINFO_whereCONSTANT: - case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ - break; - - default: - where = FFEINFO_whereFLEETING_IADDR; - break; - } - break; - - default: - switch (ffeinfo_where (info)) - { - case FFEINFO_whereCONSTANT: - where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */ - break; - - case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ - default: - where = FFEINFO_whereFLEETING; - break; - } - break; - } - - if (ffebld_op (strop) == FFEBLD_opANY) - { - reduced = ffebld_new_any (); - ffebld_set_info (reduced, ffeinfo_new_any ()); - } - else - { - reduced = ffebld_new_substr (strop, substrlist); - ffebld_set_info (reduced, ffeinfo_new - (FFEINFO_basictypeCHARACTER, - ffeinfo_kindtype (info), - 0, - FFEINFO_kindENTITY, - where, - size)); - reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]); - } - - ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off - stack. */ - string->u.operand = reduced; /* Save the line/column ffewhere info. */ - ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */ - - if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) - { - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */ - return (ffelexHandler) ffeexpr_token_substrp_; - } - - if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) - { - ffebad_here (0, ffelex_token_where_line (t), - ffelex_token_where_column (t)); - ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), - ffelex_token_where_column (ffeexpr_stack_->tokens[0])); - ffebad_finish (); - } - - ffelex_token_kill (ffeexpr_stack_->tokens[0]); - ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */ - return - (ffelexHandler) ffeexpr_find_close_paren_ (t, - (ffelexHandler) - ffeexpr_token_substrp_); -} - -/* ffeexpr_token_substrp_ -- Rhs <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 (void) -{ - assert (ffeexpr_stack_ == NULL); - assert (ffeexpr_level_ == 0); -} |
