/* expr.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995-1998 Free Software Foundation, Inc.
   Contributed by James Craig Burley (burley@gnu.org).

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_ (char *p);
static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
static void ffeexpr_reduce_ (void);
static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
				      ffeexprExpr_ r);
static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
				      ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
					    ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
				      ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
				      ffeexprExpr_ r);
static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
				      ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
				      ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
				       ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
					 ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
				      ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
					 ffeexprExpr_ op, ffeexprExpr_ r);
static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
						ffelexHandler after);
static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
static ffelexHandler ffeexpr_finished_ (ffelexToken t);
static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
					       ffelexToken t);
static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
					      ffelexToken t);
static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
						 ffelexToken t);
static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
					       ffelexToken t);
static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
						 ffelexToken t);
static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
					       ffelexToken t);
static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
					      ffelexToken t);
static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
	    ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
		    ffelexToken exponent_sign, ffelexToken exponent_digits);
static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
						 bool maybe_intrin,
					     ffeexprParenType_ *paren_type);
static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);

/* Internal macros. */

#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)

/* ffeexpr_collapse_convert -- Collapse convert expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_convert(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffetargetCharacterSize sz;
  ffetargetCharacterSize sz2;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      sz = FFETARGET_charactersizeNONE;
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_integer1_integer2
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_integer1_integer3
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_integer1_integer4
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER1/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer1_real1
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer1_real2
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer1_real3
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer1_real4
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER1/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer1_complex1
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer1_complex2
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer1_complex3
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer1_complex4
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_integer1_logical1
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_integer1_logical2
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_integer1_logical3
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_integer1_logical4
		    (ffebld_cu_ptr_integer1 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_integer1_character1
		(ffebld_cu_ptr_integer1 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_integer1_hollerith
		(ffebld_cu_ptr_integer1 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_integer1_typeless
		(ffebld_cu_ptr_integer1 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("INTEGER1 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_integer1_val
	     (ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_integer2_integer1
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_integer2_integer3
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_integer2_integer4
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER2/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer2_real1
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer2_real2
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer2_real3
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer2_real4
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER2/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer2_complex1
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer2_complex2
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer2_complex3
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer2_complex4
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_integer2_logical1
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_integer2_logical2
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_integer2_logical3
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_integer2_logical4
		    (ffebld_cu_ptr_integer2 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_integer2_character1
		(ffebld_cu_ptr_integer2 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_integer2_hollerith
		(ffebld_cu_ptr_integer2 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_integer2_typeless
		(ffebld_cu_ptr_integer2 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("INTEGER2 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_integer2_val
	     (ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_integer3_integer1
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_integer3_integer2
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_integer3_integer4
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER3/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer3_real1
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer3_real2
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer3_real3
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer3_real4
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER3/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer3_complex1
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer3_complex2
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer3_complex3
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer3_complex4
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_integer3_logical1
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_integer3_logical2
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_integer3_logical3
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_integer3_logical4
		    (ffebld_cu_ptr_integer3 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_integer3_character1
		(ffebld_cu_ptr_integer3 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_integer3_hollerith
		(ffebld_cu_ptr_integer3 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_integer3_typeless
		(ffebld_cu_ptr_integer3 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("INTEGER3 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_integer3_val
	     (ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_integer4_integer1
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_integer4_integer2
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_integer4_integer3
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER4/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer4_real1
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer4_real2
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer4_real3
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer4_real4
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER4/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_integer4_complex1
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_integer4_complex2
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_integer4_complex3
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_integer4_complex4
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_integer4_logical1
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_integer4_logical2
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_integer4_logical3
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_integer4_logical4
		    (ffebld_cu_ptr_integer4 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_integer4_character1
		(ffebld_cu_ptr_integer4 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_integer4_hollerith
		(ffebld_cu_ptr_integer4 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_integer4_typeless
		(ffebld_cu_ptr_integer4 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("INTEGER4 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_integer4_val
	     (ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      sz = FFETARGET_charactersizeNONE;
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_logical1_logical2
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_logical1_logical3
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_logical1_logical4
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_logical1_integer1
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_logical1_integer2
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_logical1_integer3
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_logical1_integer4
		    (ffebld_cu_ptr_logical1 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_logical1_character1
		(ffebld_cu_ptr_logical1 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_logical1_hollerith
		(ffebld_cu_ptr_logical1 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_logical1_typeless
		(ffebld_cu_ptr_logical1 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("LOGICAL1 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logical1_val
	     (ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_logical2_logical1
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_logical2_logical3
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_logical2_logical4
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_logical2_integer1
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_logical2_integer2
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_logical2_integer3
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_logical2_integer4
		    (ffebld_cu_ptr_logical2 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_logical2_character1
		(ffebld_cu_ptr_logical2 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_logical2_hollerith
		(ffebld_cu_ptr_logical2 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_logical2_typeless
		(ffebld_cu_ptr_logical2 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("LOGICAL2 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logical2_val
	     (ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_logical3_logical1
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_logical3_logical2
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error = ffetarget_convert_logical3_logical4
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_logical4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_logical3_integer1
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_logical3_integer2
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_logical3_integer3
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_logical3_integer4
		    (ffebld_cu_ptr_logical3 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_logical3_character1
		(ffebld_cu_ptr_logical3 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_logical3_hollerith
		(ffebld_cu_ptr_logical3 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_logical3_typeless
		(ffebld_cu_ptr_logical3 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("LOGICAL3 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logical3_val
	     (ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error = ffetarget_convert_logical4_logical1
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_logical1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error = ffetarget_convert_logical4_logical2
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_logical2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error = ffetarget_convert_logical4_logical3
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_logical3 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_logical4_integer1
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_logical4_integer2
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_logical4_integer3
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_logical4_integer4
		    (ffebld_cu_ptr_logical4 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_logical4_character1
		(ffebld_cu_ptr_logical4 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_logical4_hollerith
		(ffebld_cu_ptr_logical4 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_logical4_typeless
		(ffebld_cu_ptr_logical4 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("LOGICAL4 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logical4_val
	     (ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      sz = FFETARGET_charactersizeNONE;
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_real1_integer1
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_real1_integer2
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_real1_integer3
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_real1_integer4
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL1/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real1_real2
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real1_real3
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real1_real4
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL1/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real1_complex1
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real1_complex2
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real1_complex3
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real1_complex4
		    (ffebld_cu_ptr_real1 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL1/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_real1_character1
		(ffebld_cu_ptr_real1 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_real1_hollerith
		(ffebld_cu_ptr_real1 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_real1_typeless
		(ffebld_cu_ptr_real1 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("REAL1 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_real1_val
	     (ffebld_cu_val_real1 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_real2_integer1
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_real2_integer2
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_real2_integer3
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_real2_integer4
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL2/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real2_real1
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real2_real3
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real2_real4
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL2/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real2_complex1
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real2_complex2
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real2_complex3
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real2_complex4
		    (ffebld_cu_ptr_real2 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL2/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_real2_character1
		(ffebld_cu_ptr_real2 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_real2_hollerith
		(ffebld_cu_ptr_real2 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_real2_typeless
		(ffebld_cu_ptr_real2 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("REAL2 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_real2_val
	     (ffebld_cu_val_real2 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_real3_integer1
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_real3_integer2
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_real3_integer3
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_real3_integer4
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL3/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real3_real1
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real3_real2
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real3_real4
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL3/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real3_complex1
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real3_complex2
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real3_complex3
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real3_complex4
		    (ffebld_cu_ptr_real3 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL3/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_real3_character1
		(ffebld_cu_ptr_real3 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_real3_hollerith
		(ffebld_cu_ptr_real3 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_real3_typeless
		(ffebld_cu_ptr_real3 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("REAL3 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_real3_val
	     (ffebld_cu_val_real3 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_real4_integer1
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_real4_integer2
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_real4_integer3
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_real4_integer4
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL4/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real4_real1
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real4_real2
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real4_real3
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL4/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_real4_complex1
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_real4_complex2
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_real4_complex3
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_real4_complex4
		    (ffebld_cu_ptr_real4 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("REAL4/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_real4_character1
		(ffebld_cu_ptr_real4 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_real4_hollerith
		(ffebld_cu_ptr_real4 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_real4_typeless
		(ffebld_cu_ptr_real4 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("REAL4 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_real4_val
	     (ffebld_cu_val_real4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      sz = FFETARGET_charactersizeNONE;
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_complex1_integer1
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_complex1_integer2
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_complex1_integer3
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_complex1_integer4
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex1_real1
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex1_real2
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex1_real3
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex1_real4
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX1/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex1_complex2
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex1_complex3
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex1_complex4
		    (ffebld_cu_ptr_complex1 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_complex1_character1
		(ffebld_cu_ptr_complex1 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_complex1_hollerith
		(ffebld_cu_ptr_complex1 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_complex1_typeless
		(ffebld_cu_ptr_complex1 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("COMPLEX1 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complex1_val
	     (ffebld_cu_val_complex1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_complex2_integer1
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_complex2_integer2
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_complex2_integer3
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_complex2_integer4
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex2_real1
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex2_real2
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex2_real3
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex2_real4
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX2/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex2_complex1
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex2_complex3
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex2_complex4
		    (ffebld_cu_ptr_complex2 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_complex2_character1
		(ffebld_cu_ptr_complex2 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_complex2_hollerith
		(ffebld_cu_ptr_complex2 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_complex2_typeless
		(ffebld_cu_ptr_complex2 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("COMPLEX2 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complex2_val
	     (ffebld_cu_val_complex2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_complex3_integer1
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_complex3_integer2
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_complex3_integer3
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_complex3_integer4
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex3_real1
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex3_real2
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex3_real3
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex3_real4
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX3/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex3_complex1
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex3_complex2
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex3_complex4
		    (ffebld_cu_ptr_complex3 (u),
		     ffebld_constant_complex4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_complex3_character1
		(ffebld_cu_ptr_complex3 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_complex3_hollerith
		(ffebld_cu_ptr_complex3 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_complex3_typeless
		(ffebld_cu_ptr_complex3 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("COMPLEX3 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complex3_val
	     (ffebld_cu_val_complex3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error = ffetarget_convert_complex4_integer1
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_integer1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error = ffetarget_convert_complex4_integer2
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_integer2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error = ffetarget_convert_complex4_integer3
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_integer3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error = ffetarget_convert_complex4_integer4
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_integer4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeREAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okREAL1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex4_real1
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_real1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex4_real2
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_real2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex4_real3
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_real3 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okREAL4
		case FFEINFO_kindtypeREAL4:
		  error = ffetarget_convert_complex4_real4
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_real4 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX4/REAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCOMPLEX:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okCOMPLEX1
		case FFEINFO_kindtypeREAL1:
		  error = ffetarget_convert_complex4_complex1
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_complex1 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX2
		case FFEINFO_kindtypeREAL2:
		  error = ffetarget_convert_complex4_complex2
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_complex2 (ffebld_conter (l)));
		  break;
#endif

#if FFETARGET_okCOMPLEX3
		case FFEINFO_kindtypeREAL3:
		  error = ffetarget_convert_complex4_complex3
		    (ffebld_cu_ptr_complex4 (u),
		     ffebld_constant_complex3 (ffebld_conter (l)));
		  break;
#endif

		default:
		  assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      error = ffetarget_convert_complex4_character1
		(ffebld_cu_ptr_complex4 (u),
		 ffebld_constant_character1 (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error = ffetarget_convert_complex4_hollerith
		(ffebld_cu_ptr_complex4 (u),
		 ffebld_constant_hollerith (ffebld_conter (l)));
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error = ffetarget_convert_complex4_typeless
		(ffebld_cu_ptr_complex4 (u),
		 ffebld_constant_typeless (ffebld_conter (l)));
	      break;

	    default:
	      assert ("COMPLEX4 bad type" == NULL);
	      break;
	    }

	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complex4_val
	     (ffebld_cu_val_complex4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
	return expr;
      kt = ffeinfo_kindtype (ffebld_info (expr));
      switch (kt)
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  switch (ffeinfo_basictype (ffebld_info (l)))
	    {
	    case FFEINFO_basictypeCHARACTER:
	      if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
		return expr;
	      assert (kt == ffeinfo_kindtype (ffebld_info (l)));
	      assert (sz2 == ffetarget_length_character1
		      (ffebld_constant_character1
		       (ffebld_conter (l))));
	      error
		= ffetarget_convert_character1_character1
		(ffebld_cu_ptr_character1 (u), sz,
		 ffebld_constant_character1 (ffebld_conter (l)),
		 ffebld_constant_pool ());
	      break;

	    case FFEINFO_basictypeINTEGER:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okINTEGER1
		case FFEINFO_kindtypeINTEGER1:
		  error
		    = ffetarget_convert_character1_integer1
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_integer1 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

#if FFETARGET_okINTEGER2
		case FFEINFO_kindtypeINTEGER2:
		  error
		    = ffetarget_convert_character1_integer2
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_integer2 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

#if FFETARGET_okINTEGER3
		case FFEINFO_kindtypeINTEGER3:
		  error
		    = ffetarget_convert_character1_integer3
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_integer3 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

#if FFETARGET_okINTEGER4
		case FFEINFO_kindtypeINTEGER4:
		  error
		    = ffetarget_convert_character1_integer4
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_integer4 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

		default:
		  assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeLOGICAL:
	      switch (ffeinfo_kindtype (ffebld_info (l)))
		{
#if FFETARGET_okLOGICAL1
		case FFEINFO_kindtypeLOGICAL1:
		  error
		    = ffetarget_convert_character1_logical1
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_logical1 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

#if FFETARGET_okLOGICAL2
		case FFEINFO_kindtypeLOGICAL2:
		  error
		    = ffetarget_convert_character1_logical2
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_logical2 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

#if FFETARGET_okLOGICAL3
		case FFEINFO_kindtypeLOGICAL3:
		  error
		    = ffetarget_convert_character1_logical3
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_logical3 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

#if FFETARGET_okLOGICAL4
		case FFEINFO_kindtypeLOGICAL4:
		  error
		    = ffetarget_convert_character1_logical4
		      (ffebld_cu_ptr_character1 (u),
		       sz,
		       ffebld_constant_logical4 (ffebld_conter (l)),
		       ffebld_constant_pool ());
		  break;
#endif

		default:
		  assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
		  break;
		}
	      break;

	    case FFEINFO_basictypeHOLLERITH:
	      error
		= ffetarget_convert_character1_hollerith
		(ffebld_cu_ptr_character1 (u),
		 sz,
		 ffebld_constant_hollerith (ffebld_conter (l)),
		 ffebld_constant_pool ());
	      break;

	    case FFEINFO_basictypeTYPELESS:
	      error
		= ffetarget_convert_character1_typeless
		(ffebld_cu_ptr_character1 (u),
		 sz,
		 ffebld_constant_typeless (ffebld_conter (l)),
		 ffebld_constant_pool ());
	      break;

	    default:
	      assert ("CHARACTER1 bad type" == NULL);
	    }

	  expr
	    = ffebld_new_conter_with_orig
	    (ffebld_constant_new_character1_val
	     (ffebld_cu_val_character1 (u)),
	     expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    sz));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      assert (t != NULL);
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_paren -- Collapse paren expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_paren(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
{
  ffebld r;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffetargetCharacterSize len;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  r = ffebld_left (expr);

  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  bt = ffeinfo_basictype (ffebld_info (r));
  kt = ffeinfo_kindtype (ffebld_info (r));
  len = ffebld_size (r);

  expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
				      expr);

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    len));

  return expr;
}

/* ffeexpr_collapse_uplus -- Collapse uplus expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_uplus(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
{
  ffebld r;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffetargetCharacterSize len;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  r = ffebld_left (expr);

  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  bt = ffeinfo_basictype (ffebld_info (r));
  kt = ffeinfo_kindtype (ffebld_info (r));
  len = ffebld_size (r);

  expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
				      expr);

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    len));

  return expr;
}

/* ffeexpr_collapse_uminus -- Collapse uminus expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_uminus(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  r = ffebld_left (expr);

  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
					   (ffebld_cu_val_real1 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
					   (ffebld_cu_val_real2 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
					   (ffebld_cu_val_real3 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
					   (ffebld_cu_val_real4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
					(ffebld_cu_val_complex1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
					(ffebld_cu_val_complex2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
					(ffebld_cu_val_complex3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
					(ffebld_cu_val_complex4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_not -- Collapse not expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_not(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_not (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  r = ffebld_left (expr);

  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
			      ffebld_constant_logical1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
					(ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
			      ffebld_constant_logical2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
					(ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
			      ffebld_constant_logical3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
					(ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
			      ffebld_constant_logical4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
					(ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_add -- Collapse add expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_add(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_add (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
					   (ffebld_cu_val_real1 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
					   (ffebld_cu_val_real2 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
					   (ffebld_cu_val_real3 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
					   (ffebld_cu_val_real4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
			       ffebld_constant_complex1 (ffebld_conter (l)),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
					(ffebld_cu_val_complex1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
			       ffebld_constant_complex2 (ffebld_conter (l)),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
					(ffebld_cu_val_complex2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
			       ffebld_constant_complex3 (ffebld_conter (l)),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
					(ffebld_cu_val_complex3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
			       ffebld_constant_complex4 (ffebld_conter (l)),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
					(ffebld_cu_val_complex4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_subtract -- Collapse subtract expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_subtract(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
					   (ffebld_cu_val_real1 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
					   (ffebld_cu_val_real2 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
					   (ffebld_cu_val_real3 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
					   (ffebld_cu_val_real4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
			       ffebld_constant_complex1 (ffebld_conter (l)),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
					(ffebld_cu_val_complex1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
			       ffebld_constant_complex2 (ffebld_conter (l)),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
					(ffebld_cu_val_complex2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
			       ffebld_constant_complex3 (ffebld_conter (l)),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
					(ffebld_cu_val_complex3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
			       ffebld_constant_complex4 (ffebld_conter (l)),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
					(ffebld_cu_val_complex4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_multiply -- Collapse multiply expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_multiply(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
					   (ffebld_cu_val_real1 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
					   (ffebld_cu_val_real2 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
					   (ffebld_cu_val_real3 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
					   (ffebld_cu_val_real4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
			       ffebld_constant_complex1 (ffebld_conter (l)),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
					(ffebld_cu_val_complex1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
			       ffebld_constant_complex2 (ffebld_conter (l)),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
					(ffebld_cu_val_complex2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
			       ffebld_constant_complex3 (ffebld_conter (l)),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
					(ffebld_cu_val_complex3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
			       ffebld_constant_complex4 (ffebld_conter (l)),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
					(ffebld_cu_val_complex4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_divide -- Collapse divide expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_divide(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
					   (ffebld_cu_val_real1 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
					   (ffebld_cu_val_real2 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
					   (ffebld_cu_val_real3 (u)), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
					   (ffebld_cu_val_real4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
			       ffebld_constant_complex1 (ffebld_conter (l)),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
					(ffebld_cu_val_complex1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
			       ffebld_constant_complex2 (ffebld_conter (l)),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
					(ffebld_cu_val_complex2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
			       ffebld_constant_complex3 (ffebld_conter (l)),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
					(ffebld_cu_val_complex3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
			       ffebld_constant_complex4 (ffebld_conter (l)),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
					(ffebld_cu_val_complex4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_power -- Collapse power expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_power(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_power (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
  || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
	case FFEINFO_kindtypeINTEGERDEFAULT:
	  error = ffetarget_power_integerdefault_integerdefault
	    (ffebld_cu_ptr_integerdefault (u),
	     ffebld_constant_integerdefault (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_integerdefault_val
	     (ffebld_cu_val_integerdefault (u)), expr);
	  break;

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
	case FFEINFO_kindtypeREALDEFAULT:
	  error = ffetarget_power_realdefault_integerdefault
	    (ffebld_cu_ptr_realdefault (u),
	     ffebld_constant_realdefault (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_realdefault_val
	     (ffebld_cu_val_realdefault (u)), expr);
	  break;

	case FFEINFO_kindtypeREALDOUBLE:
	  error = ffetarget_power_realdouble_integerdefault
	    (ffebld_cu_ptr_realdouble (u),
	     ffebld_constant_realdouble (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_realdouble_val
	     (ffebld_cu_val_realdouble (u)), expr);
	  break;

#if FFETARGET_okREALQUAD
	case FFEINFO_kindtypeREALQUAD:
	  error = ffetarget_power_realquad_integerdefault
	    (ffebld_cu_ptr_realquad (u),
	     ffebld_constant_realquad (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_realquad_val
	     (ffebld_cu_val_realquad (u)), expr);
	  break;
#endif
	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
	case FFEINFO_kindtypeREALDEFAULT:
	  error = ffetarget_power_complexdefault_integerdefault
	    (ffebld_cu_ptr_complexdefault (u),
	     ffebld_constant_complexdefault (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complexdefault_val
	     (ffebld_cu_val_complexdefault (u)), expr);
	  break;

#if FFETARGET_okCOMPLEXDOUBLE
	case FFEINFO_kindtypeREALDOUBLE:
	  error = ffetarget_power_complexdouble_integerdefault
	    (ffebld_cu_ptr_complexdouble (u),
	     ffebld_constant_complexdouble (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complexdouble_val
	     (ffebld_cu_val_complexdouble (u)), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEXQUAD
	case FFEINFO_kindtypeREALQUAD:
	  error = ffetarget_power_complexquad_integerdefault
	    (ffebld_cu_ptr_complexquad (u),
	     ffebld_constant_complexquad (ffebld_conter (l)),
	     ffebld_constant_integerdefault (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_complexquad_val
	     (ffebld_cu_val_complexquad (u)), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_concatenate -- Collapse concatenate expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_concatenate(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoKindtype kt;
  ffetargetCharacterSize len;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeCHARACTER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
			     ffebld_constant_character1 (ffebld_conter (l)),
			     ffebld_constant_character1 (ffebld_conter (r)),
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
				      (ffebld_cu_val_character1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
			     ffebld_constant_character2 (ffebld_conter (l)),
			     ffebld_constant_character2 (ffebld_conter (r)),
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
				      (ffebld_cu_val_character2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
			     ffebld_constant_character3 (ffebld_conter (l)),
			     ffebld_constant_character3 (ffebld_conter (r)),
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
				      (ffebld_cu_val_character3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
			     ffebld_constant_character4 (ffebld_conter (l)),
			     ffebld_constant_character4 (ffebld_conter (r)),
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
				      (ffebld_cu_val_character4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeCHARACTER,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    len));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_eq -- Collapse eq expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_eq(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  bool val;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_eq_integer1 (&val,
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_eq_integer2 (&val,
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_eq_integer3 (&val,
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_eq_integer4 (&val,
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_eq_real1 (&val,
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_eq_real2 (&val,
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_eq_real3 (&val,
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_eq_real4 (&val,
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_eq_complex1 (&val,
			       ffebld_constant_complex1 (ffebld_conter (l)),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_eq_complex2 (&val,
			       ffebld_constant_complex2 (ffebld_conter (l)),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_eq_complex3 (&val,
			       ffebld_constant_complex3 (ffebld_conter (l)),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_eq_complex4 (&val,
			       ffebld_constant_complex4 (ffebld_conter (l)),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_eq_character1 (&val,
			     ffebld_constant_character1 (ffebld_conter (l)),
			    ffebld_constant_character1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_eq_character2 (&val,
			     ffebld_constant_character2 (ffebld_conter (l)),
			    ffebld_constant_character2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_eq_character3 (&val,
			     ffebld_constant_character3 (ffebld_conter (l)),
			    ffebld_constant_character3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_eq_character4 (&val,
			     ffebld_constant_character4 (ffebld_conter (l)),
			    ffebld_constant_character4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeLOGICAL,
		    FFEINFO_kindtypeLOGICALDEFAULT,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_ne -- Collapse ne expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_ne(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  bool val;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_ne_integer1 (&val,
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_ne_integer2 (&val,
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_ne_integer3 (&val,
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_ne_integer4 (&val,
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_ne_real1 (&val,
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_ne_real2 (&val,
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_ne_real3 (&val,
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_ne_real4 (&val,
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCOMPLEX:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCOMPLEX1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_ne_complex1 (&val,
			       ffebld_constant_complex1 (ffebld_conter (l)),
			      ffebld_constant_complex1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_ne_complex2 (&val,
			       ffebld_constant_complex2 (ffebld_conter (l)),
			      ffebld_constant_complex2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_ne_complex3 (&val,
			       ffebld_constant_complex3 (ffebld_conter (l)),
			      ffebld_constant_complex3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCOMPLEX4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_ne_complex4 (&val,
			       ffebld_constant_complex4 (ffebld_conter (l)),
			      ffebld_constant_complex4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad complex kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_ne_character1 (&val,
			     ffebld_constant_character1 (ffebld_conter (l)),
			    ffebld_constant_character1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_ne_character2 (&val,
			     ffebld_constant_character2 (ffebld_conter (l)),
			    ffebld_constant_character2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_ne_character3 (&val,
			     ffebld_constant_character3 (ffebld_conter (l)),
			    ffebld_constant_character3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_ne_character4 (&val,
			     ffebld_constant_character4 (ffebld_conter (l)),
			    ffebld_constant_character4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeLOGICAL,
		    FFEINFO_kindtypeLOGICALDEFAULT,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_ge -- Collapse ge expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_ge(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  bool val;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_ge_integer1 (&val,
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_ge_integer2 (&val,
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_ge_integer3 (&val,
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_ge_integer4 (&val,
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_ge_real1 (&val,
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_ge_real2 (&val,
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_ge_real3 (&val,
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_ge_real4 (&val,
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_ge_character1 (&val,
			     ffebld_constant_character1 (ffebld_conter (l)),
			    ffebld_constant_character1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_ge_character2 (&val,
			     ffebld_constant_character2 (ffebld_conter (l)),
			    ffebld_constant_character2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_ge_character3 (&val,
			     ffebld_constant_character3 (ffebld_conter (l)),
			    ffebld_constant_character3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_ge_character4 (&val,
			     ffebld_constant_character4 (ffebld_conter (l)),
			    ffebld_constant_character4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeLOGICAL,
		    FFEINFO_kindtypeLOGICALDEFAULT,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_gt -- Collapse gt expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_gt(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  bool val;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_gt_integer1 (&val,
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_gt_integer2 (&val,
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_gt_integer3 (&val,
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_gt_integer4 (&val,
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_gt_real1 (&val,
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_gt_real2 (&val,
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_gt_real3 (&val,
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_gt_real4 (&val,
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_gt_character1 (&val,
			     ffebld_constant_character1 (ffebld_conter (l)),
			    ffebld_constant_character1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_gt_character2 (&val,
			     ffebld_constant_character2 (ffebld_conter (l)),
			    ffebld_constant_character2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_gt_character3 (&val,
			     ffebld_constant_character3 (ffebld_conter (l)),
			    ffebld_constant_character3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_gt_character4 (&val,
			     ffebld_constant_character4 (ffebld_conter (l)),
			    ffebld_constant_character4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeLOGICAL,
		    FFEINFO_kindtypeLOGICALDEFAULT,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_le -- Collapse le expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_le(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_le (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  bool val;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_le_integer1 (&val,
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_le_integer2 (&val,
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_le_integer3 (&val,
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_le_integer4 (&val,
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_le_real1 (&val,
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_le_real2 (&val,
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_le_real3 (&val,
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_le_real4 (&val,
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_le_character1 (&val,
			     ffebld_constant_character1 (ffebld_conter (l)),
			    ffebld_constant_character1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_le_character2 (&val,
			     ffebld_constant_character2 (ffebld_conter (l)),
			    ffebld_constant_character2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_le_character3 (&val,
			     ffebld_constant_character3 (ffebld_conter (l)),
			    ffebld_constant_character3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_le_character4 (&val,
			     ffebld_constant_character4 (ffebld_conter (l)),
			    ffebld_constant_character4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeLOGICAL,
		    FFEINFO_kindtypeLOGICALDEFAULT,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_lt -- Collapse lt expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_lt(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  bool val;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_lt_integer1 (&val,
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_lt_integer2 (&val,
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_lt_integer3 (&val,
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_lt_integer4 (&val,
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeREAL:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okREAL1
	case FFEINFO_kindtypeREAL1:
	  error = ffetarget_lt_real1 (&val,
				  ffebld_constant_real1 (ffebld_conter (l)),
				 ffebld_constant_real1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL2
	case FFEINFO_kindtypeREAL2:
	  error = ffetarget_lt_real2 (&val,
				  ffebld_constant_real2 (ffebld_conter (l)),
				 ffebld_constant_real2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL3
	case FFEINFO_kindtypeREAL3:
	  error = ffetarget_lt_real3 (&val,
				  ffebld_constant_real3 (ffebld_conter (l)),
				 ffebld_constant_real3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okREAL4
	case FFEINFO_kindtypeREAL4:
	  error = ffetarget_lt_real4 (&val,
				  ffebld_constant_real4 (ffebld_conter (l)),
				 ffebld_constant_real4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad real kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeCHARACTER:
      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_lt_character1 (&val,
			     ffebld_constant_character1 (ffebld_conter (l)),
			    ffebld_constant_character1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_lt_character2 (&val,
			     ffebld_constant_character2 (ffebld_conter (l)),
			    ffebld_constant_character2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_lt_character3 (&val,
			     ffebld_constant_character3 (ffebld_conter (l)),
			    ffebld_constant_character3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_lt_character4 (&val,
			     ffebld_constant_character4 (ffebld_conter (l)),
			    ffebld_constant_character4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig
	    (ffebld_constant_new_logicaldefault (val), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeLOGICAL,
		    FFEINFO_kindtypeLOGICALDEFAULT,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_and -- Collapse and expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_and(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_and (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
			       ffebld_constant_logical1 (ffebld_conter (l)),
			      ffebld_constant_logical1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
					(ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
			       ffebld_constant_logical2 (ffebld_conter (l)),
			      ffebld_constant_logical2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
					(ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
			       ffebld_constant_logical3 (ffebld_conter (l)),
			      ffebld_constant_logical3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
					(ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
			       ffebld_constant_logical4 (ffebld_conter (l)),
			      ffebld_constant_logical4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
					(ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_or -- Collapse or expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_or(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_or (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
			       ffebld_constant_logical1 (ffebld_conter (l)),
			      ffebld_constant_logical1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
					(ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
			       ffebld_constant_logical2 (ffebld_conter (l)),
			      ffebld_constant_logical2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
					(ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
			       ffebld_constant_logical3 (ffebld_conter (l)),
			      ffebld_constant_logical3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
					(ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
			       ffebld_constant_logical4 (ffebld_conter (l)),
			      ffebld_constant_logical4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
					(ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_xor -- Collapse xor expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_xor(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
			       ffebld_constant_logical1 (ffebld_conter (l)),
			      ffebld_constant_logical1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
					(ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
			       ffebld_constant_logical2 (ffebld_conter (l)),
			      ffebld_constant_logical2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
					(ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
			       ffebld_constant_logical3 (ffebld_conter (l)),
			      ffebld_constant_logical3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
					(ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
			       ffebld_constant_logical4 (ffebld_conter (l)),
			      ffebld_constant_logical4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
					(ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_eqv -- Collapse eqv expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_eqv(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
			       ffebld_constant_logical1 (ffebld_conter (l)),
			      ffebld_constant_logical1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
					(ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
			       ffebld_constant_logical2 (ffebld_conter (l)),
			      ffebld_constant_logical2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
					(ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
			       ffebld_constant_logical3 (ffebld_conter (l)),
			      ffebld_constant_logical3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
					(ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
			       ffebld_constant_logical4 (ffebld_conter (l)),
			      ffebld_constant_logical4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
					(ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_neqv -- Collapse neqv expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_neqv(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebldConstantUnion u;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;
  if (ffebld_op (r) != FFEBLD_opCONTER)
    return expr;

  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeINTEGER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okINTEGER1
	case FFEINFO_kindtypeINTEGER1:
	  error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
			       ffebld_constant_integer1 (ffebld_conter (l)),
			      ffebld_constant_integer1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
					(ffebld_cu_val_integer1 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER2
	case FFEINFO_kindtypeINTEGER2:
	  error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
			       ffebld_constant_integer2 (ffebld_conter (l)),
			      ffebld_constant_integer2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
					(ffebld_cu_val_integer2 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER3
	case FFEINFO_kindtypeINTEGER3:
	  error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
			       ffebld_constant_integer3 (ffebld_conter (l)),
			      ffebld_constant_integer3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
					(ffebld_cu_val_integer3 (u)), expr);
	  break;
#endif

#if FFETARGET_okINTEGER4
	case FFEINFO_kindtypeINTEGER4:
	  error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
			       ffebld_constant_integer4 (ffebld_conter (l)),
			      ffebld_constant_integer4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
					(ffebld_cu_val_integer4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad integer kind type" == NULL);
	  break;
	}
      break;

    case FFEINFO_basictypeLOGICAL:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okLOGICAL1
	case FFEINFO_kindtypeLOGICAL1:
	  error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
			       ffebld_constant_logical1 (ffebld_conter (l)),
			      ffebld_constant_logical1 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
					(ffebld_cu_val_logical1 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL2
	case FFEINFO_kindtypeLOGICAL2:
	  error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
			       ffebld_constant_logical2 (ffebld_conter (l)),
			      ffebld_constant_logical2 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
					(ffebld_cu_val_logical2 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL3
	case FFEINFO_kindtypeLOGICAL3:
	  error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
			       ffebld_constant_logical3 (ffebld_conter (l)),
			      ffebld_constant_logical3 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
					(ffebld_cu_val_logical3 (u)), expr);
	  break;
#endif

#if FFETARGET_okLOGICAL4
	case FFEINFO_kindtypeLOGICAL4:
	  error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
			       ffebld_constant_logical4 (ffebld_conter (l)),
			      ffebld_constant_logical4 (ffebld_conter (r)));
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
					(ffebld_cu_val_logical4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad logical kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    FFETARGET_charactersizeNONE));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_collapse_symter -- Collapse symter expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_symter(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
{
  ffebld r;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffetargetCharacterSize len;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
    return expr;		/* A PARAMETER lhs in progress. */

  switch (ffebld_op (r))
    {
    case FFEBLD_opCONTER:
      break;

    case FFEBLD_opANY:
      return r;

    default:
      return expr;
    }

  bt = ffeinfo_basictype (ffebld_info (r));
  kt = ffeinfo_kindtype (ffebld_info (r));
  len = ffebld_size (r);

  expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
				      expr);

  ffebld_set_info (expr, ffeinfo_new
		   (bt,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    len));

  return expr;
}

