+++ /dev/null
-/* expr.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002
- Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- None.
-
- Description:
- Handles syntactic and semantic analysis of Fortran expressions.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "expr.h"
-#include "bad.h"
-#include "bld.h"
-#include "com.h"
-#include "global.h"
-#include "implic.h"
-#include "intrin.h"
-#include "info.h"
-#include "lex.h"
-#include "malloc.h"
-#include "src.h"
-#include "st.h"
-#include "symbol.h"
-#include "str.h"
-#include "target.h"
-#include "where.h"
-
-/* Externals defined here. */
-
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFEEXPR_exprtypeUNKNOWN_,
- FFEEXPR_exprtypeOPERAND_,
- FFEEXPR_exprtypeUNARY_,
- FFEEXPR_exprtypeBINARY_,
- FFEEXPR_exprtype_
- } ffeexprExprtype_;
-
-typedef enum
- {
- FFEEXPR_operatorPOWER_,
- FFEEXPR_operatorMULTIPLY_,
- FFEEXPR_operatorDIVIDE_,
- FFEEXPR_operatorADD_,
- FFEEXPR_operatorSUBTRACT_,
- FFEEXPR_operatorCONCATENATE_,
- FFEEXPR_operatorLT_,
- FFEEXPR_operatorLE_,
- FFEEXPR_operatorEQ_,
- FFEEXPR_operatorNE_,
- FFEEXPR_operatorGT_,
- FFEEXPR_operatorGE_,
- FFEEXPR_operatorNOT_,
- FFEEXPR_operatorAND_,
- FFEEXPR_operatorOR_,
- FFEEXPR_operatorXOR_,
- FFEEXPR_operatorEQV_,
- FFEEXPR_operatorNEQV_,
- FFEEXPR_operator_
- } ffeexprOperator_;
-
-typedef enum
- {
- FFEEXPR_operatorprecedenceHIGHEST_ = 1,
- FFEEXPR_operatorprecedencePOWER_ = 1,
- FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
- FFEEXPR_operatorprecedenceDIVIDE_ = 2,
- FFEEXPR_operatorprecedenceADD_ = 3,
- FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
- FFEEXPR_operatorprecedenceLOWARITH_ = 3,
- FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
- FFEEXPR_operatorprecedenceLT_ = 4,
- FFEEXPR_operatorprecedenceLE_ = 4,
- FFEEXPR_operatorprecedenceEQ_ = 4,
- FFEEXPR_operatorprecedenceNE_ = 4,
- FFEEXPR_operatorprecedenceGT_ = 4,
- FFEEXPR_operatorprecedenceGE_ = 4,
- FFEEXPR_operatorprecedenceNOT_ = 5,
- FFEEXPR_operatorprecedenceAND_ = 6,
- FFEEXPR_operatorprecedenceOR_ = 7,
- FFEEXPR_operatorprecedenceXOR_ = 8,
- FFEEXPR_operatorprecedenceEQV_ = 8,
- FFEEXPR_operatorprecedenceNEQV_ = 8,
- FFEEXPR_operatorprecedenceLOWEST_ = 8,
- FFEEXPR_operatorprecedence_
- } ffeexprOperatorPrecedence_;
-
-#define FFEEXPR_operatorassociativityL2R_ TRUE
-#define FFEEXPR_operatorassociativityR2L_ FALSE
-#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
-#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
-#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
-
-typedef enum
- {
- FFEEXPR_parentypeFUNCTION_,
- FFEEXPR_parentypeSUBROUTINE_,
- FFEEXPR_parentypeARRAY_,
- FFEEXPR_parentypeSUBSTRING_,
- FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
- FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
- FFEEXPR_parentypeANY_, /* Allow basically anything. */
- FFEEXPR_parentype_
- } ffeexprParenType_;
-
-typedef enum
- {
- FFEEXPR_percentNONE_,
- FFEEXPR_percentLOC_,
- FFEEXPR_percentVAL_,
- FFEEXPR_percentREF_,
- FFEEXPR_percentDESCR_,
- FFEEXPR_percent_
- } ffeexprPercent_;
-
-/* Internal typedefs. */
-
-typedef struct _ffeexpr_expr_ *ffeexprExpr_;
-typedef bool ffeexprOperatorAssociativity_;
-typedef struct _ffeexpr_stack_ *ffeexprStack_;
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-struct _ffeexpr_expr_
- {
- ffeexprExpr_ previous;
- ffelexToken token;
- ffeexprExprtype_ type;
- union
- {
- struct
- {
- ffeexprOperator_ op;
- ffeexprOperatorPrecedence_ prec;
- ffeexprOperatorAssociativity_ as;
- }
- operator;
- ffebld operand;
- }
- u;
- };
-
-struct _ffeexpr_stack_
- {
- ffeexprStack_ previous;
- mallocPool pool;
- ffeexprContext context;
- ffeexprCallback callback;
- ffelexToken first_token;
- ffeexprExpr_ exprstack;
- ffelexToken tokens[10]; /* Used in certain cases, like (unary)
- open-paren. */
- ffebld expr; /* For first of
- complex/implied-do/substring/array-elements
- / actual-args expression. */
- ffebld bound_list; /* For tracking dimension bounds list of
- array. */
- ffebldListBottom bottom; /* For building lists. */
- ffeinfoRank rank; /* For elements in an array reference. */
- bool constant; /* TRUE while elements seen so far are
- constants. */
- bool immediate; /* TRUE while elements seen so far are
- immediate/constants. */
- ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
- ffebldListLength num_args; /* Number of dummy args expected in arg list. */
- bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
- ffeexprPercent_ percent; /* Current %FOO keyword. */
- };
-
-struct _ffeexpr_find_
- {
- ffelexToken t;
- ffelexHandler after;
- int level;
- };
-
-/* Static objects accessed by functions in this module. */
-
-static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
-static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
-static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
-static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
-static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
-static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
-static struct _ffeexpr_find_ ffeexpr_find_;
-
-/* Static functions (internal). */
-
-static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
- ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
- ffebld expr, ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
- ffebld expr, ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
-static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
-static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
-static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
- ffebld dovar, ffelexToken dovar_t);
-static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
-static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
-static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
-static ffeexprExpr_ ffeexpr_expr_new_ (void);
-static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
-static bool ffeexpr_isdigits_ (const char *p);
-static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
-static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
-static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
-static void ffeexpr_reduce_ (void);
-static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
- ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
- ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
- ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
-static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
- ffelexHandler after);
-static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
-static ffelexHandler ffeexpr_finished_ (ffelexToken t);
-static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
-static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
-static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
- ffelexToken t);
-static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
- ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
- ffelexToken exponent_sign, ffelexToken exponent_digits);
-static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
-static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
-static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
- bool maybe_intrin,
- ffeexprParenType_ *paren_type);
-static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
-
-/* Internal macros. */
-
-#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
-#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
-\f
-/* ffeexpr_collapse_convert -- Collapse convert expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_convert(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize sz;
- ffetargetCharacterSize sz2;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_integer1_integer2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_integer1_integer3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_integer1_integer4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer1_real1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer1_real2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer1_real3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer1_real4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer1_complex1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer1_complex2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer1_complex3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer1_complex4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer1_logical1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer1_logical2
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer1_logical3
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer1_logical4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer1_character1
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer1_hollerith
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer1_typeless
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_integer2_integer1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_integer2_integer3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_integer2_integer4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer2_real1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer2_real2
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer2_real3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer2_real4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer2_complex1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer2_complex2
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer2_complex3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer2_complex4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer2_logical1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer2_logical2
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer2_logical3
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer2_logical4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer2_character1
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer2_hollerith
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer2_typeless
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_integer3_integer1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_integer3_integer2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_integer3_integer4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer3_real1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer3_real2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer3_real3
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer3_real4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer3_complex1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer3_complex2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer3_complex3
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer3_complex4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer3_logical1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer3_logical2
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer3_logical3
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer3_logical4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer3_character1
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer3_hollerith
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer3_typeless
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_integer4_integer1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_integer4_integer2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_integer4_integer3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer4_real1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer4_real2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer4_real3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer4_real4
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER4/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_integer4_complex1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_integer4_complex2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_integer4_complex3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer4_complex4
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_integer4_logical1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_integer4_logical2
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_integer4_logical3
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_integer4_logical4
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_integer4_character1
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_integer4_hollerith
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_integer4_typeless
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("INTEGER4 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_logical1_logical2
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_logical1_logical3
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_logical1_logical4
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical1_integer1
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical1_integer2
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical1_integer3
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical1_integer4
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical1_character1
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical1_hollerith
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical1_typeless
- (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_logical2_logical1
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_logical2_logical3
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_logical2_logical4
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical2_integer1
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical2_integer2
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical2_integer3
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical2_integer4
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical2_character1
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical2_hollerith
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical2_typeless
- (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_logical3_logical1
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_logical3_logical2
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_convert_logical3_logical4
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical3_integer1
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical3_integer2
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical3_integer3
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical3_integer4
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical3_character1
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical3_hollerith
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical3_typeless
- (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_convert_logical4_logical1
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_convert_logical4_logical2
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_convert_logical4_logical3
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_logical4_integer1
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_logical4_integer2
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_logical4_integer3
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_logical4_integer4
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_logical4_character1
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_logical4_hollerith
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_logical4_typeless
- (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("LOGICAL4 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real1_integer1
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real1_integer2
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real1_integer3
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real1_integer4
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real1_real2
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real1_real3
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real1_real4
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL1/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real1_complex1
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real1_complex2
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real1_complex3
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real1_complex4
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL1/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real1_character1
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real1_hollerith
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real1_typeless
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real2_integer1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real2_integer2
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real2_integer3
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real2_integer4
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real2_real1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real2_real3
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real2_real4
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL2/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real2_complex1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real2_complex2
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real2_complex3
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real2_complex4
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL2/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real2_character1
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real2_hollerith
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real2_typeless
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real3_integer1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real3_integer2
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real3_integer3
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real3_integer4
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real3_real1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real3_real2
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real3_real4
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL3/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real3_complex1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real3_complex2
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real3_complex3
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real3_complex4
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real3_character1
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real3_hollerith
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real3_typeless
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real4_integer1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real4_integer2
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real4_integer3
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real4_integer4
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real4_real1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real4_real2
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real4_real3
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL4/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real4_complex1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real4_complex2
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real4_complex3
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real4_complex4
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL4/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real4_character1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real4_hollerith
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real4_typeless
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL4 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- sz = FFETARGET_charactersizeNONE;
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex1_integer1
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex1_integer2
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex1_integer3
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex1_integer4
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex1_real1
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex1_real2
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex1_real3
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex1_real4
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX1/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex1_complex2
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex1_complex3
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex1_complex4
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex1_character1
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex1_hollerith
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex1_typeless
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX1 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex2_integer1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex2_integer2
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex2_integer3
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex2_integer4
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex2_real1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex2_real2
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex2_real3
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex2_real4
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX2/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex2_complex1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex2_complex3
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex2_complex4
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex2_character1
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex2_hollerith
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex2_typeless
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX2 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex3_integer1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex3_integer2
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex3_integer3
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex3_integer4
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex3_real1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex3_real2
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex3_real3
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex3_real4
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX3/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex3_complex1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex3_complex2
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex3_complex4
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex3_character1
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex3_hollerith
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex3_typeless
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX3 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex4_integer1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex4_integer2
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex4_integer3
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex4_integer4
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex4_real1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex4_real2
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex4_real3
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex4_real4
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX4/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex4_complex1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex4_complex2
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex4_complex3
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex4_character1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex4_hollerith
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex4_typeless
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX4 bad type" == NULL);
- break;
- }
-
- /* If conversion operation is not implemented, return original expr. */
- if (error == FFEBAD_NOCANDO)
- return expr;
-
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
- return expr;
- kt = ffeinfo_kindtype (ffebld_info (expr));
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeCHARACTER:
- if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
- return expr;
- assert (kt == ffeinfo_kindtype (ffebld_info (l)));
- assert (sz2 == ffetarget_length_character1
- (ffebld_constant_character1
- (ffebld_conter (l))));
- error
- = ffetarget_convert_character1_character1
- (ffebld_cu_ptr_character1 (u), sz,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error
- = ffetarget_convert_character1_integer1
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error
- = ffetarget_convert_character1_integer2
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error
- = ffetarget_convert_character1_integer3
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error
- = ffetarget_convert_character1_integer4
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
- default:
- assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error
- = ffetarget_convert_character1_logical1
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error
- = ffetarget_convert_character1_logical2
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error
- = ffetarget_convert_character1_logical3
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error
- = ffetarget_convert_character1_logical4
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-#endif
-
- default:
- assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error
- = ffetarget_convert_character1_hollerith
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_hollerith (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error
- = ffetarget_convert_character1_typeless
- (ffebld_cu_ptr_character1 (u),
- sz,
- ffebld_constant_typeless (ffebld_conter (l)),
- ffebld_constant_pool ());
- break;
-
- default:
- assert ("CHARACTER1 bad type" == NULL);
- }
-
- expr
- = ffebld_new_conter_with_orig
- (ffebld_constant_new_character1_val
- (ffebld_cu_val_character1 (u)),
- expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- sz));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- assert (t != NULL);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_paren -- Collapse paren expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_paren(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
-{
- ffebld r;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- bt = ffeinfo_basictype (ffebld_info (r));
- kt = ffeinfo_kindtype (ffebld_info (r));
- len = ffebld_size (r);
-
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
- expr);
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
-}
-
-/* ffeexpr_collapse_uplus -- Collapse uplus expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_uplus(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
-{
- ffebld r;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- bt = ffeinfo_basictype (ffebld_info (r));
- kt = ffeinfo_kindtype (ffebld_info (r));
- len = ffebld_size (r);
-
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
- expr);
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
-}
-
-/* ffeexpr_collapse_uminus -- Collapse uminus expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_uminus(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_not -- Collapse not expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_not(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_not (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- r = ffebld_left (expr);
-
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_add -- Collapse add expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_add(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_add (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_subtract -- Collapse subtract expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_subtract(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_multiply -- Collapse multiply expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_multiply(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_divide -- Collapse divide expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_divide(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
- (ffebld_cu_val_real1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
- (ffebld_cu_val_real2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
- (ffebld_cu_val_real3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
- (ffebld_cu_val_complex1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
- (ffebld_cu_val_complex2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_power -- Collapse power expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_power(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_power (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
- case FFEINFO_kindtypeINTEGERDEFAULT:
- error = ffetarget_power_integerdefault_integerdefault
- (ffebld_cu_ptr_integerdefault (u),
- ffebld_constant_integerdefault (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_integerdefault_val
- (ffebld_cu_val_integerdefault (u)), expr);
- break;
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
- case FFEINFO_kindtypeREALDEFAULT:
- error = ffetarget_power_realdefault_integerdefault
- (ffebld_cu_ptr_realdefault (u),
- ffebld_constant_realdefault (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_realdefault_val
- (ffebld_cu_val_realdefault (u)), expr);
- break;
-
- case FFEINFO_kindtypeREALDOUBLE:
- error = ffetarget_power_realdouble_integerdefault
- (ffebld_cu_ptr_realdouble (u),
- ffebld_constant_realdouble (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_realdouble_val
- (ffebld_cu_val_realdouble (u)), expr);
- break;
-
-#if FFETARGET_okREALQUAD
- case FFEINFO_kindtypeREALQUAD:
- error = ffetarget_power_realquad_integerdefault
- (ffebld_cu_ptr_realquad (u),
- ffebld_constant_realquad (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_realquad_val
- (ffebld_cu_val_realquad (u)), expr);
- break;
-#endif
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
- case FFEINFO_kindtypeREALDEFAULT:
- error = ffetarget_power_complexdefault_integerdefault
- (ffebld_cu_ptr_complexdefault (u),
- ffebld_constant_complexdefault (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complexdefault_val
- (ffebld_cu_val_complexdefault (u)), expr);
- break;
-
-#if FFETARGET_okCOMPLEXDOUBLE
- case FFEINFO_kindtypeREALDOUBLE:
- error = ffetarget_power_complexdouble_integerdefault
- (ffebld_cu_ptr_complexdouble (u),
- ffebld_constant_complexdouble (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complexdouble_val
- (ffebld_cu_val_complexdouble (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEXQUAD
- case FFEINFO_kindtypeREALQUAD:
- error = ffetarget_power_complexquad_integerdefault
- (ffebld_cu_ptr_complexquad (u),
- ffebld_constant_complexquad (ffebld_conter (l)),
- ffebld_constant_integerdefault (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_complexquad_val
- (ffebld_cu_val_complexquad (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_concatenate -- Collapse concatenate expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_concatenate(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
- (ffebld_cu_val_character1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
- (ffebld_cu_val_character2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
- (ffebld_cu_val_character3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
- (ffebld_cu_val_character4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_eq -- Collapse eq expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_eq(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_eq_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_eq_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_eq_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_eq_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_eq_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_eq_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_eq_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_eq_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_eq_complex1 (&val,
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_eq_complex2 (&val,
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_eq_complex3 (&val,
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_eq_complex4 (&val,
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_eq_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_eq_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_eq_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_eq_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_ne -- Collapse ne expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_ne(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_ne_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_ne_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_ne_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_ne_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_ne_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_ne_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_ne_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_ne_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_ne_complex1 (&val,
- ffebld_constant_complex1 (ffebld_conter (l)),
- ffebld_constant_complex1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_ne_complex2 (&val,
- ffebld_constant_complex2 (ffebld_conter (l)),
- ffebld_constant_complex2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_ne_complex3 (&val,
- ffebld_constant_complex3 (ffebld_conter (l)),
- ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_ne_complex4 (&val,
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad complex kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_ne_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_ne_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_ne_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_ne_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_ge -- Collapse ge expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_ge(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_ge_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_ge_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_ge_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_ge_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_ge_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_ge_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_ge_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_ge_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_ge_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_ge_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_ge_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_ge_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_gt -- Collapse gt expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_gt(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_gt_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_gt_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_gt_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_gt_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_gt_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_gt_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_gt_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_gt_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_gt_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_gt_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_gt_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_gt_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_le -- Collapse le expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_le(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_le (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_le_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_le_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_le_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_le_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_le_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_le_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_le_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_le_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_le_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_le_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_le_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_le_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_lt -- Collapse lt expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_lt(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- bool val;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_lt_integer1 (&val,
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_lt_integer2 (&val,
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_lt_integer3 (&val,
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_lt_integer4 (&val,
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_lt_real1 (&val,
- ffebld_constant_real1 (ffebld_conter (l)),
- ffebld_constant_real1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_lt_real2 (&val,
- ffebld_constant_real2 (ffebld_conter (l)),
- ffebld_constant_real2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_lt_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_lt_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad real kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_lt_character1 (&val,
- ffebld_constant_character1 (ffebld_conter (l)),
- ffebld_constant_character1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_lt_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_lt_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_lt_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_and -- Collapse and expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_and(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_and (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_or -- Collapse or expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_or(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_or (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_xor -- Collapse xor expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_xor(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_eqv -- Collapse eqv expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_eqv(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_neqv -- Collapse neqv expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_neqv(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebldConstantUnion u;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr);
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
- if (ffebld_op (r) != FFEBLD_opCONTER)
- return expr;
-
- switch (bt = ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeINTEGER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_integer1 (ffebld_conter (l)),
- ffebld_constant_integer1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
- (ffebld_cu_val_integer1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_integer2 (ffebld_conter (l)),
- ffebld_constant_integer2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
- (ffebld_cu_val_integer2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_integer3 (ffebld_conter (l)),
- ffebld_constant_integer3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
- (ffebld_cu_val_integer3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)),
- ffebld_constant_integer4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
- (ffebld_cu_val_integer4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad integer kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
- ffebld_constant_logical1 (ffebld_conter (l)),
- ffebld_constant_logical1 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
- (ffebld_cu_val_logical1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
- ffebld_constant_logical2 (ffebld_conter (l)),
- ffebld_constant_logical2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
- (ffebld_cu_val_logical2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
- ffebld_constant_logical3 (ffebld_conter (l)),
- ffebld_constant_logical3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
- (ffebld_cu_val_logical3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
- ffebld_constant_logical4 (ffebld_conter (l)),
- ffebld_constant_logical4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
- (ffebld_cu_val_logical4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad logical kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_collapse_symter -- Collapse symter expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_symter(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
-{
- ffebld r;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
- return expr; /* A PARAMETER lhs in progress. */
-
- switch (ffebld_op (r))
- {
- case FFEBLD_opCONTER:
- break;
-
- case FFEBLD_opANY:
- return r;
-
- default:
- return expr;
- }
-
- bt = ffeinfo_basictype (ffebld_info (r));
- kt = ffeinfo_kindtype (ffebld_info (r));
- len = ffebld_size (r);
-
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
- expr);
-
- ffebld_set_info (expr, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
-}
-
-/* ffeexpr_collapse_funcref -- Collapse funcref expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_funcref(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
-{
- return expr; /* ~~someday go ahead and collapse these,
- though not required */
-}
-
-/* ffeexpr_collapse_arrayref -- Collapse arrayref expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_arrayref(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
-{
- return expr;
-}
-
-/* ffeexpr_collapse_substr -- Collapse substr expr
-
- ffebld expr;
- ffelexToken token;
- expr = ffeexpr_collapse_substr(expr,token);
-
- If the result of the expr is a constant, replaces the expr with the
- computed constant. */
-
-ffebld
-ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
-{
- ffebad error = FFEBAD;
- ffebld l;
- ffebld r;
- ffebld start;
- ffebld stop;
- ffebldConstantUnion u;
- ffeinfoKindtype kt;
- ffetargetCharacterSize len;
- ffetargetIntegerDefault first;
- ffetargetIntegerDefault last;
-
- if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
- return expr;
-
- l = ffebld_left (expr);
- r = ffebld_right (expr); /* opITEM. */
-
- if (ffebld_op (l) != FFEBLD_opCONTER)
- return expr;
-
- kt = ffeinfo_kindtype (ffebld_info (l));
- len = ffebld_size (l);
-
- start = ffebld_head (r);
- stop = ffebld_head (ffebld_trail (r));
- if (start == NULL)
- first = 1;
- else
- {
- if ((ffebld_op (start) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (start))
- != FFEINFO_kindtypeINTEGERDEFAULT))
- return expr;
- first = ffebld_constant_integerdefault (ffebld_conter (start));
- }
- if (stop == NULL)
- last = len;
- else
- {
- if ((ffebld_op (stop) != FFEBLD_opCONTER)
- || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
- || (ffeinfo_kindtype (ffebld_info (stop))
- != FFEINFO_kindtypeINTEGERDEFAULT))
- return expr;
- last = ffebld_constant_integerdefault (ffebld_conter (stop));
- }
-
- /* Handle problems that should have already been diagnosed, but
- left in the expression tree. */
-
- if (first <= 0)
- first = 1;
- if (last < first)
- last = first + len - 1;
-
- if ((first == 1) && (last == len))
- { /* Same as original. */
- expr = ffebld_new_conter_with_orig (ffebld_constant_copy
- (ffebld_conter (l)), expr);
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- return expr;
- }
-
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
- case FFEINFO_basictypeANY:
- return expr;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
- ffebld_constant_character1 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
- (ffebld_cu_val_character1 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
- ffebld_constant_character2 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
- (ffebld_cu_val_character2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
- ffebld_constant_character3 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
- (ffebld_cu_val_character3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
- ffebld_constant_character4 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
- (ffebld_cu_val_character4 (u)), expr);
- break;
-#endif
-
- default:
- assert ("bad character kind type" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad type" == NULL);
- return expr;
- }
-
- ffebld_set_info (expr, ffeinfo_new
- (FFEINFO_basictypeCHARACTER,
- kt,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- len));
-
- if ((error != FFEBAD)
- && ffebad_start (error))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
-
- return expr;
-}
-
-/* ffeexpr_convert -- Convert source expression to given type
-
- ffebld source;
- ffelexToken source_token;
- ffelexToken dest_token; // Any appropriate token for "destination".
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetCharactersize sz;
- ffeexprContext context; // Mainly LET or DATA.
- source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
-
- If the expression conforms, returns the source expression. Otherwise
- returns source wrapped in a convert node doing the conversion, or
- ANY wrapped in convert if there is a conversion error (and issues an
- error message). Be sensitive to the context for certain aspects of
- the conversion. */
-
-ffebld
-ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
- ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
- ffetargetCharacterSize sz, ffeexprContext context)
-{
- bool bad;
- ffeinfo info;
- ffeinfoWhere wh;
-
- info = ffebld_info (source);
- if ((bt != ffeinfo_basictype (info))
- || (kt != ffeinfo_kindtype (info))
- || (rk != 0) /* Can't convert from or to arrays yet. */
- || (ffeinfo_rank (info) != 0)
- || (sz != ffebld_size_known (source)))
-#if 0 /* Nobody seems to need this spurious CONVERT node. */
- || ((context != FFEEXPR_contextLET)
- && (bt == FFEINFO_basictypeCHARACTER)
- && (sz == FFETARGET_charactersizeNONE)))
-#endif
- {
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- switch (bt)
- {
- case FFEINFO_basictypeLOGICAL:
- bad = FALSE;
- break;
-
- case FFEINFO_basictypeINTEGER:
- bad = !ffe_is_ugly_logint ();
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = ffe_is_pedantic ()
- || !(ffe_is_ugly_init ()
- && (context == FFEEXPR_contextDATA));
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- bad = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- bad = !ffe_is_ugly_logint ();
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = ffe_is_pedantic ()
- || !(ffe_is_ugly_init ()
- && (context == FFEEXPR_contextDATA));
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- bad = FALSE;
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = TRUE;
- break;
-
- default:
- bad = TRUE;
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- bad = (bt != FFEINFO_basictypeCHARACTER)
- && (ffe_is_pedantic ()
- || (bt != FFEINFO_basictypeINTEGER)
- || !(ffe_is_ugly_init ()
- && (context == FFEEXPR_contextDATA)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- case FFEINFO_basictypeHOLLERITH:
- bad = ffe_is_pedantic ()
- || !(ffe_is_ugly_init ()
- && ((context == FFEEXPR_contextDATA)
- || (context == FFEEXPR_contextLET)));
- break;
-
- default:
- bad = TRUE;
- break;
- }
-
- if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
- bad = TRUE;
-
- if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
- && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
- && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
- && (ffeinfo_where (info) != FFEINFO_whereANY))
- {
- if (ffebad_start (FFEBAD_BAD_TYPES))
- {
- if (dest_token == NULL)
- ffebad_here (0, ffewhere_line_unknown (),
- ffewhere_column_unknown ());
- else
- ffebad_here (0, ffelex_token_where_line (dest_token),
- ffelex_token_where_column (dest_token));
- assert (source_token != NULL);
- ffebad_here (1, ffelex_token_where_line (source_token),
- ffelex_token_where_column (source_token));
- ffebad_finish ();
- }
-
- source = ffebld_new_any ();
- ffebld_set_info (source, ffeinfo_new_any ());
- }
- else
- {
- switch (ffeinfo_where (info))
- {
- case FFEINFO_whereCONSTANT:
- wh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- wh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- wh = FFEINFO_whereFLEETING;
- break;
- }
- source = ffebld_new_convert (source);
- ffebld_set_info (source, ffeinfo_new
- (bt,
- kt,
- 0,
- FFEINFO_kindENTITY,
- wh,
- sz));
- source = ffeexpr_collapse_convert (source, source_token);
- }
- }
-
- return source;
-}
-
-/* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
-
- ffebld source;
- ffebld dest;
- ffelexToken source_token;
- ffelexToken dest_token;
- ffeexprContext context;
- source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
-
- If the expressions conform, returns the source expression. Otherwise
- returns source wrapped in a convert node doing the conversion, or
- ANY wrapped in convert if there is a conversion error (and issues an
- error message). Be sensitive to the context, such as LET or DATA. */
-
-ffebld
-ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
- ffelexToken dest_token, ffeexprContext context)
-{
- ffeinfo info;
-
- info = ffebld_info (dest);
- return ffeexpr_convert (source, source_token, dest_token,
- ffeinfo_basictype (info),
- ffeinfo_kindtype (info),
- ffeinfo_rank (info),
- ffebld_size_known (dest),
- context);
-}
-
-/* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
-
- ffebld source;
- ffesymbol dest;
- ffelexToken source_token;
- ffelexToken dest_token;
- source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
-
- If the expressions conform, returns the source expression. Otherwise
- returns source wrapped in a convert node doing the conversion, or
- ANY wrapped in convert if there is a conversion error (and issues an
- error message). */
-
-ffebld
-ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
- ffesymbol dest, ffelexToken dest_token)
-{
- return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
- ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
- FFEEXPR_contextLET);
-}
-
-/* Initializes the module. */
-
-void
-ffeexpr_init_2 ()
-{
- ffeexpr_stack_ = NULL;
- ffeexpr_level_ = 0;
-}
-
-/* ffeexpr_lhs -- Begin processing left-hand-side-context expression
-
- Prepares cluster for delivery of lexer tokens representing an expression
- in a left-hand-side context (A in A=B, for example). ffebld is used
- to build expressions in the given pool. The appropriate lexer-token
- handling routine within ffeexpr is returned. When the end of the
- expression is detected, mycallbackroutine is called with the resulting
- single ffebld object specifying the entire expression and the first
- lexer token that is not considered part of the expression. This caller-
- supplied routine itself returns a lexer-token handling routine. Thus,
- if necessary, ffeexpr can return several tokens as end-of-expression
- tokens if it needs to scan forward more than one in any instance. */
-
-ffelexHandler
-ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
-{
- ffeexprStack_ s;
-
- ffebld_pool_push (pool);
- s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
- s->previous = ffeexpr_stack_;
- s->pool = pool;
- s->context = context;
- s->callback = callback;
- s->first_token = NULL;
- s->exprstack = NULL;
- s->is_rhs = FALSE;
- ffeexpr_stack_ = s;
- return (ffelexHandler) ffeexpr_token_first_lhs_;
-}
-
-/* ffeexpr_rhs -- Begin processing right-hand-side-context expression
-
- return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
-
- Prepares cluster for delivery of lexer tokens representing an expression
- in a right-hand-side context (B in A=B, for example). ffebld is used
- to build expressions in the given pool. The appropriate lexer-token
- handling routine within ffeexpr is returned. When the end of the
- expression is detected, mycallbackroutine is called with the resulting
- single ffebld object specifying the entire expression and the first
- lexer token that is not considered part of the expression. This caller-
- supplied routine itself returns a lexer-token handling routine. Thus,
- if necessary, ffeexpr can return several tokens as end-of-expression
- tokens if it needs to scan forward more than one in any instance. */
-
-ffelexHandler
-ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
-{
- ffeexprStack_ s;
-
- ffebld_pool_push (pool);
- s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
- s->previous = ffeexpr_stack_;
- s->pool = pool;
- s->context = context;
- s->callback = callback;
- s->first_token = NULL;
- s->exprstack = NULL;
- s->is_rhs = TRUE;
- ffeexpr_stack_ = s;
- return (ffelexHandler) ffeexpr_token_first_rhs_;
-}
-
-/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Makes sure the end token is close-paren and swallows it, else issues
- an error message and doesn't swallow the token (passing it along instead).
- In either case wraps up subexpression construction by enclosing the
- ffebld expression in a paren. */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
-
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- {
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- ffeexpr_exprstack_push_operand_ (e);
-
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_binary_);
- }
-
- if (expr->op == FFEBLD_opIMPDO)
- {
- if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
- }
- else
- {
- expr = ffebld_new_paren (expr);
- ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
- }
-
- /* Now push the (parenthesized) expression as an operand onto the
- expression stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->u.operand = expr;
- e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
- e->token = ffeexpr_stack_->tokens[0];
- ffeexpr_exprstack_push_operand_ (e);
-
- return (ffelexHandler) ffeexpr_token_binary_;
-}
-
-/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
- with the next token in t. If the next token is possibly a binary
- operator, continue processing the outer expression. If the next
- token is COMMA, then the expression is a unit specifier, and
- parentheses should not be added to it because it surrounds the
- I/O control list that starts with the unit specifier (and continues
- on from here -- we haven't seen the CLOSE_PAREN that matches the
- OPEN_PAREN, it is up to the callback function to expect to see it
- at some point). In this case, we notify the callback function that
- the COMMA is inside, not outside, the parens by wrapping the expression
- in an opITEM (with a NULL trail) -- the callback function presumably
- unwraps it after seeing this kludgey indicator.
-
- If the next token is CLOSE_PAREN, then we go to the _1_ state to
- decide what to do with the token after that.
-
- 15-Feb-91 JCB 1.1
- Use an extra state for the CLOSE_PAREN case to make READ &co really
- work right. */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- { /* Need to see the next token before we
- decide anything. */
- ffeexpr_stack_->expr = expr;
- ffeexpr_tokens_[0] = ffelex_token_use (ft);
- ffeexpr_tokens_[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
- }
-
- expr = ffeexpr_finished_ambig_ (ft, expr);
-
- /* Let the callback function handle the case where t isn't COMMA. */
-
- /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
- that preceded the expression starts a list of expressions, and the expr
- hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
- node. The callback function should extract the real expr from the head
- of this opITEM node after testing it. */
-
- expr = ffebld_new_item (expr, NULL);
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ffelex_token_kill (ffeexpr_stack_->first_token);
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- return (ffelexHandler) (*callback) (ft, expr, t);
-}
-
-/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
-
- See ffeexpr_cb_close_paren_ambig_.
-
- We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
- with the next token in t. If the next token is possibly a binary
- operator, continue processing the outer expression. If the next
- token is COMMA, the expression is a parenthesized format specifier.
- If the next token is not EOS or SEMICOLON, then because it is not a
- binary operator (it is NAME, OPEN_PAREN, &c), the expression is
- a unit specifier, and parentheses should not be added to it because
- they surround the I/O control list that consists of only the unit
- specifier. If the next token is EOS or SEMICOLON, the statement
- must be disambiguated by looking at the type of the expression -- a
- character expression is a parenthesized format specifier, while a
- non-character expression is a unit specifier.
-
- Another issue is how to do the callback so the recipient of the
- next token knows how to handle it if it is a COMMA. In all other
- cases, disambiguation is straightforward: the same approach as the
- above is used.
-
- EXTENSION: in COMMA case, if not pedantic, use same disambiguation
- as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
- and apparently other compilers do, as well, and some code out there
- uses this "feature".
-
- 19-Feb-91 JCB 1.1
- Extend to allow COMMA as nondisambiguating by itself. Remember
- to not try and check info field for opSTAR, since that expr doesn't
- have a valid info field. */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
- these. */
- ffelexToken orig_t = ffeexpr_tokens_[1];
- ffebld expr = ffeexpr_stack_->expr;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
- if (ffe_is_pedantic ())
- goto pedantic_comma; /* :::::::::::::::::::: */
- /* Fall through. */
- case FFELEX_typeEOS: /* Ambiguous; use type of expr to
- disambiguate. */
- case FFELEX_typeSEMICOLON:
- if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
- || (ffebld_op (expr) == FFEBLD_opSTAR)
- || (ffeinfo_basictype (ffebld_info (expr))
- != FFEINFO_basictypeCHARACTER))
- break; /* Not a valid CHARACTER entity, can't be a
- format spec. */
- /* Fall through. */
- default: /* Binary op (we assume; error otherwise);
- format specifier. */
-
- pedantic_comma: /* :::::::::::::::::::: */
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENUMAMBIG:
- ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
- break;
-
- case FFEEXPR_contextFILEUNITAMBIG:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- assert ("bad context" == NULL);
- break;
- }
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
- next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
- ffelex_token_kill (orig_ft);
- ffelex_token_kill (orig_t);
- return (ffelexHandler) (*next) (t);
-
- case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
- case FFELEX_typeNAME:
- break;
- }
-
- expr = ffeexpr_finished_ambig_ (orig_ft, expr);
-
- /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
- that preceded the expression starts a list of expressions, and the expr
- hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
- node. The callback function should extract the real expr from the head
- of this opITEM node after testing it. */
-
- expr = ffebld_new_item (expr, NULL);
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ffelex_token_kill (ffeexpr_stack_->first_token);
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
- ffelex_token_kill (orig_ft);
- ffelex_token_kill (orig_t);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Makes sure the end token is close-paren and swallows it, or a comma
- and handles complex/implied-do possibilities, else issues
- an error message and doesn't swallow the token (passing it along instead). */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- /* First check to see if this is a possible complex entity. It is if the
- token is a comma. */
-
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- {
- ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
- ffeexpr_stack_->expr = expr;
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
- }
-
- return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- If this token is not a comma, we have a complex constant (or an attempt
- at one), so handle it accordingly, displaying error messages if the token
- is not a close-paren. */
-
-static ffelexHandler
-ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
- ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
- ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
- ffeinfoBasictype rty = (expr == NULL)
- ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
- ffeinfoKindtype lkt;
- ffeinfoKindtype rkt;
- ffeinfoKindtype nkt;
- bool ok = TRUE;
- ffebld orig;
-
- if ((ffeexpr_stack_->expr == NULL)
- || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
- || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
- && (((ffebld_op (orig) != FFEBLD_opUMINUS)
- && (ffebld_op (orig) != FFEBLD_opUPLUS))
- || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
- || ((lty != FFEINFO_basictypeINTEGER)
- && (lty != FFEINFO_basictypeREAL)))
- {
- if ((lty != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_string ("Real");
- ffebad_finish ();
- }
- ok = FALSE;
- }
- if ((expr == NULL)
- || (ffebld_op (expr) != FFEBLD_opCONTER)
- || (((orig = ffebld_conter_orig (expr)) != NULL)
- && (((ffebld_op (orig) != FFEBLD_opUMINUS)
- && (ffebld_op (orig) != FFEBLD_opUPLUS))
- || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
- || ((rty != FFEINFO_basictypeINTEGER)
- && (rty != FFEINFO_basictypeREAL)))
- {
- if ((rty != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
- {
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string ("Imaginary");
- ffebad_finish ();
- }
- ok = FALSE;
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
-
- /* Push the (parenthesized) expression as an operand onto the expression
- stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_stack_->tokens[0];
-
- if (ok)
- {
- if (lty == FFEINFO_basictypeINTEGER)
- lkt = FFEINFO_kindtypeREALDEFAULT;
- else
- lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
- if (rty == FFEINFO_basictypeINTEGER)
- rkt = FFEINFO_kindtypeREALDEFAULT;
- else
- rkt = ffeinfo_kindtype (ffebld_info (expr));
-
- nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
- ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
- ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
- FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- expr = ffeexpr_convert (expr,
- ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
- FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- }
- else
- nkt = FFEINFO_kindtypeANY;
-
- switch (nkt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
- default:
- if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
- ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- e->u.operand = ffebld_new_any ();
- ffebld_set_info (e->u.operand, ffeinfo_new_any ());
- break;
- }
- ffeexpr_exprstack_push_operand_ (e);
-
- /* Now, if the token is a close parenthese, we're in great shape so return
- the next handler. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_token_binary_;
-
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
- ffebad_finish ();
- }
-
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_binary_);
-}
-
-/* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
- implied-DO construct)
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Makes sure the end token is close-paren and swallows it, or a comma
- and handles complex/implied-do possibilities, else issues
- an error message and doesn't swallow the token (passing it along instead). */
-
-static ffelexHandler
-ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctx;
-
- /* First check to see if this is a possible complex or implied-DO entity.
- It is if the token is a comma. */
-
- if (ffelex_token_type (t) == FFELEX_typeCOMMA)
- {
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- ctx = FFEEXPR_contextIMPDOITEM_;
- break;
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctx = FFEEXPR_contextIMPDOITEMDF_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_contextIMPDOITEM_;
- break;
- }
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
- ffeexpr_stack_->expr = expr;
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctx, ffeexpr_cb_comma_ci_);
- }
-
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
- return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- If this token is not a comma, we have a complex constant (or an attempt
- at one), so handle it accordingly, displaying error messages if the token
- is not a close-paren. If we have a comma here, it is an attempt at an
- implied-DO, so start making a list accordingly. Oh, it might be an
- equal sign also, meaning an implied-DO with only one item in its list. */
-
-static ffelexHandler
-ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffebld fexpr;
-
- /* First check to see if this is a possible complex constant. It is if the
- token is not a comma or an equals sign, in which case it should be a
- close-paren. */
-
- if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
- && (ffelex_token_type (t) != FFELEX_typeEQUALS))
- {
- ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
- ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
- return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
- }
-
- /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
- construct. Make a list and handle accordingly. */
-
- ffelex_token_kill (ffeexpr_stack_->tokens[0]);
- fexpr = ffeexpr_stack_->expr;
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
- return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle first item in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeCOMMA)
- {
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-
- return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
-}
-
-/* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle first item in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctxi;
- ffeexprContext ctxc;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- ctxi = FFEEXPR_contextDATAIMPDOITEM_;
- ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- ctxi = FFEEXPR_contextIMPDOITEM_;
- ctxc = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctxi = FFEEXPR_contextIMPDOITEMDF_;
- ctxc = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctxi = FFEEXPR_context;
- ctxc = FFEEXPR_context;
- break;
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- if (ffeexpr_stack_->is_rhs)
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctxi, ffeexpr_cb_comma_i_1_);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- ctxi, ffeexpr_cb_comma_i_1_);
-
- case FFELEX_typeEQUALS:
- ffebld_end_list (&ffeexpr_stack_->bottom);
-
- /* Complain if implied-DO variable in list of items to be read. */
-
- if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
- ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
- ffeexpr_stack_->first_token, expr, ft);
-
- /* Set doiter flag for all appropriate SYMTERs. */
-
- ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
-
- ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
- ffebld_set_info (ffeexpr_stack_->expr,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
- &ffeexpr_stack_->bottom);
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctxc, ffeexpr_cb_comma_i_2_);
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-}
-
-/* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle start-value in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctx;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- ctx = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctx = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctx, ffeexpr_cb_comma_i_3_);
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-}
-
-/* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle end-value in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- ffeexprContext ctx;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- ctx = FFEEXPR_contextDATAIMPDOCTRL_;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- ctx = FFEEXPR_contextIMPDOCTRL_;
- break;
-
- default:
- assert ("bad context" == NULL);
- ctx = FFEEXPR_context;
- break;
- }
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ctx, ffeexpr_cb_comma_i_4_);
- break;
-
- case FFELEX_typeCLOSE_PAREN:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- }
-}
-
-/* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
- [COMMA expr]
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Handle incr-value in an implied-DO construct. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- ffebld_append_item (&ffeexpr_stack_->bottom, expr);
- ffebld_end_list (&ffeexpr_stack_->bottom);
- {
- ffebld item;
-
- for (item = ffebld_left (ffeexpr_stack_->expr);
- item != NULL;
- item = ffebld_trail (item))
- if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
- goto replace_with_any; /* :::::::::::::::::::: */
-
- for (item = ffebld_right (ffeexpr_stack_->expr);
- item != NULL;
- item = ffebld_trail (item))
- if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
- && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
- goto replace_with_any; /* :::::::::::::::::::: */
- }
- break;
-
- default:
- if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_finish ();
- }
- ffebld_end_list (&ffeexpr_stack_->bottom);
-
- replace_with_any: /* :::::::::::::::::::: */
-
- ffeexpr_stack_->expr = ffebld_new_any ();
- ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
- break;
- }
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_comma_i_5_;
- return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
-}
-
-/* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
- [COMMA expr] CLOSE_PAREN
-
- Pass it to ffeexpr_rhs as the callback routine.
-
- Collects token following implied-DO construct for callback function. */
-
-static ffelexHandler
-ffeexpr_cb_comma_i_5_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
- ffebld expr;
- bool terminate;
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- case FFEEXPR_contextDATAIMPDOITEM_:
- terminate = TRUE;
- break;
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEM_:
- case FFEEXPR_contextIMPDOITEMDF_:
- terminate = FALSE;
- break;
-
- default:
- assert ("bad context" == NULL);
- terminate = FALSE;
- break;
- }
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- expr = ffeexpr_stack_->expr;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- if (terminate)
- {
- ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
- --ffeexpr_level_;
- if (ffeexpr_level_ == 0)
- ffe_terminate_4 ();
- }
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
-
- Makes sure the end token is close-paren and swallows it, else issues
- an error message and doesn't swallow the token (passing it along instead).
- In either case wraps up subexpression construction by enclosing the
- ffebld expression in a %LOC. */
-
-static ffelexHandler
-ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
-
- /* First push the (%LOC) expression as an operand onto the expression
- stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_stack_->tokens[0];
- e->u.operand = ffebld_new_percent_loc (expr);
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- ffecom_pointer_kind (),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereFLEETING,
- FFETARGET_charactersizeNONE));
-#if 0 /* ~~ */
- e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
-#endif
- ffeexpr_exprstack_push_operand_ (e);
-
- /* Now, if the token is a close parenthese, we're in great shape so return
- the next handler. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- {
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return (ffelexHandler) ffeexpr_token_binary_;
- }
-
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_finish ();
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_token_binary_);
-}
-
-/* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
-
- Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
-
-static ffelexHandler
-ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
-{
- ffeexprExpr_ e;
- ffebldOp op;
-
- /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
- such things until the lowest-level expression is reached. */
-
- op = ffebld_op (expr);
- if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
- || (op == FFEBLD_opPERCENT_DESCR))
- {
- if (ffebad_start (FFEBAD_NESTED_PERCENT))
- {
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
-
- do
- {
- expr = ffebld_left (expr);
- op = ffebld_op (expr);
- }
- while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
- || (op == FFEBLD_opPERCENT_DESCR));
- }
-
- /* Push the expression as an operand onto the expression stack. */
-
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_stack_->tokens[0];
- switch (ffeexpr_stack_->percent)
- {
- case FFEEXPR_percentVAL_:
- e->u.operand = ffebld_new_percent_val (expr);
- break;
-
- case FFEEXPR_percentREF_:
- e->u.operand = ffebld_new_percent_ref (expr);
- break;
-
- case FFEEXPR_percentDESCR_:
- e->u.operand = ffebld_new_percent_descr (expr);
- break;
-
- default:
- assert ("%lossage" == NULL);
- e->u.operand = expr;
- break;
- }
- ffebld_set_info (e->u.operand, ffebld_info (expr));
-#if 0 /* ~~ */
- e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
-#endif
- ffeexpr_exprstack_push_operand_ (e);
-
- /* Now, if the token is a close parenthese, we're in great shape so return
- the next handler. */
-
- if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
- return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
-
- /* Oops, naughty user didn't specify the close paren! */
-
- if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
- {
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
- ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
- ffebad_finish ();
- }
-
- ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return
- (ffelexHandler) ffeexpr_find_close_paren_ (t,
- (ffelexHandler)
- ffeexpr_cb_end_notloc_1_);
-}
-
-/* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
- CLOSE_PAREN
-
- Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
-
-static ffelexHandler
-ffeexpr_cb_end_notloc_1_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCOMMA:
- case FFELEX_typeCLOSE_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
- break;
-
- default:
- if (ffebad_start (FFEBAD_INVALID_PERCENT))
- {
- ffebad_here (0,
- ffelex_token_where_line (ffeexpr_stack_->first_token),
- ffelex_token_where_column (ffeexpr_stack_->first_token));
- ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
- ffebad_finish ();
- }
-
- ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
- FFEBLD_opPERCENT_LOC);
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
- }
-
- ffelex_token_kill (ffeexpr_stack_->tokens[1]);
- return
- (ffelexHandler) ffeexpr_token_binary_ (t);
-}
-
-/* Process DATA implied-DO iterator variables as this implied-DO level
- terminates. At this point, ffeexpr_level_ == 1 when we see the
- last right-paren in "DATA (A(I),I=1,10)/.../". */
-
-static ffesymbol
-ffeexpr_check_impctrl_ (ffesymbol s)
-{
- assert (s != NULL);
- assert (ffesymbol_sfdummyparent (s) != NULL);
-
- switch (ffesymbol_state (s))
- {
- case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
- be used as iterator at any level at or
- innermore than the outermost of the
- current level and the symbol's current
- level. */
- if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
- {
- ffesymbol_signal_change (s);
- ffesymbol_set_maxentrynum (s, ffeexpr_level_);
- ffesymbol_signal_unreported (s);
- }
- break;
-
- case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
- Error if at outermost level, else it can
- still become an iterator. */
- if ((ffeexpr_level_ == 1)
- && ffebad_start (FFEBAD_BAD_IMPDCL))
- {
- ffebad_string (ffesymbol_text (s));
- ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
- ffebad_finish ();
- }
- break;
-
- case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
- assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
- ffesymbol_signal_change (s);
- ffesymbol_set_state (s, FFESYMBOL_stateNONE);
- ffesymbol_signal_unreported (s);
- break;
-
- case FFESYMBOL_stateUNDERSTOOD:
- break; /* ANY. */
-
- default:
- assert ("Sasha Foo!!" == NULL);
- break;
- }
-
- return s;
-}
-
-/* Issue diagnostic if implied-DO variable appears in list of lhs
- expressions (as in "READ *, (I,I=1,10)"). */
-
-static void
-ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
- ffebld dovar, ffelexToken dovar_t)
-{
- ffebld item;
- ffesymbol dovar_sym;
- int itemnum;
-
- if (ffebld_op (dovar) != FFEBLD_opSYMTER)
- return; /* Presumably opANY. */
-
- dovar_sym = ffebld_symter (dovar);
-
- for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
- {
- if (((item = ffebld_head (list)) != NULL)
- && (ffebld_op (item) == FFEBLD_opSYMTER)
- && (ffebld_symter (item) == dovar_sym))
- {
- char itemno[20];
-
- sprintf (&itemno[0], "%d", itemnum);
- if (ffebad_start (FFEBAD_DOITER_IMPDO))
- {
- ffebad_here (0, ffelex_token_where_line (list_t),
- ffelex_token_where_column (list_t));
- ffebad_here (1, ffelex_token_where_line (dovar_t),
- ffelex_token_where_column (dovar_t));
- ffebad_string (ffesymbol_text (dovar_sym));
- ffebad_string (itemno);
- ffebad_finish ();
- }
- }
- }
-}
-
-/* Decorate any SYMTERs referencing the DO variable with the "doiter"
- flag. */
-
-static void
-ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
-{
- ffesymbol dovar_sym;
-
- if (ffebld_op (dovar) != FFEBLD_opSYMTER)
- return; /* Presumably opANY. */
-
- dovar_sym = ffebld_symter (dovar);
-
- ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
-}
-
-/* Recursive function to update any expr so SYMTERs have "doiter" flag
- if they refer to the given variable. */
-
-static void
-ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
-{
- tail_recurse: /* :::::::::::::::::::: */
-
- if (expr == NULL)
- return;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- if (ffebld_symter (expr) == dovar)
- ffebld_symter_set_is_doiter (expr, TRUE);
- break;
-
- case FFEBLD_opITEM:
- ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
- expr = ffebld_trail (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- switch (ffebld_arity (expr))
- {
- case 2:
- ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
- expr = ffebld_right (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- case 1:
- expr = ffebld_left (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- return;
-}
-
-/* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
-
- if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
- // After zero or more PAREN_ contexts, an IF context exists */
-
-static ffeexprContext
-ffeexpr_context_outer_ (ffeexprStack_ s)
-{
- assert (s != NULL);
-
- for (;;)
- {
- switch (s->context)
- {
- case FFEEXPR_contextPAREN_:
- case FFEEXPR_contextPARENFILENUM_:
- case FFEEXPR_contextPARENFILEUNIT_:
- break;
-
- default:
- return s->context;
- }
- s = s->previous;
- assert (s != NULL);
- }
-}
-
-/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
-
- ffeexprPercent_ p;
- ffelexToken t;
- p = ffeexpr_percent_(t);
-
- Returns the identifier for the name, or the NONE identifier. */
-
-static ffeexprPercent_
-ffeexpr_percent_ (ffelexToken t)
-{
- const char *p;
-
- switch (ffelex_token_length (t))
- {
- case 3:
- switch (*(p = ffelex_token_text (t)))
- {
- case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
- && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
- return FFEEXPR_percentLOC_;
- return FFEEXPR_percentNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
- && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
- return FFEEXPR_percentREF_;
- return FFEEXPR_percentNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
- && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
- return FFEEXPR_percentVAL_;
- return FFEEXPR_percentNONE_;
-
- default:
- no_match_3: /* :::::::::::::::::::: */
- return FFEEXPR_percentNONE_;
- }
-
- case 5:
- if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
- "descr", "Descr") == 0)
- return FFEEXPR_percentDESCR_;
- return FFEEXPR_percentNONE_;
-
- default:
- return FFEEXPR_percentNONE_;
- }
-}
-
-/* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
-
- See prototype.
-
- If combining the two basictype/kindtype pairs produces a COMPLEX with an
- unsupported kind type, complain and use the default kind type for
- COMPLEX. */
-
-void
-ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
- ffeinfoBasictype lbt, ffeinfoKindtype lkt,
- ffeinfoBasictype rbt, ffeinfoKindtype rkt,
- ffelexToken t)
-{
- ffeinfoBasictype nbt;
- ffeinfoKindtype nkt;
-
- nbt = ffeinfo_basictype_combine (lbt, rbt);
- if ((nbt == FFEINFO_basictypeCOMPLEX)
- && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
- && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
- {
- nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
- if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
- nkt = FFEINFO_kindtypeNONE; /* Force error. */
- switch (nkt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
-#endif
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
-#endif
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
-#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
-#endif
- break; /* Fine and dandy. */
-
- default:
- if (t != NULL)
- {
- ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
- ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
- ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_finish ();
- }
- nbt = FFEINFO_basictypeNONE;
- nkt = FFEINFO_kindtypeNONE;
- break;
-
- case FFEINFO_kindtypeANY:
- nkt = FFEINFO_kindtypeREALDEFAULT;
- break;
- }
- }
- else
- { /* The normal stuff. */
- if (nbt == lbt)
- {
- if (nbt == rbt)
- nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
- else
- nkt = lkt;
- }
- else if (nbt == rbt)
- nkt = rkt;
- else
- { /* Let the caller do the complaining. */
- nbt = FFEINFO_basictypeNONE;
- nkt = FFEINFO_kindtypeNONE;
- }
- }
-
- /* Always a good idea to avoid aliasing problems. */
-
- *xnbt = nbt;
- *xnkt = nkt;
-}
-
-/* ffeexpr_token_first_lhs_ -- First state for lhs expression
-
- Return a pointer to this function to the lexer (ffelex), which will
- invoke it for the next token.
-
- Record line and column of first token in expression, then invoke the
- initial-state lhs handler. */
-
-static ffelexHandler
-ffeexpr_token_first_lhs_ (ffelexToken t)
-{
- ffeexpr_stack_->first_token = ffelex_token_use (t);
-
- /* When changing the list of valid initial lhs tokens, check whether to
- update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
- READ (expr) <token> case -- it assumes it knows which tokens <token> can
- be to indicate an lhs (or implied DO), which right now is the set
- {NAME,OPEN_PAREN}.
-
- This comment also appears in ffeexpr_token_lhs_. */
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeOPEN_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextDATA:
- ffe_init_4 ();
- ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
- return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
-
- case FFEEXPR_contextFILEEXTFUNC:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_lhs_1_;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeNAME:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENAMELIST:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_namelist_;
-
- case FFEEXPR_contextFILEEXTFUNC:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_lhs_1_;
-
- default:
- break;
- }
- break;
-
- default:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEEXTFUNC:
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_lhs_1_;
-
- default:
- break;
- }
- break;
- }
-
- return (ffelexHandler) ffeexpr_token_lhs_ (t);
-}
-
-/* ffeexpr_token_first_lhs_1_ -- NAME
-
- return ffeexpr_token_first_lhs_1_; // to lexer
-
- Handle NAME as an external function (USEROPEN= VXT extension to OPEN
- statement). */
-
-static ffelexHandler
-ffeexpr_token_first_lhs_1_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
- ffesymbol sy = NULL;
- ffebld expr;
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
-
- if ((ffelex_token_type (ft) != FFELEX_typeNAME)
- || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
- & FFESYMBOL_attrANY))
- {
- if ((ffelex_token_type (ft) != FFELEX_typeNAME)
- || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
- {
- ffebad_start (FFEBAD_EXPR_WRONG);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- else
- {
- expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (expr, ffesymbol_info (sy));
- }
-
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
-
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_ -- First state for rhs expression
-
- Record line and column of first token in expression, then invoke the
- initial-state rhs handler.
-
- 19-Feb-91 JCB 1.1
- Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
- (i.e. only as in READ(*), not READ((*))). */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_ (ffelexToken t)
-{
- ffesymbol s;
-
- ffeexpr_stack_->first_token = ffelex_token_use (t);
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeASTERISK:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- /* Fall through. */
- case FFEEXPR_contextFILEUNIT:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextFILEFORMAT:
- case FFEEXPR_contextCHARACTERSIZE:
- if (ffeexpr_stack_->previous != NULL)
- break; /* Valid only on first level. */
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_1_;
-
- case FFEEXPR_contextPARENFILEUNIT_:
- if (ffeexpr_stack_->previous->previous != NULL)
- break; /* Valid only on second level. */
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_1_;
-
- case FFEEXPR_contextACTUALARG_:
- if (ffeexpr_stack_->previous->context
- != FFEEXPR_contextSUBROUTINEREF)
- {
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
- }
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_3_;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeOPEN_PAREN:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILENUMAMBIG:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPARENFILENUM_,
- ffeexpr_cb_close_paren_ambig_);
-
- case FFEEXPR_contextFILEUNITAMBIG:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextPARENFILEUNIT_,
- ffeexpr_cb_close_paren_ambig_);
-
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextIMPDOITEM_:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEM_,
- ffeexpr_cb_close_paren_ci_);
-
- case FFEEXPR_contextIOLISTDF:
- case FFEEXPR_contextIMPDOITEMDF_:
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- FFEEXPR_contextIMPDOITEMDF_,
- ffeexpr_cb_close_paren_ci_);
-
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeNUMBER:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- /* Fall through. */
- case FFEEXPR_contextFILEFORMAT:
- if (ffeexpr_stack_->previous != NULL)
- break; /* Valid only on first level. */
- assert (ffeexpr_stack_->exprstack == NULL);
- return (ffelexHandler) ffeexpr_token_first_rhs_2_;
-
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typeNAME:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextFILEFORMATNML:
- assert (ffeexpr_stack_->exprstack == NULL);
- s = ffesymbol_lookup_local (t);
- if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
- return (ffelexHandler) ffeexpr_token_namelist_;
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- break;
- }
- break;
-
- case FFELEX_typePERCENT:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextINDEXORACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- return (ffelexHandler) ffeexpr_token_first_rhs_5_;
-
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- break;
- }
-
- default:
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextFILEFORMATNML:
- ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
- break;
-
- default:
- break;
- }
- break;
- }
-
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
-}
-
-/* ffeexpr_token_first_rhs_1_ -- ASTERISK
-
- return ffeexpr_token_first_rhs_1_; // to lexer
-
- Return STAR as expression. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_1_ (ffelexToken t)
-{
- ffebld expr;
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
-
- expr = ffebld_new_star ();
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_2_ -- NUMBER
-
- return ffeexpr_token_first_rhs_2_; // to lexer
-
- Return NULL as expression; NUMBER as first (and only) token, unless the
- current token is not a terminating token, in which case run normal
- expression handling. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_2_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- case FFELEX_typeCOMMA:
- case FFELEX_typeEOS:
- case FFELEX_typeSEMICOLON:
- break;
-
- default:
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- return (ffelexHandler) (*next) (t);
- }
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
- sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, NULL, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_3_ -- ASTERISK
-
- return ffeexpr_token_first_rhs_3_; // to lexer
-
- Expect NUMBER, make LABTOK (with copy of token if not inhibited after
- confirming, else NULL). */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_3_ (ffelexToken t)
-{
- ffelexHandler next;
-
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- { /* An error, but let normal processing handle
- it. */
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- return (ffelexHandler) (*next) (t);
- }
-
- /* Special case: when we see "*10" as an argument to a subroutine
- reference, we confirm the current statement and, if not inhibited at
- this point, put a copy of the token into a LABTOK node. We do this
- instead of just resolving the label directly via ffelab and putting it
- into a LABTER simply to improve error reporting and consistency in
- ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
- doesn't have to worry about killing off any tokens when retracting. */
-
- ffest_confirmed ();
- if (ffest_is_inhibited ())
- ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
- else
- ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
- ffebld_set_info (ffeexpr_stack_->expr,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
-
- return (ffelexHandler) ffeexpr_token_first_rhs_4_;
-}
-
-/* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
-
- return ffeexpr_token_first_rhs_4_; // to lexer
-
- Collect/flush appropriate stuff, send token to callback function. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_4_ (ffelexToken t)
-{
- ffebld expr;
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
-
- expr = ffeexpr_stack_->expr;
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_token_first_rhs_5_ -- PERCENT
-
- Should be NAME, or pass through original mechanism. If NAME is LOC,
- pass through original mechanism, otherwise must be VAL, REF, or DESCR,
- in which case handle the argument (in parentheses), etc. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_5_ (ffelexToken t)
-{
- ffelexHandler next;
-
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- {
- ffeexprPercent_ p = ffeexpr_percent_ (t);
-
- switch (p)
- {
- case FFEEXPR_percentNONE_:
- case FFEEXPR_percentLOC_:
- break; /* Treat %LOC as any other expression. */
-
- case FFEEXPR_percentVAL_:
- case FFEEXPR_percentREF_:
- case FFEEXPR_percentDESCR_:
- ffeexpr_stack_->percent = p;
- ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_token_first_rhs_6_;
-
- default:
- assert ("bad percent?!?" == NULL);
- break;
- }
- }
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
-
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
-
- Should be OPEN_PAREN, or pass through original mechanism. */
-
-static ffelexHandler
-ffeexpr_token_first_rhs_6_ (ffelexToken t)
-{
- ffelexHandler next;
- ffelexToken ft;
-
- if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
- {
- ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
- ffeexpr_stack_->context,
- ffeexpr_cb_end_notloc_);
- }
-
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- break;
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
- break;
-
- default:
- assert ("bad context?!?!" == NULL);
- break;
- }
-
- ft = ffeexpr_stack_->tokens[0];
- next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
- next = (ffelexHandler) (*next) (ft);
- ffelex_token_kill (ft);
- return (ffelexHandler) (*next) (t);
-}
-
-/* ffeexpr_token_namelist_ -- NAME
-
- return ffeexpr_token_namelist_; // to lexer
-
- Make sure NAME was a valid namelist object, wrap it in a SYMTER and
- return. */
-
-static ffelexHandler
-ffeexpr_token_namelist_ (ffelexToken t)
-{
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffelexHandler next;
- ffelexToken ft;
- ffesymbol sy;
- ffebld expr;
-
- ffebld_pool_pop ();
- callback = ffeexpr_stack_->callback;
- ft = ffeexpr_stack_->first_token;
- s = ffeexpr_stack_->previous;
- malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
- ffeexpr_stack_ = s;
-
- sy = ffesymbol_lookup_local (ft);
- if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
- {
- ffebad_start (FFEBAD_EXPR_WRONG);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- expr = ffebld_new_any ();
- ffebld_set_info (expr, ffeinfo_new_any ());
- }
- else
- {
- expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (expr, ffesymbol_info (sy));
- }
- next = (ffelexHandler) (*callback) (ft, expr, t);
- ffelex_token_kill (ft);
- return (ffelexHandler) next;
-}
-
-/* ffeexpr_expr_kill_ -- Kill an existing internal expression object
-
- ffeexprExpr_ e;
- ffeexpr_expr_kill_(e);
-
- Kills the ffewhere info, if necessary, then kills the object. */
-
-static void
-ffeexpr_expr_kill_ (ffeexprExpr_ e)
-{
- if (e->token != NULL)
- ffelex_token_kill (e->token);
- malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
-}
-
-/* ffeexpr_expr_new_ -- Make a new internal expression object
-
- ffeexprExpr_ e;
- e = ffeexpr_expr_new_();
-
- Allocates and initializes a new expression object, returns it. */
-
-static ffeexprExpr_
-ffeexpr_expr_new_ ()
-{
- ffeexprExpr_ e;
-
- e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
- sizeof (*e));
- e->previous = NULL;
- e->type = FFEEXPR_exprtypeUNKNOWN_;
- e->token = NULL;
- return e;
-}
-
-/* Verify that call to global is valid, and register whatever
- new information about a global might be discoverable by looking
- at the call. */
-
-static void
-ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
-{
- int n_args;
- ffebld list;
- ffebld item;
- ffesymbol s;
-
- assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
- || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
-
- if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
- return;
-
- if (ffesymbol_retractable ())
- return;
-
- s = ffebld_symter (ffebld_left (*expr));
- if (ffesymbol_global (s) == NULL)
- return;
-
- for (n_args = 0, list = ffebld_right (*expr);
- list != NULL;
- list = ffebld_trail (list), ++n_args)
- ;
-
- if (ffeglobal_proc_ref_nargs (s, n_args, t))
- {
- ffeglobalArgSummary as;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- bool array;
- bool fail = FALSE;
-
- for (n_args = 0, list = ffebld_right (*expr);
- list != NULL;
- list = ffebld_trail (list), ++n_args)
- {
- item = ffebld_head (list);
- if (item != NULL)
- {
- bt = ffeinfo_basictype (ffebld_info (item));
- kt = ffeinfo_kindtype (ffebld_info (item));
- array = (ffeinfo_rank (ffebld_info (item)) > 0);
- switch (ffebld_op (item))
- {
- case FFEBLD_opLABTOK:
- case FFEBLD_opLABTER:
- as = FFEGLOBAL_argsummaryALTRTN;
- break;
-
-#if 0
- /* No, %LOC(foo) is just like any INTEGER(KIND=7)
- expression, so don't treat it specially. */
- case FFEBLD_opPERCENT_LOC:
- as = FFEGLOBAL_argsummaryPTR;
- break;
-#endif
-
- case FFEBLD_opPERCENT_VAL:
- as = FFEGLOBAL_argsummaryVAL;
- break;
-
- case FFEBLD_opPERCENT_REF:
- as = FFEGLOBAL_argsummaryREF;
- break;
-
- case FFEBLD_opPERCENT_DESCR:
- as = FFEGLOBAL_argsummaryDESCR;
- break;
-
- case FFEBLD_opFUNCREF:
-#if 0
- /* No, LOC(foo) is just like any INTEGER(KIND=7)
- expression, so don't treat it specially. */
- if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
- && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
- == FFEINTRIN_specLOC))
- {
- as = FFEGLOBAL_argsummaryPTR;
- break;
- }
-#endif
- /* Fall through. */
- default:
- if (ffebld_op (item) == FFEBLD_opSYMTER)
- {
- as = FFEGLOBAL_argsummaryNONE;
-
- switch (ffeinfo_kind (ffebld_info (item)))
- {
- case FFEINFO_kindFUNCTION:
- as = FFEGLOBAL_argsummaryFUNC;
- break;
-
- case FFEINFO_kindSUBROUTINE:
- as = FFEGLOBAL_argsummarySUBR;
- break;
-
- case FFEINFO_kindNONE:
- as = FFEGLOBAL_argsummaryPROC;
- break;
-
- default:
- break;
- }
-
- if (as != FFEGLOBAL_argsummaryNONE)
- break;
- }
-
- if (bt == FFEINFO_basictypeCHARACTER)
- as = FFEGLOBAL_argsummaryDESCR;
- else
- as = FFEGLOBAL_argsummaryREF;
- break;
- }
- }
- else
- {
- array = FALSE;
- as = FFEGLOBAL_argsummaryNONE;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- }
-
- if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
- fail = TRUE;
- }
- if (! fail)
- return;
- }
-
- *expr = ffebld_new_any ();
- ffebld_set_info (*expr, ffeinfo_new_any ());
-}
-
-/* Check whether rest of string is all decimal digits. */
-
-static bool
-ffeexpr_isdigits_ (const char *p)
-{
- for (; *p != '\0'; ++p)
- if (! ISDIGIT (*p))
- return FALSE;
- return TRUE;
-}
-
-/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_(e);
-
- Pushes the expression onto the stack without any analysis of the existing
- contents of the stack. */
-
-static void
-ffeexpr_exprstack_push_ (ffeexprExpr_ e)
-{
- e->previous = ffeexpr_stack_->exprstack;
- ffeexpr_stack_->exprstack = e;
-}
-
-/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_operand_(e);
-
- Pushes the expression already containing an operand (a constant, variable,
- or more complicated expression that has already been fully resolved) after
- analyzing the stack and checking for possible reduction (which will never
- happen here since the highest precedence operator is ** and it has right-
- to-left associativity). */
-
-static void
-ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
-{
- ffeexpr_exprstack_push_ (e);
-#ifdef WEIRD_NONFORTRAN_RULES
- if ((ffeexpr_stack_->exprstack != NULL)
- && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
- && (ffeexpr_stack_->exprstack->expr->u.operator.prec
- == FFEEXPR_operatorprecedenceHIGHEST_)
- && (ffeexpr_stack_->exprstack->expr->u.operator.as
- == FFEEXPR_operatorassociativityL2R_))
- ffeexpr_reduce_ ();
-#endif
-}
-
-/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
-
- ffeexprExpr_ e;
- ffeexpr_exprstack_push_unary_(e);
-
- Pushes the expression already containing a unary operator. Reduction can
- never happen since unary operators are themselves always R-L; that is, the
- top of the expression stack is not an operand, in that it is either empty,
- has a binary operator at the top, or a unary operator at the top. In any
- of these cases, reduction is impossible. */
-
-static void
-ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
-{
- if ((ffe_is_pedantic ()
- || ffe_is_warn_surprising ())
- && (ffeexpr_stack_->exprstack != NULL)
- && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
- && (ffeexpr_stack_->exprstack->u.operator.prec
- <= FFEEXPR_operatorprecedenceLOWARITH_)
- && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
- {
- /* 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_ ()
-{
- ffeexprExpr_ operand; /* This is B in -B or A+B. */
- ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
- ffeexprExpr_ operator; /* This is + in A+B. */
- ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
- ffebldConstant constnode; /* For checking magical numbers (where mag ==
- -mag). */
- ffebld expr;
- ffebld left_expr;
- bool submag = FALSE;
-
- operand = ffeexpr_stack_->exprstack;
- assert (operand != NULL);
- assert (operand->type == FFEEXPR_exprtypeOPERAND_);
- operator = operand->previous;
- assert (operator != NULL);
- assert (operator->type != FFEEXPR_exprtypeOPERAND_);
- if (operator->type == FFEEXPR_exprtypeUNARY_)
- {
- expr = operand->u.operand;
- switch (operator->u.operator.op)
- {
- case FFEEXPR_operatorADD_:
- reduced = ffebld_new_uplus (expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
- reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
- reduced = ffeexpr_collapse_uplus (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorSUBTRACT_:
- submag = TRUE; /* Ok to negate a magic number. */
- reduced = ffebld_new_uminus (expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
- reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
- reduced = ffeexpr_collapse_uminus (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorNOT_:
- reduced = ffebld_new_not (expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
- reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
- reduced = ffeexpr_collapse_not (reduced, operator->token);
- break;
-
- default:
- assert ("unexpected unary op" != NULL);
- reduced = NULL;
- break;
- }
- if (!submag
- && (ffebld_op (expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
- {
- ffetarget_integer_bad_magical (operand->token);
- }
- ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
- off stack. */
- ffeexpr_expr_kill_ (operand);
- operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
- save */
- operator->u.operand = reduced; /* the line/column ffewhere info. */
- ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
- stack. */
- }
- else
- {
- assert (operator->type == FFEEXPR_exprtypeBINARY_);
- left_operand = operator->previous;
- assert (left_operand != NULL);
- assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
- expr = operand->u.operand;
- left_expr = left_operand->u.operand;
- switch (operator->u.operator.op)
- {
- case FFEEXPR_operatorADD_:
- reduced = ffebld_new_add (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_add (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorSUBTRACT_:
- submag = TRUE; /* Just to pick the right error if magic
- number. */
- reduced = ffebld_new_subtract (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_subtract (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorMULTIPLY_:
- reduced = ffebld_new_multiply (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_multiply (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorDIVIDE_:
- reduced = ffebld_new_divide (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_divide (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorPOWER_:
- reduced = ffebld_new_power (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_power (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorCONCATENATE_:
- reduced = ffebld_new_concatenate (left_expr, expr);
- reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorLT_:
- reduced = ffebld_new_lt (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_lt (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorLE_:
- reduced = ffebld_new_le (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_le (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorEQ_:
- reduced = ffebld_new_eq (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_eq (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorNE_:
- reduced = ffebld_new_ne (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_ne (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorGT_:
- reduced = ffebld_new_gt (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_gt (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorGE_:
- reduced = ffebld_new_ge (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_ge (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorAND_:
- reduced = ffebld_new_and (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_and (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorOR_:
- reduced = ffebld_new_or (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_or (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorXOR_:
- reduced = ffebld_new_xor (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_xor (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorEQV_:
- reduced = ffebld_new_eqv (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_eqv (reduced, operator->token);
- break;
-
- case FFEEXPR_operatorNEQV_:
- reduced = ffebld_new_neqv (left_expr, expr);
- if (ffe_is_ugly_logint ())
- reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
- operand);
- reduced = ffeexpr_collapse_neqv (reduced, operator->token);
- break;
-
- default:
- assert ("bad bin op" == NULL);
- reduced = expr;
- break;
- }
- if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
- {
- if ((left_operand->previous != NULL)
- && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
- && (left_operand->previous->u.operator.op
- == FFEEXPR_operatorSUBTRACT_))
- {
- if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
- ffetarget_integer_bad_magical_precedence (left_operand->token,
- left_operand->previous->token,
- operator->token);
- else
- ffetarget_integer_bad_magical_precedence_binary
- (left_operand->token,
- left_operand->previous->token,
- operator->token);
- }
- else
- ffetarget_integer_bad_magical (left_operand->token);
- }
- if ((ffebld_op (expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
- {
- if (submag)
- ffetarget_integer_bad_magical_binary (operand->token,
- operator->token);
- else
- ffetarget_integer_bad_magical (operand->token);
- }
- ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
- operands off stack. */
- ffeexpr_expr_kill_ (left_operand);
- ffeexpr_expr_kill_ (operand);
- operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
- save */
- operator->u.operand = reduced; /* the line/column ffewhere info. */
- ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
- stack. */
- }
-}
-
-/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
-
- reduced = ffeexpr_reduced_bool1_(reduced,op,r);
-
- Makes sure the argument for reduced has basictype of
- LOGICAL or (ugly) INTEGER. If
- argument has where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
-{
- ffeinfo rinfo, ninfo;
- ffeinfoBasictype rbt;
- ffeinfoKindtype rkt;
- ffeinfoRank rrk;
- ffeinfoKind rkd;
- ffeinfoWhere rwh, nwh;
-
- rinfo = ffebld_info (ffebld_left (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if (((rbt == FFEINFO_basictypeLOGICAL)
- || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
- && (rrk == 0))
- {
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- return reduced;
- }
-
- if ((rbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_NOT_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_NOT_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
-
- reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- LOGICAL or (ugly) INTEGER. Determine common basictype and
- size for reduction (flag expression for combined hollerith/typeless
- situations for later determination of effective basictype). If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Convert typeless
- constants to the desired type/size explicitly.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
- if (((nbt == FFEINFO_basictypeLOGICAL)
- || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
- && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
- FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
- {
- if ((rbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- }
- else if ((rbt != FFEINFO_basictypeLOGICAL)
- && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lrk != 0)
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_BOOL_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
- else
- {
- if ((rkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_BOOL_ARG_KIND))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string ("an array");
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
-
- reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
- basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
- size of concatenation and assign that size to reduced. If both left and
- right arguments have where of CONSTANT, assign where CONSTANT to reduced,
- else assign where FLEETING.
-
- If these requirements cannot be met, generate error message using the
- info in l, op, and r arguments and assign basictype, size, kind, and where
- of ANY. */
-
-static ffebld
-ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd, nkd;
- ffeinfoWhere lwh, rwh, nwh;
- ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- lszk = ffeinfo_size (linfo); /* Known size. */
- lszm = ffebld_size_max (ffebld_left (reduced));
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- rszk = ffeinfo_size (rinfo); /* Known size. */
- rszm = ffebld_size_max (ffebld_right (reduced));
-
- if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
- && (lkt == rkt) && (lrk == 0) && (rrk == 0)
- && (((lszm != FFETARGET_charactersizeNONE)
- && (rszm != FFETARGET_charactersizeNONE))
- || (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextLET)
- || (ffeexpr_context_outer_ (ffeexpr_stack_)
- == FFEEXPR_contextSFUNCDEF)))
- {
- nbt = FFEINFO_basictypeCHARACTER;
- nkd = FFEINFO_kindENTITY;
- if ((lszk == FFETARGET_charactersizeNONE)
- || (rszk == FFETARGET_charactersizeNONE))
- nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
- stmt. */
- else
- nszk = lszk + rszk;
-
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- nkt = lkt;
- ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
- ffebld_set_info (reduced, ninfo);
- return reduced;
- }
-
- if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
- {
- if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if (lbt != FFEINFO_basictypeCHARACTER)
- {
- if ((lbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_finish ();
- }
- }
- else if (rbt != FFEINFO_basictypeCHARACTER)
- {
- if ((rbt != FFEINFO_basictypeANY)
- && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
- {
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_finish ();
- }
- }
- else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
- {
- if ((lkd != FFEINFO_kindANY)
- && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
- {
- const char *what;
-
- if (lrk != 0)
- what = "an array";
- else
- what = "of indeterminate length";
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
- ffebad_string (what);
- ffebad_finish ();
- }
- }
- else
- {
- if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
- {
- const char *what;
-
- if (rrk != 0)
- what = "an array";
- else
- what = "of indeterminate length";
- ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
- ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
- ffebad_string (what);
- ffebad_finish ();
- }
- }
-
- reduced = ffebld_new_any ();
- ffebld_set_info (reduced, ffeinfo_new_any ());
- return reduced;
-}
-
-/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
-
- reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
-
- Makes sure the left and right arguments for reduced have basictype of
- INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
- size for reduction. If both left
- and right arguments have where of CONSTANT, assign where CONSTANT to
- reduced, else assign where FLEETING. Create CONVERT ops for args where
- needed. Convert typeless
- constants to the desired type/size explicitly.
-
- If these requirements cannot be met, generate error message. */
-
-static ffebld
-ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
-{
- ffeinfo linfo, rinfo, ninfo;
- ffeinfoBasictype lbt, rbt, nbt;
- ffeinfoKindtype lkt, rkt, nkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh, nwh;
- ffetargetCharacterSize lsz, rsz;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- lsz = ffebld_size_known (ffebld_left (reduced));
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- rsz = ffebld_size_known (ffebld_right (reduced));
-
- ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
-
- if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
- || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
- && (lrk == 0) && (rrk == 0))
- {
- switch (lwh)
- {
- case FFEINFO_whereCONSTANT:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- nwh = FFEINFO_whereCONSTANT;
- break;
-
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- case FFEINFO_whereIMMEDIATE:
- switch (rwh)
- {
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereIMMEDIATE:
- nwh = FFEINFO_whereIMMEDIATE;
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
- break;
-
- default:
- nwh = FFEINFO_whereFLEETING;
- break;
- }
-
- if ((lsz != FFETARGET_charactersizeNONE)
- && (rsz != FFETARGET_charactersizeNONE))
- lsz = rsz = (lsz > rsz) ? lsz : rsz;
-
- ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
- 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
- ffebld_set_info (reduced, ninfo);
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, nbt, nkt, 0, lsz,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, nbt, nkt, 0, rsz,
- FFEEXPR_contextLET));
- return reduced;
- }
-
- if ((lbt == FFEINFO_basictypeLOGICAL)
- && (rbt == FFEINFO_basictypeLOGICAL))
- {
- /* 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)
-{
- ffeinfo linfo, rinfo;
- ffeinfoBasictype lbt, rbt;
- ffeinfoKindtype lkt, rkt;
- ffeinfoRank lrk, rrk;
- ffeinfoKind lkd, rkd;
- ffeinfoWhere lwh, rwh;
-
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
-
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
-
- if ((lbt == FFEINFO_basictypeTYPELESS)
- || (lbt == FFEINFO_basictypeHOLLERITH))
- {
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
- l->token, op->token, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
- r->token, op->token, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET));
- linfo = ffebld_info (ffebld_left (reduced));
- rinfo = ffebld_info (ffebld_right (reduced));
- lbt = rbt = FFEINFO_basictypeLOGICAL;
- lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
- lrk = rrk = 0;
- lkd = rkd = FFEINFO_kindENTITY;
- lwh = ffeinfo_where (linfo);
- rwh = ffeinfo_where (rinfo);
- }
- else
- {
- ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
- l->token, ffebld_right (reduced), r->token,
- FFEEXPR_contextLET));
- linfo = ffebld_info (ffebld_left (reduced));
- lbt = ffeinfo_basictype (linfo);
- lkt = ffeinfo_kindtype (linfo);
- lrk = ffeinfo_rank (linfo);
- lkd = ffeinfo_kind (linfo);
- lwh = ffeinfo_where (linfo);
- }
- }
- else
- {
- if ((rbt == FFEINFO_basictypeTYPELESS)
- || (rbt == FFEINFO_basictypeHOLLERITH))
- {
- ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
- r->token, ffebld_left (reduced), l->token,
- FFEEXPR_contextLET));
- rinfo = ffebld_info (ffebld_right (reduced));
- rbt = ffeinfo_basictype (rinfo);
- rkt = ffeinfo_kindtype (rinfo);
- rrk = ffeinfo_rank (rinfo);
- rkd = ffeinfo_kind (rinfo);
- rwh = ffeinfo_where (rinfo);
- }
- /* else Leave it alone. */
- }
-
- return reduced;
-}
-
-/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
- is found.
-
- The idea is to process the tokens as they would be done by normal
- expression processing, with the key things being telling the lexer
- when hollerith/character constants are about to happen, until the
- true closing token is found. */
-
-static ffelexHandler
-ffeexpr_find_close_paren_ (ffelexToken t,
- ffelexHandler after)
-{
- ffeexpr_find_.after = after;
- ffeexpr_find_.level = 1;
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
-}
-
-static ffelexHandler
-ffeexpr_nil_finished_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeCLOSE_PAREN:
- if (--ffeexpr_find_.level == 0)
- return (ffelexHandler) ffeexpr_find_.after;
- return (ffelexHandler) ffeexpr_nil_binary_;
-
- case FFELEX_typeCOMMA:
- case FFELEX_typeCOLON:
- case FFELEX_typeEQUALS:
- case FFELEX_typePOINTS:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- default:
- if (--ffeexpr_find_.level == 0)
- return (ffelexHandler) ffeexpr_find_.after (t);
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_rhs_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeQUOTE:
- if (ffe_is_vxt ())
- return (ffelexHandler) ffeexpr_nil_quote_;
- ffelex_set_expecting_hollerith (-1, '\"',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_nil_apostrophe_;
-
- case FFELEX_typeAPOSTROPHE:
- ffelex_set_expecting_hollerith (-1, '\'',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_nil_apostrophe_;
-
- case FFELEX_typePERCENT:
- return (ffelexHandler) ffeexpr_nil_percent_;
-
- case FFELEX_typeOPEN_PAREN:
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFELEX_typePLUS:
- case FFELEX_typeMINUS:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFELEX_typePERIOD:
- return (ffelexHandler) ffeexpr_nil_period_;
-
- case FFELEX_typeNUMBER:
- ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
- if (ffeexpr_hollerith_count_ > 0)
- ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
- '\0',
- ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- return (ffelexHandler) ffeexpr_nil_number_;
-
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- return (ffelexHandler) ffeexpr_nil_name_rhs_;
-
- case FFELEX_typeASTERISK:
- case FFELEX_typeSLASH:
- case FFELEX_typePOWER:
- case FFELEX_typeCONCAT:
- case FFELEX_typeREL_EQ:
- case FFELEX_typeREL_NE:
- case FFELEX_typeREL_LE:
- case FFELEX_typeREL_GE:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_finished_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_period_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffestr_other (t);
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherNone:
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
-
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- case FFESTR_otherNOT:
- return (ffelexHandler) ffeexpr_nil_end_period_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_swallow_period_;
- }
- break; /* Nothing really reaches here. */
-
- case FFELEX_typeNUMBER:
- return (ffelexHandler) ffeexpr_nil_real_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_end_period_ (ffelexToken t)
-{
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherNOT:
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-
- default:
- assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
- exit (0);
- return NULL;
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_swallow_period_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-static ffelexHandler
-ffeexpr_nil_real_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (((ffelex_token_type (t) != FFELEX_typeNAME)
- && (ffelex_token_type (t) != FFELEX_typeNAMES))
- || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q')))
- && ffeexpr_isdigits_ (++p)))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- if (*p == '\0')
- return (ffelexHandler) ffeexpr_nil_real_exponent_;
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_real_exponent_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
-}
-
-static ffelexHandler
-ffeexpr_nil_real_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (ffeexpr_hollerith_count_ > 0)
- ffelex_set_expecting_hollerith (0, '\0',
- ffewhere_line_unknown (),
- ffewhere_column_unknown ());
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q'))
- && ffeexpr_isdigits_ (++p))
- {
- if (*p == '\0')
- {
- ffeexpr_find_.t = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_nil_number_exponent_;
- }
- return (ffelexHandler) ffeexpr_nil_binary_;
- }
- break;
-
- case FFELEX_typePERIOD:
- ffeexpr_find_.t = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_nil_number_period_;
-
- case FFELEX_typeHOLLERITH:
- return (ffelexHandler) ffeexpr_nil_binary_;
-
- default:
- break;
- }
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_number_exponent_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
-
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- nexthandler
- = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_number_period_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
- char d;
- const char *p;
-
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q'))
- && ffeexpr_isdigits_ (++p))
- {
- if (*p == '\0')
- return (ffelexHandler) ffeexpr_nil_number_per_exp_;
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_binary_;
- }
- nexthandler
- = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
-
- case FFELEX_typeNUMBER:
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_number_real_;
-
- default:
- break;
- }
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_number_per_exp_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- {
- ffelexHandler nexthandler;
-
- nexthandler
- = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_real_ (ffelexToken t)
-{
- char d;
- const char *p;
-
- if (((ffelex_token_type (t) != FFELEX_typeNAME)
- && (ffelex_token_type (t) != FFELEX_typeNAMES))
- || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
- 'D', 'd')
- || ffesrc_char_match_init (d, 'E', 'e')
- || ffesrc_char_match_init (d, 'Q', 'q')))
- && ffeexpr_isdigits_ (++p)))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- if (*p == '\0')
- return (ffelexHandler) ffeexpr_nil_number_real_exp_;
-
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_number_real_exp_ (ffelexToken t)
-{
- if ((ffelex_token_type (t) != FFELEX_typePLUS)
- && (ffelex_token_type (t) != FFELEX_typeMINUS))
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
-}
-
-static ffelexHandler
-ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typePLUS:
- case FFELEX_typeMINUS:
- case FFELEX_typeASTERISK:
- case FFELEX_typeSLASH:
- case FFELEX_typePOWER:
- case FFELEX_typeCONCAT:
- case FFELEX_typeOPEN_ANGLE:
- case FFELEX_typeCLOSE_ANGLE:
- case FFELEX_typeREL_EQ:
- case FFELEX_typeREL_NE:
- case FFELEX_typeREL_GE:
- case FFELEX_typeREL_LE:
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- case FFELEX_typePERIOD:
- return (ffelexHandler) ffeexpr_nil_binary_period_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_finished_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_period_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffestr_other (t);
- switch (ffeexpr_current_dotdot_)
- {
- case FFESTR_otherTRUE:
- case FFESTR_otherFALSE:
- case FFESTR_otherNOT:
- return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_binary_end_per_;
- }
- break; /* Nothing really reaches here. */
-
- default:
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_end_per_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-static ffelexHandler
-ffeexpr_nil_binary_sw_per_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_quote_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeNUMBER)
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_binary_;
-}
-
-static ffelexHandler
-ffeexpr_nil_apostrophe_ (ffelexToken t)
-{
- assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
- return (ffelexHandler) ffeexpr_nil_apos_char_;
-}
-
-static ffelexHandler
-ffeexpr_nil_apos_char_ (ffelexToken t)
-{
- char c;
-
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- {
- if ((ffelex_token_length (t) == 1)
- && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
- 'B', 'b')
- || ffesrc_char_match_init (c, 'O', 'o')
- || ffesrc_char_match_init (c, 'X', 'x')
- || ffesrc_char_match_init (c, 'Z', 'z')))
- return (ffelexHandler) ffeexpr_nil_binary_;
- }
- if ((ffelex_token_type (t) == FFELEX_typeNAME)
- || (ffelex_token_type (t) == FFELEX_typeNAMES))
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- return (ffelexHandler) ffeexpr_nil_substrp_ (t);
-}
-
-static ffelexHandler
-ffeexpr_nil_name_rhs_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeQUOTE:
- case FFELEX_typeAPOSTROPHE:
- ffelex_set_hexnum (TRUE);
- return (ffelexHandler) ffeexpr_nil_name_apos_;
-
- case FFELEX_typeOPEN_PAREN:
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_name_apos_ (ffelexToken t)
-{
- if (ffelex_token_type (t) == FFELEX_typeNAME)
- return (ffelexHandler) ffeexpr_nil_name_apos_name_;
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-}
-
-static ffelexHandler
-ffeexpr_nil_name_apos_name_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeAPOSTROPHE:
- case FFELEX_typeQUOTE:
- return (ffelexHandler) ffeexpr_nil_finished_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_finished_ (t);
- }
-}
-
-static ffelexHandler
-ffeexpr_nil_percent_ (ffelexToken t)
-{
- switch (ffelex_token_type (t))
- {
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- ffeexpr_stack_->percent = ffeexpr_percent_ (t);
- ffeexpr_find_.t = ffelex_token_use (t);
- return (ffelexHandler) ffeexpr_nil_percent_name_;
-
- default:
- return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- }
-}
-
-/* Expects ffeexpr_find_.t. */
-
-static ffelexHandler
-ffeexpr_nil_percent_name_ (ffelexToken t)
-{
- ffelexHandler nexthandler;
-
- if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
- {
- nexthandler
- = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
- ffelex_token_kill (ffeexpr_find_.t);
- return (ffelexHandler) (*nexthandler) (t);
- }
-
- ffelex_token_kill (ffeexpr_find_.t);
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-static ffelexHandler
-ffeexpr_nil_substrp_ (ffelexToken t)
-{
- if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
- return (ffelexHandler) ffeexpr_nil_binary_ (t);
-
- ++ffeexpr_find_.level;
- return (ffelexHandler) ffeexpr_nil_rhs_;
-}
-
-/* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
-
- ffelexToken t;
- return ffeexpr_finished_(t);
-
- Reduces expression stack to one (or zero) elements by repeatedly reducing
- the top operator on the stack (or, if the top element on the stack is
- itself an operator, issuing an error message and discarding it). Calls
- finishing routine with the expression, returning the ffelexHandler it
- returns to the caller. */
-
-static ffelexHandler
-ffeexpr_finished_ (ffelexToken t)
-{
- ffeexprExpr_ operand; /* This is B in -B or A+B. */
- ffebld expr;
- ffeexprCallback callback;
- ffeexprStack_ s;
- ffebldConstant constnode; /* For detecting magical number. */
- ffelexToken ft; /* Temporary copy of first token in
- expression. */
- ffelexHandler next;
- ffeinfo info;
- bool error = FALSE;
-
- while (((operand = ffeexpr_stack_->exprstack) != NULL)
- && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
- {
- if (operand->type == FFEEXPR_exprtypeOPERAND_)
- ffeexpr_reduce_ ();
- else
- {
- if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
- {
- ffebad_here (0, ffelex_token_where_line (t),
- ffelex_token_where_column (t));
- ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
- ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
- ffebad_finish ();
- }
- ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
- operator. */
- ffeexpr_expr_kill_ (operand);
- }
- }
-
- assert ((operand == NULL) || (operand->previous == NULL));
-
- ffebld_pool_pop ();
- if (operand == NULL)
- expr = NULL;
- else
- {
- expr = operand->u.operand;
- info = ffebld_info (expr);
- if ((ffebld_op (expr) == FFEBLD_opCONTER)
- && (ffebld_conter_orig (expr) == NULL)
- && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
- {
- ffetarget_integer_bad_magical (operand->token);
- }
- ffeexpr_expr_kill_ (operand);
- ffeexpr_stack_->exprstack = NULL;
- }
-
- ft = ffeexpr_stack_->first_token;
-
-again: /* :::::::::::::::::::: */
- switch (ffeexpr_stack_->context)
- {
- case FFEEXPR_contextLET:
- case FFEEXPR_contextSFUNCDEF:
- error = (expr == NULL)
- || (ffeinfo_rank (info) != 0);
- break;
-
- case FFEEXPR_contextPAREN_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- break;
- }
- break;
-
- case FFEEXPR_contextPARENFILENUM_:
- if (ffelex_token_type (t) != FFELEX_typeCOMMA)
- ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextPARENFILEUNIT_:
- if (ffelex_token_type (t) != FFELEX_typeCOMMA)
- ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextACTUALARGEXPR_:
- case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- if (!ffe_is_ugly_args ()
- && ffebad_start (FFEBAD_ACTUALARG))
- {
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_finish ();
- }
- break;
-
- default:
- break;
- }
- error = (expr != NULL) && (ffeinfo_rank (info) != 0);
- break;
-
- case FFEEXPR_contextACTUALARG_:
- case FFEEXPR_contextSFUNCDEFACTUALARG_:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
-#if 0 /* Should never get here. */
- expr = ffeexpr_convert (expr, ft, ft,
- FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
-#else
- assert ("why hollerith/typeless in actualarg_?" == NULL);
-#endif
- break;
-
- default:
- break;
- }
- switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- case FFEBLD_opPERCENT_LOC:
- case FFEBLD_opPERCENT_VAL:
- case FFEBLD_opPERCENT_REF:
- case FFEBLD_opPERCENT_DESCR:
- error = FALSE;
- break;
-
- default:
- error = (expr != NULL) && (ffeinfo_rank (info) != 0);
- break;
- }
- {
- ffesymbol s;
- ffeinfoWhere where;
- ffeinfoKind kind;
-
- if (!error
- && (expr != NULL)
- && (ffebld_op (expr) == FFEBLD_opSYMTER)
- && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
- (where == FFEINFO_whereINTRINSIC)
- || (where == FFEINFO_whereGLOBAL)
- || ((where == FFEINFO_whereDUMMY)
- && ((kind = ffesymbol_kind (s)),
- (kind == FFEINFO_kindFUNCTION)
- || (kind == FFEINFO_kindSUBROUTINE))))
- && !ffesymbol_explicitwhere (s))
- {
- ffebad_start (where == FFEINFO_whereINTRINSIC
- ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- ffesymbol_signal_change (s);
- ffesymbol_set_explicitwhere (s, TRUE);
- ffesymbol_signal_unreported (s);
- }
- }
- break;
-
- case FFEEXPR_contextINDEX_:
- case FFEEXPR_contextSFUNCDEFINDEX_:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeINTEGER:
- /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
- unmolested. Leave it to downstream to handle kinds. */
- break;
-
- default:
- error = TRUE;
- break;
- }
- break; /* expr==NULL ok for substring; element case
- caught by callback. */
-
- case FFEEXPR_contextRETURN:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextDO:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- error = !ffe_is_ugly_logint ();
- if (!ffeexpr_stack_->is_rhs)
- break; /* Don't convert lhs variable. */
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- ffeinfo_kindtype (ffebld_info (expr)), 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- if (!ffeexpr_stack_->is_rhs)
- {
- error = TRUE;
- break; /* Don't convert lhs variable. */
- }
- break;
-
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- break;
-
- default:
- error = TRUE;
- break;
- }
- if (!ffeexpr_stack_->is_rhs
- && (ffebld_op (expr) != FFEBLD_opSYMTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextDOWHILE:
- case FFEEXPR_contextIF:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeLOGICAL:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextASSIGN:
- case FFEEXPR_contextAGOTO:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
- break;
-
- case FFEINFO_basictypeLOGICAL:
- error = !ffe_is_ugly_logint ()
- || (ffeinfo_kindtype (info) != ffecom_label_kind ());
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffebld_op (expr) != FFEBLD_opSYMTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextCGOTO:
- case FFEEXPR_contextFORMAT:
- case FFEEXPR_contextDIMLIST:
- case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextARITHIF:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeREAL:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextSTOP:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
- || (ffebld_conter_orig (expr) != NULL)))
- error = TRUE;
- break;
-
- case FFEEXPR_contextINCLUDE:
- error = (expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
- || (ffebld_op (expr) != FFEBLD_opCONTER)
- || (ffebld_conter_orig (expr) != NULL);
- break;
-
- case FFEEXPR_contextSELECTCASE:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeCHARACTER:
- case FFEINFO_basictypeLOGICAL:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextCASE:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeCHARACTER:
- case FFEINFO_basictypeLOGICAL:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextCHARACTERSIZE:
- case FFEEXPR_contextKINDTYPE:
- case FFEEXPR_contextDIMLISTCOMMON:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextEQVINDEX_:
- if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
- break;
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeNONE:
- error = FALSE;
- break;
-
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
- error = TRUE;
- break;
-
- case FFEEXPR_contextPARAMETER:
- if (ffeexpr_stack_->is_rhs)
- error = (expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffebld_op (expr) != FFEBLD_opCONTER);
- else
- error = (expr == NULL) || (ffeinfo_rank (info) != 0)
- || (ffebld_op (expr) != FFEBLD_opSYMTER);
- break;
-
- case FFEEXPR_contextINDEXORACTUALARG_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextINDEXORACTUALARGEXPR_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
- if (ffelex_token_type (t) == FFELEX_typeCOLON)
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
- else
- ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
- goto again; /* :::::::::::::::::::: */
-
- case FFEEXPR_contextIMPDOCTRL_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- if (!ffeexpr_stack_->is_rhs
- && (ffebld_op (expr) != FFEBLD_opSYMTER))
- error = TRUE;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- if (! ffe_is_ugly_logint ())
- error = TRUE;
- if (! ffeexpr_stack_->is_rhs)
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- ffeinfo_kindtype (info), 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- break;
-
- case FFEINFO_basictypeREAL:
- if (!ffeexpr_stack_->is_rhs
- && ffe_is_warn_surprising ()
- && !error)
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffelex_token_text (ft));
- ffebad_finish ();
- }
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextDATAIMPDOCTRL_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- if (ffeexpr_stack_->is_rhs)
- {
- if ((ffebld_op (expr) != FFEBLD_opCONTER)
- && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
- error = TRUE;
- }
- else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
- error = TRUE;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- if (! ffeexpr_stack_->is_rhs)
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- ffeinfo_kindtype (info), 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- if (ffeexpr_stack_->is_rhs
- && (ffeinfo_kindtype (ffebld_info (expr))
- != FFEINFO_kindtypeINTEGERDEFAULT))
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeREAL:
- if (!ffeexpr_stack_->is_rhs
- && ffe_is_warn_surprising ()
- && !error)
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (ft),
- ffelex_token_where_column (ft));
- ffebad_string (ffelex_token_text (ft));
- ffebad_finish ();
- }
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextIMPDOITEM_:
- if (ffelex_token_type (t) == FFELEX_typeEQUALS)
- {
- ffeexpr_stack_->is_rhs = FALSE;
- ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
- goto again; /* :::::::::::::::::::: */
- }
- /* Fall through. */
- case FFEEXPR_contextIOLIST:
- case FFEEXPR_contextFILEVXTCODE:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- break;
- }
- error = (expr == NULL)
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR))); /* Bad if null expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think) or has a NULL or
- STAR (assumed) array
- size. */
- break;
-
- case FFEEXPR_contextIMPDOITEMDF_:
- if (ffelex_token_type (t) == FFELEX_typeEQUALS)
- {
- ffeexpr_stack_->is_rhs = FALSE;
- ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
- goto again; /* :::::::::::::::::::: */
- }
- /* Fall through. */
- case FFEEXPR_contextIOLISTDF:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- break;
- }
- error
- = (expr == NULL)
- || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
- && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR))); /* Bad if null expr,
- non-default-kindtype
- character expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think) or has a NULL or
- STAR (assumed) array
- size. */
- break;
-
- case FFEEXPR_contextDATAIMPDOITEM_:
- error = (expr == NULL)
- || (ffebld_op (expr) != FFEBLD_opARRAYREF)
- || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
- && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
- break;
-
- case FFEEXPR_contextDATAIMPDOINDEX_:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- error = FALSE;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
- && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
- error = TRUE;
- break;
-
- case FFEEXPR_contextDATA:
- if (expr == NULL)
- error = TRUE;
- else if (ffeexpr_stack_->is_rhs)
- error = (ffebld_op (expr) != FFEBLD_opCONTER);
- else if (ffebld_op (expr) == FFEBLD_opSYMTER)
- error = FALSE;
- else
- error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
- break;
-
- case FFEEXPR_contextINITVAL:
- error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
- break;
-
- case FFEEXPR_contextEQUIVALENCE:
- if (expr == NULL)
- error = TRUE;
- else if (ffebld_op (expr) == FFEBLD_opSYMTER)
- error = FALSE;
- else
- error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
- break;
-
- case FFEEXPR_contextFILEASSOC:
- case FFEEXPR_contextFILEINT:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- /* Maybe this should be supported someday, but, right now,
- g77 can't generate a call to libf2c to write to an
- integer other than the default size. */
- error = ((! ffeexpr_stack_->is_rhs)
- && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILEDFINT:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILELOG:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILECHAR:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeCHARACTER:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if ((expr == NULL) || (ffeinfo_rank (info) != 0))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILENUMCHAR:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeCHARACTER:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextFILEDFCHAR:
- if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
- break;
- switch (ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeCHARACTER:
- error
- = (ffeinfo_kindtype (info)
- != FFEINFO_kindtypeCHARACTERDEFAULT);
- break;
-
- default:
- error = TRUE;
- break;
- }
- if (!ffeexpr_stack_->is_rhs
- && (ffebld_op (expr) == FFEBLD_opSUBSTR))
- error = TRUE;
- break;
-
- case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeLOGICAL:
- if ((error = (ffeinfo_rank (info) != 0)))
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- /* Fall through. */
- case FFEINFO_basictypeREAL:
- case FFEINFO_basictypeCOMPLEX:
- if ((error = (ffeinfo_rank (info) != 0)))
- break;
- if (ffe_is_pedantic ())
- {
- error = TRUE;
- break;
- }
- /* Fall through. */
- case FFEINFO_basictypeINTEGER:
- case FFEINFO_basictypeHOLLERITH:
- case FFEINFO_basictypeTYPELESS:
- if ((error = (ffeinfo_rank (info) != 0)))
- break;
- expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
- FFEEXPR_contextLET);
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (ffebld_op (expr))
- { /* As if _lhs had been called instead of
- _rhs. */
- case FFEBLD_opSYMTER:
- error
- = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
- break;
-
- case FFEBLD_opSUBSTR:
- error = (ffeinfo_where (ffebld_info (expr))
- == FFEINFO_whereCONSTANT_SUBOBJECT);
- break;
-
- case FFEBLD_opARRAYREF:
- error = FALSE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- if (!error
- && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
- || ((ffeinfo_rank (info) != 0)
- && ((ffebld_op (expr) != FFEBLD_opSYMTER)
- || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
- || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
- == FFEBLD_opSTAR))))) /* Bad if
- non-default-kindtype
- character expr, or if
- array that is not a SYMTER
- (can't happen yet, I
- think), or has a NULL or
- STAR (assumed) array
- size. */
- error = TRUE;
- break;
-
- default:
- error = TRUE;
- break;
- }
- break;
-
- case FFEEXPR_contextFILEFORMAT:
- switch ((expr == NULL) ? FFEINFO_basictypeNONE
- : ffeinfo_basictype (info))
- {
- case FFEINFO_basictypeINTEGER:
- error = (expr == NULL)
- || ((ffeinfo_rank (info) != 0) ?
- ffe_is_pedantic () /* F77 C5. */
- : (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 ()
-{
- assert (ffeexpr_stack_ == NULL);
- assert (ffeexpr_level_ == 0);
-}
projects / msp430-gcc.git / blobdiff