/* ffeexpr_collapse_funcref -- Collapse funcref expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_funcref(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
{
  return expr;			/* ~~someday go ahead and collapse these,
				   though not required */
}

/* ffeexpr_collapse_arrayref -- Collapse arrayref expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_arrayref(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
{
  return expr;
}

/* ffeexpr_collapse_substr -- Collapse substr expr

   ffebld expr;
   ffelexToken token;
   expr = ffeexpr_collapse_substr(expr,token);

   If the result of the expr is a constant, replaces the expr with the
   computed constant.  */

ffebld
ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
{
  ffebad error = FFEBAD;
  ffebld l;
  ffebld r;
  ffebld start;
  ffebld stop;
  ffebldConstantUnion u;
  ffeinfoKindtype kt;
  ffetargetCharacterSize len;
  ffetargetIntegerDefault first;
  ffetargetIntegerDefault last;

  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
    return expr;

  l = ffebld_left (expr);
  r = ffebld_right (expr);	/* opITEM. */

  if (ffebld_op (l) != FFEBLD_opCONTER)
    return expr;

  kt = ffeinfo_kindtype (ffebld_info (l));
  len = ffebld_size (l);

  start = ffebld_head (r);
  stop = ffebld_head (ffebld_trail (r));
  if (start == NULL)
    first = 1;
  else
    {
      if ((ffebld_op (start) != FFEBLD_opCONTER)
	  || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
	  || (ffeinfo_kindtype (ffebld_info (start))
	      != FFEINFO_kindtypeINTEGERDEFAULT))
	return expr;
      first = ffebld_constant_integerdefault (ffebld_conter (start));
    }
  if (stop == NULL)
    last = len;
  else
    {
      if ((ffebld_op (stop) != FFEBLD_opCONTER)
      || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
	  || (ffeinfo_kindtype (ffebld_info (stop))
	      != FFEINFO_kindtypeINTEGERDEFAULT))
	return expr;
      last = ffebld_constant_integerdefault (ffebld_conter (stop));
    }

  /* Handle problems that should have already been diagnosed, but
     left in the expression tree.  */

  if (first <= 0)
    first = 1;
  if (last < first)
    last = first + len - 1;

  if ((first == 1) && (last == len))
    {				/* Same as original. */
      expr = ffebld_new_conter_with_orig (ffebld_constant_copy
					  (ffebld_conter (l)), expr);
      ffebld_set_info (expr, ffeinfo_new
		       (FFEINFO_basictypeCHARACTER,
			kt,
			0,
			FFEINFO_kindENTITY,
			FFEINFO_whereCONSTANT,
			len));

      return expr;
    }

  switch (ffeinfo_basictype (ffebld_info (expr)))
    {
    case FFEINFO_basictypeANY:
      return expr;

    case FFEINFO_basictypeCHARACTER:
      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
	{
#if FFETARGET_okCHARACTER1
	case FFEINFO_kindtypeCHARACTER1:
	  error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
		ffebld_constant_character1 (ffebld_conter (l)), first, last,
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
				      (ffebld_cu_val_character1 (u)), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER2
	case FFEINFO_kindtypeCHARACTER2:
	  error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
		ffebld_constant_character2 (ffebld_conter (l)), first, last,
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
				      (ffebld_cu_val_character2 (u)), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER3
	case FFEINFO_kindtypeCHARACTER3:
	  error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
		ffebld_constant_character3 (ffebld_conter (l)), first, last,
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
				      (ffebld_cu_val_character3 (u)), expr);
	  break;
#endif

#if FFETARGET_okCHARACTER4
	case FFEINFO_kindtypeCHARACTER4:
	  error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
		ffebld_constant_character4 (ffebld_conter (l)), first, last,
				   ffebld_constant_pool (), &len);
	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
				      (ffebld_cu_val_character4 (u)), expr);
	  break;
#endif

	default:
	  assert ("bad character kind type" == NULL);
	  break;
	}
      break;

    default:
      assert ("bad type" == NULL);
      return expr;
    }

  ffebld_set_info (expr, ffeinfo_new
		   (FFEINFO_basictypeCHARACTER,
		    kt,
		    0,
		    FFEINFO_kindENTITY,
		    FFEINFO_whereCONSTANT,
		    len));

  if ((error != FFEBAD)
      && ffebad_start (error))
    {
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  return expr;
}

/* ffeexpr_convert -- Convert source expression to given type

   ffebld source;
   ffelexToken source_token;
   ffelexToken dest_token;  // Any appropriate token for "destination".
   ffeinfoBasictype bt;
   ffeinfoKindtype kt;
   ffetargetCharactersize sz;
   ffeexprContext context;  // Mainly LET or DATA.
   source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);

   If the expression conforms, returns the source expression.  Otherwise
   returns source wrapped in a convert node doing the conversion, or
   ANY wrapped in convert if there is a conversion error (and issues an
   error message).  Be sensitive to the context for certain aspects of
   the conversion.  */

ffebld
ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
		 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
		 ffetargetCharacterSize sz, ffeexprContext context)
{
  bool bad;
  ffeinfo info;
  ffeinfoWhere wh;

  info = ffebld_info (source);
  if ((bt != ffeinfo_basictype (info))
      || (kt != ffeinfo_kindtype (info))
      || (rk != 0)		/* Can't convert from or to arrays yet. */
      || (ffeinfo_rank (info) != 0)
      || (sz != ffebld_size_known (source)))
#if 0	/* Nobody seems to need this spurious CONVERT node. */
      || ((context != FFEEXPR_contextLET)
	  && (bt == FFEINFO_basictypeCHARACTER)
	  && (sz == FFETARGET_charactersizeNONE)))
#endif
    {
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  switch (bt)
	    {
	    case FFEINFO_basictypeLOGICAL:
	      bad = FALSE;
	      break;

	    case FFEINFO_basictypeINTEGER:
	      bad = !ffe_is_ugly_logint ();
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      bad = ffe_is_pedantic ()
		|| !(ffe_is_ugly_init ()
		     && (context == FFEEXPR_contextDATA));
	      break;

	    default:
	      bad = TRUE;
	      break;
	    }
	  break;

	case FFEINFO_basictypeINTEGER:
	  switch (bt)
	    {
	    case FFEINFO_basictypeINTEGER:
	    case FFEINFO_basictypeREAL:
	    case FFEINFO_basictypeCOMPLEX:
	      bad = FALSE;
	      break;

	    case FFEINFO_basictypeLOGICAL:
	      bad = !ffe_is_ugly_logint ();
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      bad = ffe_is_pedantic ()
		|| !(ffe_is_ugly_init ()
		     && (context == FFEEXPR_contextDATA));
	      break;

	    default:
	      bad = TRUE;
	      break;
	    }
	  break;

	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  switch (bt)
	    {
	    case FFEINFO_basictypeINTEGER:
	    case FFEINFO_basictypeREAL:
	    case FFEINFO_basictypeCOMPLEX:
	      bad = FALSE;
	      break;

	    case FFEINFO_basictypeCHARACTER:
	      bad = TRUE;
	      break;

	    default:
	      bad = TRUE;
	      break;
	    }
	  break;

	case FFEINFO_basictypeCHARACTER:
	  bad = (bt != FFEINFO_basictypeCHARACTER)
	    && (ffe_is_pedantic ()
		|| (bt != FFEINFO_basictypeINTEGER)
		|| !(ffe_is_ugly_init ()
		     && (context == FFEEXPR_contextDATA)));
	  break;

	case FFEINFO_basictypeTYPELESS:
	case FFEINFO_basictypeHOLLERITH:
	  bad = ffe_is_pedantic ()
	    || !(ffe_is_ugly_init ()
		 && ((context == FFEEXPR_contextDATA)
		     || (context == FFEEXPR_contextLET)));
	  break;

	default:
	  bad = TRUE;
	  break;
	}

      if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
	bad = TRUE;

      if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
	  && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
	  && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
	  && (ffeinfo_where (info) != FFEINFO_whereANY))
	{
	  if (ffebad_start (FFEBAD_BAD_TYPES))
	    {
	      if (dest_token == NULL)
		ffebad_here (0, ffewhere_line_unknown (),
			     ffewhere_column_unknown ());
	      else
		ffebad_here (0, ffelex_token_where_line (dest_token),
			     ffelex_token_where_column (dest_token));
	      assert (source_token != NULL);
	      ffebad_here (1, ffelex_token_where_line (source_token),
			   ffelex_token_where_column (source_token));
	      ffebad_finish ();
	    }

	  source = ffebld_new_any ();
	  ffebld_set_info (source, ffeinfo_new_any ());
	}
      else
	{
	  switch (ffeinfo_where (info))
	    {
	    case FFEINFO_whereCONSTANT:
	      wh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      wh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      wh = FFEINFO_whereFLEETING;
	      break;
	    }
	  source = ffebld_new_convert (source);
	  ffebld_set_info (source, ffeinfo_new
			   (bt,
			    kt,
			    0,
			    FFEINFO_kindENTITY,
			    wh,
			    sz));
	  source = ffeexpr_collapse_convert (source, source_token);
	}
    }

  return source;
}

/* ffeexpr_convert_expr -- Convert source expr to conform to dest expr

   ffebld source;
   ffebld dest;
   ffelexToken source_token;
   ffelexToken dest_token;
   ffeexprContext context;
   source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);

   If the expressions conform, returns the source expression.  Otherwise
   returns source wrapped in a convert node doing the conversion, or
   ANY wrapped in convert if there is a conversion error (and issues an
   error message).  Be sensitive to the context, such as LET or DATA.  */

ffebld
ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
		      ffelexToken dest_token, ffeexprContext context)
{
  ffeinfo info;

  info = ffebld_info (dest);
  return ffeexpr_convert (source, source_token, dest_token,
			  ffeinfo_basictype (info),
			  ffeinfo_kindtype (info),
			  ffeinfo_rank (info),
			  ffebld_size_known (dest),
			  context);
}

/* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol

   ffebld source;
   ffesymbol dest;
   ffelexToken source_token;
   ffelexToken dest_token;
   source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);

   If the expressions conform, returns the source expression.  Otherwise
   returns source wrapped in a convert node doing the conversion, or
   ANY wrapped in convert if there is a conversion error (and issues an
   error message).  */

ffebld
ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
			ffesymbol dest, ffelexToken dest_token)
{
  return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
    ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
			  FFEEXPR_contextLET);
}

/* Initializes the module.  */

void
ffeexpr_init_2 ()
{
  ffeexpr_stack_ = NULL;
  ffeexpr_level_ = 0;
}

/* ffeexpr_lhs -- Begin processing left-hand-side-context expression

   Prepares cluster for delivery of lexer tokens representing an expression
   in a left-hand-side context (A in A=B, for example).	 ffebld is used
   to build expressions in the given pool.  The appropriate lexer-token
   handling routine within ffeexpr is returned.	 When the end of the
   expression is detected, mycallbackroutine is called with the resulting
   single ffebld object specifying the entire expression and the first
   lexer token that is not considered part of the expression.  This caller-
   supplied routine itself returns a lexer-token handling routine.  Thus,
   if necessary, ffeexpr can return several tokens as end-of-expression
   tokens if it needs to scan forward more than one in any instance.  */

ffelexHandler
ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
{
  ffeexprStack_ s;

  ffebld_pool_push (pool);
  s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
  s->previous = ffeexpr_stack_;
  s->pool = pool;
  s->context = context;
  s->callback = callback;
  s->first_token = NULL;
  s->exprstack = NULL;
  s->is_rhs = FALSE;
  ffeexpr_stack_ = s;
  return (ffelexHandler) ffeexpr_token_first_lhs_;
}

/* ffeexpr_rhs -- Begin processing right-hand-side-context expression

   return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.

   Prepares cluster for delivery of lexer tokens representing an expression
   in a right-hand-side context (B in A=B, for example).  ffebld is used
   to build expressions in the given pool.  The appropriate lexer-token
   handling routine within ffeexpr is returned.	 When the end of the
   expression is detected, mycallbackroutine is called with the resulting
   single ffebld object specifying the entire expression and the first
   lexer token that is not considered part of the expression.  This caller-
   supplied routine itself returns a lexer-token handling routine.  Thus,
   if necessary, ffeexpr can return several tokens as end-of-expression
   tokens if it needs to scan forward more than one in any instance.  */

ffelexHandler
ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
{
  ffeexprStack_ s;

  ffebld_pool_push (pool);
  s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
  s->previous = ffeexpr_stack_;
  s->pool = pool;
  s->context = context;
  s->callback = callback;
  s->first_token = NULL;
  s->exprstack = NULL;
  s->is_rhs = TRUE;
  ffeexpr_stack_ = s;
  return (ffelexHandler) ffeexpr_token_first_rhs_;
}

/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr

   Pass it to ffeexpr_rhs as the callback routine.

   Makes sure the end token is close-paren and swallows it, else issues
   an error message and doesn't swallow the token (passing it along instead).
   In either case wraps up subexpression construction by enclosing the
   ffebld expression in a paren.  */

static ffelexHandler
ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeexprExpr_ e;

  if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
    {
      /* Oops, naughty user didn't specify the close paren! */

      if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
	{
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		       ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	  ffebad_finish ();
	}

      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeOPERAND_;
      e->u.operand = ffebld_new_any ();
      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
      ffeexpr_exprstack_push_operand_ (e);

      return
	(ffelexHandler) ffeexpr_find_close_paren_ (t,
						   (ffelexHandler)
						   ffeexpr_token_binary_);
    }

  if (expr->op == FFEBLD_opIMPDO)
    {
      if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		       ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	  ffebad_finish ();
	}
    }
  else
    {
      expr = ffebld_new_paren (expr);
      ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
    }

  /* Now push the (parenthesized) expression as an operand onto the
     expression stack. */

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->u.operand = expr;
  e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
  e->token = ffeexpr_stack_->tokens[0];
  ffeexpr_exprstack_push_operand_ (e);

  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr

   Pass it to ffeexpr_rhs as the callback routine.

   We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
   with the next token in t.  If the next token is possibly a binary
   operator, continue processing the outer expression.	If the next
   token is COMMA, then the expression is a unit specifier, and
   parentheses should not be added to it because it surrounds the
   I/O control list that starts with the unit specifier (and continues
   on from here -- we haven't seen the CLOSE_PAREN that matches the
   OPEN_PAREN, it is up to the callback function to expect to see it
   at some point).  In this case, we notify the callback function that
   the COMMA is inside, not outside, the parens by wrapping the expression
   in an opITEM (with a NULL trail) -- the callback function presumably
   unwraps it after seeing this kludgey indicator.

   If the next token is CLOSE_PAREN, then we go to the _1_ state to
   decide what to do with the token after that.

   15-Feb-91  JCB  1.1
      Use an extra state for the CLOSE_PAREN case to make READ &co really
      work right.  */

static ffelexHandler
ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeexprCallback callback;
  ffeexprStack_ s;

  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
    {				/* Need to see the next token before we
				   decide anything. */
      ffeexpr_stack_->expr = expr;
      ffeexpr_tokens_[0] = ffelex_token_use (ft);
      ffeexpr_tokens_[1] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
    }

  expr = ffeexpr_finished_ambig_ (ft, expr);

  /* Let the callback function handle the case where t isn't COMMA. */

  /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
     that preceded the expression starts a list of expressions, and the expr
     hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
     node.  The callback function should extract the real expr from the head
     of this opITEM node after testing it. */

  expr = ffebld_new_item (expr, NULL);

  ffebld_pool_pop ();
  callback = ffeexpr_stack_->callback;
  ffelex_token_kill (ffeexpr_stack_->first_token);
  s = ffeexpr_stack_->previous;
  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  ffeexpr_stack_ = s;
  return (ffelexHandler) (*callback) (ft, expr, t);
}

/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN

   See ffeexpr_cb_close_paren_ambig_.

   We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
   with the next token in t.  If the next token is possibly a binary
   operator, continue processing the outer expression.	If the next
   token is COMMA, the expression is a parenthesized format specifier.
   If the next token is not EOS or SEMICOLON, then because it is not a
   binary operator (it is NAME, OPEN_PAREN, &c), the expression is
   a unit specifier, and parentheses should not be added to it because
   they surround the I/O control list that consists of only the unit
   specifier.  If the next token is EOS or SEMICOLON, the statement
   must be disambiguated by looking at the type of the expression -- a
   character expression is a parenthesized format specifier, while a
   non-character expression is a unit specifier.

   Another issue is how to do the callback so the recipient of the
   next token knows how to handle it if it is a COMMA.	In all other
   cases, disambiguation is straightforward: the same approach as the
   above is used.

   EXTENSION: in COMMA case, if not pedantic, use same disambiguation
   as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
   and apparently other compilers do, as well, and some code out there
   uses this "feature".

   19-Feb-91  JCB  1.1
      Extend to allow COMMA as nondisambiguating by itself.  Remember
      to not try and check info field for opSTAR, since that expr doesn't
      have a valid info field.	*/

static ffelexHandler
ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
{
  ffeexprCallback callback;
  ffeexprStack_ s;
  ffelexHandler next;
  ffelexToken orig_ft = ffeexpr_tokens_[0];	/* In case callback clobbers
						   these. */
  ffelexToken orig_t = ffeexpr_tokens_[1];
  ffebld expr = ffeexpr_stack_->expr;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeCOMMA:	/* Subexpr is parenthesized format specifier. */
      if (ffe_is_pedantic ())
	goto pedantic_comma;	/* :::::::::::::::::::: */
      /* Fall through. */
    case FFELEX_typeEOS:	/* Ambiguous; use type of expr to
				   disambiguate. */
    case FFELEX_typeSEMICOLON:
      if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
	  || (ffebld_op (expr) == FFEBLD_opSTAR)
	  || (ffeinfo_basictype (ffebld_info (expr))
	      != FFEINFO_basictypeCHARACTER))
	break;			/* Not a valid CHARACTER entity, can't be a
				   format spec. */
      /* Fall through. */
    default:			/* Binary op (we assume; error otherwise);
				   format specifier. */

    pedantic_comma:		/* :::::::::::::::::::: */

      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFILENUMAMBIG:
	  ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
	  break;

	case FFEEXPR_contextFILEUNITAMBIG:
	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
	  break;

	default:
	  assert ("bad context" == NULL);
	  break;
	}

      ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
      next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
      ffelex_token_kill (orig_ft);
      ffelex_token_kill (orig_t);
      return (ffelexHandler) (*next) (t);

    case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
    case FFELEX_typeNAME:
      break;
    }

  expr = ffeexpr_finished_ambig_ (orig_ft, expr);

  /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
     that preceded the expression starts a list of expressions, and the expr
     hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
     node.  The callback function should extract the real expr from the head
     of this opITEM node after testing it. */

  expr = ffebld_new_item (expr, NULL);

  ffebld_pool_pop ();
  callback = ffeexpr_stack_->callback;
  ffelex_token_kill (ffeexpr_stack_->first_token);
  s = ffeexpr_stack_->previous;
  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  ffeexpr_stack_ = s;
  next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
  ffelex_token_kill (orig_ft);
  ffelex_token_kill (orig_t);
  return (ffelexHandler) (*next) (t);
}

/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)

   Pass it to ffeexpr_rhs as the callback routine.

   Makes sure the end token is close-paren and swallows it, or a comma
   and handles complex/implied-do possibilities, else issues
   an error message and doesn't swallow the token (passing it along instead).  */

static ffelexHandler
ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  /* First check to see if this is a possible complex entity.  It is if the
     token is a comma. */

  if (ffelex_token_type (t) == FFELEX_typeCOMMA)
    {
      ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
      ffeexpr_stack_->expr = expr;
      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
				FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
    }

  return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
}

/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr

   Pass it to ffeexpr_rhs as the callback routine.

   If this token is not a comma, we have a complex constant (or an attempt
   at one), so handle it accordingly, displaying error messages if the token
   is not a close-paren.  */

static ffelexHandler
ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeexprExpr_ e;
  ffeinfoBasictype lty = (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)
{
  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_ (char *p)
{
  for (; *p != '\0'; ++p)
    if (! ISDIGIT (*p))
      return FALSE;
  return TRUE;
}

/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack

   ffeexprExpr_ e;
   ffeexpr_exprstack_push_(e);

   Pushes the expression onto the stack without any analysis of the existing
   contents of the stack.  */

static void
ffeexpr_exprstack_push_ (ffeexprExpr_ e)
{
  e->previous = ffeexpr_stack_->exprstack;
  ffeexpr_stack_->exprstack = e;
}

/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?

   ffeexprExpr_ e;
   ffeexpr_exprstack_push_operand_(e);

   Pushes the expression already containing an operand (a constant, variable,
   or more complicated expression that has already been fully resolved) after
   analyzing the stack and checking for possible reduction (which will never
   happen here since the highest precedence operator is ** and it has right-
   to-left associativity).  */

static void
ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
{
  ffeexpr_exprstack_push_ (e);
#ifdef WEIRD_NONFORTRAN_RULES
  if ((ffeexpr_stack_->exprstack != NULL)
      && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
      && (ffeexpr_stack_->exprstack->expr->u.operator.prec
	  == FFEEXPR_operatorprecedenceHIGHEST_)
      && (ffeexpr_stack_->exprstack->expr->u.operator.as
	  == FFEEXPR_operatorassociativityL2R_))
    ffeexpr_reduce_ ();
#endif
}

/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack

   ffeexprExpr_ e;
   ffeexpr_exprstack_push_unary_(e);

   Pushes the expression already containing a unary operator.  Reduction can
   never happen since unary operators are themselves always R-L; that is, the
   top of the expression stack is not an operand, in that it is either empty,
   has a binary operator at the top, or a unary operator at the top.  In any
   of these cases, reduction is impossible.  */

static void
ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
{
  if ((ffe_is_pedantic ()
       || ffe_is_warn_surprising ())
      && (ffeexpr_stack_->exprstack != NULL)
      && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
      && (ffeexpr_stack_->exprstack->u.operator.prec
	  <= FFEEXPR_operatorprecedenceLOWARITH_)
      && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
    {
      ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
			ffe_is_pedantic ()
			? FFEBAD_severityPEDANTIC
			: FFEBAD_severityWARNING);
      ffebad_here (0,
		  ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
	       ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
      ffebad_here (1,
		   ffelex_token_where_line (e->token),
		   ffelex_token_where_column (e->token));
      ffebad_finish ();
    }

  ffeexpr_exprstack_push_ (e);
}

/* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?

   ffeexprExpr_ e;
   ffeexpr_exprstack_push_binary_(e);

   Pushes the expression already containing a binary operator after checking
   whether reduction is possible.  If the stack is not empty, the top of the
   stack must be an operand or syntactic analysis has failed somehow.  If
   the operand is preceded by a unary operator of higher (or equal and L-R
   associativity) precedence than the new binary operator, then reduce that
   preceding operator and its operand(s) before pushing the new binary
   operator.  */

static void
ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
{
  ffeexprExpr_ ce;

  if (ffe_is_warn_surprising ()
      /* These next two are always true (see assertions below).  */
      && (ffeexpr_stack_->exprstack != NULL)
      && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
      /* If the previous operator is a unary minus, and the binary op
	 is of higher precedence, might not do what user expects,
	 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
	 yield "4".  */
      && (ffeexpr_stack_->exprstack->previous != NULL)
      && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
      && (ffeexpr_stack_->exprstack->previous->u.operator.op
	  == FFEEXPR_operatorSUBTRACT_)
      && (e->u.operator.prec
	  < ffeexpr_stack_->exprstack->previous->u.operator.prec))
    {
      ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
      ffebad_here (0,
	 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
      ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
      ffebad_here (1,
		   ffelex_token_where_line (e->token),
		   ffelex_token_where_column (e->token));
      ffebad_finish ();
    }

again:
  assert (ffeexpr_stack_->exprstack != NULL);
  assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
  if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
    {
      assert (ce->type != FFEEXPR_exprtypeOPERAND_);
      if ((ce->u.operator.prec < e->u.operator.prec)
	  || ((ce->u.operator.prec == e->u.operator.prec)
	      && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
	{
	  ffeexpr_reduce_ ();
	  goto again;	/* :::::::::::::::::::: */
	}
    }

  ffeexpr_exprstack_push_ (e);
}

/* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack

   ffeexpr_reduce_();

   Converts operand binop operand or unop operand at top of stack to a
   single operand having the appropriate ffebld expression, and makes
   sure that the expression is proper (like not trying to add two character
   variables, not trying to concatenate two numbers).  Also does the
   requisite type-assignment.  */

static void
ffeexpr_reduce_ ()
{
  ffeexprExpr_ operand;		/* This is B in -B or A+B. */
  ffeexprExpr_ left_operand;	/* When operator is binary, this is A in A+B. */
  ffeexprExpr_ operator;	/* This is + in A+B. */
  ffebld reduced;		/* This is +(A,B) in A+B or u-(B) in -B. */
  ffebldConstant constnode;	/* For checking magical numbers (where mag ==
				   -mag). */
  ffebld expr;
  ffebld left_expr;
  bool submag = FALSE;

  operand = ffeexpr_stack_->exprstack;
  assert (operand != NULL);
  assert (operand->type == FFEEXPR_exprtypeOPERAND_);
  operator = operand->previous;
  assert (operator != NULL);
  assert (operator->type != FFEEXPR_exprtypeOPERAND_);
  if (operator->type == FFEEXPR_exprtypeUNARY_)
    {
      expr = operand->u.operand;
      switch (operator->u.operator.op)
	{
	case FFEEXPR_operatorADD_:
	  reduced = ffebld_new_uplus (expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
	  reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
	  reduced = ffeexpr_collapse_uplus (reduced, operator->token);
	  break;

	case FFEEXPR_operatorSUBTRACT_:
	  submag = TRUE;	/* Ok to negate a magic number. */
	  reduced = ffebld_new_uminus (expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
	  reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
	  reduced = ffeexpr_collapse_uminus (reduced, operator->token);
	  break;

	case FFEEXPR_operatorNOT_:
	  reduced = ffebld_new_not (expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
	  reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
	  reduced = ffeexpr_collapse_not (reduced, operator->token);
	  break;

	default:
	  assert ("unexpected unary op" != NULL);
	  reduced = NULL;
	  break;
	}
      if (!submag
	  && (ffebld_op (expr) == FFEBLD_opCONTER)
	  && (ffebld_conter_orig (expr) == NULL)
	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
	{
	  ffetarget_integer_bad_magical (operand->token);
	}
      ffeexpr_stack_->exprstack = operator->previous;	/* Pops unary-op operand
							   off stack. */
      ffeexpr_expr_kill_ (operand);
      operator->type = FFEEXPR_exprtypeOPERAND_;	/* Convert operator, but
							   save */
      operator->u.operand = reduced;	/* the line/column ffewhere info. */
      ffeexpr_exprstack_push_operand_ (operator);	/* Push it back on
							   stack. */
    }
  else
    {
      assert (operator->type == FFEEXPR_exprtypeBINARY_);
      left_operand = operator->previous;
      assert (left_operand != NULL);
      assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
      expr = operand->u.operand;
      left_expr = left_operand->u.operand;
      switch (operator->u.operator.op)
	{
	case FFEEXPR_operatorADD_:
	  reduced = ffebld_new_add (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_add (reduced, operator->token);
	  break;

	case FFEEXPR_operatorSUBTRACT_:
	  submag = TRUE;	/* Just to pick the right error if magic
				   number. */
	  reduced = ffebld_new_subtract (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_subtract (reduced, operator->token);
	  break;

	case FFEEXPR_operatorMULTIPLY_:
	  reduced = ffebld_new_multiply (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_multiply (reduced, operator->token);
	  break;

	case FFEEXPR_operatorDIVIDE_:
	  reduced = ffebld_new_divide (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_divide (reduced, operator->token);
	  break;

	case FFEEXPR_operatorPOWER_:
	  reduced = ffebld_new_power (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_power (reduced, operator->token);
	  break;

	case FFEEXPR_operatorCONCATENATE_:
	  reduced = ffebld_new_concatenate (left_expr, expr);
	  reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
						  operand);
	  reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
	  break;

	case FFEEXPR_operatorLT_:
	  reduced = ffebld_new_lt (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
					     operand);
	  reduced = ffeexpr_collapse_lt (reduced, operator->token);
	  break;

	case FFEEXPR_operatorLE_:
	  reduced = ffebld_new_le (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
					     operand);
	  reduced = ffeexpr_collapse_le (reduced, operator->token);
	  break;

	case FFEEXPR_operatorEQ_:
	  reduced = ffebld_new_eq (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_eq (reduced, operator->token);
	  break;

	case FFEEXPR_operatorNE_:
	  reduced = ffebld_new_ne (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_ne (reduced, operator->token);
	  break;

	case FFEEXPR_operatorGT_:
	  reduced = ffebld_new_gt (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
					     operand);
	  reduced = ffeexpr_collapse_gt (reduced, operator->token);
	  break;

	case FFEEXPR_operatorGE_:
	  reduced = ffebld_new_ge (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
					      operand);
	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
					     operand);
	  reduced = ffeexpr_collapse_ge (reduced, operator->token);
	  break;

	case FFEEXPR_operatorAND_:
	  reduced = ffebld_new_and (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
						 operand);
	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_and (reduced, operator->token);
	  break;

	case FFEEXPR_operatorOR_:
	  reduced = ffebld_new_or (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
						 operand);
	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_or (reduced, operator->token);
	  break;

	case FFEEXPR_operatorXOR_:
	  reduced = ffebld_new_xor (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
						 operand);
	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_xor (reduced, operator->token);
	  break;

	case FFEEXPR_operatorEQV_:
	  reduced = ffebld_new_eqv (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
						 operand);
	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_eqv (reduced, operator->token);
	  break;

	case FFEEXPR_operatorNEQV_:
	  reduced = ffebld_new_neqv (left_expr, expr);
	  if (ffe_is_ugly_logint ())
	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
						 operand);
	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
					    operand);
	  reduced = ffeexpr_collapse_neqv (reduced, operator->token);
	  break;

	default:
	  assert ("bad bin op" == NULL);
	  reduced = expr;
	  break;
	}
      if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
	  && (ffebld_conter_orig (expr) == NULL)
      && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
	{
	  if ((left_operand->previous != NULL)
	      && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
	      && (left_operand->previous->u.operator.op
		  == FFEEXPR_operatorSUBTRACT_))
	    {
	      if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
		ffetarget_integer_bad_magical_precedence (left_operand->token,
							  left_operand->previous->token,
							  operator->token);
	      else
		ffetarget_integer_bad_magical_precedence_binary
		  (left_operand->token,
		   left_operand->previous->token,
		   operator->token);
	    }
	  else
	    ffetarget_integer_bad_magical (left_operand->token);
	}
      if ((ffebld_op (expr) == FFEBLD_opCONTER)
	  && (ffebld_conter_orig (expr) == NULL)
	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
	{
	  if (submag)
	    ffetarget_integer_bad_magical_binary (operand->token,
						  operator->token);
	  else
	    ffetarget_integer_bad_magical (operand->token);
	}
      ffeexpr_stack_->exprstack = left_operand->previous;	/* Pops binary-op
								   operands off stack. */
      ffeexpr_expr_kill_ (left_operand);
      ffeexpr_expr_kill_ (operand);
      operator->type = FFEEXPR_exprtypeOPERAND_;	/* Convert operator, but
							   save */
      operator->u.operand = reduced;	/* the line/column ffewhere info. */
      ffeexpr_exprstack_push_operand_ (operator);	/* Push it back on
							   stack. */
    }
}

/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator

   reduced = ffeexpr_reduced_bool1_(reduced,op,r);

   Makes sure the argument for reduced has basictype of
   LOGICAL or (ugly) INTEGER.  If
   argument has where of CONSTANT, assign where CONSTANT to
   reduced, else assign where FLEETING.

   If these requirements cannot be met, generate error message.	 */

static ffebld
ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
  ffeinfo rinfo, ninfo;
  ffeinfoBasictype rbt;
  ffeinfoKindtype rkt;
  ffeinfoRank rrk;
  ffeinfoKind rkd;
  ffeinfoWhere rwh, nwh;

  rinfo = ffebld_info (ffebld_left (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if (((rbt == FFEINFO_basictypeLOGICAL)
       || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
      && (rrk == 0))
    {
      switch (rwh)
	{
	case FFEINFO_whereCONSTANT:
	  nwh = FFEINFO_whereCONSTANT;
	  break;

	case FFEINFO_whereIMMEDIATE:
	  nwh = FFEINFO_whereIMMEDIATE;
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
			   FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      return reduced;
    }

  if ((rbt != FFEINFO_basictypeLOGICAL)
      && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_NOT_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_NOT_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators

   reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);

   Makes sure the left and right arguments for reduced have basictype of
   LOGICAL or (ugly) INTEGER.  Determine common basictype and
   size for reduction (flag expression for combined hollerith/typeless
   situations for later determination of effective basictype).	If both left
   and right arguments have where of CONSTANT, assign where CONSTANT to
   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
   needed.  Convert typeless
   constants to the desired type/size explicitly.

   If these requirements cannot be met, generate error message.	 */

static ffebld
ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo, ninfo;
  ffeinfoBasictype lbt, rbt, nbt;
  ffeinfoKindtype lkt, rkt, nkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh, nwh;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);

  if (((nbt == FFEINFO_basictypeLOGICAL)
       || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
      && (lrk == 0) && (rrk == 0))
    {
      switch (lwh)
	{
	case FFEINFO_whereCONSTANT:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	      nwh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	case FFEINFO_whereIMMEDIATE:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
			   FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
						  FFEEXPR_contextLET));
      return reduced;
    }

  if ((lbt != FFEINFO_basictypeLOGICAL)
      && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
    {
      if ((rbt != FFEINFO_basictypeLOGICAL)
	  && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
	{
	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	      ffebad_finish ();
	    }
	}
      else
	{
	  if ((lbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_finish ();
	    }
	}
    }
  else if ((rbt != FFEINFO_basictypeLOGICAL)
	   && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if (lrk != 0)
    {
      if ((lkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_BOOL_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_BOOL_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator

   reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);

   Makes sure the left and right arguments for reduced have basictype of
   CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
   basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
   size of concatenation and assign that size to reduced.  If both left and
   right arguments have where of CONSTANT, assign where CONSTANT to reduced,
   else assign where FLEETING.

   If these requirements cannot be met, generate error message using the
   info in l, op, and r arguments and assign basictype, size, kind, and where
   of ANY.  */

static ffebld
ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			      ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo, ninfo;
  ffeinfoBasictype lbt, rbt, nbt;
  ffeinfoKindtype lkt, rkt, nkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd, nkd;
  ffeinfoWhere lwh, rwh, nwh;
  ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);
  lszk = ffeinfo_size (linfo);	/* Known size. */
  lszm = ffebld_size_max (ffebld_left (reduced));

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);
  rszk = ffeinfo_size (rinfo);	/* Known size. */
  rszm = ffebld_size_max (ffebld_right (reduced));

  if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
      && (lkt == rkt) && (lrk == 0) && (rrk == 0)
      && (((lszm != FFETARGET_charactersizeNONE)
	   && (rszm != FFETARGET_charactersizeNONE))
	  || (ffeexpr_context_outer_ (ffeexpr_stack_)
	      == FFEEXPR_contextLET)
	  || (ffeexpr_context_outer_ (ffeexpr_stack_)
	      == FFEEXPR_contextSFUNCDEF)))
    {
      nbt = FFEINFO_basictypeCHARACTER;
      nkd = FFEINFO_kindENTITY;
      if ((lszk == FFETARGET_charactersizeNONE)
	  || (rszk == FFETARGET_charactersizeNONE))
	nszk = FFETARGET_charactersizeNONE;	/* Ok only in rhs of LET
						   stmt. */
      else
	nszk = lszk + rszk;

      switch (lwh)
	{
	case FFEINFO_whereCONSTANT:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	      nwh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	case FFEINFO_whereIMMEDIATE:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      nkt = lkt;
      ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
      ffebld_set_info (reduced, ninfo);
      return reduced;
    }

  if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
    {
      if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if (lbt != FFEINFO_basictypeCHARACTER)
    {
      if ((lbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_finish ();
	}
    }
  else if (rbt != FFEINFO_basictypeCHARACTER)
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
    {
      if ((lkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
	{
	  char *what;

	  if (lrk != 0)
	    what = "an array";
	  else
	    what = "of indeterminate length";
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_string (what);
	  ffebad_finish ();
	}
    }
  else
    {
      if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
	{
	  char *what;

	  if (rrk != 0)
	    what = "an array";
	  else
	    what = "of indeterminate length";
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string (what);
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators

   reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);

   Makes sure the left and right arguments for reduced have basictype of
   INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
   size for reduction.	If both left
   and right arguments have where of CONSTANT, assign where CONSTANT to
   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
   needed.  Convert typeless
   constants to the desired type/size explicitly.

   If these requirements cannot be met, generate error message.	 */

static ffebld
ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo, ninfo;
  ffeinfoBasictype lbt, rbt, nbt;
  ffeinfoKindtype lkt, rkt, nkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh, nwh;
  ffetargetCharacterSize lsz, rsz;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);
  lsz = ffebld_size_known (ffebld_left (reduced));

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);
  rsz = ffebld_size_known (ffebld_right (reduced));

  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);

  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
       || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
      && (lrk == 0) && (rrk == 0))
    {
      switch (lwh)
	{
	case FFEINFO_whereCONSTANT:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	      nwh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	case FFEINFO_whereIMMEDIATE:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      if ((lsz != FFETARGET_charactersizeNONE)
	  && (rsz != FFETARGET_charactersizeNONE))
	lsz = rsz = (lsz > rsz) ? lsz : rsz;

      ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
		   0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
				      l->token, op->token, nbt, nkt, 0, lsz,
						 FFEEXPR_contextLET));
      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
				      r->token, op->token, nbt, nkt, 0, rsz,
						  FFEEXPR_contextLET));
      return reduced;
    }

  if ((lbt == FFEINFO_basictypeLOGICAL)
      && (rbt == FFEINFO_basictypeLOGICAL))
    {
      if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
			    FFEBAD_severityFATAL))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
      && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
    {
      if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
	  && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
	{
	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	      ffebad_finish ();
	    }
	}
      else
	{
	  if ((lbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_finish ();
	    }
	}
    }
  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
	   && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if (lrk != 0)
    {
      if ((lkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_EQOP_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_EQOP_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators

   reduced = ffeexpr_reduced_math1_(reduced,op,r);

   Makes sure the argument for reduced has basictype of
   INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
   assign where CONSTANT to
   reduced, else assign where FLEETING.

   If these requirements cannot be met, generate error message.	 */

static ffebld
ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
  ffeinfo rinfo, ninfo;
  ffeinfoBasictype rbt;
  ffeinfoKindtype rkt;
  ffeinfoRank rrk;
  ffeinfoKind rkd;
  ffeinfoWhere rwh, nwh;

  rinfo = ffebld_info (ffebld_left (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
       || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
    {
      switch (rwh)
	{
	case FFEINFO_whereCONSTANT:
	  nwh = FFEINFO_whereCONSTANT;
	  break;

	case FFEINFO_whereIMMEDIATE:
	  nwh = FFEINFO_whereIMMEDIATE;
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
			   FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      return reduced;
    }

  if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
      && (rbt != FFEINFO_basictypeCOMPLEX))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators

   reduced = ffeexpr_reduced_math2_(reduced,l,op,r);

   Makes sure the left and right arguments for reduced have basictype of
   INTEGER, REAL, or COMPLEX.  Determine common basictype and
   size for reduction (flag expression for combined hollerith/typeless
   situations for later determination of effective basictype).	If both left
   and right arguments have where of CONSTANT, assign where CONSTANT to
   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
   needed.  Convert typeless
   constants to the desired type/size explicitly.

   If these requirements cannot be met, generate error message.	 */

static ffebld
ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo, ninfo;
  ffeinfoBasictype lbt, rbt, nbt;
  ffeinfoKindtype lkt, rkt, nkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh, nwh;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);

  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
       || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
    {
      switch (lwh)
	{
	case FFEINFO_whereCONSTANT:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	      nwh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	case FFEINFO_whereIMMEDIATE:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
			   FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
						  FFEEXPR_contextLET));
      return reduced;
    }

  if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
      && (lbt != FFEINFO_basictypeCOMPLEX))
    {
      if ((rbt != FFEINFO_basictypeINTEGER)
      && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
	{
	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	      ffebad_finish ();
	    }
	}
      else
	{
	  if ((lbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_MATH_ARG_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_finish ();
	    }
	}
    }
  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
	   && (rbt != FFEINFO_basictypeCOMPLEX))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if (lrk != 0)
    {
      if ((lkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator

   reduced = ffeexpr_reduced_power_(reduced,l,op,r);

   Makes sure the left and right arguments for reduced have basictype of
   INTEGER, REAL, or COMPLEX.  Determine common basictype and
   size for reduction (flag expression for combined hollerith/typeless
   situations for later determination of effective basictype).	If both left
   and right arguments have where of CONSTANT, assign where CONSTANT to
   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
   needed.  Note that real**int or complex**int
   comes out as int = real**int etc with no conversions.

   If these requirements cannot be met, generate error message using the
   info in l, op, and r arguments and assign basictype, size, kind, and where
   of ANY.  */

static ffebld
ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo, ninfo;
  ffeinfoBasictype lbt, rbt, nbt;
  ffeinfoKindtype lkt, rkt, nkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh, nwh;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if ((rbt == FFEINFO_basictypeINTEGER)
      && ((lbt == FFEINFO_basictypeREAL)
	  || (lbt == FFEINFO_basictypeCOMPLEX)))
    {
      nbt = lbt;
      nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
      if (nkt != FFEINFO_kindtypeREALDEFAULT)
	{
	  nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
	  if (nkt != FFEINFO_kindtypeREALDOUBLE)
	    nkt = FFEINFO_kindtypeREALDOUBLE;	/* Highest kt we can power! */
	}
      if (rkt == FFEINFO_kindtypeINTEGER4)
	{
	  ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
			    FFEBAD_severityWARNING);
	  ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
      if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
	{
	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
						      r->token, op->token,
		FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
						FFETARGET_charactersizeNONE,
						      FFEEXPR_contextLET));
	  rkt = FFEINFO_kindtypeINTEGERDEFAULT;
	}
    }
  else
    {
      ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);

#if 0	/* INTEGER4**INTEGER4 works now. */
      if ((nbt == FFEINFO_basictypeINTEGER)
	  && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
	nkt = FFEINFO_kindtypeINTEGERDEFAULT;	/* Highest kt we can power! */
#endif
      if (((nbt == FFEINFO_basictypeREAL)
	   || (nbt == FFEINFO_basictypeCOMPLEX))
	  && (nkt != FFEINFO_kindtypeREALDEFAULT))
	{
	  nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
	  if (nkt != FFEINFO_kindtypeREALDOUBLE)
	    nkt = FFEINFO_kindtypeREALDOUBLE;	/* Highest kt we can power! */
	}
      /* else Gonna turn into an error below. */
    }

  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
       || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
    {
      switch (lwh)
	{
	case FFEINFO_whereCONSTANT:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	      nwh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	case FFEINFO_whereIMMEDIATE:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
			   FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
      if (rbt != FFEINFO_basictypeINTEGER)
	ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
						    FFEEXPR_contextLET));
      return reduced;
    }

  if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
      && (lbt != FFEINFO_basictypeCOMPLEX))
    {
      if ((rbt != FFEINFO_basictypeINTEGER)
      && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
	{
	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	      ffebad_finish ();
	    }
	}
      else
	{
	  if ((lbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_MATH_ARG_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_finish ();
	    }
	}
    }
  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
	   && (rbt != FFEINFO_basictypeCOMPLEX))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if (lrk != 0)
    {
      if ((lkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators

   reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);

   Makes sure the left and right arguments for reduced have basictype of
   INTEGER, REAL, or CHARACTER.	 Determine common basictype and
   size for reduction.	If both left
   and right arguments have where of CONSTANT, assign where CONSTANT to
   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
   needed.  Convert typeless
   constants to the desired type/size explicitly.

   If these requirements cannot be met, generate error message.	 */

static ffebld
ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			 ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo, ninfo;
  ffeinfoBasictype lbt, rbt, nbt;
  ffeinfoKindtype lkt, rkt, nkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh, nwh;
  ffetargetCharacterSize lsz, rsz;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);
  lsz = ffebld_size_known (ffebld_left (reduced));

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);
  rsz = ffebld_size_known (ffebld_right (reduced));

  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);

  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
       || (nbt == FFEINFO_basictypeCHARACTER))
      && (lrk == 0) && (rrk == 0))
    {
      switch (lwh)
	{
	case FFEINFO_whereCONSTANT:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	      nwh = FFEINFO_whereCONSTANT;
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	case FFEINFO_whereIMMEDIATE:
	  switch (rwh)
	    {
	    case FFEINFO_whereCONSTANT:
	    case FFEINFO_whereIMMEDIATE:
	      nwh = FFEINFO_whereIMMEDIATE;
	      break;

	    default:
	      nwh = FFEINFO_whereFLEETING;
	      break;
	    }
	  break;

	default:
	  nwh = FFEINFO_whereFLEETING;
	  break;
	}

      if ((lsz != FFETARGET_charactersizeNONE)
	  && (rsz != FFETARGET_charactersizeNONE))
	lsz = rsz = (lsz > rsz) ? lsz : rsz;

      ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
		   0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
      ffebld_set_info (reduced, ninfo);
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
				      l->token, op->token, nbt, nkt, 0, lsz,
						 FFEEXPR_contextLET));
      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
				      r->token, op->token, nbt, nkt, 0, rsz,
						  FFEEXPR_contextLET));
      return reduced;
    }

  if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
      && (lbt != FFEINFO_basictypeCHARACTER))
    {
      if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
	  && (rbt != FFEINFO_basictypeCHARACTER))
	{
	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	      ffebad_finish ();
	    }
	}
      else
	{
	  if ((lbt != FFEINFO_basictypeANY)
	      && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
	    {
	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	      ffebad_finish ();
	    }
	}
    }
  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
	   && (rbt != FFEINFO_basictypeCHARACTER))
    {
      if ((rbt != FFEINFO_basictypeANY)
	  && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_finish ();
	}
    }
  else if (lrk != 0)
    {
      if ((lkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_RELOP_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }
  else
    {
      if ((rkd != FFEINFO_kindANY)
	  && ffebad_start (FFEBAD_RELOP_ARG_KIND))
	{
	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
	  ffebad_string ("an array");
	  ffebad_finish ();
	}
    }

  reduced = ffebld_new_any ();
  ffebld_set_info (reduced, ffeinfo_new_any ());
  return reduced;
}

/* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL

   reduced = ffeexpr_reduced_ugly1_(reduced,op,r);

   Sigh.  */

static ffebld
ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
  ffeinfo rinfo;
  ffeinfoBasictype rbt;
  ffeinfoKindtype rkt;
  ffeinfoRank rrk;
  ffeinfoKind rkd;
  ffeinfoWhere rwh;

  rinfo = ffebld_info (ffebld_left (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if ((rbt == FFEINFO_basictypeTYPELESS)
      || (rbt == FFEINFO_basictypeHOLLERITH))
    {
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
			      r->token, op->token, FFEINFO_basictypeINTEGER,
					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
						 FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
      rinfo = ffebld_info (ffebld_left (reduced));
      rbt = FFEINFO_basictypeINTEGER;
      rkt = FFEINFO_kindtypeINTEGERDEFAULT;
      rrk = 0;
      rkd = FFEINFO_kindENTITY;
      rwh = ffeinfo_where (rinfo);
    }

  if (rbt == FFEINFO_basictypeLOGICAL)
    {
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
			      r->token, op->token, FFEINFO_basictypeINTEGER,
					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
						 FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
    }

  return reduced;
}

/* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH

   reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);

   Sigh.  */

static ffebld
ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
{
  ffeinfo rinfo;
  ffeinfoBasictype rbt;
  ffeinfoKindtype rkt;
  ffeinfoRank rrk;
  ffeinfoKind rkd;
  ffeinfoWhere rwh;

  rinfo = ffebld_info (ffebld_left (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if ((rbt == FFEINFO_basictypeTYPELESS)
      || (rbt == FFEINFO_basictypeHOLLERITH))
    {
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
			   r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
					     FFEINFO_kindtypeLOGICALDEFAULT,
						 FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
      rinfo = ffebld_info (ffebld_left (reduced));
      rbt = FFEINFO_basictypeLOGICAL;
      rkt = FFEINFO_kindtypeLOGICALDEFAULT;
      rrk = 0;
      rkd = FFEINFO_kindENTITY;
      rwh = ffeinfo_where (rinfo);
    }

  return reduced;
}

/* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL

   reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);

   Sigh.  */

static ffebld
ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo;
  ffeinfoBasictype lbt, rbt;
  ffeinfoKindtype lkt, rkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if ((lbt == FFEINFO_basictypeTYPELESS)
      || (lbt == FFEINFO_basictypeHOLLERITH))
    {
      if ((rbt == FFEINFO_basictypeTYPELESS)
	  || (rbt == FFEINFO_basictypeHOLLERITH))
	{
	  ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
			      l->token, op->token, FFEINFO_basictypeINTEGER,
					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
						FFETARGET_charactersizeNONE,
						     FFEEXPR_contextLET));
	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
			   r->token, op->token, FFEINFO_basictypeINTEGER, 0,
					     FFEINFO_kindtypeINTEGERDEFAULT,
						FFETARGET_charactersizeNONE,
						      FFEEXPR_contextLET));
	  linfo = ffebld_info (ffebld_left (reduced));
	  rinfo = ffebld_info (ffebld_right (reduced));
	  lbt = rbt = FFEINFO_basictypeINTEGER;
	  lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
	  lrk = rrk = 0;
	  lkd = rkd = FFEINFO_kindENTITY;
	  lwh = ffeinfo_where (linfo);
	  rwh = ffeinfo_where (rinfo);
	}
      else
	{
	  ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
				 l->token, ffebld_right (reduced), r->token,
						       FFEEXPR_contextLET));
	  linfo = ffebld_info (ffebld_left (reduced));
	  lbt = ffeinfo_basictype (linfo);
	  lkt = ffeinfo_kindtype (linfo);
	  lrk = ffeinfo_rank (linfo);
	  lkd = ffeinfo_kind (linfo);
	  lwh = ffeinfo_where (linfo);
	}
    }
  else
    {
      if ((rbt == FFEINFO_basictypeTYPELESS)
	  || (rbt == FFEINFO_basictypeHOLLERITH))
	{
	  ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
				  r->token, ffebld_left (reduced), l->token,
						       FFEEXPR_contextLET));
	  rinfo = ffebld_info (ffebld_right (reduced));
	  rbt = ffeinfo_basictype (rinfo);
	  rkt = ffeinfo_kindtype (rinfo);
	  rrk = ffeinfo_rank (rinfo);
	  rkd = ffeinfo_kind (rinfo);
	  rwh = ffeinfo_where (rinfo);
	}
      /* else Leave it alone. */
    }

  if (lbt == FFEINFO_basictypeLOGICAL)
    {
      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
			      l->token, op->token, FFEINFO_basictypeINTEGER,
					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
						 FFETARGET_charactersizeNONE,
						 FFEEXPR_contextLET));
    }

  if (rbt == FFEINFO_basictypeLOGICAL)
    {
      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
			      r->token, op->token, FFEINFO_basictypeINTEGER,
					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
						FFETARGET_charactersizeNONE,
						  FFEEXPR_contextLET));
    }

  return reduced;
}

/* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH

   reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);

   Sigh.  */

static ffebld
ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
			   ffeexprExpr_ r)
{
  ffeinfo linfo, rinfo;
  ffeinfoBasictype lbt, rbt;
  ffeinfoKindtype lkt, rkt;
  ffeinfoRank lrk, rrk;
  ffeinfoKind lkd, rkd;
  ffeinfoWhere lwh, rwh;

  linfo = ffebld_info (ffebld_left (reduced));
  lbt = ffeinfo_basictype (linfo);
  lkt = ffeinfo_kindtype (linfo);
  lrk = ffeinfo_rank (linfo);
  lkd = ffeinfo_kind (linfo);
  lwh = ffeinfo_where (linfo);

  rinfo = ffebld_info (ffebld_right (reduced));
  rbt = ffeinfo_basictype (rinfo);
  rkt = ffeinfo_kindtype (rinfo);
  rrk = ffeinfo_rank (rinfo);
  rkd = ffeinfo_kind (rinfo);
  rwh = ffeinfo_where (rinfo);

  if ((lbt == FFEINFO_basictypeTYPELESS)
      || (lbt == FFEINFO_basictypeHOLLERITH))
    {
      if ((rbt == FFEINFO_basictypeTYPELESS)
	  || (rbt == FFEINFO_basictypeHOLLERITH))
	{
	  ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
			      l->token, op->token, FFEINFO_basictypeLOGICAL,
					  FFEINFO_kindtypeLOGICALDEFAULT, 0,
						FFETARGET_charactersizeNONE,
						     FFEEXPR_contextLET));
	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
			      r->token, op->token, FFEINFO_basictypeLOGICAL,
					  FFEINFO_kindtypeLOGICALDEFAULT, 0,
						FFETARGET_charactersizeNONE,
						      FFEEXPR_contextLET));
	  linfo = ffebld_info (ffebld_left (reduced));
	  rinfo = ffebld_info (ffebld_right (reduced));
	  lbt = rbt = FFEINFO_basictypeLOGICAL;
	  lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
	  lrk = rrk = 0;
	  lkd = rkd = FFEINFO_kindENTITY;
	  lwh = ffeinfo_where (linfo);
	  rwh = ffeinfo_where (rinfo);
	}
      else
	{
	  ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
				 l->token, ffebld_right (reduced), r->token,
						       FFEEXPR_contextLET));
	  linfo = ffebld_info (ffebld_left (reduced));
	  lbt = ffeinfo_basictype (linfo);
	  lkt = ffeinfo_kindtype (linfo);
	  lrk = ffeinfo_rank (linfo);
	  lkd = ffeinfo_kind (linfo);
	  lwh = ffeinfo_where (linfo);
	}
    }
  else
    {
      if ((rbt == FFEINFO_basictypeTYPELESS)
	  || (rbt == FFEINFO_basictypeHOLLERITH))
	{
	  ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
				  r->token, ffebld_left (reduced), l->token,
						       FFEEXPR_contextLET));
	  rinfo = ffebld_info (ffebld_right (reduced));
	  rbt = ffeinfo_basictype (rinfo);
	  rkt = ffeinfo_kindtype (rinfo);
	  rrk = ffeinfo_rank (rinfo);
	  rkd = ffeinfo_kind (rinfo);
	  rwh = ffeinfo_where (rinfo);
	}
      /* else Leave it alone. */
    }

  return reduced;
}

/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
   is found.

   The idea is to process the tokens as they would be done by normal
   expression processing, with the key things being telling the lexer
   when hollerith/character constants are about to happen, until the
   true closing token is found.  */

static ffelexHandler
ffeexpr_find_close_paren_ (ffelexToken t,
			   ffelexHandler after)
{
  ffeexpr_find_.after = after;
  ffeexpr_find_.level = 1;
  return (ffelexHandler) ffeexpr_nil_rhs_ (t);
}

static ffelexHandler
ffeexpr_nil_finished_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeCLOSE_PAREN:
      if (--ffeexpr_find_.level == 0)
	return (ffelexHandler) ffeexpr_find_.after;
      return (ffelexHandler) ffeexpr_nil_binary_;

    case FFELEX_typeCOMMA:
    case FFELEX_typeCOLON:
    case FFELEX_typeEQUALS:
    case FFELEX_typePOINTS:
      return (ffelexHandler) ffeexpr_nil_rhs_;

    default:
      if (--ffeexpr_find_.level == 0)
	return (ffelexHandler) ffeexpr_find_.after (t);
      return (ffelexHandler) ffeexpr_nil_rhs_ (t);
    }
}

static ffelexHandler
ffeexpr_nil_rhs_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeQUOTE:
      if (ffe_is_vxt ())
	return (ffelexHandler) ffeexpr_nil_quote_;
      ffelex_set_expecting_hollerith (-1, '\"',
				      ffelex_token_where_line (t),
				      ffelex_token_where_column (t));
      return (ffelexHandler) ffeexpr_nil_apostrophe_;

    case FFELEX_typeAPOSTROPHE:
      ffelex_set_expecting_hollerith (-1, '\'',
				      ffelex_token_where_line (t),
				      ffelex_token_where_column (t));
      return (ffelexHandler) ffeexpr_nil_apostrophe_;

    case FFELEX_typePERCENT:
      return (ffelexHandler) ffeexpr_nil_percent_;

    case FFELEX_typeOPEN_PAREN:
      ++ffeexpr_find_.level;
      return (ffelexHandler) ffeexpr_nil_rhs_;

    case FFELEX_typePLUS:
    case FFELEX_typeMINUS:
      return (ffelexHandler) ffeexpr_nil_rhs_;

    case FFELEX_typePERIOD:
      return (ffelexHandler) ffeexpr_nil_period_;

    case FFELEX_typeNUMBER:
      ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
      if (ffeexpr_hollerith_count_ > 0)
	ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
					'\0',
					ffelex_token_where_line (t),
					ffelex_token_where_column (t));
      return (ffelexHandler) ffeexpr_nil_number_;

    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      return (ffelexHandler) ffeexpr_nil_name_rhs_;

    case FFELEX_typeASTERISK:
    case FFELEX_typeSLASH:
    case FFELEX_typePOWER:
    case FFELEX_typeCONCAT:
    case FFELEX_typeREL_EQ:
    case FFELEX_typeREL_NE:
    case FFELEX_typeREL_LE:
    case FFELEX_typeREL_GE:
      return (ffelexHandler) ffeexpr_nil_rhs_;

    default:
      return (ffelexHandler) ffeexpr_nil_finished_ (t);
    }
}

static ffelexHandler
ffeexpr_nil_period_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_current_dotdot_ = ffestr_other (t);
      switch (ffeexpr_current_dotdot_)
	{
	case FFESTR_otherNone:
	  return (ffelexHandler) ffeexpr_nil_rhs_ (t);

	case FFESTR_otherTRUE:
	case FFESTR_otherFALSE:
	case FFESTR_otherNOT:
	  return (ffelexHandler) ffeexpr_nil_end_period_;

	default:
	  return (ffelexHandler) ffeexpr_nil_swallow_period_;
	}
      break;			/* Nothing really reaches here. */

    case FFELEX_typeNUMBER:
      return (ffelexHandler) ffeexpr_nil_real_;

    default:
      return (ffelexHandler) ffeexpr_nil_rhs_ (t);
    }
}

static ffelexHandler
ffeexpr_nil_end_period_ (ffelexToken t)
{
  switch (ffeexpr_current_dotdot_)
    {
    case FFESTR_otherNOT:
      if (ffelex_token_type (t) != FFELEX_typePERIOD)
	return (ffelexHandler) ffeexpr_nil_rhs_ (t);
      return (ffelexHandler) ffeexpr_nil_rhs_;

    case FFESTR_otherTRUE:
    case FFESTR_otherFALSE:
      if (ffelex_token_type (t) != FFELEX_typePERIOD)
	return (ffelexHandler) ffeexpr_nil_binary_ (t);
      return (ffelexHandler) ffeexpr_nil_binary_;

    default:
      assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
      exit (0);
      return NULL;
    }
}

static ffelexHandler
ffeexpr_nil_swallow_period_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typePERIOD)
    return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  return (ffelexHandler) ffeexpr_nil_rhs_;
}

static ffelexHandler
ffeexpr_nil_real_ (ffelexToken t)
{
  char d;
  char *p;

  if (((ffelex_token_type (t) != FFELEX_typeNAME)
       && (ffelex_token_type (t) != FFELEX_typeNAMES))
      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				     'D', 'd')
	     || ffesrc_char_match_init (d, 'E', 'e')
	     || ffesrc_char_match_init (d, 'Q', 'q')))
	   && ffeexpr_isdigits_ (++p)))
    return (ffelexHandler) ffeexpr_nil_binary_ (t);

  if (*p == '\0')
    return (ffelexHandler) ffeexpr_nil_real_exponent_;
  return (ffelexHandler) ffeexpr_nil_binary_;
}

static ffelexHandler
ffeexpr_nil_real_exponent_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    return (ffelexHandler) ffeexpr_nil_binary_ (t);

  return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
}

static ffelexHandler
ffeexpr_nil_real_exp_sign_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    return (ffelexHandler) ffeexpr_nil_binary_ (t);
  return (ffelexHandler) ffeexpr_nil_binary_;
}

static ffelexHandler
ffeexpr_nil_number_ (ffelexToken t)
{
  char d;
  char *p;

  if (ffeexpr_hollerith_count_ > 0)
    ffelex_set_expecting_hollerith (0, '\0',
				    ffewhere_line_unknown (),
				    ffewhere_column_unknown ());

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				   'D', 'd')
	   || ffesrc_char_match_init (d, 'E', 'e')
	   || ffesrc_char_match_init (d, 'Q', 'q'))
	  && ffeexpr_isdigits_ (++p))
	{
	  if (*p == '\0')
	    {
	      ffeexpr_find_.t = ffelex_token_use (t);
	      return (ffelexHandler) ffeexpr_nil_number_exponent_;
	    }
	  return (ffelexHandler) ffeexpr_nil_binary_;
	}
      break;

    case FFELEX_typePERIOD:
      ffeexpr_find_.t = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_nil_number_period_;

    case FFELEX_typeHOLLERITH:
      return (ffelexHandler) ffeexpr_nil_binary_;

    default:
      break;
    }
  return (ffelexHandler) ffeexpr_nil_binary_ (t);
}

/* Expects ffeexpr_find_.t.  */

static ffelexHandler
ffeexpr_nil_number_exponent_ (ffelexToken t)
{
  ffelexHandler nexthandler;

  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    {
      nexthandler
	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
      ffelex_token_kill (ffeexpr_find_.t);
      return (ffelexHandler) (*nexthandler) (t);
    }

  ffelex_token_kill (ffeexpr_find_.t);
  return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
}

static ffelexHandler
ffeexpr_nil_number_exp_sign_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    return (ffelexHandler) ffeexpr_nil_binary_ (t);

  return (ffelexHandler) ffeexpr_nil_binary_;
}

/* Expects ffeexpr_find_.t.  */

static ffelexHandler
ffeexpr_nil_number_period_ (ffelexToken t)
{
  ffelexHandler nexthandler;
  char d;
  char *p;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				   'D', 'd')
	   || ffesrc_char_match_init (d, 'E', 'e')
	   || ffesrc_char_match_init (d, 'Q', 'q'))
	  && ffeexpr_isdigits_ (++p))
	{
	  if (*p == '\0')
	    return (ffelexHandler) ffeexpr_nil_number_per_exp_;
	  ffelex_token_kill (ffeexpr_find_.t);
	  return (ffelexHandler) ffeexpr_nil_binary_;
	}
      nexthandler
	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
      ffelex_token_kill (ffeexpr_find_.t);
      return (ffelexHandler) (*nexthandler) (t);

    case FFELEX_typeNUMBER:
      ffelex_token_kill (ffeexpr_find_.t);
      return (ffelexHandler) ffeexpr_nil_number_real_;

    default:
      break;
    }
  ffelex_token_kill (ffeexpr_find_.t);
  return (ffelexHandler) ffeexpr_nil_binary_ (t);
}

/* Expects ffeexpr_find_.t.  */

static ffelexHandler
ffeexpr_nil_number_per_exp_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    {
      ffelexHandler nexthandler;

      nexthandler
	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
      ffelex_token_kill (ffeexpr_find_.t);
      return (ffelexHandler) (*nexthandler) (t);
    }

  ffelex_token_kill (ffeexpr_find_.t);
  return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
}

static ffelexHandler
ffeexpr_nil_number_real_ (ffelexToken t)
{
  char d;
  char *p;

  if (((ffelex_token_type (t) != FFELEX_typeNAME)
       && (ffelex_token_type (t) != FFELEX_typeNAMES))
      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				     'D', 'd')
	     || ffesrc_char_match_init (d, 'E', 'e')
	     || ffesrc_char_match_init (d, 'Q', 'q')))
	   && ffeexpr_isdigits_ (++p)))
    return (ffelexHandler) ffeexpr_nil_binary_ (t);

  if (*p == '\0')
    return (ffelexHandler) ffeexpr_nil_number_real_exp_;

  return (ffelexHandler) ffeexpr_nil_binary_;
}

static ffelexHandler
ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    return (ffelexHandler) ffeexpr_nil_binary_ (t);
  return (ffelexHandler) ffeexpr_nil_binary_;
}

static ffelexHandler
ffeexpr_nil_number_real_exp_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    return (ffelexHandler) ffeexpr_nil_binary_ (t);
  return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
}

static ffelexHandler
ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    return (ffelexHandler) ffeexpr_nil_binary_ (t);
  return (ffelexHandler) ffeexpr_nil_binary_;
}

static ffelexHandler
ffeexpr_nil_binary_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typePLUS:
    case FFELEX_typeMINUS:
    case FFELEX_typeASTERISK:
    case FFELEX_typeSLASH:
    case FFELEX_typePOWER:
    case FFELEX_typeCONCAT:
    case FFELEX_typeOPEN_ANGLE:
    case FFELEX_typeCLOSE_ANGLE:
    case FFELEX_typeREL_EQ:
    case FFELEX_typeREL_NE:
    case FFELEX_typeREL_GE:
    case FFELEX_typeREL_LE:
      return (ffelexHandler) ffeexpr_nil_rhs_;

    case FFELEX_typePERIOD:
      return (ffelexHandler) ffeexpr_nil_binary_period_;

    default:
      return (ffelexHandler) ffeexpr_nil_finished_ (t);
    }
}

static ffelexHandler
ffeexpr_nil_binary_period_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_current_dotdot_ = 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_:
    case FFEEXPR_contextRETURN:
      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
	break;
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeNONE:
	  error = FALSE;
	  break;

	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;			/* expr==NULL ok for substring; element case
				   caught by callback. */

    case FFEEXPR_contextDO:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  error = !ffe_is_ugly_logint ();
	  if (!ffeexpr_stack_->is_rhs)
	    break;		/* Don't convert lhs variable. */
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
				  ffeinfo_kindtype (ffebld_info (expr)), 0,
				  FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  if (!ffeexpr_stack_->is_rhs)
	    {
	      error = TRUE;
	      break;		/* Don't convert lhs variable. */
	    }
	  break;

	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeREAL:
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if (!ffeexpr_stack_->is_rhs
	  && (ffebld_op (expr) != FFEBLD_opSYMTER))
	error = TRUE;
      break;

    case FFEEXPR_contextDOWHILE:
    case FFEEXPR_contextIF:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeLOGICAL:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextASSIGN:
    case FFEEXPR_contextAGOTO:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	  error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
	  break;

	case FFEINFO_basictypeLOGICAL:
	  error = !ffe_is_ugly_logint ()
	    || (ffeinfo_kindtype (info) != ffecom_label_kind ());
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr == NULL) || (ffeinfo_rank (info) != 0)
	  || (ffebld_op (expr) != FFEBLD_opSYMTER))
	error = TRUE;
      break;

    case FFEEXPR_contextCGOTO:
    case FFEEXPR_contextFORMAT:
    case FFEEXPR_contextDIMLIST:
    case FFEEXPR_contextFILENUM:	/* See equiv code in _ambig_. */
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextARITHIF:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeREAL:
	  error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextSTOP:
      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
	break;
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
	  break;

	case FFEINFO_basictypeCHARACTER:
	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
	  break;

	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeNONE:
	  error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
			     || (ffebld_conter_orig (expr) != NULL)))
	error = TRUE;
      break;

    case FFEEXPR_contextINCLUDE:
      error = (expr == NULL) || (ffeinfo_rank (info) != 0)
	|| (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
	|| (ffebld_op (expr) != FFEBLD_opCONTER)
	|| (ffebld_conter_orig (expr) != NULL);
      break;

    case FFEEXPR_contextSELECTCASE:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeCHARACTER:
	case FFEINFO_basictypeLOGICAL:
	  error = FALSE;
	  break;

	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextCASE:
      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
	break;
      switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeCHARACTER:
	case FFEINFO_basictypeLOGICAL:
	  error = FALSE;
	  break;

	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
	error = TRUE;
      break;

    case FFEEXPR_contextCHARACTERSIZE:
    case FFEEXPR_contextKINDTYPE:
    case FFEEXPR_contextDIMLISTCOMMON:
      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
	break;
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
	error = TRUE;
      break;

    case FFEEXPR_contextEQVINDEX_:
      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
	break;
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeNONE:
	  error = FALSE;
	  break;

	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
	error = TRUE;
      break;

    case FFEEXPR_contextPARAMETER:
      if (ffeexpr_stack_->is_rhs)
	error = (expr == NULL) || (ffeinfo_rank (info) != 0)
	  || (ffebld_op (expr) != FFEBLD_opCONTER);
      else
	error = (expr == NULL) || (ffeinfo_rank (info) != 0)
	  || (ffebld_op (expr) != FFEBLD_opSYMTER);
      break;

    case FFEEXPR_contextINDEXORACTUALARG_:
      if (ffelex_token_type (t) == FFELEX_typeCOLON)
	ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
      else
	ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
      goto again;		/* :::::::::::::::::::: */

    case FFEEXPR_contextINDEXORACTUALARGEXPR_:
      if (ffelex_token_type (t) == FFELEX_typeCOLON)
	ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
      else
	ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
      goto again;		/* :::::::::::::::::::: */

    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
      if (ffelex_token_type (t) == FFELEX_typeCOLON)
	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
      else
	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
      goto again;		/* :::::::::::::::::::: */

    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
      if (ffelex_token_type (t) == FFELEX_typeCOLON)
	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
      else
	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
      goto again;		/* :::::::::::::::::::: */

    case FFEEXPR_contextIMPDOCTRL_:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      if (!ffeexpr_stack_->is_rhs
	  && (ffebld_op (expr) != FFEBLD_opSYMTER))
	error = TRUE;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  error = error && !ffe_is_ugly_logint ();
	  if (!ffeexpr_stack_->is_rhs)
	    break;		/* Don't convert lhs variable. */
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
				  ffeinfo_kindtype (ffebld_info (expr)), 0,
				  FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  break;

	case FFEINFO_basictypeREAL:
	  if (!ffeexpr_stack_->is_rhs
	      && ffe_is_warn_surprising ()
	      && !error)
	    {
	      ffebad_start (FFEBAD_DO_REAL);	/* See error message!!! */
	      ffebad_here (0, ffelex_token_where_line (ft),
			   ffelex_token_where_column (ft));
	      ffebad_string (ffelex_token_text (ft));
	      ffebad_finish ();
	    }
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextDATAIMPDOCTRL_:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      if (ffeexpr_stack_->is_rhs)
	{
	  if ((ffebld_op (expr) != FFEBLD_opCONTER)
	      && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
	    error = TRUE;
	}
      else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
	       || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
	error = TRUE;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  error = error
	    && (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT);
	  if (!ffeexpr_stack_->is_rhs)
	    break;		/* Don't convert lhs variable. */
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeINTEGER:
	  error = error &&
	    (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
	  break;

	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeREAL:
	  if (!ffeexpr_stack_->is_rhs
	      && ffe_is_warn_surprising ()
	      && !error)
	    {
	      ffebad_start (FFEBAD_DO_REAL);	/* See error message!!! */
	      ffebad_here (0, ffelex_token_where_line (ft),
			   ffelex_token_where_column (ft));
	      ffebad_string (ffelex_token_text (ft));
	      ffebad_finish ();
	    }
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextIMPDOITEM_:
      if (ffelex_token_type (t) == FFELEX_typeEQUALS)
	{
	  ffeexpr_stack_->is_rhs = FALSE;
	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
	  goto again;		/* :::::::::::::::::::: */
	}
      /* Fall through. */
    case FFEEXPR_contextIOLIST:
    case FFEEXPR_contextFILEVXTCODE:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  break;
	}
      error = (expr == NULL)
	|| ((ffeinfo_rank (info) != 0)
	    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
		|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
		|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
		    == FFEBLD_opSTAR)));	/* Bad if null expr, or if
						   array that is not a SYMTER
						   (can't happen yet, I
						   think) or has a NULL or
						   STAR (assumed) array
						   size. */
      break;

    case FFEEXPR_contextIMPDOITEMDF_:
      if (ffelex_token_type (t) == FFELEX_typeEQUALS)
	{
	  ffeexpr_stack_->is_rhs = FALSE;
	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
	  goto again;		/* :::::::::::::::::::: */
	}
      /* Fall through. */
    case FFEEXPR_contextIOLISTDF:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  break;
	}
      error
	= (expr == NULL)
	  || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
	      && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
	    || ((ffeinfo_rank (info) != 0)
		&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
		    || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
		    || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
			== FFEBLD_opSTAR)));	/* Bad if null expr,
						   non-default-kindtype
						   character expr, or if
						   array that is not a SYMTER
						   (can't happen yet, I
						   think) or has a NULL or
						   STAR (assumed) array
						   size. */
      break;

    case FFEEXPR_contextDATAIMPDOITEM_:
      error = (expr == NULL)
	|| (ffebld_op (expr) != FFEBLD_opARRAYREF)
	|| ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
	    && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
      break;

    case FFEEXPR_contextDATAIMPDOINDEX_:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
	  && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
	error = TRUE;
      break;

    case FFEEXPR_contextDATA:
      if (expr == NULL)
	error = TRUE;
      else if (ffeexpr_stack_->is_rhs)
	error = (ffebld_op (expr) != FFEBLD_opCONTER);
      else if (ffebld_op (expr) == FFEBLD_opSYMTER)
	error = FALSE;
      else
	error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
      break;

    case FFEEXPR_contextINITVAL:
      error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
      break;

    case FFEEXPR_contextEQUIVALENCE:
      if (expr == NULL)
	error = TRUE;
      else if (ffebld_op (expr) == FFEBLD_opSYMTER)
	error = FALSE;
      else
	error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
      break;

    case FFEEXPR_contextFILEASSOC:
    case FFEEXPR_contextFILEINT:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	  error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
	error = TRUE;
      break;

    case FFEEXPR_contextFILEDFINT:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
	error = TRUE;
      break;

    case FFEEXPR_contextFILELOG:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
	error = TRUE;
      break;

    case FFEEXPR_contextFILECHAR:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeCHARACTER:
	  error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
	error = TRUE;
      break;

    case FFEEXPR_contextFILENUMCHAR:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeCHARACTER:
	  error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextFILEDFCHAR:
      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
	break;
      switch (ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeCHARACTER:
	  error
	    = (ffeinfo_kindtype (info)
	       != FFEINFO_kindtypeCHARACTERDEFAULT);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if (!ffeexpr_stack_->is_rhs
	  && (ffebld_op (expr) == FFEBLD_opSUBSTR))
	error = TRUE;
      break;

    case FFEEXPR_contextFILEUNIT:	/* See equiv code in _ambig_. */
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  if ((error = (ffeinfo_rank (info) != 0)))
	    break;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if ((error = (ffeinfo_rank (info) != 0)))
	    break;
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  if ((error = (ffeinfo_rank (info) != 0)))
	    break;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeCHARACTER:
	  switch (ffebld_op (expr))
	    {			/* As if _lhs had been called instead of
				   _rhs. */
	    case FFEBLD_opSYMTER:
	      error
		= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
	      break;

	    case FFEBLD_opSUBSTR:
	      error = (ffeinfo_where (ffebld_info (expr))
		       == FFEINFO_whereCONSTANT_SUBOBJECT);
	      break;

	    case FFEBLD_opARRAYREF:
	      error = FALSE;
	      break;

	    default:
	      error = TRUE;
	      break;
	    }
	  if (!error
	   && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
	       || ((ffeinfo_rank (info) != 0)
		   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
		     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
		  || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
		      == FFEBLD_opSTAR)))))	/* Bad if
						   non-default-kindtype
						   character expr, or if
						   array that is not a SYMTER
						   (can't happen yet, I
						   think), or has a NULL or
						   STAR (assumed) array
						   size. */
	    error = TRUE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextFILEFORMAT:
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeINTEGER:
	  error = (expr == NULL)
	    || ((ffeinfo_rank (info) != 0) ?
		ffe_is_pedantic ()	/* F77 C5. */
		: (ffeinfo_kindtype (info) != ffecom_label_kind ()))
	    || (ffebld_op (expr) != FFEBLD_opSYMTER);
	  break;

	case FFEINFO_basictypeLOGICAL:
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  /* F77 C5 -- must be an array of hollerith.  */
	  error
	    = ffe_is_pedantic ()
	      || (ffeinfo_rank (info) == 0);
	  break;

	case FFEINFO_basictypeCHARACTER:
	  if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
	      || ((ffeinfo_rank (info) != 0)
		  && ((ffebld_op (expr) != FFEBLD_opSYMTER)
		      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
		      || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
			  == FFEBLD_opSTAR))))	/* Bad if
						   non-default-kindtype
						   character expr, or if
						   array that is not a SYMTER
						   (can't happen yet, I
						   think), or has a NULL or
						   STAR (assumed) array
						   size. */
	    error = TRUE;
	  else
	    error = FALSE;
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    case FFEEXPR_contextLOC_:
      /* See also ffeintrin_check_loc_.  */
      if ((expr == NULL)
	  || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
	  || ((ffebld_op (expr) != FFEBLD_opSYMTER)
	      && (ffebld_op (expr) != FFEBLD_opSUBSTR)
	      && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
	error = TRUE;
      break;

    default:
      error = FALSE;
      break;
    }

  if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
    {
      ffebad_start (FFEBAD_EXPR_WRONG);
      ffebad_here (0, ffelex_token_where_line (ft),
		   ffelex_token_where_column (ft));
      ffebad_finish ();
      expr = ffebld_new_any ();
      ffebld_set_info (expr, ffeinfo_new_any ());
    }

  callback = ffeexpr_stack_->callback;
  s = ffeexpr_stack_->previous;
  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
		  sizeof (*ffeexpr_stack_));
  ffeexpr_stack_ = s;
  next = (ffelexHandler) (*callback) (ft, expr, t);
  ffelex_token_kill (ft);
  return (ffelexHandler) next;
}

/* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec

   ffebld expr;
   expr = ffeexpr_finished_ambig_(expr);

   Replicates a bit of ffeexpr_finished_'s task when in a context
   of UNIT or FORMAT.  */

static ffebld
ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
{
  ffeinfo info = ffebld_info (expr);
  bool error;

  switch (ffeexpr_stack_->context)
    {
    case FFEEXPR_contextFILENUMAMBIG:	/* Same as FILENUM in _finished_. */
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = FALSE;
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	default:
	  error = TRUE;
	  break;
	}
      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
	error = TRUE;
      break;

    case FFEEXPR_contextFILEUNITAMBIG:	/* Same as FILEUNIT in _finished_. */
      if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
	{
	  error = FALSE;
	  break;
	}
      switch ((expr == NULL) ? FFEINFO_basictypeNONE
	      : ffeinfo_basictype (info))
	{
	case FFEINFO_basictypeLOGICAL:
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  /* Fall through. */
	case FFEINFO_basictypeREAL:
	case FFEINFO_basictypeCOMPLEX:
	  if (ffe_is_pedantic ())
	    {
	      error = TRUE;
	      break;
	    }
	  /* Fall through. */
	case FFEINFO_basictypeINTEGER:
	case FFEINFO_basictypeHOLLERITH:
	case FFEINFO_basictypeTYPELESS:
	  error = (ffeinfo_rank (info) != 0);
	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
				  FFEEXPR_contextLET);
	  break;

	case FFEINFO_basictypeCHARACTER:
	  switch (ffebld_op (expr))
	    {			/* As if _lhs had been called instead of
				   _rhs. */
	    case FFEBLD_opSYMTER:
	      error
		= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
	      break;

	    case FFEBLD_opSUBSTR:
	      error = (ffeinfo_where (ffebld_info (expr))
		       == FFEINFO_whereCONSTANT_SUBOBJECT);
	      break;

	    case FFEBLD_opARRAYREF:
	      error = FALSE;
	      break;

	    default:
	      error = TRUE;
	      break;
	    }
	  break;

	default:
	  error = TRUE;
	  break;
	}
      break;

    default:
      assert ("bad context" == NULL);
      error = TRUE;
      break;
    }

  if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
    {
      ffebad_start (FFEBAD_EXPR_WRONG);
      ffebad_here (0, ffelex_token_where_line (ft),
		   ffelex_token_where_column (ft));
      ffebad_finish ();
      expr = ffebld_new_any ();
      ffebld_set_info (expr, ffeinfo_new_any ());
    }

  return expr;
}

/* ffeexpr_token_lhs_ -- Initial state for lhs expression

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Basically a smaller version of _rhs_; keep them both in sync, of course.  */

static ffelexHandler
ffeexpr_token_lhs_ (ffelexToken t)
{

  /* When changing the list of valid initial lhs tokens, check whether to
     update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
     READ (expr) <token> case -- it assumes it knows which tokens <token> can
     be to indicate an lhs (or implied DO), which right now is the set
     {NAME,OPEN_PAREN}.

     This comment also appears in ffeexpr_token_first_lhs_. */

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_name_lhs_;

    default:
      return (ffelexHandler) ffeexpr_finished_ (t);
    }
}

/* ffeexpr_token_rhs_ -- Initial state for rhs expression

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   The initial state and the post-binary-operator state are the same and
   both handled here, with the expression stack used to distinguish
   between them.  Binary operators are invalid here; unary operators,
   constants, subexpressions, and name references are valid.  */

static ffelexHandler
ffeexpr_token_rhs_ (ffelexToken t)
{
  ffeexprExpr_ e;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeQUOTE:
      if (ffe_is_vxt ())
	{
	  ffeexpr_tokens_[0] = ffelex_token_use (t);
	  return (ffelexHandler) ffeexpr_token_quote_;
	}
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      ffelex_set_expecting_hollerith (-1, '\"',
				      ffelex_token_where_line (t),
				      ffelex_token_where_column (t));
      /* Don't have to unset this one. */
      return (ffelexHandler) ffeexpr_token_apostrophe_;

    case FFELEX_typeAPOSTROPHE:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      ffelex_set_expecting_hollerith (-1, '\'',
				      ffelex_token_where_line (t),
				      ffelex_token_where_column (t));
      /* Don't have to unset this one. */
      return (ffelexHandler) ffeexpr_token_apostrophe_;

    case FFELEX_typePERCENT:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_percent_;

    case FFELEX_typeOPEN_PAREN:
      ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					  FFEEXPR_contextPAREN_,
					  ffeexpr_cb_close_paren_c_);

    case FFELEX_typePLUS:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeUNARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorADD_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
      e->u.operator.as = FFEEXPR_operatorassociativityADD_;
      ffeexpr_exprstack_push_unary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeMINUS:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeUNARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
      e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
      ffeexpr_exprstack_push_unary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typePERIOD:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_period_;

    case FFELEX_typeNUMBER:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
      if (ffeexpr_hollerith_count_ > 0)
	ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
					'\0',
					ffelex_token_where_line (t),
					ffelex_token_where_column (t));
      return (ffelexHandler) ffeexpr_token_number_;

    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextACTUALARG_:
	case FFEEXPR_contextINDEXORACTUALARG_:
	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  return (ffelexHandler) ffeexpr_token_name_arg_;

	default:
	  return (ffelexHandler) ffeexpr_token_name_rhs_;
	}

    case FFELEX_typeASTERISK:
    case FFELEX_typeSLASH:
    case FFELEX_typePOWER:
    case FFELEX_typeCONCAT:
    case FFELEX_typeREL_EQ:
    case FFELEX_typeREL_NE:
    case FFELEX_typeREL_LE:
    case FFELEX_typeREL_GE:
      if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
	{
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}
      return (ffelexHandler) ffeexpr_token_rhs_;

#if 0
    case FFELEX_typeEQUALS:
    case FFELEX_typePOINTS:
    case FFELEX_typeCLOSE_ANGLE:
    case FFELEX_typeCLOSE_PAREN:
    case FFELEX_typeCOMMA:
    case FFELEX_typeCOLON:
    case FFELEX_typeEOS:
    case FFELEX_typeSEMICOLON:
#endif
    default:
      return (ffelexHandler) ffeexpr_finished_ (t);
    }
}

/* ffeexpr_token_period_ -- Rhs PERIOD

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle a period detected at rhs (expecting unary op or operand) state.
   Must begin a floating-point value (as in .12) or a dot-dot name, of
   which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
   valid names represent binary operators, which are invalid here because
   there isn't an operand at the top of the stack.  */

static ffelexHandler
ffeexpr_token_period_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_current_dotdot_ = 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;
  char *p;

  if (((ffelex_token_type (t) != FFELEX_typeNAME)
       && (ffelex_token_type (t) != FFELEX_typeNAMES))
      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				     'D', 'd')
	     || ffesrc_char_match_init (d, 'E', 'e')
	     || ffesrc_char_match_init (d, 'Q', 'q')))
	   && ffeexpr_isdigits_ (++p)))
    {
#if 0
      /* This code has been removed because it seems inconsistent to
	 produce a diagnostic in this case, but not all of the other
	 ones that look for an exponent and cannot recognize one.  */
      if (((ffelex_token_type (t) == FFELEX_typeNAME)
	   || (ffelex_token_type (t) == FFELEX_typeNAMES))
	  && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
	{
	  char bad[2];

	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  bad[0] = *(p - 1);
	  bad[1] = '\0';
	  ffebad_string (bad);
	  ffebad_finish ();
	}
#endif
      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  /* Just exponent character by itself?	 In which case, PLUS or MINUS must
     surely be next, followed by a NUMBER token. */

  if (*p == '\0')
    {
      ffeexpr_tokens_[2] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_real_exponent_;
    }

  ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
			     t, NULL, NULL);

  ffelex_token_kill (ffeexpr_tokens_[0]);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Ensures this token is PLUS or MINUS, preserves it, goes to final state
   for real number (exponent digits).  Else issues diagnostic, assumes a
   zero exponent field for number, passes token on to binary state as if
   previous token had been "E0" instead of "E", for example.  */

static ffelexHandler
ffeexpr_token_real_exponent_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    {
      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
		       ffelex_token_where_column (ffeexpr_tokens_[2]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}

      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  ffeexpr_tokens_[3] = ffelex_token_use (t);
  return (ffelexHandler) ffeexpr_token_real_exp_sign_;
}

/* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Make sure token is a NUMBER, make a real constant out of all we have and
   push it onto the expression stack.  Else issue diagnostic and pretend
   exponent field was a zero.  */

static ffelexHandler
ffeexpr_token_real_exp_sign_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    {
      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
		       ffelex_token_where_column (ffeexpr_tokens_[2]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}

      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      ffelex_token_kill (ffeexpr_tokens_[3]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
		 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
			     ffeexpr_tokens_[3], t);

  ffelex_token_kill (ffeexpr_tokens_[0]);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  ffelex_token_kill (ffeexpr_tokens_[2]);
  ffelex_token_kill (ffeexpr_tokens_[3]);
  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_number_ -- Rhs NUMBER

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   If the token is a period, we may have a floating-point number, or an
   integer followed by a dotdot binary operator.  If the token is a name
   beginning with D, E, or Q, we definitely have a floating-point number.
   If the token is a hollerith constant, that's what we've got, so push
   it onto the expression stack and continue with the binary state.

   Otherwise, we have an integer followed by something the binary state
   should be able to swallow.  */

static ffelexHandler
ffeexpr_token_number_ (ffelexToken t)
{
  ffeexprExpr_ e;
  ffeinfo ni;
  char d;
  char *p;

  if (ffeexpr_hollerith_count_ > 0)
    ffelex_set_expecting_hollerith (0, '\0',
				    ffewhere_line_unknown (),
				    ffewhere_column_unknown ());

  /* See if we've got a floating-point number here. */

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				   'D', 'd')
	   || ffesrc_char_match_init (d, 'E', 'e')
	   || ffesrc_char_match_init (d, 'Q', 'q'))
	  && ffeexpr_isdigits_ (++p))
	{

	  /* Just exponent character by itself?	 In which case, PLUS or MINUS
	     must surely be next, followed by a NUMBER token. */

	  if (*p == '\0')
	    {
	      ffeexpr_tokens_[1] = ffelex_token_use (t);
	      return (ffelexHandler) ffeexpr_token_number_exponent_;
	    }
	  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
				     NULL, NULL);

	  ffelex_token_kill (ffeexpr_tokens_[0]);
	  return (ffelexHandler) ffeexpr_token_binary_;
	}
      break;

    case FFELEX_typePERIOD:
      ffeexpr_tokens_[1] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_number_period_;

    case FFELEX_typeHOLLERITH:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeOPERAND_;
      e->token = ffeexpr_tokens_[0];
      e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
      ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
			0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
			ffelex_token_length (t));
      ffebld_set_info (e->u.operand, ni);
      ffeexpr_exprstack_push_operand_ (e);
      return (ffelexHandler) ffeexpr_token_binary_;

    default:
      break;
    }

  /* Nothing specific we were looking for, so make an integer and pass the
     current token to the binary state. */

  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;
  char *p;
  char d;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				   'D', 'd')
	   || ffesrc_char_match_init (d, 'E', 'e')
	   || ffesrc_char_match_init (d, 'Q', 'q'))
	  && ffeexpr_isdigits_ (++p))
	{

	  /* Just exponent character by itself?	 In which case, PLUS or MINUS
	     must surely be next, followed by a NUMBER token. */

	  if (*p == '\0')
	    {
	      ffeexpr_tokens_[2] = ffelex_token_use (t);
	      return (ffelexHandler) ffeexpr_token_number_per_exp_;
	    }
	  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
				     ffeexpr_tokens_[1], NULL, t, NULL,
				     NULL);

	  ffelex_token_kill (ffeexpr_tokens_[0]);
	  ffelex_token_kill (ffeexpr_tokens_[1]);
	  return (ffelexHandler) ffeexpr_token_binary_;
	}
      /* A name not representing an exponent, so assume it will be something
	 like EQ, make an integer from the number, pass the period to binary
	 state and the current token to the resulting state. */

      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeOPERAND_;
      e->token = ffeexpr_tokens_[0];
      e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
					(ffeexpr_tokens_[0]));
      ffebld_set_info (e->u.operand,
		       ffeinfo_new (FFEINFO_basictypeINTEGER,
				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
				    FFETARGET_charactersizeNONE));
      ffeexpr_exprstack_push_operand_ (e);
      nexthandler = (ffelexHandler) ffeexpr_token_binary_
	(ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      return (ffelexHandler) (*nexthandler) (t);

    case FFELEX_typeNUMBER:
      ffeexpr_tokens_[2] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_number_real_;

    default:
      break;
    }

  /* Nothing specific we were looking for, so make a real number and pass the
     period and then the current token to the binary state. */

  ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
			     ffeexpr_tokens_[0], ffeexpr_tokens_[1],
			     NULL, NULL, NULL, NULL);

  ffelex_token_kill (ffeexpr_tokens_[0]);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  return (ffelexHandler) ffeexpr_token_binary_ (t);
}

/* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Ensures this token is PLUS or MINUS, preserves it, goes to final state
   for real number (exponent digits).  Else treats number as real, passes
   name to binary, passes current token to subsequent handler.	*/

static ffelexHandler
ffeexpr_token_number_per_exp_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    {
      ffelexHandler nexthandler;

      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 NULL, NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      return (ffelexHandler) (*nexthandler) (t);
    }

  ffeexpr_tokens_[3] = ffelex_token_use (t);
  return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
}

/* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   After a number, period, and number, check next token for possible
   exponent designation (D, E, or Q as first/only character) and continue
   real-number handling accordingly.  Else form basic real constant, push
   onto expression stack, and enter binary state using current token (which,
   if it is a name not beginning with D, E, or Q, will certainly result
   in an error, but that's not for this routine to deal with).	*/

static ffelexHandler
ffeexpr_token_number_real_ (ffelexToken t)
{
  char d;
  char *p;

  if (((ffelex_token_type (t) != FFELEX_typeNAME)
       && (ffelex_token_type (t) != FFELEX_typeNAMES))
      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
				     'D', 'd')
	     || ffesrc_char_match_init (d, 'E', 'e')
	     || ffesrc_char_match_init (d, 'Q', 'q')))
	   && ffeexpr_isdigits_ (++p)))
    {
#if 0
      /* This code has been removed because it seems inconsistent to
	 produce a diagnostic in this case, but not all of the other
	 ones that look for an exponent and cannot recognize one.  */
      if (((ffelex_token_type (t) == FFELEX_typeNAME)
	   || (ffelex_token_type (t) == FFELEX_typeNAMES))
	  && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
	{
	  char bad[2];

	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  bad[0] = *(p - 1);
	  bad[1] = '\0';
	  ffebad_string (bad);
	  ffebad_finish ();
	}
#endif
      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 ffeexpr_tokens_[2], NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  /* Just exponent character by itself?	 In which case, PLUS or MINUS must
     surely be next, followed by a NUMBER token. */

  if (*p == '\0')
    {
      ffeexpr_tokens_[3] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_number_real_exp_;
    }

  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
			     ffeexpr_tokens_[2], t, NULL, NULL);

  ffelex_token_kill (ffeexpr_tokens_[0]);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  ffelex_token_kill (ffeexpr_tokens_[2]);
  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Make sure token is a NUMBER, make a real constant out of all we have and
   push it onto the expression stack.  Else issue diagnostic and pretend
   exponent field was a zero.  */

static ffelexHandler
ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    {
      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
		       ffelex_token_where_column (ffeexpr_tokens_[2]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}

      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 NULL, NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      ffelex_token_kill (ffeexpr_tokens_[3]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
			     ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
			     ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);

  ffelex_token_kill (ffeexpr_tokens_[0]);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  ffelex_token_kill (ffeexpr_tokens_[2]);
  ffelex_token_kill (ffeexpr_tokens_[3]);
  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Ensures this token is PLUS or MINUS, preserves it, goes to final state
   for real number (exponent digits).  Else issues diagnostic, assumes a
   zero exponent field for number, passes token on to binary state as if
   previous token had been "E0" instead of "E", for example.  */

static ffelexHandler
ffeexpr_token_number_real_exp_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typePLUS)
      && (ffelex_token_type (t) != FFELEX_typeMINUS))
    {
      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
		       ffelex_token_where_column (ffeexpr_tokens_[3]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}

      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 ffeexpr_tokens_[2], NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      ffelex_token_kill (ffeexpr_tokens_[3]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  ffeexpr_tokens_[4] = ffelex_token_use (t);
  return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
}

/* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
				  PLUS/MINUS

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Make sure token is a NUMBER, make a real constant out of all we have and
   push it onto the expression stack.  Else issue diagnostic and pretend
   exponent field was a zero.  */

static ffelexHandler
ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    {
      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
		       ffelex_token_where_column (ffeexpr_tokens_[3]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}

      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
				 ffeexpr_tokens_[2], NULL, NULL, NULL);

      ffelex_token_kill (ffeexpr_tokens_[0]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      ffelex_token_kill (ffeexpr_tokens_[3]);
      ffelex_token_kill (ffeexpr_tokens_[4]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }

  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
			     ffeexpr_tokens_[0], ffeexpr_tokens_[1],
			     ffeexpr_tokens_[2], ffeexpr_tokens_[3],
			     ffeexpr_tokens_[4], t);

  ffelex_token_kill (ffeexpr_tokens_[0]);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  ffelex_token_kill (ffeexpr_tokens_[2]);
  ffelex_token_kill (ffeexpr_tokens_[3]);
  ffelex_token_kill (ffeexpr_tokens_[4]);
  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_binary_ -- Handle binary operator possibility

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   The possibility of a binary operator is handled here, meaning the previous
   token was an operand.  */

static ffelexHandler
ffeexpr_token_binary_ (ffelexToken t)
{
  ffeexprExpr_ e;

  if (!ffeexpr_stack_->is_rhs)
    return (ffelexHandler) ffeexpr_finished_ (t);	/* For now. */

  switch (ffelex_token_type (t))
    {
    case FFELEX_typePLUS:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorADD_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
      e->u.operator.as = FFEEXPR_operatorassociativityADD_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeMINUS:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
      e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeASTERISK:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextDATA:
	  return (ffelexHandler) ffeexpr_finished_ (t);

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
      e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeSLASH:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextDATA:
	  return (ffelexHandler) ffeexpr_finished_ (t);

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorDIVIDE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
      e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typePOWER:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorPOWER_;
      e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
      e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeCONCAT:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
      e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeOPEN_ANGLE:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFORMAT:
	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	  break;

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorLT_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
      e->u.operator.as = FFEEXPR_operatorassociativityLT_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeCLOSE_ANGLE:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFORMAT:
	  return ffeexpr_finished_ (t);

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorGT_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
      e->u.operator.as = FFEEXPR_operatorassociativityGT_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeREL_EQ:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFORMAT:
	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	  break;

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorEQ_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
      e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeREL_NE:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFORMAT:
	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	  break;

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorNE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
      e->u.operator.as = FFEEXPR_operatorassociativityNE_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeREL_LE:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFORMAT:
	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	  break;

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorLE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
      e->u.operator.as = FFEEXPR_operatorassociativityLE_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typeREL_GE:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextFORMAT:
	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	  break;

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorGE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
      e->u.operator.as = FFEEXPR_operatorassociativityGE_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_;

    case FFELEX_typePERIOD:
      ffeexpr_tokens_[0] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_binary_period_;

#if 0
    case FFELEX_typeOPEN_PAREN:
    case FFELEX_typeCLOSE_PAREN:
    case FFELEX_typeEQUALS:
    case FFELEX_typePOINTS:
    case FFELEX_typeCOMMA:
    case FFELEX_typeCOLON:
    case FFELEX_typeEOS:
    case FFELEX_typeSEMICOLON:
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
#endif
    default:
      return (ffelexHandler) ffeexpr_finished_ (t);
    }
}

/* ffeexpr_token_binary_period_ -- Binary PERIOD

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle a period detected at binary (expecting binary op or end) state.
   Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
   valid.  */

static ffelexHandler
ffeexpr_token_binary_period_ (ffelexToken t)
{
  ffeexprExpr_ operand;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_current_dotdot_ = ffestr_other (t);
      switch (ffeexpr_current_dotdot_)
	{
	case FFESTR_otherTRUE:
	case FFESTR_otherFALSE:
	case FFESTR_otherNOT:
	  if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
	    {
	      operand = ffeexpr_stack_->exprstack;
	      assert (operand != NULL);
	      assert (operand->type == FFEEXPR_exprtypeOPERAND_);
	      ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
	      ffebad_here (1, ffelex_token_where_line (t),
			   ffelex_token_where_column (t));
	      ffebad_finish ();
	    }
	  ffelex_token_kill (ffeexpr_tokens_[0]);
	  return (ffelexHandler) ffeexpr_token_binary_sw_per_;

	default:
	  ffeexpr_tokens_[1] = ffelex_token_use (t);
	  return (ffelexHandler) ffeexpr_token_binary_end_per_;
	}
      break;			/* Nothing really reaches here. */

    default:
      if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_finish ();
	}
      ffelex_token_kill (ffeexpr_tokens_[0]);
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }
}

/* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Expecting a period to close a dot-dot at binary (binary op
   or operator) state.	If period isn't found, issue a diagnostic but
   pretend we saw one.	ffeexpr_current_dotdot_ must already contained the
   dotdot representation of the name in between the two PERIOD tokens.	*/

static ffelexHandler
ffeexpr_token_binary_end_per_ (ffelexToken t)
{
  ffeexprExpr_ e;

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeBINARY_;
  e->token = ffeexpr_tokens_[0];

  switch (ffeexpr_current_dotdot_)
    {
    case FFESTR_otherAND:
      e->u.operator.op = FFEEXPR_operatorAND_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
      e->u.operator.as = FFEEXPR_operatorassociativityAND_;
      break;

    case FFESTR_otherOR:
      e->u.operator.op = FFEEXPR_operatorOR_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
      e->u.operator.as = FFEEXPR_operatorassociativityOR_;
      break;

    case FFESTR_otherXOR:
      e->u.operator.op = FFEEXPR_operatorXOR_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
      e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
      break;

    case FFESTR_otherEQV:
      e->u.operator.op = FFEEXPR_operatorEQV_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
      e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
      break;

    case FFESTR_otherNEQV:
      e->u.operator.op = FFEEXPR_operatorNEQV_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
      e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
      break;

    case FFESTR_otherLT:
      e->u.operator.op = FFEEXPR_operatorLT_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
      e->u.operator.as = FFEEXPR_operatorassociativityLT_;
      break;

    case FFESTR_otherLE:
      e->u.operator.op = FFEEXPR_operatorLE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
      e->u.operator.as = FFEEXPR_operatorassociativityLE_;
      break;

    case FFESTR_otherEQ:
      e->u.operator.op = FFEEXPR_operatorEQ_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
      e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
      break;

    case FFESTR_otherNE:
      e->u.operator.op = FFEEXPR_operatorNE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
      e->u.operator.as = FFEEXPR_operatorassociativityNE_;
      break;

    case FFESTR_otherGT:
      e->u.operator.op = FFEEXPR_operatorGT_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
      e->u.operator.as = FFEEXPR_operatorassociativityGT_;
      break;

    case FFESTR_otherGE:
      e->u.operator.op = FFEEXPR_operatorGE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
      e->u.operator.as = FFEEXPR_operatorassociativityGE_;
      break;

    default:
      if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
	  ffebad_finish ();
	}
      e->u.operator.op = FFEEXPR_operatorEQ_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
      e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
      break;
    }

  ffeexpr_exprstack_push_binary_ (e);

  if (ffelex_token_type (t) != FFELEX_typePERIOD)
    {
      if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
	  ffebad_finish ();
	}
      ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill dot-dot token. */
      return (ffelexHandler) ffeexpr_token_rhs_ (t);
    }

  ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill dot-dot token. */
  return (ffelexHandler) ffeexpr_token_rhs_;
}

/* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   A diagnostic has already been issued; just swallow a period if there is
   one, then continue with ffeexpr_token_binary_.  */

static ffelexHandler
ffeexpr_token_binary_sw_per_ (ffelexToken t)
{
  if (ffelex_token_type (t) != FFELEX_typePERIOD)
    return (ffelexHandler) ffeexpr_token_binary_ (t);

  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_quote_ -- Rhs QUOTE

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Expecting a NUMBER that we'll treat as an octal integer.  */

static ffelexHandler
ffeexpr_token_quote_ (ffelexToken t)
{
  ffeexprExpr_ e;
  ffebld anyexpr;

  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
    {
      if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}
      ffelex_token_kill (ffeexpr_tokens_[0]);
      return (ffelexHandler) ffeexpr_token_rhs_ (t);
    }

  /* This is kind of a kludge to prevent any whining about magical numbers
     that start out as these octal integers, so "20000000000 (on a 32-bit
     2's-complement machine) by itself won't produce an error. */

  anyexpr = ffebld_new_any ();
  ffebld_set_info (anyexpr, ffeinfo_new_any ());

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->token = ffeexpr_tokens_[0];
  e->u.operand = ffebld_new_conter_with_orig
    (ffebld_constant_new_integeroctal (t), anyexpr);
  ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
		      FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
		       FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  ffeexpr_exprstack_push_operand_ (e);
  return (ffelexHandler) ffeexpr_token_binary_;
}

/* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle an open-apostrophe, which begins either a character ('char-const'),
   typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
   'hex-const'X) constant.  */

static ffelexHandler
ffeexpr_token_apostrophe_ (ffelexToken t)
{
  assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
  if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
    {
      ffebad_start (FFEBAD_NULL_CHAR_CONST);
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_finish ();
    }
  ffeexpr_tokens_[1] = ffelex_token_use (t);
  return (ffelexHandler) ffeexpr_token_apos_char_;
}

/* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Close-apostrophe is implicit; if this token is NAME, it is a possible
   typeless-constant radix specifier.  */

static ffelexHandler
ffeexpr_token_apos_char_ (ffelexToken t)
{
  ffeexprExpr_ e;
  ffeinfo ni;
  char c;
  ffetargetCharacterSize size;

  if ((ffelex_token_type (t) == FFELEX_typeNAME)
      || (ffelex_token_type (t) == FFELEX_typeNAMES))
    {
      if ((ffelex_token_length (t) == 1)
	  && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
				      'b')
	      || ffesrc_char_match_init (c, 'O', 'o')
	      || ffesrc_char_match_init (c, 'X', 'x')
	      || ffesrc_char_match_init (c, 'Z', 'z')))
	{
	  e = ffeexpr_expr_new_ ();
	  e->type = FFEEXPR_exprtypeOPERAND_;
	  e->token = ffeexpr_tokens_[0];
	  switch (c)
	    {
	    case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
	      e->u.operand = ffebld_new_conter
		(ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
	      size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
	      break;

	    case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
	      e->u.operand = ffebld_new_conter
		(ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
	      size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
	      break;

	    case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
	      e->u.operand = ffebld_new_conter
		(ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
	      size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
	      break;

	    case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
	      e->u.operand = ffebld_new_conter
		(ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
	      size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
	      break;

	    default:
	    no_match:		/* :::::::::::::::::::: */
	      assert ("not BOXZ!" == NULL);
	      size = 0;
	      break;
	    }
	  ffebld_set_info (e->u.operand,
	       ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
		       0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
	  ffeexpr_exprstack_push_operand_ (e);
	  ffelex_token_kill (ffeexpr_tokens_[1]);
	  return (ffelexHandler) ffeexpr_token_binary_;
	}
    }
  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->token = ffeexpr_tokens_[0];
  e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
				    (ffeexpr_tokens_[1]));
  ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
		    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
		    ffelex_token_length (ffeexpr_tokens_[1]));
  ffebld_set_info (e->u.operand, ni);
  ffelex_token_kill (ffeexpr_tokens_[1]);
  ffeexpr_exprstack_push_operand_ (e);
  if ((ffelex_token_type (t) == FFELEX_typeNAME)
      || (ffelex_token_type (t) == FFELEX_typeNAMES))
    {
      if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
	{
	  ffebad_string (ffelex_token_text (t));
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_finish ();
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeBINARY_;
      e->token = ffelex_token_use (t);
      e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
      e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
      e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
      ffeexpr_exprstack_push_binary_ (e);
      return (ffelexHandler) ffeexpr_token_rhs_ (t);
    }
  ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();	/* Allow "'hello'(3:5)". */
  return (ffelexHandler) ffeexpr_token_substrp_ (t);
}

/* ffeexpr_token_name_lhs_ -- Lhs NAME

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle a name followed by open-paren, period (RECORD.MEMBER), percent
   (RECORD%MEMBER), or nothing at all.	*/

static ffelexHandler
ffeexpr_token_name_lhs_ (ffelexToken t)
{
  ffeexprExpr_ e;
  ffeexprParenType_ paren_type;
  ffesymbol s;
  ffebld expr;
  ffeinfo info;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeOPEN_PAREN:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextASSIGN:
	case FFEEXPR_contextAGOTO:
	case FFEEXPR_contextFILEUNIT_DF:
	  goto just_name;	/* :::::::::::::::::::: */

	default:
	  break;
	}
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeOPERAND_;
      e->token = ffelex_token_use (ffeexpr_tokens_[0]);
      s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
					  &paren_type);

      switch (ffesymbol_where (s))
	{
	case FFEINFO_whereLOCAL:
	  if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
	    ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Recursion. */
	  break;

	case FFEINFO_whereINTRINSIC:
	case FFEINFO_whereGLOBAL:
	  if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
	    ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Can call intrin. */
	  break;

	case FFEINFO_whereCOMMON:
	case FFEINFO_whereDUMMY:
	case FFEINFO_whereRESULT:
	  break;

	case FFEINFO_whereNONE:
	case FFEINFO_whereANY:
	  break;

	default:
	  ffesymbol_error (s, ffeexpr_tokens_[0]);
	  break;
	}

      if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
	{
	  e->u.operand = ffebld_new_any ();
	  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
	}
      else
	{
	  e->u.operand = ffebld_new_symter (s,
					    ffesymbol_generic (s),
					    ffesymbol_specific (s),
					    ffesymbol_implementation (s));
	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
	}
      ffeexpr_exprstack_push_ (e);	/* Not a complete operand yet. */
      ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
      switch (paren_type)
	{
	case FFEEXPR_parentypeSUBROUTINE_:
	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 FFEEXPR_contextACTUALARG_,
			 ffeexpr_token_arguments_);

	case FFEEXPR_parentypeARRAY_:
	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
	  ffeexpr_stack_->rank = 0;
	  ffeexpr_stack_->constant = TRUE;
	  ffeexpr_stack_->immediate = TRUE;
	  switch (ffeexpr_stack_->context)
	    {
	    case FFEEXPR_contextDATAIMPDOITEM_:
	      return
		(ffelexHandler)
		ffeexpr_rhs (ffeexpr_stack_->pool,
			     FFEEXPR_contextDATAIMPDOINDEX_,
			     ffeexpr_token_elements_);

	    case FFEEXPR_contextEQUIVALENCE:
	      return
		(ffelexHandler)
		ffeexpr_rhs (ffeexpr_stack_->pool,
			     FFEEXPR_contextEQVINDEX_,
			     ffeexpr_token_elements_);

	    default:
	      return
		(ffelexHandler)
		ffeexpr_rhs (ffeexpr_stack_->pool,
			     FFEEXPR_contextINDEX_,
			     ffeexpr_token_elements_);
	    }

	case FFEEXPR_parentypeSUBSTRING_:
	  e->u.operand = ffeexpr_collapse_symter (e->u.operand,
						  ffeexpr_tokens_[0]);
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 FFEEXPR_contextINDEX_,
			 ffeexpr_token_substring_);

	case FFEEXPR_parentypeEQUIVALENCE_:
	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
	  ffeexpr_stack_->rank = 0;
	  ffeexpr_stack_->constant = TRUE;
	  ffeexpr_stack_->immediate = TRUE;
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 FFEEXPR_contextEQVINDEX_,
			 ffeexpr_token_equivalence_);

	case FFEEXPR_parentypeFUNCTION_:	/* Invalid case. */
	case FFEEXPR_parentypeFUNSUBSTR_:	/* Invalid case. */
	  ffesymbol_error (s, ffeexpr_tokens_[0]);
	  /* Fall through. */
	case FFEEXPR_parentypeANY_:
	  e->u.operand = ffebld_new_any ();
	  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 FFEEXPR_contextACTUALARG_,
			 ffeexpr_token_anything_);

	default:
	  assert ("bad paren type" == NULL);
	  break;
	}

    case FFELEX_typeEQUALS:	/* As in "VAR=". */
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextIMPDOITEM_:	/* within
						   "(,VAR=start,end[,incr])". */
	case FFEEXPR_contextIMPDOITEMDF_:
	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
	  break;

	case FFEEXPR_contextDATAIMPDOITEM_:
	  ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
	  break;

	default:
	  break;
	}
      break;

#if 0
    case FFELEX_typePERIOD:
    case FFELEX_typePERCENT:
      assert ("FOO%, FOO. not yet supported!~~" == NULL);
      break;
#endif

    default:
      break;
    }

just_name:			/* :::::::::::::::::::: */
  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->token = ffeexpr_tokens_[0];
  s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
				  (ffeexpr_stack_->context
				   == FFEEXPR_contextSUBROUTINEREF));

  switch (ffesymbol_where (s))
    {
    case FFEINFO_whereCONSTANT:
      if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
	  || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
	ffesymbol_error (s, ffeexpr_tokens_[0]);
      break;

    case FFEINFO_whereIMMEDIATE:
      if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
	  && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
	ffesymbol_error (s, ffeexpr_tokens_[0]);
      break;

    case FFEINFO_whereLOCAL:
      if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
	ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Recurse!. */
      break;

    case FFEINFO_whereINTRINSIC:
      if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
	ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Can call intrin. */
      break;

    default:
      break;
    }

  if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
    {
      expr = ffebld_new_any ();
      info = ffeinfo_new_any ();
      ffebld_set_info (expr, info);
    }
  else
    {
      expr = ffebld_new_symter (s,
				ffesymbol_generic (s),
				ffesymbol_specific (s),
				ffesymbol_implementation (s));
      info = ffesymbol_info (s);
      ffebld_set_info (expr, info);
      if (ffesymbol_is_doiter (s))
	{
	  ffebad_start (FFEBAD_DOITER);
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffest_ffebad_here_doiter (1, s);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_finish ();
	}
      expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
    }

  if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
    {
      if (ffebld_op (expr) == FFEBLD_opANY)
	{
	  expr = ffebld_new_any ();
	  ffebld_set_info (expr, ffeinfo_new_any ());
	}
      else
	{
	  expr = ffebld_new_subrref (expr, NULL);	/* No argument list. */
	  if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
	    ffeintrin_fulfill_generic (&expr, &info, e->token);
	  else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
	    ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
	  else
	    ffeexpr_fulfill_call_ (&expr, e->token);

	  if (ffebld_op (expr) != FFEBLD_opANY)
	    ffebld_set_info (expr,
			     ffeinfo_new (ffeinfo_basictype (info),
					  ffeinfo_kindtype (info),
					  0,
					  FFEINFO_kindENTITY,
					  FFEINFO_whereFLEETING,
					  ffeinfo_size (info)));
	  else
	    ffebld_set_info (expr, ffeinfo_new_any ());
	}
    }

  e->u.operand = expr;
  ffeexpr_exprstack_push_operand_ (e);
  return (ffelexHandler) ffeexpr_finished_ (t);
}

/* ffeexpr_token_name_arg_ -- Rhs NAME

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle first token in an actual-arg (or possible actual-arg) context
   being a NAME, and use second token to refine the context.  */

static ffelexHandler
ffeexpr_token_name_arg_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeCLOSE_PAREN:
    case FFELEX_typeCOMMA:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextINDEXORACTUALARG_:
	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
	  break;

	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
	  break;

	default:
	  break;
	}
      break;

    default:
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextACTUALARG_:
	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
	  break;

	case FFEEXPR_contextINDEXORACTUALARG_:
	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
	  break;

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
	  break;

	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  ffeexpr_stack_->context
	    = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
	  break;

	default:
	  assert ("bad context in _name_arg_" == NULL);
	  break;
	}
      break;
    }

  return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
}

/* ffeexpr_token_name_rhs_ -- Rhs NAME

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle a name followed by open-paren, apostrophe (O'octal-const',
   Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).

   26-Nov-91  JCB  1.2
      When followed by apostrophe or quote, set lex hexnum flag on so
      [0-9] as first char of next token seen as starting a potentially
      hex number (NAME).
   04-Oct-91  JCB  1.1
      In case of intrinsic, decorate its SYMTER with the type info for
      the specific intrinsic.  */

static ffelexHandler
ffeexpr_token_name_rhs_ (ffelexToken t)
{
  ffeexprExpr_ e;
  ffeexprParenType_ paren_type;
  ffesymbol s;
  bool sfdef;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeQUOTE:
    case FFELEX_typeAPOSTROPHE:
      ffeexpr_tokens_[1] = ffelex_token_use (t);
      ffelex_set_hexnum (TRUE);
      return (ffelexHandler) ffeexpr_token_name_apos_;

    case FFELEX_typeOPEN_PAREN:
      e = ffeexpr_expr_new_ ();
      e->type = FFEEXPR_exprtypeOPERAND_;
      e->token = ffelex_token_use (ffeexpr_tokens_[0]);
      s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
					  &paren_type);
      if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
	e->u.operand = ffebld_new_any ();
      else
	e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
					  ffesymbol_specific (s),
					  ffesymbol_implementation (s));
      ffeexpr_exprstack_push_ (e);	/* Not a complete operand yet. */
      ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	  sfdef = TRUE;
	  break;

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  assert ("weird context!" == NULL);
	  sfdef = FALSE;
	  break;

	default:
	  sfdef = FALSE;
	  break;
	}
      switch (paren_type)
	{
	case FFEEXPR_parentypeFUNCTION_:
	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
	  if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
	    {			/* A statement function. */
	      ffeexpr_stack_->num_args
		= ffebld_list_length
		  (ffeexpr_stack_->next_dummy
		   = ffesymbol_dummyargs (s));
	      ffeexpr_stack_->tokens[1] = NULL;	/* !=NULL when > num_args. */
	    }
	  else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
		   && !ffe_is_pedantic_not_90 ()
		   && ((ffesymbol_implementation (s)
			== FFEINTRIN_impICHAR)
		       || (ffesymbol_implementation (s)
			   == FFEINTRIN_impIACHAR)
		       || (ffesymbol_implementation (s)
			   == FFEINTRIN_impLEN)))
	    {			/* Allow arbitrary concatenations. */
	      return
		(ffelexHandler)
		  ffeexpr_rhs (ffeexpr_stack_->pool,
			       sfdef
			       ? FFEEXPR_contextSFUNCDEF
			       : FFEEXPR_contextLET,
			       ffeexpr_token_arguments_);
	    }
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 sfdef
			 ? FFEEXPR_contextSFUNCDEFACTUALARG_
			 : FFEEXPR_contextACTUALARG_,
			 ffeexpr_token_arguments_);

	case FFEEXPR_parentypeARRAY_:
	  ffebld_set_info (e->u.operand,
			   ffesymbol_info (ffebld_symter (e->u.operand)));
	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
	  ffeexpr_stack_->rank = 0;
	  ffeexpr_stack_->constant = TRUE;
	  ffeexpr_stack_->immediate = TRUE;
	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					      sfdef
					      ? FFEEXPR_contextSFUNCDEFINDEX_
					      : FFEEXPR_contextINDEX_,
					      ffeexpr_token_elements_);

	case FFEEXPR_parentypeSUBSTRING_:
	  ffebld_set_info (e->u.operand,
			   ffesymbol_info (ffebld_symter (e->u.operand)));
	  e->u.operand = ffeexpr_collapse_symter (e->u.operand,
						  ffeexpr_tokens_[0]);
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 sfdef
			 ? FFEEXPR_contextSFUNCDEFINDEX_
			 : FFEEXPR_contextINDEX_,
			 ffeexpr_token_substring_);

	case FFEEXPR_parentypeFUNSUBSTR_:
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 sfdef
			 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
			 : FFEEXPR_contextINDEXORACTUALARG_,
			 ffeexpr_token_funsubstr_);

	case FFEEXPR_parentypeANY_:
	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
	  return
	    (ffelexHandler)
	    ffeexpr_rhs (ffeexpr_stack_->pool,
			 sfdef
			 ? FFEEXPR_contextSFUNCDEFACTUALARG_
			 : FFEEXPR_contextACTUALARG_,
			 ffeexpr_token_anything_);

	default:
	  assert ("bad paren type" == NULL);
	  break;
	}

    case FFELEX_typeEQUALS:	/* As in "VAR=". */
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextIMPDOITEM_:	/* "(,VAR=start,end[,incr])". */
	case FFEEXPR_contextIMPDOITEMDF_:
	  ffeexpr_stack_->is_rhs = FALSE;	/* Really an lhs construct. */
	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
	  break;

	default:
	  break;
	}
      break;

#if 0
    case FFELEX_typePERIOD:
    case FFELEX_typePERCENT:
      ~~Support these two someday, though not required
	assert ("FOO%, FOO. not yet supported!~~" == NULL);
      break;
#endif

    default:
      break;
    }

  switch (ffeexpr_stack_->context)
    {
    case FFEEXPR_contextINDEXORACTUALARG_:
    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
      assert ("strange context" == NULL);
      break;

    default:
      break;
    }

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->token = ffeexpr_tokens_[0];
  s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
  if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
    {
      e->u.operand = ffebld_new_any ();
      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
    }
  else
    {
      e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
					ffesymbol_specific (s),
					ffesymbol_implementation (s));
      if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
	ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
      else
	{			/* Decorate the SYMTER with the actual type
				   of the intrinsic. */
	  ffebld_set_info (e->u.operand, ffeinfo_new
			(ffeintrin_basictype (ffesymbol_specific (s)),
			 ffeintrin_kindtype (ffesymbol_specific (s)),
			 0,
			 ffesymbol_kind (s),
			 ffesymbol_where (s),
			 FFETARGET_charactersizeNONE));
	}
      if (ffesymbol_is_doiter (s))
	ffebld_symter_set_is_doiter (e->u.operand, TRUE);
      e->u.operand = ffeexpr_collapse_symter (e->u.operand,
					      ffeexpr_tokens_[0]);
    }
  ffeexpr_exprstack_push_operand_ (e);
  return (ffelexHandler) ffeexpr_token_binary_ (t);
}

/* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Expecting a NAME token, analyze the previous NAME token to see what kind,
   if any, typeless constant we've got.

   01-Sep-90  JCB  1.1
      Expect a NAME instead of CHARACTER in this situation.  */

static ffelexHandler
ffeexpr_token_name_apos_ (ffelexToken t)
{
  ffeexprExpr_ e;

  ffelex_set_hexnum (FALSE);

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
      ffeexpr_tokens_[2] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_name_apos_name_;

    default:
      break;
    }

  if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
    {
      ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
      ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		   ffelex_token_where_column (ffeexpr_tokens_[0]));
      ffebad_here (1, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_finish ();
    }

  ffelex_token_kill (ffeexpr_tokens_[1]);

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->u.operand = ffebld_new_any ();
  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  e->token = ffeexpr_tokens_[0];
  ffeexpr_exprstack_push_operand_ (e);

  return (ffelexHandler) ffeexpr_token_binary_ (t);
}

/* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Expecting an APOSTROPHE token, analyze the previous NAME token to see
   what kind, if any, typeless constant we've got.  */

static ffelexHandler
ffeexpr_token_name_apos_name_ (ffelexToken t)
{
  ffeexprExpr_ e;
  char c;

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  e->token = ffeexpr_tokens_[0];

  if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
      && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
      && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
				  'B', 'b')
	  || ffesrc_char_match_init (c, 'O', 'o')
	  || ffesrc_char_match_init (c, 'X', 'x')
	  || ffesrc_char_match_init (c, 'Z', 'z')))
    {
      ffetargetCharacterSize size;

      if (!ffe_is_typeless_boz ()) {

      switch (c)
	{
	case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
					    (ffeexpr_tokens_[2]));
	  break;

	case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
					    (ffeexpr_tokens_[2]));
	  break;

	case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
					    (ffeexpr_tokens_[2]));
	  break;

	case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
					    (ffeexpr_tokens_[2]));
	  break;

	default:
	no_imatch:		/* :::::::::::::::::::: */
	  assert ("not BOXZ!" == NULL);
	  abort ();
	}

	ffebld_set_info (e->u.operand,
			 ffeinfo_new (FFEINFO_basictypeINTEGER,
				      FFEINFO_kindtypeINTEGERDEFAULT, 0,
				      FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
				      FFETARGET_charactersizeNONE));
	ffeexpr_exprstack_push_operand_ (e);
	ffelex_token_kill (ffeexpr_tokens_[1]);
	ffelex_token_kill (ffeexpr_tokens_[2]);
	return (ffelexHandler) ffeexpr_token_binary_;
      }

      switch (c)
	{
	case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
					    (ffeexpr_tokens_[2]));
	  size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
	  break;

	case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
					    (ffeexpr_tokens_[2]));
	  size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
	  break;

	case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
					    (ffeexpr_tokens_[2]));
	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
	  break;

	case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
					    (ffeexpr_tokens_[2]));
	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
	  break;

	default:
	no_match:		/* :::::::::::::::::::: */
	  assert ("not BOXZ!" == NULL);
	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
					    (ffeexpr_tokens_[2]));
	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
	  break;
	}
      ffebld_set_info (e->u.operand,
	       ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
		       0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
      ffeexpr_exprstack_push_operand_ (e);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[2]);
      return (ffelexHandler) ffeexpr_token_binary_;
    }

  if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
    {
      ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
      ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		   ffelex_token_where_column (ffeexpr_tokens_[0]));
      ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_finish ();
    }

  ffelex_token_kill (ffeexpr_tokens_[1]);
  ffelex_token_kill (ffeexpr_tokens_[2]);

  e->type = FFEEXPR_exprtypeOPERAND_;
  e->u.operand = ffebld_new_any ();
  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  e->token = ffeexpr_tokens_[0];
  ffeexpr_exprstack_push_operand_ (e);

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeAPOSTROPHE:
    case FFELEX_typeQUOTE:
      return (ffelexHandler) ffeexpr_token_binary_;

    default:
      return (ffelexHandler) ffeexpr_token_binary_ (t);
    }
}

/* ffeexpr_token_percent_ -- Rhs PERCENT

   Handle a percent sign possibly followed by "LOC".  If followed instead
   by "VAL", "REF", or "DESCR", issue an error message and substitute
   "LOC".  If followed by something else, treat the percent sign as a
   spurious incorrect token and reprocess the token via _rhs_.	*/

static ffelexHandler
ffeexpr_token_percent_ (ffelexToken t)
{
  switch (ffelex_token_type (t))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNAMES:
      ffeexpr_stack_->percent = ffeexpr_percent_ (t);
      ffeexpr_tokens_[1] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_token_percent_name_;

    default:
      if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
		   ffelex_token_where_column (ffeexpr_stack_->first_token));
	  ffebad_finish ();
	}
      ffelex_token_kill (ffeexpr_tokens_[0]);
      return (ffelexHandler) ffeexpr_token_rhs_ (t);
    }
}

/* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME

   Make sure the token is OPEN_PAREN and prepare for the one-item list of
   LHS expressions.  Else display an error message.  */

static ffelexHandler
ffeexpr_token_percent_name_ (ffelexToken t)
{
  ffelexHandler nexthandler;

  if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
    {
      if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
		   ffelex_token_where_column (ffeexpr_stack_->first_token));
	  ffebad_finish ();
	}
      ffelex_token_kill (ffeexpr_tokens_[0]);
      nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
      ffelex_token_kill (ffeexpr_tokens_[1]);
      return (ffelexHandler) (*nexthandler) (t);
    }

  switch (ffeexpr_stack_->percent)
    {
    default:
      if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
		       ffelex_token_where_column (ffeexpr_tokens_[0]));
	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
	  ffebad_finish ();
	}
      ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
      /* Fall through. */
    case FFEEXPR_percentLOC_:
      ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
      ffelex_token_kill (ffeexpr_tokens_[1]);
      ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					  FFEEXPR_contextLOC_,
					  ffeexpr_cb_end_loc_);
    }
}

/* ffeexpr_make_float_const_ -- Make a floating-point constant

   See prototype.

   Pass 'E', 'D', or 'Q' for exponent letter.  */

static void
ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
			   ffelexToken decimal, ffelexToken fraction,
			   ffelexToken exponent, ffelexToken exponent_sign,
			   ffelexToken exponent_digits)
{
  ffeexprExpr_ e;

  e = ffeexpr_expr_new_ ();
  e->type = FFEEXPR_exprtypeOPERAND_;
  if (integer != NULL)
    e->token = ffelex_token_use (integer);
  else
    {
      assert (decimal != NULL);
      e->token = ffelex_token_use (decimal);
    }

  switch (exp_letter)
    {
#if !FFETARGET_okREALQUAD
    case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
      if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
	{
	  ffebad_here (0, ffelex_token_where_line (e->token),
		       ffelex_token_where_column (e->token));
	  ffebad_finish ();
	}
      goto match_d;		/* The FFESRC_CASE_* macros don't
				   allow fall-through! */
#endif

    case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
      e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
      ffebld_set_info (e->u.operand,
	     ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
			  0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
      break;

    case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
      e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
      ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
			 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
		       FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
      break;

#if FFETARGET_okREALQUAD
    case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
      e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
      ffebld_set_info (e->u.operand,
	       ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
			    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
      break;
#endif

    case 'I':	/* Make an integer. */
      e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
					(ffeexpr_tokens_[0]));
      ffebld_set_info (e->u.operand,
		       ffeinfo_new (FFEINFO_basictypeINTEGER,
				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
				    FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
				    FFETARGET_charactersizeNONE));
      break;

    default:
    no_match:			/* :::::::::::::::::::: */
      assert ("Lost the exponent letter!" == NULL);
    }

  ffeexpr_exprstack_push_operand_ (e);
}

/* Just like ffesymbol_declare_local, except performs any implicit info
   assignment necessary.  */

static ffesymbol
ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
{
  ffesymbol s;
  ffeinfoKind k;
  bool bad;

  s = ffesymbol_declare_local (t, maybe_intrin);

  switch (ffeexpr_context_outer_ (ffeexpr_stack_))
    /* Special-case these since they can involve a different concept
       of "state" (in the stmtfunc name space).  */
    {
    case FFEEXPR_contextDATAIMPDOINDEX_:
    case FFEEXPR_contextDATAIMPDOCTRL_:
      if (ffeexpr_context_outer_ (ffeexpr_stack_)
	  == FFEEXPR_contextDATAIMPDOINDEX_)
	s = ffeexpr_sym_impdoitem_ (s, t);
      else
	if (ffeexpr_stack_->is_rhs)
	  s = ffeexpr_sym_impdoitem_ (s, t);
	else
	  s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
      bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
	|| ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
	    && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
      if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
	ffesymbol_error (s, t);
      return s;

    default:
      break;
    }

  switch ((ffesymbol_sfdummyparent (s) == NULL)
	  ? ffesymbol_state (s)
	  : FFESYMBOL_stateUNDERSTOOD)
    {
    case FFESYMBOL_stateNONE:	/* Before first exec, not seen in expr
				   context. */
      if (!ffest_seen_first_exec ())
	goto seen;		/* :::::::::::::::::::: */
      /* Fall through. */
    case FFESYMBOL_stateUNCERTAIN:	/* Unseen since first exec. */
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextSUBROUTINEREF:
	  s = ffeexpr_sym_lhs_call_ (s, t);
	  break;

	case FFEEXPR_contextFILEEXTFUNC:
	  s = ffeexpr_sym_lhs_extfunc_ (s, t);
	  break;

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  /* Fall through. */
	case FFEEXPR_contextACTUALARG_:
	  s = ffeexpr_sym_rhs_actualarg_ (s, t);
	  break;

	case FFEEXPR_contextDATA:
	  if (ffeexpr_stack_->is_rhs)
	    s = ffeexpr_sym_rhs_let_ (s, t);
	  else
	    s = ffeexpr_sym_lhs_data_ (s, t);
	  break;

	case FFEEXPR_contextDATAIMPDOITEM_:
	  s = ffeexpr_sym_lhs_data_ (s, t);
	  break;

	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  /* Fall through. */
	case FFEEXPR_contextLET:
	case FFEEXPR_contextPAREN_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextASSIGN:
	case FFEEXPR_contextIOLIST:
	case FFEEXPR_contextIOLISTDF:
	case FFEEXPR_contextDO:
	case FFEEXPR_contextDOWHILE:
	case FFEEXPR_contextAGOTO:
	case FFEEXPR_contextCGOTO:
	case FFEEXPR_contextIF:
	case FFEEXPR_contextARITHIF:
	case FFEEXPR_contextFORMAT:
	case FFEEXPR_contextSTOP:
	case FFEEXPR_contextRETURN:
	case FFEEXPR_contextSELECTCASE:
	case FFEEXPR_contextCASE:
	case FFEEXPR_contextFILEASSOC:
	case FFEEXPR_contextFILEINT:
	case FFEEXPR_contextFILEDFINT:
	case FFEEXPR_contextFILELOG:
	case FFEEXPR_contextFILENUM:
	case FFEEXPR_contextFILENUMAMBIG:
	case FFEEXPR_contextFILECHAR:
	case FFEEXPR_contextFILENUMCHAR:
	case FFEEXPR_contextFILEDFCHAR:
	case FFEEXPR_contextFILEKEY:
	case FFEEXPR_contextFILEUNIT:
	case FFEEXPR_contextFILEUNIT_DF:
	case FFEEXPR_contextFILEUNITAMBIG:
	case FFEEXPR_contextFILEFORMAT:
	case FFEEXPR_contextFILENAMELIST:
	case FFEEXPR_contextFILEVXTCODE:
	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextIMPDOITEM_:
	case FFEEXPR_contextIMPDOITEMDF_:
	case FFEEXPR_contextIMPDOCTRL_:
	case FFEEXPR_contextLOC_:
	  if (ffeexpr_stack_->is_rhs)
	    s = ffeexpr_sym_rhs_let_ (s, t);
	  else
	    s = ffeexpr_sym_lhs_let_ (s, t);
	  break;

	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextEQUIVALENCE:
	case FFEEXPR_contextINCLUDE:
	case FFEEXPR_contextPARAMETER:
	case FFEEXPR_contextDIMLIST:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  break;		/* Will turn into errors below. */

	default:
	  ffesymbol_error (s, t);
	  break;
	}
      /* Fall through. */
    case FFESYMBOL_stateUNDERSTOOD:	/* Nothing much more to learn. */
    understood:		/* :::::::::::::::::::: */
      k = ffesymbol_kind (s);
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextSUBROUTINEREF:
	  bad = ((k != FFEINFO_kindSUBROUTINE)
		 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
		     || (k != FFEINFO_kindNONE)));
	  break;

	case FFEEXPR_contextFILEEXTFUNC:
	  bad = (k != FFEINFO_kindFUNCTION)
	    || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
	  break;

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextACTUALARG_:
	  switch (k)
	    {
	    case FFEINFO_kindENTITY:
	      bad = FALSE;
	      break;

	    case FFEINFO_kindFUNCTION:
	    case FFEINFO_kindSUBROUTINE:
	      bad
		= ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
		   && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
		   && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
		       || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
	      break;

	    case FFEINFO_kindNONE:
	      if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
		{
		  bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
		  break;
		}

	      /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
		 and in the former case, attrsTYPE is set, so we
		 see this as an error as we should, since CHAR*(*)
		 cannot be actually referenced in a main/block data
		 program unit.  */

	      if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
					  | FFESYMBOL_attrsEXTERNAL
					  | FFESYMBOL_attrsTYPE))
		  == FFESYMBOL_attrsEXTERNAL)
		bad = FALSE;
	      else
		bad = TRUE;
	      break;

	    default:
	      bad = TRUE;
	      break;
	    }
	  break;

	case FFEEXPR_contextDATA:
	  if (ffeexpr_stack_->is_rhs)
	    bad = (k != FFEINFO_kindENTITY)
	      || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
	  else
	    bad = (k != FFEINFO_kindENTITY)
	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
		  && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
		  && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
	  break;

	case FFEEXPR_contextDATAIMPDOITEM_:
	  bad = TRUE;		/* Unadorned item never valid. */
	  break;

	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextLET:
	case FFEEXPR_contextPAREN_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextASSIGN:
	case FFEEXPR_contextIOLIST:
	case FFEEXPR_contextIOLISTDF:
	case FFEEXPR_contextDO:
	case FFEEXPR_contextDOWHILE:
	case FFEEXPR_contextAGOTO:
	case FFEEXPR_contextCGOTO:
	case FFEEXPR_contextIF:
	case FFEEXPR_contextARITHIF:
	case FFEEXPR_contextFORMAT:
	case FFEEXPR_contextSTOP:
	case FFEEXPR_contextRETURN:
	case FFEEXPR_contextSELECTCASE:
	case FFEEXPR_contextCASE:
	case FFEEXPR_contextFILEASSOC:
	case FFEEXPR_contextFILEINT:
	case FFEEXPR_contextFILEDFINT:
	case FFEEXPR_contextFILELOG:
	case FFEEXPR_contextFILENUM:
	case FFEEXPR_contextFILENUMAMBIG:
	case FFEEXPR_contextFILECHAR:
	case FFEEXPR_contextFILENUMCHAR:
	case FFEEXPR_contextFILEDFCHAR:
	case FFEEXPR_contextFILEKEY:
	case FFEEXPR_contextFILEUNIT:
	case FFEEXPR_contextFILEUNIT_DF:
	case FFEEXPR_contextFILEUNITAMBIG:
	case FFEEXPR_contextFILEFORMAT:
	case FFEEXPR_contextFILENAMELIST:
	case FFEEXPR_contextFILEVXTCODE:
	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextIMPDOITEM_:
	case FFEEXPR_contextIMPDOITEMDF_:
	case FFEEXPR_contextIMPDOCTRL_:
	case FFEEXPR_contextLOC_:
	  bad = (k != FFEINFO_kindENTITY);	/* This catches "SUBROUTINE
						   X(A);EXTERNAL A;CALL
						   Y(A);B=A", for example. */
	  break;

	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextEQUIVALENCE:
	case FFEEXPR_contextPARAMETER:
	case FFEEXPR_contextDIMLIST:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  bad = (k != FFEINFO_kindENTITY)
	    || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
	  break;

	case FFEEXPR_contextINCLUDE:
	  bad = TRUE;
	  break;

	default:
	  bad = TRUE;
	  break;
	}
      if (bad && (k != FFEINFO_kindANY))
	ffesymbol_error (s, t);
      return s;

    case FFESYMBOL_stateSEEN:	/* Seen but not yet in exec portion. */
    seen:			/* :::::::::::::::::::: */
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextPARAMETER:
	  if (ffeexpr_stack_->is_rhs)
	    ffesymbol_error (s, t);
	  else
	    s = ffeexpr_sym_lhs_parameter_ (s, t);
	  break;

	case FFEEXPR_contextDATA:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  if (ffeexpr_stack_->is_rhs)
	    ffesymbol_error (s, t);
	  else
	    s = ffeexpr_sym_lhs_data_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	case FFEEXPR_contextDATAIMPDOITEM_:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  s = ffeexpr_sym_lhs_data_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	case FFEEXPR_contextEQUIVALENCE:
	  s = ffeexpr_sym_lhs_equivalence_ (s, t);
	  break;

	case FFEEXPR_contextDIMLIST:
	  s = ffeexpr_sym_rhs_dimlist_ (s, t);
	  break;

	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  ffesymbol_error (s, t);
	  break;

	case FFEEXPR_contextINCLUDE:
	  ffesymbol_error (s, t);
	  break;

	case FFEEXPR_contextACTUALARG_:	/* E.g. I in REAL A(Y(I)). */
	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  s = ffeexpr_sym_rhs_actualarg_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	  assert (ffeexpr_stack_->is_rhs);
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  s = ffeexpr_sym_rhs_let_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	default:
	  ffesymbol_error (s, t);
	  break;
	}
      return s;

    default:
      assert ("bad symbol state" == NULL);
      return NULL;
      break;
    }
}

/* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
   Could be found via the "statement-function" name space (in which case
   it should become an iterator) or the local name space (in which case
   it should be either a named constant, or a variable that will have an
   sfunc name space sibling that should become an iterator).  */

static ffesymbol
ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffesymbolState ss;
  ffesymbolState ns;
  ffeinfoKind kind;
  ffeinfoWhere where;

  ss = ffesymbol_state (sp);

  if (ffesymbol_sfdummyparent (sp) != NULL)
    {				/* Have symbol in sfunc name space. */
      switch (ss)
	{
	case FFESYMBOL_stateNONE:	/* Used as iterator already. */
	  if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
	    ffesymbol_error (sp, t);	/* Can't use dead iterator. */
	  else
	    {			/* Can use dead iterator because we're at at
				   least an innermore (higher-numbered) level
				   than the iterator's outermost
				   (lowest-numbered) level. */
	      ffesymbol_signal_change (sp);
	      ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
	      ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
	      ffesymbol_signal_unreported (sp);
	    }
	  break;

	case FFESYMBOL_stateSEEN:	/* Seen already in this or other
					   implied-DO.  Set symbol level
					   number to outermost value, as that
					   tells us we can see it as iterator
					   at that level at the innermost. */
	  if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
	    {
	      ffesymbol_signal_change (sp);
	      ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
	      ffesymbol_signal_unreported (sp);
	    }
	  break;

	case FFESYMBOL_stateUNCERTAIN:	/* Iterator. */
	  assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
	  ffesymbol_error (sp, t);	/* (,,,I=I,10). */
	  break;

	case FFESYMBOL_stateUNDERSTOOD:
	  break;		/* ANY. */

	default:
	  assert ("Foo Bar!!" == NULL);
	  break;
	}

      return sp;
    }

  /* Got symbol in local name space, so we haven't seen it in impdo yet.
     First, if it is brand-new and we're in executable statements, set the
     attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
     Second, if it is now a constant (PARAMETER), then just return it, it
     can't be an implied-do iterator.  If it is understood, complain if it is
     not a valid variable, but make the inner name space iterator anyway and
     return that.  If it is not understood, improve understanding of the
     symbol accordingly, complain accordingly, in either case make the inner
     name space iterator and return that.  */

  sa = ffesymbol_attrs (sp);

  if (ffesymbol_state_is_specable (ss)
      && ffest_seen_first_exec ())
    {
      assert (sa == FFESYMBOL_attrsetNONE);
      ffesymbol_signal_change (sp);
      ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
      ffesymbol_resolve_intrin (sp);
      if (ffeimplic_establish_symbol (sp))
	ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
      else
	ffesymbol_error (sp, t);

      /* After the exec transition, the state will either be UNCERTAIN (could
	 be a dummy or local var) or UNDERSTOOD (local var, because this is a
	 PROGRAM/BLOCKDATA program unit).  */

      sp = ffecom_sym_exec_transition (sp);
      sa = ffesymbol_attrs (sp);
      ss = ffesymbol_state (sp);
    }

  ns = ss;
  kind = ffesymbol_kind (sp);
  where = ffesymbol_where (sp);

  if (ss == FFESYMBOL_stateUNDERSTOOD)
    {
      if (kind != FFEINFO_kindENTITY)
	ffesymbol_error (sp, t);
      if (where == FFEINFO_whereCONSTANT)
	return sp;
    }
  else
    {
      /* Enhance understanding of local symbol.  This used to imply exec
	 transition, but that doesn't seem necessary, since the local symbol
	 doesn't actually get put into an ffebld tree here -- we just learn
	 more about it, just like when we see a local symbol's name in the
	 dummy-arg list of a statement function.  */

      if (ss != FFESYMBOL_stateUNCERTAIN)
	{
	  /* Figure out what kind of object we've got based on previous
	     declarations of or references to the object. */

	  ns = FFESYMBOL_stateSEEN;

	  if (sa & FFESYMBOL_attrsANY)
	    na = sa;
	  else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
			    | FFESYMBOL_attrsANY
			    | FFESYMBOL_attrsCOMMON
			    | FFESYMBOL_attrsDUMMY
			    | FFESYMBOL_attrsEQUIV
			    | FFESYMBOL_attrsINIT
			    | FFESYMBOL_attrsNAMELIST
			    | FFESYMBOL_attrsRESULT
			    | FFESYMBOL_attrsSAVE
			    | FFESYMBOL_attrsSFARG
			    | FFESYMBOL_attrsTYPE)))
	    na = sa | FFESYMBOL_attrsSFARG;
	  else
	    na = FFESYMBOL_attrsetNONE;
	}
      else
	{			/* stateUNCERTAIN. */
	  na = sa | FFESYMBOL_attrsSFARG;
	  ns = FFESYMBOL_stateUNDERSTOOD;

	  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
			   | FFESYMBOL_attrsADJUSTABLE
			   | FFESYMBOL_attrsANYLEN
			   | FFESYMBOL_attrsARRAY
			   | FFESYMBOL_attrsDUMMY
			   | FFESYMBOL_attrsEXTERNAL
			   | FFESYMBOL_attrsSFARG
			   | FFESYMBOL_attrsTYPE)));

	  if (sa & FFESYMBOL_attrsEXTERNAL)
	    {
	      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
			       | FFESYMBOL_attrsDUMMY
			       | FFESYMBOL_attrsEXTERNAL
			       | FFESYMBOL_attrsTYPE)));

	      na = FFESYMBOL_attrsetNONE;
	    }
	  else if (sa & FFESYMBOL_attrsDUMMY)
	    {
	      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
	      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
			       | FFESYMBOL_attrsEXTERNAL
			       | FFESYMBOL_attrsTYPE)));

	      kind = FFEINFO_kindENTITY;
	    }
	  else if (sa & FFESYMBOL_attrsARRAY)
	    {
	      assert (!(sa & ~(FFESYMBOL_attrsARRAY
			       | FFESYMBOL_attrsADJUSTABLE
			       | FFESYMBOL_attrsTYPE)));

	      na = FFESYMBOL_attrsetNONE;
	    }
	  else if (sa & FFESYMBOL_attrsSFARG)
	    {
	      assert (!(sa & ~(FFESYMBOL_attrsSFARG
			       | FFESYMBOL_attrsTYPE)));

	      ns = FFESYMBOL_stateUNCERTAIN;
	    }
	  else if (sa & FFESYMBOL_attrsTYPE)
	    {
	      assert (!(sa & (FFESYMBOL_attrsARRAY
			      | FFESYMBOL_attrsDUMMY
			      | FFESYMBOL_attrsEXTERNAL
			      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
	      assert (!(sa & ~(FFESYMBOL_attrsTYPE
			       | FFESYMBOL_attrsADJUSTABLE
			       | FFESYMBOL_attrsANYLEN
			       | FFESYMBOL_attrsARRAY
			       | FFESYMBOL_attrsDUMMY
			       | FFESYMBOL_attrsEXTERNAL
			       | FFESYMBOL_attrsSFARG)));

	      kind = FFEINFO_kindENTITY;

	      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
		na = FFESYMBOL_attrsetNONE;
	      else if (ffest_is_entry_valid ())
		ns = FFESYMBOL_stateUNCERTAIN;	/* Could be DUMMY or LOCAL. */
	      else
		where = FFEINFO_whereLOCAL;
	    }
	  else
	    na = FFESYMBOL_attrsetNONE;	/* Error. */
	}

      /* Now see what we've got for a new object: NONE means a new error
	 cropped up; ANY means an old error to be ignored; otherwise,
	 everything's ok, update the object (symbol) and continue on. */

      if (na == FFESYMBOL_attrsetNONE)
	ffesymbol_error (sp, t);
      else if (!(na & FFESYMBOL_attrsANY))
	{
	  ffesymbol_signal_change (sp);	/* May need to back up to previous
					   version. */
	  if (!ffeimplic_establish_symbol (sp))
	    ffesymbol_error (sp, t);
	  else
	    {
	      ffesymbol_set_info (sp,
				  ffeinfo_new (ffesymbol_basictype (sp),
					       ffesymbol_kindtype (sp),
					       ffesymbol_rank (sp),
					       kind,
					       where,
					       ffesymbol_size (sp)));
	      ffesymbol_set_attrs (sp, na);
	      ffesymbol_set_state (sp, ns);
	      ffesymbol_resolve_intrin (sp);
	      if (!ffesymbol_state_is_specable (ns))
		sp = ffecom_sym_learned (sp);
	      ffesymbol_signal_unreported (sp);	/* For debugging purposes. */
	    }
	}
    }

  /* Here we create the sfunc-name-space symbol representing what should
     become an iterator in this name space at this or an outermore (lower-
     numbered) expression level, else the implied-DO construct is in error.  */

  s = ffesymbol_declare_sfdummy (t);	/* Sets maxentrynum to 0 for new obj;
					   also sets sfa_dummy_parent to
					   parent symbol. */
  assert (sp == ffesymbol_sfdummyparent (s));

  ffesymbol_signal_change (s);
  ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
  ffesymbol_set_info (s,
		      ffeinfo_new (FFEINFO_basictypeINTEGER,
				   FFEINFO_kindtypeINTEGERDEFAULT,
				   0,
				   FFEINFO_kindENTITY,
				   FFEINFO_whereIMMEDIATE,
				   FFETARGET_charactersizeNONE));
  ffesymbol_signal_unreported (s);

  if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
       && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
      || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
	  && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
    ffesymbol_error (s, t);

  return s;
}

/* Have FOO in CALL FOO.  Local name space, executable context only.  */

static ffesymbol
ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;
  bool error = FALSE;

  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));

  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	error = TRUE;
      else
	/* Not TYPE. */
	{
	  kind = FFEINFO_kindSUBROUTINE;

	  if (sa & FFESYMBOL_attrsDUMMY)
	    ;			/* Not TYPE. */
	  else if (sa & FFESYMBOL_attrsACTUALARG)
	    ;			/* Not DUMMY or TYPE. */
	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
	    where = FFEINFO_whereGLOBAL;
	}
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	error = TRUE;
      else
	kind = FFEINFO_kindSUBROUTINE;
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      error = TRUE;
    }
  else if (sa == FFESYMBOL_attrsetNONE)
    {
      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);

      if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
				  &gen, &spec, &imp))
	{
	  ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
	  ffesymbol_set_generic (s, gen);
	  ffesymbol_set_specific (s, spec);
	  ffesymbol_set_implementation (s, imp);
	  ffesymbol_set_info (s,
			      ffeinfo_new (FFEINFO_basictypeNONE,
					   FFEINFO_kindtypeNONE,
					   0,
					   FFEINFO_kindSUBROUTINE,
					   FFEINFO_whereINTRINSIC,
					   FFETARGET_charactersizeNONE));
	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
	  ffesymbol_resolve_intrin (s);
	  ffesymbol_reference (s, t, FALSE);
	  s = ffecom_sym_learned (s);
	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */

	  return s;
	}

      kind = FFEINFO_kindSUBROUTINE;
      where = FFEINFO_whereGLOBAL;
    }
  else
    error = TRUE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (error)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,	/* SUBROUTINE. */
				       where,	/* GLOBAL or DUMMY. */
				       ffesymbol_size (s)));
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      ffesymbol_reference (s, t, FALSE);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in DATA FOO/.../.  Local name space and executable context
   only.  (This will change in the future when DATA FOO may be followed
   by COMMON FOO or even INTEGER FOO(10), etc.)  */

static ffesymbol
ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;
  bool error = FALSE;

  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));

  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsADJUSTABLE)
	error = TRUE;
      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
	error = TRUE;
      else
	{
	  kind = FFEINFO_kindENTITY;
	  where = FFEINFO_whereLOCAL;
	}
    }
  else if (sa == FFESYMBOL_attrsetNONE)
    {
      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
      kind = FFEINFO_kindENTITY;
      where = FFEINFO_whereLOCAL;
    }
  else
    error = TRUE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (error)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (!ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,	/* ENTITY. */
				       where,	/* LOCAL. */
				       ffesymbol_size (s)));
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
   EQUIVALENCE (...,BAR(FOO),...).  */

static ffesymbol
ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;

  na = sa = ffesymbol_attrs (s);
  kind = FFEINFO_kindENTITY;
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!(sa & ~(FFESYMBOL_attrsADJUSTS
	       | FFESYMBOL_attrsARRAY
	       | FFESYMBOL_attrsCOMMON
	       | FFESYMBOL_attrsEQUIV
	       | FFESYMBOL_attrsINIT
	       | FFESYMBOL_attrsNAMELIST
	       | FFESYMBOL_attrsSAVE
	       | FFESYMBOL_attrsSFARG
	       | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsEQUIV;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Don't know why we're bothering to set kind and where in this code, but
     added the following to make it complete, in case it's really important.
     Generally this is left up to symbol exec transition.  */

  if (where == FFEINFO_whereNONE)
    {
      if (na & (FFESYMBOL_attrsADJUSTS
		| FFESYMBOL_attrsCOMMON))
	where = FFEINFO_whereCOMMON;
      else if (na & FFESYMBOL_attrsSAVE)
	where = FFEINFO_whereLOCAL;
    }

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,	/* Always ENTITY. */
				       where,	/* NONE, COMMON, or LOCAL. */
				       ffesymbol_size (s)));
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_resolve_intrin (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.

   Note that I think this should be considered semantically similar to
   doing CALL XYZ(FOO), in that it should be considered like an
   ACTUALARG context.  In particular, without EXTERNAL being specified,
   it should not be allowed.  */

static ffesymbol
ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;
  bool needs_type = FALSE;
  bool error = FALSE;

  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));

  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	where = FFEINFO_whereGLOBAL;
      else
	/* Not TYPE. */
	{
	  kind = FFEINFO_kindFUNCTION;
	  needs_type = TRUE;

	  if (sa & FFESYMBOL_attrsDUMMY)
	    ;			/* Not TYPE. */
	  else if (sa & FFESYMBOL_attrsACTUALARG)
	    ;			/* Not DUMMY or TYPE. */
	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
	    where = FFEINFO_whereGLOBAL;
	}
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      kind = FFEINFO_kindFUNCTION;
      if (!(sa & FFESYMBOL_attrsTYPE))
	needs_type = TRUE;
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
	error = TRUE;
      else
	{
	  kind = FFEINFO_kindFUNCTION;
	  where = FFEINFO_whereGLOBAL;
	}
    }
  else if (sa == FFESYMBOL_attrsetNONE)
    {
      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
      kind = FFEINFO_kindFUNCTION;
      where = FFEINFO_whereGLOBAL;
      needs_type = TRUE;
    }
  else
    error = TRUE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (error)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (needs_type && !ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      if (!ffesymbol_explicitwhere (s))
	{
	  ffebad_start (FFEBAD_NEED_EXTERNAL);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (ffesymbol_text (s));
	  ffebad_finish ();
	  ffesymbol_set_explicitwhere (s, TRUE);
	}
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,	/* FUNCTION. */
				       where,	/* GLOBAL or DUMMY. */
				       ffesymbol_size (s)));
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      ffesymbol_reference (s, t, FALSE);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in DATA (stuff,FOO=1,10)/.../.  */

static ffesymbol
ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
{
  ffesymbolState ss;

  /* If the symbol isn't in the sfunc name space, pretend as though we saw a
     reference to it already within the imp-DO construct at this level, so as
     to get a symbol that is in the sfunc name space. But this is an
     erroneous construct, and should be caught elsewhere.  */

  if (ffesymbol_sfdummyparent (s) == NULL)
    {
      s = ffeexpr_sym_impdoitem_ (s, t);
      if (ffesymbol_sfdummyparent (s) == NULL)
	{			/* PARAMETER FOO...DATA (A(I),FOO=...). */
	  ffesymbol_error (s, t);
	  return s;
	}
    }

  ss = ffesymbol_state (s);

  switch (ss)
    {
    case FFESYMBOL_stateNONE:	/* Used as iterator already. */
      if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
	ffesymbol_error (s, t);	/* Can't reuse dead iterator.  F90 disallows
				   this; F77 allows it but it is a stupid
				   feature. */
      else
	{			/* Can use dead iterator because we're at at
				   least a innermore (higher-numbered) level
				   than the iterator's outermost
				   (lowest-numbered) level.  This should be
				   diagnosed later, because it means an item
				   in this list didn't reference this
				   iterator. */
#if 1
	  ffesymbol_error (s, t);	/* For now, complain. */
#else /* Someday will detect all cases where initializer doesn't reference
	 all applicable iterators, in which case reenable this code. */
	  ffesymbol_signal_change (s);
	  ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
	  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
	  ffesymbol_signal_unreported (s);
#endif
	}
      break;

    case FFESYMBOL_stateSEEN:	/* Seen already in this or other implied-DO.
				   If seen in outermore level, can't be an
				   iterator here, so complain.  If not seen
				   at current level, complain for now,
				   because that indicates something F90
				   rejects (though we currently don't detect
				   all such cases for now). */
      if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
	{
	  ffesymbol_signal_change (s);
	  ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
	  ffesymbol_signal_unreported (s);
	}
      else
	ffesymbol_error (s, t);
      break;

    case FFESYMBOL_stateUNCERTAIN:	/* Already iterator! */
      assert ("DATA implied-DO control var seen twice!!" == NULL);
      ffesymbol_error (s, t);
      break;

    case FFESYMBOL_stateUNDERSTOOD:
      break;			/* ANY. */

    default:
      assert ("Foo Bletch!!" == NULL);
      break;
    }

  return s;
}

/* Have FOO in PARAMETER (FOO=...).  */

static ffesymbol
ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;

  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & ~(FFESYMBOL_attrsANYLEN
	     | FFESYMBOL_attrsTYPE))
    {
      if (!(sa & FFESYMBOL_attrsANY))
	ffesymbol_error (s, t);
    }
  else
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (!ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       FFEINFO_kindENTITY,
				       FFEINFO_whereCONSTANT,
				       ffesymbol_size (s)));
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
   embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */

static ffesymbol
ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;
  ffesymbolState ns;
  bool needs_type = FALSE;

  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));

  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  ns = FFESYMBOL_stateUNDERSTOOD;

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	where = FFEINFO_whereGLOBAL;
      else
	/* Not TYPE. */
	{
	  ns = FFESYMBOL_stateUNCERTAIN;

	  if (sa & FFESYMBOL_attrsDUMMY)
	    assert (kind == FFEINFO_kindNONE);	/* FUNCTION, SUBROUTINE. */
	  else if (sa & FFESYMBOL_attrsACTUALARG)
	    ;			/* Not DUMMY or TYPE. */
	  else
	    /* Not ACTUALARG, DUMMY, or TYPE. */
	    {
	      assert (kind == FFEINFO_kindNONE);	/* FUNCTION, SUBROUTINE. */
	      na |= FFESYMBOL_attrsACTUALARG;
	      where = FFEINFO_whereGLOBAL;
	    }
	}
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      kind = FFEINFO_kindENTITY;
      if (!(sa & FFESYMBOL_attrsTYPE))
	needs_type = TRUE;
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      if (sa & FFESYMBOL_attrsANYLEN)
	ns = FFESYMBOL_stateNONE;
      else
	{
	  kind = FFEINFO_kindENTITY;
	  where = FFEINFO_whereLOCAL;
	}
    }
  else if (sa == FFESYMBOL_attrsetNONE)
    {
      /* New state is left empty because there isn't any state flag to
	 set for this case, and it's UNDERSTOOD after all.  */
      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
      kind = FFEINFO_kindENTITY;
      where = FFEINFO_whereLOCAL;
      needs_type = TRUE;
    }
  else
    ns = FFESYMBOL_stateNONE;	/* Error. */

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (ns == FFESYMBOL_stateNONE)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (needs_type && !ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,
				       where,
				       ffesymbol_size (s)));
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, ns);
      s = ffecom_sym_learned (s);
      ffesymbol_reference (s, t, FALSE);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
   a reference to FOO.  */

static ffesymbol
ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;

  na = sa = ffesymbol_attrs (s);
  kind = FFEINFO_kindENTITY;
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!(sa & ~(FFESYMBOL_attrsADJUSTS
	       | FFESYMBOL_attrsCOMMON
	       | FFESYMBOL_attrsDUMMY
	       | FFESYMBOL_attrsEQUIV
	       | FFESYMBOL_attrsINIT
	       | FFESYMBOL_attrsNAMELIST
	       | FFESYMBOL_attrsSFARG
	       | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsADJUSTS;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Since this symbol definitely is going into an expression (the
     dimension-list for some dummy array, presumably), figure out WHERE if
     possible.  */

  if (where == FFEINFO_whereNONE)
    {
      if (na & (FFESYMBOL_attrsCOMMON
		| FFESYMBOL_attrsEQUIV
		| FFESYMBOL_attrsINIT
		| FFESYMBOL_attrsNAMELIST))
	where = FFEINFO_whereCOMMON;
      else if (na & FFESYMBOL_attrsDUMMY)
	where = FFEINFO_whereDUMMY;
    }

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (!ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,	/* Always ENTITY. */
				       where,	/* NONE, COMMON, or DUMMY. */
				       ffesymbol_size (s)));
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_resolve_intrin (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
   XYZ = BAR(FOO), as such cases are handled elsewhere.  */

static ffesymbol
ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;
  bool error = FALSE;

  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));

  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      error = TRUE;
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      kind = FFEINFO_kindENTITY;
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      if (sa & FFESYMBOL_attrsANYLEN)
	error = TRUE;
      else
	{
	  kind = FFEINFO_kindENTITY;
	  where = FFEINFO_whereLOCAL;
	}
    }
  else if (sa == FFESYMBOL_attrsetNONE)
    {
      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
      kind = FFEINFO_kindENTITY;
      where = FFEINFO_whereLOCAL;
    }
  else
    error = TRUE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (error)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (!ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,	/* ENTITY. */
				       where,	/* LOCAL. */
				       ffesymbol_size (s)));
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand

   ffelexToken t;
   bool maybe_intrin;
   ffeexprParenType_ paren_type;
   ffesymbol s;
   s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);

   Just like ffesymbol_declare_local, except performs any implicit info
   assignment necessary, and it returns the type of the parenthesized list
   (list of function args, list of array args, or substring spec).  */

static ffesymbol
ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
				ffeexprParenType_ *paren_type)
{
  ffesymbol s;
  ffesymbolState st;		/* Effective state. */
  ffeinfoKind k;
  bool bad;

  if (maybe_intrin && ffesrc_check_symbol ())
    {				/* Knock off some easy cases. */
      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextSUBROUTINEREF:
	case FFEEXPR_contextDATA:
	case FFEEXPR_contextDATAIMPDOINDEX_:
	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextLET:
	case FFEEXPR_contextPAREN_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextIOLIST:
	case FFEEXPR_contextIOLISTDF:
	case FFEEXPR_contextDO:
	case FFEEXPR_contextDOWHILE:
	case FFEEXPR_contextACTUALARG_:
	case FFEEXPR_contextCGOTO:
	case FFEEXPR_contextIF:
	case FFEEXPR_contextARITHIF:
	case FFEEXPR_contextFORMAT:
	case FFEEXPR_contextSTOP:
	case FFEEXPR_contextRETURN:
	case FFEEXPR_contextSELECTCASE:
	case FFEEXPR_contextCASE:
	case FFEEXPR_contextFILEASSOC:
	case FFEEXPR_contextFILEINT:
	case FFEEXPR_contextFILEDFINT:
	case FFEEXPR_contextFILELOG:
	case FFEEXPR_contextFILENUM:
	case FFEEXPR_contextFILENUMAMBIG:
	case FFEEXPR_contextFILECHAR:
	case FFEEXPR_contextFILENUMCHAR:
	case FFEEXPR_contextFILEDFCHAR:
	case FFEEXPR_contextFILEKEY:
	case FFEEXPR_contextFILEUNIT:
	case FFEEXPR_contextFILEUNIT_DF:
	case FFEEXPR_contextFILEUNITAMBIG:
	case FFEEXPR_contextFILEFORMAT:
	case FFEEXPR_contextFILENAMELIST:
	case FFEEXPR_contextFILEVXTCODE:
	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextIMPDOITEM_:
	case FFEEXPR_contextIMPDOITEMDF_:
	case FFEEXPR_contextIMPDOCTRL_:
	case FFEEXPR_contextDATAIMPDOCTRL_:
	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextPARAMETER:
	case FFEEXPR_contextDIMLIST:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  break;		/* These could be intrinsic invocations. */

	case FFEEXPR_contextAGOTO:
	case FFEEXPR_contextFILEFORMATNML:
	case FFEEXPR_contextALLOCATE:
	case FFEEXPR_contextDEALLOCATE:
	case FFEEXPR_contextHEAPSTAT:
	case FFEEXPR_contextNULLIFY:
	case FFEEXPR_contextINCLUDE:
	case FFEEXPR_contextDATAIMPDOITEM_:
	case FFEEXPR_contextLOC_:
	case FFEEXPR_contextINDEXORACTUALARG_:
	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	case FFEEXPR_contextPARENFILENUM_:
	case FFEEXPR_contextPARENFILEUNIT_:
	  maybe_intrin = FALSE;
	  break;		/* Can't be intrinsic invocation. */

	default:
	  assert ("blah! blah! waaauuggh!" == NULL);
	  break;
	}
    }

  s = ffesymbol_declare_local (t, maybe_intrin);

  switch (ffeexpr_context_outer_ (ffeexpr_stack_))
    /* Special-case these since they can involve a different concept
       of "state" (in the stmtfunc name space).  */
    {
    case FFEEXPR_contextDATAIMPDOINDEX_:
    case FFEEXPR_contextDATAIMPDOCTRL_:
      if (ffeexpr_context_outer_ (ffeexpr_stack_)
	  == FFEEXPR_contextDATAIMPDOINDEX_)
	s = ffeexpr_sym_impdoitem_ (s, t);
      else
	if (ffeexpr_stack_->is_rhs)
	  s = ffeexpr_sym_impdoitem_ (s, t);
	else
	  s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
      if (ffesymbol_kind (s) != FFEINFO_kindANY)
	ffesymbol_error (s, t);
      return s;

    default:
      break;
    }

  switch ((ffesymbol_sfdummyparent (s) == NULL)
	  ? ffesymbol_state (s)
	  : FFESYMBOL_stateUNDERSTOOD)
    {
    case FFESYMBOL_stateNONE:	/* Before first exec, not seen in expr
				   context. */
      if (!ffest_seen_first_exec ())
	goto seen;		/* :::::::::::::::::::: */
      /* Fall through. */
    case FFESYMBOL_stateUNCERTAIN:	/* Unseen since first exec. */
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextSUBROUTINEREF:
	  s = ffeexpr_sym_lhs_call_ (s, t);	/* "CALL FOO"=="CALL
						   FOO(...)". */
	  break;

	case FFEEXPR_contextDATA:
	  if (ffeexpr_stack_->is_rhs)
	    s = ffeexpr_sym_rhs_let_ (s, t);
	  else
	    s = ffeexpr_sym_lhs_data_ (s, t);
	  break;

	case FFEEXPR_contextDATAIMPDOITEM_:
	  s = ffeexpr_sym_lhs_data_ (s, t);
	  break;

	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  /* Fall through. */
	case FFEEXPR_contextLET:
	case FFEEXPR_contextPAREN_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextIOLIST:
	case FFEEXPR_contextIOLISTDF:
	case FFEEXPR_contextDO:
	case FFEEXPR_contextDOWHILE:
	case FFEEXPR_contextACTUALARG_:
	case FFEEXPR_contextCGOTO:
	case FFEEXPR_contextIF:
	case FFEEXPR_contextARITHIF:
	case FFEEXPR_contextFORMAT:
	case FFEEXPR_contextSTOP:
	case FFEEXPR_contextRETURN:
	case FFEEXPR_contextSELECTCASE:
	case FFEEXPR_contextCASE:
	case FFEEXPR_contextFILEASSOC:
	case FFEEXPR_contextFILEINT:
	case FFEEXPR_contextFILEDFINT:
	case FFEEXPR_contextFILELOG:
	case FFEEXPR_contextFILENUM:
	case FFEEXPR_contextFILENUMAMBIG:
	case FFEEXPR_contextFILECHAR:
	case FFEEXPR_contextFILENUMCHAR:
	case FFEEXPR_contextFILEDFCHAR:
	case FFEEXPR_contextFILEKEY:
	case FFEEXPR_contextFILEUNIT:
	case FFEEXPR_contextFILEUNIT_DF:
	case FFEEXPR_contextFILEUNITAMBIG:
	case FFEEXPR_contextFILEFORMAT:
	case FFEEXPR_contextFILENAMELIST:
	case FFEEXPR_contextFILEVXTCODE:
	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextIMPDOITEM_:
	case FFEEXPR_contextIMPDOITEMDF_:
	case FFEEXPR_contextIMPDOCTRL_:
	case FFEEXPR_contextLOC_:
	  if (ffeexpr_stack_->is_rhs)
	    s = ffeexpr_paren_rhs_let_ (s, t);
	  else
	    s = ffeexpr_paren_lhs_let_ (s, t);
	  break;

	case FFEEXPR_contextASSIGN:
	case FFEEXPR_contextAGOTO:
	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextEQUIVALENCE:
	case FFEEXPR_contextINCLUDE:
	case FFEEXPR_contextPARAMETER:
	case FFEEXPR_contextDIMLIST:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  break;		/* Will turn into errors below. */

	default:
	  ffesymbol_error (s, t);
	  break;
	}
      /* Fall through. */
    case FFESYMBOL_stateUNDERSTOOD:	/* Nothing much more to learn. */
    understood:		/* :::::::::::::::::::: */

      /* State might have changed, update it.  */
      st = ((ffesymbol_sfdummyparent (s) == NULL)
	    ? ffesymbol_state (s)
	    : FFESYMBOL_stateUNDERSTOOD);

      k = ffesymbol_kind (s);
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextSUBROUTINEREF:
	  bad = ((k != FFEINFO_kindSUBROUTINE)
		 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
		     || (k != FFEINFO_kindNONE)));
	  break;

	case FFEEXPR_contextDATA:
	  if (ffeexpr_stack_->is_rhs)
	    bad = (k != FFEINFO_kindENTITY)
	      || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
	  else
	    bad = (k != FFEINFO_kindENTITY)
	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
		  && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
		  && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
	  break;

	case FFEEXPR_contextDATAIMPDOITEM_:
	  bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
	    || ((ffesymbol_where (s) != FFEINFO_whereNONE)
		&& (ffesymbol_where (s) != FFEINFO_whereLOCAL)
		&& (ffesymbol_where (s) != FFEINFO_whereCOMMON));
	  break;

	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextLET:
	case FFEEXPR_contextPAREN_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextIOLIST:
	case FFEEXPR_contextIOLISTDF:
	case FFEEXPR_contextDO:
	case FFEEXPR_contextDOWHILE:
	case FFEEXPR_contextACTUALARG_:
	case FFEEXPR_contextCGOTO:
	case FFEEXPR_contextIF:
	case FFEEXPR_contextARITHIF:
	case FFEEXPR_contextFORMAT:
	case FFEEXPR_contextSTOP:
	case FFEEXPR_contextRETURN:
	case FFEEXPR_contextSELECTCASE:
	case FFEEXPR_contextCASE:
	case FFEEXPR_contextFILEASSOC:
	case FFEEXPR_contextFILEINT:
	case FFEEXPR_contextFILEDFINT:
	case FFEEXPR_contextFILELOG:
	case FFEEXPR_contextFILENUM:
	case FFEEXPR_contextFILENUMAMBIG:
	case FFEEXPR_contextFILECHAR:
	case FFEEXPR_contextFILENUMCHAR:
	case FFEEXPR_contextFILEDFCHAR:
	case FFEEXPR_contextFILEKEY:
	case FFEEXPR_contextFILEUNIT:
	case FFEEXPR_contextFILEUNIT_DF:
	case FFEEXPR_contextFILEUNITAMBIG:
	case FFEEXPR_contextFILEFORMAT:
	case FFEEXPR_contextFILENAMELIST:
	case FFEEXPR_contextFILEVXTCODE:
	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextIMPDOITEM_:
	case FFEEXPR_contextIMPDOITEMDF_:
	case FFEEXPR_contextIMPDOCTRL_:
	case FFEEXPR_contextLOC_:
	  bad = FALSE;		/* Let paren-switch handle the cases. */
	  break;

	case FFEEXPR_contextASSIGN:
	case FFEEXPR_contextAGOTO:
	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextEQUIVALENCE:
	case FFEEXPR_contextPARAMETER:
	case FFEEXPR_contextDIMLIST:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  bad = (k != FFEINFO_kindENTITY)
	    || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
	  break;

	case FFEEXPR_contextINCLUDE:
	  bad = TRUE;
	  break;

	default:
	  bad = TRUE;
	  break;
	}

      switch (bad ? FFEINFO_kindANY : k)
	{
	case FFEINFO_kindNONE:	/* Case "CHARACTER X,Y; Y=X(?". */
	  if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
	    {
	      if (ffeexpr_context_outer_ (ffeexpr_stack_)
		  == FFEEXPR_contextSUBROUTINEREF)
		*paren_type = FFEEXPR_parentypeSUBROUTINE_;
	      else
		*paren_type = FFEEXPR_parentypeFUNCTION_;
	      break;
	    }
	  if (st == FFESYMBOL_stateUNDERSTOOD)
	    {
	      bad = TRUE;
	      *paren_type = FFEEXPR_parentypeANY_;
	    }
	  else
	    *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
	  break;

	case FFEINFO_kindFUNCTION:
	  *paren_type = FFEEXPR_parentypeFUNCTION_;
	  switch (ffesymbol_where (s))
	    {
	    case FFEINFO_whereLOCAL:
	      bad = TRUE;	/* Attempt to recurse! */
	      break;

	    case FFEINFO_whereCONSTANT:
	      bad = ((ffesymbol_sfexpr (s) == NULL)
		     || (ffebld_op (ffesymbol_sfexpr (s))
			 == FFEBLD_opANY));	/* Attempt to recurse! */
	      break;

	    default:
	      break;
	    }
	  break;

	case FFEINFO_kindSUBROUTINE:
	  if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
	      || (ffeexpr_stack_->previous != NULL))
	    {
	      bad = TRUE;
	      *paren_type = FFEEXPR_parentypeANY_;
	      break;
	    }

	  *paren_type = FFEEXPR_parentypeSUBROUTINE_;
	  switch (ffesymbol_where (s))
	    {
	    case FFEINFO_whereLOCAL:
	    case FFEINFO_whereCONSTANT:
	      bad = TRUE;	/* Attempt to recurse! */
	      break;

	    default:
	      break;
	    }
	  break;

	case FFEINFO_kindENTITY:
	  if (ffesymbol_rank (s) == 0)
	    {
	      if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
		*paren_type = FFEEXPR_parentypeSUBSTRING_;
	      else
		{
		  bad = TRUE;
		  *paren_type = FFEEXPR_parentypeANY_;
		}
	    }
	  else
	    *paren_type = FFEEXPR_parentypeARRAY_;
	  break;

	default:
	case FFEINFO_kindANY:
	  bad = TRUE;
	  *paren_type = FFEEXPR_parentypeANY_;
	  break;
	}

      if (bad)
	{
	  if (k == FFEINFO_kindANY)
	    ffest_shutdown ();
	  else
	    ffesymbol_error (s, t);
	}

      return s;

    case FFESYMBOL_stateSEEN:	/* Seen but not yet in exec portion. */
    seen:			/* :::::::::::::::::::: */
      bad = TRUE;
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextPARAMETER:
	  if (ffeexpr_stack_->is_rhs)
	    ffesymbol_error (s, t);
	  else
	    s = ffeexpr_sym_lhs_parameter_ (s, t);
	  break;

	case FFEEXPR_contextDATA:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  if (ffeexpr_stack_->is_rhs)
	    ffesymbol_error (s, t);
	  else
	    s = ffeexpr_sym_lhs_data_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	case FFEEXPR_contextDATAIMPDOITEM_:
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  s = ffeexpr_sym_lhs_data_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	case FFEEXPR_contextEQUIVALENCE:
	  s = ffeexpr_sym_lhs_equivalence_ (s, t);
	  bad = FALSE;
	  break;

	case FFEEXPR_contextDIMLIST:
	  s = ffeexpr_sym_rhs_dimlist_ (s, t);
	  break;

	case FFEEXPR_contextCHARACTERSIZE:
	case FFEEXPR_contextKINDTYPE:
	case FFEEXPR_contextDIMLISTCOMMON:
	case FFEEXPR_contextINITVAL:
	case FFEEXPR_contextEQVINDEX_:
	  break;

	case FFEEXPR_contextINCLUDE:
	  break;

	case FFEEXPR_contextINDEX_:
	case FFEEXPR_contextACTUALARGEXPR_:
	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	  assert (ffeexpr_stack_->is_rhs);
	  s = ffecom_sym_exec_transition (s);
	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
	    goto understood;	/* :::::::::::::::::::: */
	  s = ffeexpr_paren_rhs_let_ (s, t);
	  goto understood;	/* :::::::::::::::::::: */

	default:
	  break;
	}
      k = ffesymbol_kind (s);
      switch (bad ? FFEINFO_kindANY : k)
	{
	case FFEINFO_kindNONE:	/* Case "CHARACTER X,Y; Y=X(?". */
	  *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
	  break;

	case FFEINFO_kindFUNCTION:
	  *paren_type = FFEEXPR_parentypeFUNCTION_;
	  switch (ffesymbol_where (s))
	    {
	    case FFEINFO_whereLOCAL:
	      bad = TRUE;	/* Attempt to recurse! */
	      break;

	    case FFEINFO_whereCONSTANT:
	      bad = ((ffesymbol_sfexpr (s) == NULL)
		     || (ffebld_op (ffesymbol_sfexpr (s))
			 == FFEBLD_opANY));	/* Attempt to recurse! */
	      break;

	    default:
	      break;
	    }
	  break;

	case FFEINFO_kindSUBROUTINE:
	  *paren_type = FFEEXPR_parentypeANY_;
	  bad = TRUE;		/* Cannot possibly be in
				   contextSUBROUTINEREF. */
	  break;

	case FFEINFO_kindENTITY:
	  if (ffesymbol_rank (s) == 0)
	    {
	      if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
		*paren_type = FFEEXPR_parentypeEQUIVALENCE_;
	      else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
		*paren_type = FFEEXPR_parentypeSUBSTRING_;
	      else
		{
		  bad = TRUE;
		  *paren_type = FFEEXPR_parentypeANY_;
		}
	    }
	  else
	    *paren_type = FFEEXPR_parentypeARRAY_;
	  break;

	default:
	case FFEINFO_kindANY:
	  bad = TRUE;
	  *paren_type = FFEEXPR_parentypeANY_;
	  break;
	}

      if (bad)
	{
	  if (k == FFEINFO_kindANY)
	    ffest_shutdown ();
	  else
	    ffesymbol_error (s, t);
	}

      return s;

    default:
      assert ("bad symbol state" == NULL);
      return NULL;
    }
}

/* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */

static ffesymbol
ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
{
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeinfoKind kind;
  ffeinfoWhere where;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;
  bool maybe_ambig = FALSE;
  bool error = FALSE;

  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));

  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	where = FFEINFO_whereGLOBAL;
      else
	/* Not TYPE. */
	{
	  kind = FFEINFO_kindFUNCTION;

	  if (sa & FFESYMBOL_attrsDUMMY)
	    ;			/* Not TYPE. */
	  else if (sa & FFESYMBOL_attrsACTUALARG)
	    ;			/* Not DUMMY or TYPE. */
	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
	    where = FFEINFO_whereGLOBAL;
	}
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      kind = FFEINFO_kindFUNCTION;
      maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure; kind
				   could be ENTITY w/substring ref. */
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      where = FFEINFO_whereLOCAL;	/* Actually an error, but at least we
					   know it's a local var. */
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
				  &gen, &spec, &imp))
	{
	  if (!(sa & FFESYMBOL_attrsANYLEN)
	      && (ffeimplic_peek_symbol_type (s, NULL)
		  == FFEINFO_basictypeCHARACTER))
	    return s;		/* Haven't learned anything yet. */

	  ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
	  ffesymbol_set_generic (s, gen);
	  ffesymbol_set_specific (s, spec);
	  ffesymbol_set_implementation (s, imp);
	  ffesymbol_set_info (s,
			      ffeinfo_new (ffesymbol_basictype (s),
					   ffesymbol_kindtype (s),
					   0,
					   FFEINFO_kindFUNCTION,
					   FFEINFO_whereINTRINSIC,
					   ffesymbol_size (s)));
	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
	  ffesymbol_resolve_intrin (s);
	  ffesymbol_reference (s, t, FALSE);
	  s = ffecom_sym_learned (s);
	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */

	  return s;
	}
      if (sa & FFESYMBOL_attrsANYLEN)
	error = TRUE;		/* Error, since the only way we can,
				   given CHARACTER*(*) FOO, accept
				   FOO(...) is for FOO to be a dummy
				   arg or constant, but it can't
				   become either now. */
      else if (sa & FFESYMBOL_attrsADJUSTABLE)
	{
	  kind = FFEINFO_kindENTITY;
	  where = FFEINFO_whereLOCAL;
	}
      else
	{
	  kind = FFEINFO_kindFUNCTION;
	  where = FFEINFO_whereGLOBAL;
	  maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure;
				   could be ENTITY/LOCAL w/substring ref. */
	}
    }
  else if (sa == FFESYMBOL_attrsetNONE)
    {
      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);

      if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
				  &gen, &spec, &imp))
	{
	  if (ffeimplic_peek_symbol_type (s, NULL)
	      == FFEINFO_basictypeCHARACTER)
	    return s;		/* Haven't learned anything yet. */

	  ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
	  ffesymbol_set_generic (s, gen);
	  ffesymbol_set_specific (s, spec);
	  ffesymbol_set_implementation (s, imp);
	  ffesymbol_set_info (s,
			      ffeinfo_new (ffesymbol_basictype (s),
					   ffesymbol_kindtype (s),
					   0,
					   FFEINFO_kindFUNCTION,
					   FFEINFO_whereINTRINSIC,
					   ffesymbol_size (s)));
	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
	  ffesymbol_resolve_intrin (s);
	  s = ffecom_sym_learned (s);
	  ffesymbol_reference (s, t, FALSE);
	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
	  return s;
	}

      kind = FFEINFO_kindFUNCTION;
      where = FFEINFO_whereGLOBAL;
      maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure;
				   could be ENTITY/LOCAL w/substring ref. */
    }
  else
    error = TRUE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (error)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);	/* May need to back up to previous
					   version. */
      if (!ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, t);
	  return s;
	}
      if (maybe_ambig
	  && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
	return s;		/* Still not sure, let caller deal with it
				   based on (...). */

      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       kind,
				       where,
				       ffesymbol_size (s)));
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      s = ffecom_sym_learned (s);
      ffesymbol_reference (s, t, FALSE);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */

static ffelexHandler
ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeexprExpr_ procedure;
  ffebld reduced;
  ffeinfo info;
  ffeexprContext ctx;
  bool check_intrin = FALSE;	/* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */

  procedure = ffeexpr_stack_->exprstack;
  info = ffebld_info (procedure->u.operand);

  /* Is there an expression to add?  If the expression is nil,
     it might still be an argument.  It is if:

       -  The current token is comma, or

       -  The -fugly-comma flag was specified *and* the procedure
          being invoked is external.

     Otherwise, if neither of the above is the case, just
     ignore this (nil) expression.  */

  if ((expr != NULL)
      || (ffelex_token_type (t) == FFELEX_typeCOMMA)
      || (ffe_is_ugly_comma ()
	  && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
    {
      /* This expression, even if nil, is apparently intended as an argument.  */

      /* Internal procedure (CONTAINS, or statement function)?  */

      if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
	{
	  if ((expr == NULL)
	      && ffebad_start (FFEBAD_NULL_ARGUMENT))
	    {
	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
			   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	      ffebad_here (1, ffelex_token_where_line (t),
			   ffelex_token_where_column (t));
	      ffebad_finish ();
	    }

	  if (expr == NULL)
	    ;
	  else
	    {
	      if (ffeexpr_stack_->next_dummy == NULL)
		{			/* Report later which was the first extra argument. */
		  if (ffeexpr_stack_->tokens[1] == NULL)
		    {
		      ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
		      ffeexpr_stack_->num_args = 0;
		    }
		  ++ffeexpr_stack_->num_args;	/* Count # of extra arguments. */
		}
	      else
		{
		  if ((ffeinfo_rank (ffebld_info (expr)) != 0)
		      && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
		    {
		      ffebad_here (0,
				   ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
				   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
		      ffebad_here (1, ffelex_token_where_line (ft),
				   ffelex_token_where_column (ft));
		      ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
						     (ffebld_symter (ffebld_head
								     (ffeexpr_stack_->next_dummy)))));
		      ffebad_finish ();
		    }
		  else
		    {
		      expr = ffeexpr_convert_expr (expr, ft,
						   ffebld_head (ffeexpr_stack_->next_dummy),
						   ffeexpr_stack_->tokens[0],
						   FFEEXPR_contextLET);
		      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
		    }
		  --ffeexpr_stack_->num_args;	/* Count down # of args. */
		  ffeexpr_stack_->next_dummy
		    = ffebld_trail (ffeexpr_stack_->next_dummy);
		}
	    }
	}
      else
	{
	  if ((expr == NULL)
	      && ffe_is_pedantic ()
	      && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
	    {
	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
			   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	      ffebad_here (1, ffelex_token_where_line (t),
			   ffelex_token_where_column (t));
	      ffebad_finish ();
	    }
	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
	}
    }

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeCOMMA:
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
	  ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
	  break;

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  assert ("bad context" == NULL);
	  ctx = FFEEXPR_context;
	  break;

	default:
	  ctx = FFEEXPR_contextACTUALARG_;
	  break;
	}
      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
					  ffeexpr_token_arguments_);

    default:
      break;
    }

  if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
      && (ffeexpr_stack_->next_dummy != NULL))
    {				/* Too few arguments. */
      if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
	{
	  char num[10];

	  sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);

	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	  ffebad_string (num);
	  ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
			      (ffebld_head (ffeexpr_stack_->next_dummy)))));
	  ffebad_finish ();
	}
      for (;
	   ffeexpr_stack_->next_dummy != NULL;
	   ffeexpr_stack_->next_dummy
	   = ffebld_trail (ffeexpr_stack_->next_dummy))
	{
	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
	  ffebld_set_info (expr, ffeinfo_new_any ());
	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
	}
    }

  if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
      && (ffeexpr_stack_->tokens[1] != NULL))
    {				/* Too many arguments to statement function. */
      if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
	{
	  char num[10];

	  sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);

	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	  ffebad_string (num);
	  ffebad_finish ();
	}
      ffelex_token_kill (ffeexpr_stack_->tokens[1]);
    }
  ffebld_end_list (&ffeexpr_stack_->bottom);

  if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
    {
      reduced = ffebld_new_any ();
      ffebld_set_info (reduced, ffeinfo_new_any ());
    }
  else
    {
      if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
	reduced = ffebld_new_funcref (procedure->u.operand,
				      ffeexpr_stack_->expr);
      else
	reduced = ffebld_new_subrref (procedure->u.operand,
				      ffeexpr_stack_->expr);
      if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
	ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
      else if (ffebld_symter_specific (procedure->u.operand)
	       != FFEINTRIN_specNONE)
	ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
				    ffeexpr_stack_->tokens[0]);
      else
	ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);

      if (ffebld_op (reduced) != FFEBLD_opANY)
	ffebld_set_info (reduced,
			 ffeinfo_new (ffeinfo_basictype (info),
				      ffeinfo_kindtype (info),
				      0,
				      FFEINFO_kindENTITY,
				      FFEINFO_whereFLEETING,
				      ffeinfo_size (info)));
      else
	ffebld_set_info (reduced, ffeinfo_new_any ());
    }
  if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
    reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
  ffeexpr_stack_->exprstack = procedure->previous;	/* Pops
							   not-quite-operand off
							   stack. */
  procedure->u.operand = reduced;	/* Save the line/column ffewhere
					   info. */
  ffeexpr_exprstack_push_operand_ (procedure);	/* Push it back on stack. */
  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
    {
      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
      ffeexpr_is_substr_ok_ = FALSE;	/* Nobody likes "FUNC(3)(1:1)".... */

      /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
	 Z is DOUBLE COMPLEX), and a command-line option doesn't already
	 establish interpretation, probably complain.  */

      if (check_intrin
	  && !ffe_is_90 ()
	  && !ffe_is_ugly_complex ())
	{
	  /* If the outer expression is REAL(me...), issue diagnostic
	     only if next token isn't the close-paren for REAL(me).  */

	  if ((ffeexpr_stack_->previous != NULL)
	      && (ffeexpr_stack_->previous->exprstack != NULL)
	      && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
	      && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
	      && (ffebld_op (reduced) == FFEBLD_opSYMTER)
	      && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
	    return (ffelexHandler) ffeexpr_token_intrincheck_;

	  /* Diagnose the ambiguity now.  */

	  if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
	    {
	      ffebad_string (ffeintrin_name_implementation
			     (ffebld_symter_implementation
			      (ffebld_left
			       (ffeexpr_stack_->exprstack->u.operand))));
	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
			   ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
	      ffebad_finish ();
	    }
	}
      return (ffelexHandler) ffeexpr_token_substrp_;
    }

  if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
    {
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
      ffebad_finish ();
    }
  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
  return
    (ffelexHandler) ffeexpr_find_close_paren_ (t,
					       (ffelexHandler)
					       ffeexpr_token_substrp_);
}

/* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr

   Return a pointer to this array to the lexer (ffelex), which will
   invoke it for the next token.

   Handle expression and COMMA or CLOSE_PAREN.	*/

static ffelexHandler
ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeexprExpr_ array;
  ffebld reduced;
  ffeinfo info;
  ffeinfoWhere where;
  ffetargetIntegerDefault val;
  ffetargetIntegerDefault lval = 0;
  ffetargetIntegerDefault uval = 0;
  ffebld lbound;
  ffebld ubound;
  bool lcheck;
  bool ucheck;

  array = ffeexpr_stack_->exprstack;
  info = ffebld_info (array->u.operand);

  if ((expr == NULL)		/* && ((ffeexpr_stack_->rank != 0) ||
				   (ffelex_token_type(t) ==
	 FFELEX_typeCOMMA)) */ )
    {
      if (ffebad_start (FFEBAD_NULL_ELEMENT))
	{
	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	  ffebad_here (1, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_finish ();
	}
      if (ffeexpr_stack_->rank < ffeinfo_rank (info))
	{			/* Don't bother if we're going to complain
				   later! */
	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
	  ffebld_set_info (expr, ffeinfo_new_any ());
	}
    }

  if (expr == NULL)
    ;
  else if (ffeinfo_rank (info) == 0)
    {				/* In EQUIVALENCE context, ffeinfo_rank(info)
				   may == 0. */
      ++ffeexpr_stack_->rank;	/* Track anyway, may need for new VXT
				   feature. */
      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
    }
  else
    {
      ++ffeexpr_stack_->rank;
      if (ffeexpr_stack_->rank > ffeinfo_rank (info))
	{			/* Report later which was the first extra
				   element. */
	  if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
	    ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
	}
      else
	{
	  switch (ffeinfo_where (ffebld_info (expr)))
	    {
	    case FFEINFO_whereCONSTANT:
	      break;

	    case FFEINFO_whereIMMEDIATE:
	      ffeexpr_stack_->constant = FALSE;
	      break;

	    default:
	      ffeexpr_stack_->constant = FALSE;
	      ffeexpr_stack_->immediate = FALSE;
	      break;
	    }
	  if (ffebld_op (expr) == FFEBLD_opCONTER)
	    {
	      val = ffebld_constant_integerdefault (ffebld_conter (expr));

	      lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
	      if (lbound == NULL)
		{
		  lcheck = TRUE;
		  lval = 1;
		}
	      else if (ffebld_op (lbound) == FFEBLD_opCONTER)
		{
		  lcheck = TRUE;
		  lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
		}
	      else
		lcheck = FALSE;

	      ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
	      assert (ubound != NULL);
	      if (ffebld_op (ubound) == FFEBLD_opCONTER)
		{
		  ucheck = TRUE;
		  uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
		}
	      else
		ucheck = FALSE;

	      if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
		{
		  ffebad_start (FFEBAD_RANGE_ARRAY);
		  ffebad_here (0, ffelex_token_where_line (ft),
			       ffelex_token_where_column (ft));
		  ffebad_finish ();
		}
	    }
	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
	  ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
	}
    }

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeCOMMA:
      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
	{
	case FFEEXPR_contextDATAIMPDOITEM_:
	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					      FFEEXPR_contextDATAIMPDOINDEX_,
					      ffeexpr_token_elements_);

	case FFEEXPR_contextEQUIVALENCE:
	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					      FFEEXPR_contextEQVINDEX_,
					      ffeexpr_token_elements_);

	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					      FFEEXPR_contextSFUNCDEFINDEX_,
					      ffeexpr_token_elements_);

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  assert ("bad context" == NULL);
	  break;

	default:
	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					      FFEEXPR_contextINDEX_,
					      ffeexpr_token_elements_);
	}

    default:
      break;
    }

  if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
      && (ffeinfo_rank (info) != 0))
    {
      char num[10];

      if (ffeexpr_stack_->rank < ffeinfo_rank (info))
	{
	  if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
	    {
	      sprintf (num, "%d",
		       (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));

	      ffebad_here (0, ffelex_token_where_line (t),
			   ffelex_token_where_column (t));
	      ffebad_here (1,
			ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	      ffebad_string (num);
	      ffebad_finish ();
	    }
	}
      else
	{
	  if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
	    {
	      sprintf (num, "%d",
		       (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));

	      ffebad_here (0,
			ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
	      ffebad_here (1,
			ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
	      ffebad_string (num);
	      ffebad_finish ();
	    }
	  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
	}
      while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
	{
	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
	  ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
					      FFEINFO_kindtypeINTEGERDEFAULT,
					      0, FFEINFO_kindENTITY,
					      FFEINFO_whereCONSTANT,
					      FFETARGET_charactersizeNONE));
	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
	}
    }
  ffebld_end_list (&ffeexpr_stack_->bottom);

  if (ffebld_op (array->u.operand) == FFEBLD_opANY)
    {
      reduced = ffebld_new_any ();
      ffebld_set_info (reduced, ffeinfo_new_any ());
    }
  else
    {
      reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
      if (ffeexpr_stack_->constant)
	where = FFEINFO_whereFLEETING_CADDR;
      else if (ffeexpr_stack_->immediate)
	where = FFEINFO_whereFLEETING_IADDR;
      else
	where = FFEINFO_whereFLEETING;
      ffebld_set_info (reduced,
		       ffeinfo_new (ffeinfo_basictype (info),
				    ffeinfo_kindtype (info),
				    0,
				    FFEINFO_kindENTITY,
				    where,
				    ffeinfo_size (info)));
      reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
    }

  ffeexpr_stack_->exprstack = array->previous;	/* Pops not-quite-operand off
						   stack. */
  array->u.operand = reduced;	/* Save the line/column ffewhere info. */
  ffeexpr_exprstack_push_operand_ (array);	/* Push it back on stack. */

  switch (ffeinfo_basictype (info))
    {
    case FFEINFO_basictypeCHARACTER:
      ffeexpr_is_substr_ok_ = TRUE;	/* Everyone likes "FOO(3)(1:1)".... */
      break;

    case FFEINFO_basictypeNONE:
      ffeexpr_is_substr_ok_ = TRUE;
      assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
      break;

    default:
      ffeexpr_is_substr_ok_ = FALSE;
      break;
    }

  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
    {
      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
      return (ffelexHandler) ffeexpr_token_substrp_;
    }

  if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
    {
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
      ffebad_finish ();
    }
  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  return
    (ffelexHandler) ffeexpr_find_close_paren_ (t,
					       (ffelexHandler)
					       ffeexpr_token_substrp_);
}

/* ffeexpr_token_equivalence_ -- OPEN_PAREN expr

   Return a pointer to this array to the lexer (ffelex), which will
   invoke it for the next token.

   If token is COLON, pass off to _substr_, else init list and pass off
   to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
   ? marks the token, and where FOO's rank/type has not yet been established,
   meaning we could be in a list of indices or in a substring
   specification.  */

static ffelexHandler
ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  if (ffelex_token_type (t) == FFELEX_typeCOLON)
    return ffeexpr_token_substring_ (ft, expr, t);

  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  return ffeexpr_token_elements_ (ft, expr, t);
}

/* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle expression (which may be null) and COLON.  */

static ffelexHandler
ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeexprExpr_ string;
  ffeinfo info;
  ffetargetIntegerDefault i;
  ffeexprContext ctx;
  ffetargetCharacterSize size;

  string = ffeexpr_stack_->exprstack;
  info = ffebld_info (string->u.operand);
  size = ffebld_size_max (string->u.operand);

  if (ffelex_token_type (t) == FFELEX_typeCOLON)
    {
      if ((expr != NULL)
	  && (ffebld_op (expr) == FFEBLD_opCONTER)
	  && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
	       < 1)
	      || ((size != FFETARGET_charactersizeNONE) && (i > size))))
	{
	  ffebad_start (FFEBAD_RANGE_SUBSTR);
	  ffebad_here (0, ffelex_token_where_line (ft),
		       ffelex_token_where_column (ft));
	  ffebad_finish ();
	}
      ffeexpr_stack_->expr = expr;

      switch (ffeexpr_stack_->context)
	{
	case FFEEXPR_contextSFUNCDEF:
	case FFEEXPR_contextSFUNCDEFINDEX_:
	  ctx = FFEEXPR_contextSFUNCDEFINDEX_;
	  break;

	case FFEEXPR_contextSFUNCDEFACTUALARG_:
	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
	  assert ("bad context" == NULL);
	  ctx = FFEEXPR_context;
	  break;

	default:
	  ctx = FFEEXPR_contextINDEX_;
	  break;
	}

      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
					  ffeexpr_token_substring_1_);
    }

  if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
    {
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
      ffebad_finish ();
    }

  ffeexpr_stack_->expr = NULL;
  return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
}

/* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   Handle expression (which might be null) and CLOSE_PAREN.  */

static ffelexHandler
ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
{
  ffeexprExpr_ string;
  ffebld reduced;
  ffebld substrlist;
  ffebld first = ffeexpr_stack_->expr;
  ffebld strop;
  ffeinfo info;
  ffeinfoWhere lwh;
  ffeinfoWhere rwh;
  ffeinfoWhere where;
  ffeinfoKindtype first_kt;
  ffeinfoKindtype last_kt;
  ffetargetIntegerDefault first_val;
  ffetargetIntegerDefault last_val;
  ffetargetCharacterSize size;
  ffetargetCharacterSize strop_size_max;

  string = ffeexpr_stack_->exprstack;
  strop = string->u.operand;
  info = ffebld_info (strop);

  if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
    {				/* The starting point is known. */
      first_val = (first == NULL) ? 1
	: ffebld_constant_integerdefault (ffebld_conter (first));
    }
  else
    {				/* Assume start of the entity. */
      first_val = 1;
    }

  if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER))
    {				/* The ending point is known. */
      last_val = ffebld_constant_integerdefault (ffebld_conter (last));

      if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
	{			/* The beginning point is a constant. */
	  if (first_val <= last_val)
	    size = last_val - first_val + 1;
	  else
	    {
	      if (0 && ffe_is_90 ())
		size = 0;
	      else
		{
		  size = 1;
		  ffebad_start (FFEBAD_ZERO_SIZE);
		  ffebad_here (0, ffelex_token_where_line (ft),
			       ffelex_token_where_column (ft));
		  ffebad_finish ();
		}
	    }
	}
      else
	size = FFETARGET_charactersizeNONE;

      strop_size_max = ffebld_size_max (strop);

      if ((strop_size_max != FFETARGET_charactersizeNONE)
	  && (last_val > strop_size_max))
	{			/* Beyond maximum possible end of string. */
	  ffebad_start (FFEBAD_RANGE_SUBSTR);
	  ffebad_here (0, ffelex_token_where_line (ft),
		       ffelex_token_where_column (ft));
	  ffebad_finish ();
	}
    }
  else
    size = FFETARGET_charactersizeNONE;	/* The size is not known. */

#if 0				/* Don't do this, or "is size of target
				   known?" would no longer be easily
				   answerable.	To see if there is a max
				   size, use ffebld_size_max; to get only the
				   known size, else NONE, use
				   ffebld_size_known; use ffebld_size if
				   values are sure to be the same (not
				   opSUBSTR or opCONCATENATE or known to have
				   known length). By getting rid of this
				   "useful info" stuff, we don't end up
				   blank-padding the constant in the
				   assignment "A(I:J)='XYZ'" to the known
				   length of A. */
  if (size == FFETARGET_charactersizeNONE)
    size = strop_size_max;	/* Assume we use the entire string. */
#endif

  substrlist
    = ffebld_new_item
    (first,
     ffebld_new_item
     (last,
      NULL
     )
    )
    ;

  if (first == NULL)
    lwh = FFEINFO_whereCONSTANT;
  else
    lwh = ffeinfo_where (ffebld_info (first));
  if (last == NULL)
    rwh = FFEINFO_whereCONSTANT;
  else
    rwh = ffeinfo_where (ffebld_info (last));

  switch (lwh)
    {
    case FFEINFO_whereCONSTANT:
      switch (rwh)
	{
	case FFEINFO_whereCONSTANT:
	  where = FFEINFO_whereCONSTANT;
	  break;

	case FFEINFO_whereIMMEDIATE:
	  where = FFEINFO_whereIMMEDIATE;
	  break;

	default:
	  where = FFEINFO_whereFLEETING;
	  break;
	}
      break;

    case FFEINFO_whereIMMEDIATE:
      switch (rwh)
	{
	case FFEINFO_whereCONSTANT:
	case FFEINFO_whereIMMEDIATE:
	  where = FFEINFO_whereIMMEDIATE;
	  break;

	default:
	  where = FFEINFO_whereFLEETING;
	  break;
	}
      break;

    default:
      where = FFEINFO_whereFLEETING;
      break;
    }

  if (first == NULL)
    first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
  else
    first_kt = ffeinfo_kindtype (ffebld_info (first));
  if (last == NULL)
    last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
  else
    last_kt = ffeinfo_kindtype (ffebld_info (last));

  switch (where)
    {
    case FFEINFO_whereCONSTANT:
      switch (ffeinfo_where (info))
	{
	case FFEINFO_whereCONSTANT:
	  break;

	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
	  where = FFEINFO_whereIMMEDIATE;
	  break;

	default:
	  where = FFEINFO_whereFLEETING_CADDR;
	  break;
	}
      break;

    case FFEINFO_whereIMMEDIATE:
      switch (ffeinfo_where (info))
	{
	case FFEINFO_whereCONSTANT:
	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
	  break;

	default:
	  where = FFEINFO_whereFLEETING_IADDR;
	  break;
	}
      break;

    default:
      switch (ffeinfo_where (info))
	{
	case FFEINFO_whereCONSTANT:
	  where = FFEINFO_whereCONSTANT_SUBOBJECT;	/* An F90 concept. */
	  break;

	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
	default:
	  where = FFEINFO_whereFLEETING;
	  break;
	}
      break;
    }

  if (ffebld_op (strop) == FFEBLD_opANY)
    {
      reduced = ffebld_new_any ();
      ffebld_set_info (reduced, ffeinfo_new_any ());
    }
  else
    {
      reduced = ffebld_new_substr (strop, substrlist);
      ffebld_set_info (reduced, ffeinfo_new
		       (FFEINFO_basictypeCHARACTER,
			ffeinfo_kindtype (info),
			0,
			FFEINFO_kindENTITY,
			where,
			size));
      reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
    }

  ffeexpr_stack_->exprstack = string->previous;	/* Pops not-quite-operand off
						   stack. */
  string->u.operand = reduced;	/* Save the line/column ffewhere info. */
  ffeexpr_exprstack_push_operand_ (string);	/* Push it back on stack. */

  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
    {
      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
      ffeexpr_is_substr_ok_ = FALSE;	/* Nobody likes "FOO(3:5)(1:1)".... */
      return (ffelexHandler) ffeexpr_token_substrp_;
    }

  if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
    {
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
      ffebad_finish ();
    }

  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
  return
    (ffelexHandler) ffeexpr_find_close_paren_ (t,
					       (ffelexHandler)
					       ffeexpr_token_substrp_);
}

/* ffeexpr_token_substrp_ -- Rhs <character entity>

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
   issue error message if flag (serves as argument) is set.  Else, just
   forward token to binary_.  */

static ffelexHandler
ffeexpr_token_substrp_ (ffelexToken t)
{
  ffeexprContext ctx;

  if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
    return (ffelexHandler) ffeexpr_token_binary_ (t);

  ffeexpr_stack_->tokens[0] = ffelex_token_use (t);

  switch (ffeexpr_stack_->context)
    {
    case FFEEXPR_contextSFUNCDEF:
    case FFEEXPR_contextSFUNCDEFINDEX_:
      ctx = FFEEXPR_contextSFUNCDEFINDEX_;
      break;

    case FFEEXPR_contextSFUNCDEFACTUALARG_:
    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
      assert ("bad context" == NULL);
      ctx = FFEEXPR_context;
      break;

    default:
      ctx = FFEEXPR_contextINDEX_;
      break;
    }

  if (!ffeexpr_is_substr_ok_)
    {
      if (ffebad_start (FFEBAD_BAD_SUBSTR))
	{
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
		       ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
	  ffebad_finish ();
	}

      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
					  ffeexpr_token_anything_);
    }

  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
				      ffeexpr_token_substring_);
}

static ffelexHandler
ffeexpr_token_intrincheck_ (ffelexToken t)
{
  if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
      && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
    {
      ffebad_string (ffeintrin_name_implementation
		     (ffebld_symter_implementation
		      (ffebld_left
		       (ffeexpr_stack_->exprstack->u.operand))));
      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
		   ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
      ffebad_finish ();
    }

  return (ffelexHandler) ffeexpr_token_substrp_ (t);
}

/* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr

   Return a pointer to this function to the lexer (ffelex), which will
   invoke it for the next token.

   If COLON, do everything we would have done since _parenthesized_ if
   we had known NAME represented a kindENTITY instead of a kindFUNCTION.
   If not COLON, do likewise for kindFUNCTION instead.	*/

static ffelexHandler
ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
{
  ffeinfoWhere where;
  ffesymbol s;
  ffesymbolAttrs sa;
  ffebld symter = ffeexpr_stack_->exprstack->u.operand;
  bool needs_type;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;

  s = ffebld_symter (symter);
  sa = ffesymbol_attrs (s);
  where = ffesymbol_where (s);

  /* We get here only if we don't already know enough about FOO when seeing a
     FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
     "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
     Else FOO is a function, either intrinsic or external.  If intrinsic, it
     wouldn't necessarily be CHARACTER type, so unless it has already been
     declared DUMMY, it hasn't had its type established yet.  It can't be
     CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */

  assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsTYPE)));

  needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);

  ffesymbol_signal_change (s);	/* Probably already done, but in case.... */

  if (ffelex_token_type (t) == FFELEX_typeCOLON)
    {				/* Definitely an ENTITY (char substring). */
      if (needs_type && !ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
	  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
	}

      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       FFEINFO_kindENTITY,
				       (where == FFEINFO_whereNONE)
				       ? FFEINFO_whereLOCAL
				       : where,
				       ffesymbol_size (s)));
      ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));

      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_resolve_intrin (s);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */

      ffeexpr_stack_->exprstack->u.operand
	= ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);

      return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
    }

  /* The "stuff" isn't a substring notation, so we now know the overall
     reference is to a function.  */

  if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
			      FALSE, &gen, &spec, &imp))
    {
      ffebld_symter_set_generic (symter, gen);
      ffebld_symter_set_specific (symter, spec);
      ffebld_symter_set_implementation (symter, imp);
      ffesymbol_set_generic (s, gen);
      ffesymbol_set_specific (s, spec);
      ffesymbol_set_implementation (s, imp);
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       0,
				       FFEINFO_kindFUNCTION,
				       FFEINFO_whereINTRINSIC,
				       ffesymbol_size (s)));
    }
  else
    {				/* Not intrinsic, now needs CHAR type. */
      if (!ffeimplic_establish_symbol (s))
	{
	  ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
	  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
	}

      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       FFEINFO_kindFUNCTION,
				       (where == FFEINFO_whereNONE)
				       ? FFEINFO_whereGLOBAL
				       : where,
				       ffesymbol_size (s)));
    }

  ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));

  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  ffesymbol_resolve_intrin (s);
  s = ffecom_sym_learned (s);
  ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
}

/* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr

   Handle basically any expression, looking for CLOSE_PAREN.  */

static ffelexHandler
ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
			 ffelexToken t)
{
  ffeexprExpr_ e = ffeexpr_stack_->exprstack;

  switch (ffelex_token_type (t))
    {
    case FFELEX_typeCOMMA:
    case FFELEX_typeCOLON:
      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
					  FFEEXPR_contextACTUALARG_,
					  ffeexpr_token_anything_);

    default:
      e->u.operand = ffebld_new_any ();
      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
      ffeexpr_is_substr_ok_ = FALSE;
      if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
	return (ffelexHandler) ffeexpr_token_substrp_;
      return (ffelexHandler) ffeexpr_token_substrp_ (t);
    }
}

/* Terminate module.  */

void
ffeexpr_terminate_2 ()
{
  assert (ffeexpr_stack_ == NULL);
  assert (ffeexpr_level_ == 0);
}