contrib/gcc-3.4/gcc/f/expr.c

   1 /* expr.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None.
  25
  26    Description:
  27       Handles syntactic and semantic analysis of Fortran expressions.
  28
  29    Modifications:
  30 */
  31
  32 /* Include files. */
  33
  34 #include "proj.h"
  35 #include "expr.h"
  36 #include "bad.h"
  37 #include "bld.h"
  38 #include "com.h"
  39 #include "global.h"
  40 #include "implic.h"
  41 #include "intrin.h"
  42 #include "info.h"
  43 #include "lex.h"
  44 #include "malloc.h"
  45 #include "src.h"
  46 #include "st.h"
  47 #include "symbol.h"
  48 #include "str.h"
  49 #include "target.h"
  50 #include "where.h"
  51 #include "real.h"
  52
  53 /* Externals defined here. */
  54
  55
  56 /* Simple definitions and enumerations. */
  57
  58 typedef enum
  59   {
  60     FFEEXPR_exprtypeUNKNOWN_,
  61     FFEEXPR_exprtypeOPERAND_,
  62     FFEEXPR_exprtypeUNARY_,
  63     FFEEXPR_exprtypeBINARY_,
  64     FFEEXPR_exprtype_
  65   } ffeexprExprtype_;
  66
  67 typedef enum
  68   {
  69     FFEEXPR_operatorPOWER_,
  70     FFEEXPR_operatorMULTIPLY_,
  71     FFEEXPR_operatorDIVIDE_,
  72     FFEEXPR_operatorADD_,
  73     FFEEXPR_operatorSUBTRACT_,
  74     FFEEXPR_operatorCONCATENATE_,
  75     FFEEXPR_operatorLT_,
  76     FFEEXPR_operatorLE_,
  77     FFEEXPR_operatorEQ_,
  78     FFEEXPR_operatorNE_,
  79     FFEEXPR_operatorGT_,
  80     FFEEXPR_operatorGE_,
  81     FFEEXPR_operatorNOT_,
  82     FFEEXPR_operatorAND_,
  83     FFEEXPR_operatorOR_,
  84     FFEEXPR_operatorXOR_,
  85     FFEEXPR_operatorEQV_,
  86     FFEEXPR_operatorNEQV_,
  87     FFEEXPR_operator_
  88   } ffeexprOperator_;
  89
  90 typedef enum
  91   {
  92     FFEEXPR_operatorprecedenceHIGHEST_ = 1,
  93     FFEEXPR_operatorprecedencePOWER_ = 1,
  94     FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
  95     FFEEXPR_operatorprecedenceDIVIDE_ = 2,
  96     FFEEXPR_operatorprecedenceADD_ = 3,
  97     FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
  98     FFEEXPR_operatorprecedenceLOWARITH_ = 3,
  99     FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
 100     FFEEXPR_operatorprecedenceLT_ = 4,
 101     FFEEXPR_operatorprecedenceLE_ = 4,
 102     FFEEXPR_operatorprecedenceEQ_ = 4,
 103     FFEEXPR_operatorprecedenceNE_ = 4,
 104     FFEEXPR_operatorprecedenceGT_ = 4,
 105     FFEEXPR_operatorprecedenceGE_ = 4,
 106     FFEEXPR_operatorprecedenceNOT_ = 5,
 107     FFEEXPR_operatorprecedenceAND_ = 6,
 108     FFEEXPR_operatorprecedenceOR_ = 7,
 109     FFEEXPR_operatorprecedenceXOR_ = 8,
 110     FFEEXPR_operatorprecedenceEQV_ = 8,
 111     FFEEXPR_operatorprecedenceNEQV_ = 8,
 112     FFEEXPR_operatorprecedenceLOWEST_ = 8,
 113     FFEEXPR_operatorprecedence_
 114   } ffeexprOperatorPrecedence_;
 115
 116 #define FFEEXPR_operatorassociativityL2R_ TRUE
 117 #define FFEEXPR_operatorassociativityR2L_ FALSE
 118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
 119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
 120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
 121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
 122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
 123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
 124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
 125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
 126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
 127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
 128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
 129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
 130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
 131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
 132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
 133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
 134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
 135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
 136
 137 typedef enum
 138   {
 139     FFEEXPR_parentypeFUNCTION_,
 140     FFEEXPR_parentypeSUBROUTINE_,
 141     FFEEXPR_parentypeARRAY_,
 142     FFEEXPR_parentypeSUBSTRING_,
 143     FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
 144     FFEEXPR_parentypeEQUIVALENCE_,      /* Ambig: ARRAY_ or SUBSTRING_. */
 145     FFEEXPR_parentypeANY_,      /* Allow basically anything. */
 146     FFEEXPR_parentype_
 147   } ffeexprParenType_;
 148
 149 typedef enum
 150   {
 151     FFEEXPR_percentNONE_,
 152     FFEEXPR_percentLOC_,
 153     FFEEXPR_percentVAL_,
 154     FFEEXPR_percentREF_,
 155     FFEEXPR_percentDESCR_,
 156     FFEEXPR_percent_
 157   } ffeexprPercent_;
 158
 159 /* Internal typedefs. */
 160
 161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
 162 typedef bool ffeexprOperatorAssociativity_;
 163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
 164
 165 /* Private include files. */
 166
 167
 168 /* Internal structure definitions. */
 169
 170 struct _ffeexpr_expr_
 171   {
 172     ffeexprExpr_ previous;
 173     ffelexToken token;
 174     ffeexprExprtype_ type;
 175     union
 176       {
 177         struct
 178           {
 179             ffeexprOperator_ op;
 180             ffeexprOperatorPrecedence_ prec;
 181             ffeexprOperatorAssociativity_ as;
 182           }
 183         operator;
 184         ffebld operand;
 185       }
 186     u;
 187   };
 188
 189 struct _ffeexpr_stack_
 190   {
 191     ffeexprStack_ previous;
 192     mallocPool pool;
 193     ffeexprContext context;
 194     ffeexprCallback callback;
 195     ffelexToken first_token;
 196     ffeexprExpr_ exprstack;
 197     ffelexToken tokens[10];     /* Used in certain cases, like (unary)
 198                                    open-paren. */
 199     ffebld expr;                /* For first of
 200                                    complex/implied-do/substring/array-elements
 201                                    / actual-args expression. */
 202     ffebld bound_list;          /* For tracking dimension bounds list of
 203                                    array. */
 204     ffebldListBottom bottom;    /* For building lists. */
 205     ffeinfoRank rank;           /* For elements in an array reference. */
 206     bool constant;              /* TRUE while elements seen so far are
 207                                    constants. */
 208     bool immediate;             /* TRUE while elements seen so far are
 209                                    immediate/constants. */
 210     ffebld next_dummy;          /* Next SFUNC dummy arg in arg list. */
 211     ffebldListLength num_args;  /* Number of dummy args expected in arg list. */
 212     bool is_rhs;                /* TRUE if rhs context, FALSE otherwise. */
 213     ffeexprPercent_ percent;    /* Current %FOO keyword. */
 214   };
 215
 216 struct _ffeexpr_find_
 217   {
 218     ffelexToken t;
 219     ffelexHandler after;
 220     int level;
 221   };
 222
 223 /* Static objects accessed by functions in this module. */
 224
 225 static ffeexprStack_ ffeexpr_stack_;    /* Expression stack for semantic. */
 226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
 227 static ffestrOther ffeexpr_current_dotdot_;     /* Current .FOO. keyword. */
 228 static long ffeexpr_hollerith_count_;   /* ffeexpr_token_number_ and caller. */
 229 static int ffeexpr_level_;      /* Level of DATA implied-DO construct. */
 230 static bool ffeexpr_is_substr_ok_;      /* If OPEN_PAREN as binary "op" ok. */
 231 static struct _ffeexpr_find_ ffeexpr_find_;
 232
 233 /* Static functions (internal). */
 234
 235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
 236                                               ffelexToken t);
 237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
 238                                                     ffebld expr,
 239                                                     ffelexToken t);
 240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
 241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
 242                                                 ffebld expr, ffelexToken t);
 243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
 244                                           ffelexToken t);
 245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
 246                                                  ffebld expr, ffelexToken t);
 247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
 248                                            ffelexToken t);
 249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
 250                                           ffelexToken t);
 251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
 252                                             ffelexToken t);
 253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
 254                                             ffelexToken t);
 255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
 256                                             ffelexToken t);
 257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
 258                                             ffelexToken t);
 259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
 260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
 261                                           ffelexToken t);
 262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
 263                                              ffelexToken t);
 264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
 265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
 266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
 267                                   ffebld dovar, ffelexToken dovar_t);
 268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
 269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
 270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
 271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
 272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
 273 static bool ffeexpr_isdigits_ (const char *p);
 274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
 275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
 276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
 277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
 278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
 279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
 280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
 281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
 282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
 283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
 284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
 285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
 286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
 287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
 288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
 289 static void ffeexpr_reduce_ (void);
 290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
 291                                       ffeexprExpr_ r);
 292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
 293                                       ffeexprExpr_ op, ffeexprExpr_ r);
 294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
 295                                             ffeexprExpr_ op, ffeexprExpr_ r);
 296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
 297                                       ffeexprExpr_ op, ffeexprExpr_ r);
 298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
 299                                       ffeexprExpr_ r);
 300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
 301                                       ffeexprExpr_ op, ffeexprExpr_ r);
 302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
 303                                       ffeexprExpr_ op, ffeexprExpr_ r);
 304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
 305                                        ffeexprExpr_ op, ffeexprExpr_ r);
 306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
 307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
 308                                          ffeexprExpr_ r);
 309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
 310                                       ffeexprExpr_ op, ffeexprExpr_ r);
 311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
 312                                          ffeexprExpr_ op, ffeexprExpr_ r,
 313                                          bool *);
 314 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
 315                                                 ffelexHandler after);
 316 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
 317 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
 318 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
 319 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
 320 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
 321 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
 322 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
 323 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
 324 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
 325 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
 326 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
 327 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
 328 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
 329 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
 330 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
 331 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
 332 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
 333 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
 334 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
 335 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
 336 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
 337 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
 338 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
 339 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
 340 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
 341 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
 342 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
 343 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
 344 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
 345 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
 346 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
 347 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
 348 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
 349 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
 350 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
 351 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
 352 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
 353 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
 354 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
 355 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
 356 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
 357 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
 358 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
 359 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
 360 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
 361 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
 362 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
 363 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
 364 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
 365 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
 366 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
 367 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
 368 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
 369 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
 370 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
 371 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
 372 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
 373 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
 374 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
 375 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
 376 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
 377 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
 378 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
 379 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
 380                                                ffelexToken t);
 381 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
 382                                               ffelexToken t);
 383 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
 384                                                  ffelexToken t);
 385 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
 386                                                ffelexToken t);
 387 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
 388                                                  ffelexToken t);
 389 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
 390 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
 391 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
 392                                                ffelexToken t);
 393 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
 394                                               ffelexToken t);
 395 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
 396             ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
 397                     ffelexToken exponent_sign, ffelexToken exponent_digits);
 398 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
 399 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
 400 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
 401 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
 402 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
 403 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
 404 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
 405 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
 406 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
 407 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
 408 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
 409 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
 410                                                  bool maybe_intrin,
 411                                              ffeexprParenType_ *paren_type);
 412 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
 413
 414 /* Internal macros. */
 415
 416 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 417 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 418 \f
 419 /* ffeexpr_collapse_convert -- Collapse convert expr
 420
 421    ffebld expr;
 422    ffelexToken token;
 423    expr = ffeexpr_collapse_convert(expr,token);
 424
 425    If the result of the expr is a constant, replaces the expr with the
 426    computed constant.  */
 427
 428 ffebld
 429 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
 430 {
 431   ffebad error = FFEBAD;
 432   ffebld l;
 433   ffebldConstantUnion u;
 434   ffeinfoBasictype bt;
 435   ffeinfoKindtype kt;
 436   ffetargetCharacterSize sz;
 437   ffetargetCharacterSize sz2;
 438
 439   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
 440     return expr;
 441
 442   l = ffebld_left (expr);
 443
 444   if (ffebld_op (l) != FFEBLD_opCONTER)
 445     return expr;
 446
 447   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
 448     {
 449     case FFEINFO_basictypeANY:
 450       return expr;
 451
 452     case FFEINFO_basictypeINTEGER:
 453       sz = FFETARGET_charactersizeNONE;
 454       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
 455         {
 456 #if FFETARGET_okINTEGER1
 457         case FFEINFO_kindtypeINTEGER1:
 458           switch (ffeinfo_basictype (ffebld_info (l)))
 459             {
 460             case FFEINFO_basictypeINTEGER:
 461               switch (ffeinfo_kindtype (ffebld_info (l)))
 462                 {
 463 #if FFETARGET_okINTEGER2
 464                 case FFEINFO_kindtypeINTEGER2:
 465                   error = ffetarget_convert_integer1_integer2
 466                     (ffebld_cu_ptr_integer1 (u),
 467                      ffebld_constant_integer2 (ffebld_conter (l)));
 468                   break;
 469 #endif
 470
 471 #if FFETARGET_okINTEGER3
 472                 case FFEINFO_kindtypeINTEGER3:
 473                   error = ffetarget_convert_integer1_integer3
 474                     (ffebld_cu_ptr_integer1 (u),
 475                      ffebld_constant_integer3 (ffebld_conter (l)));
 476                   break;
 477 #endif
 478
 479 #if FFETARGET_okINTEGER4
 480                 case FFEINFO_kindtypeINTEGER4:
 481                   error = ffetarget_convert_integer1_integer4
 482                     (ffebld_cu_ptr_integer1 (u),
 483                      ffebld_constant_integer4 (ffebld_conter (l)));
 484                   break;
 485 #endif
 486
 487                 default:
 488                   assert ("INTEGER1/INTEGER bad source kind type" == NULL);
 489                   break;
 490                 }
 491               break;
 492
 493             case FFEINFO_basictypeREAL:
 494               switch (ffeinfo_kindtype (ffebld_info (l)))
 495                 {
 496 #if FFETARGET_okREAL1
 497                 case FFEINFO_kindtypeREAL1:
 498                   error = ffetarget_convert_integer1_real1
 499                     (ffebld_cu_ptr_integer1 (u),
 500                      ffebld_constant_real1 (ffebld_conter (l)));
 501                   break;
 502 #endif
 503
 504 #if FFETARGET_okREAL2
 505                 case FFEINFO_kindtypeREAL2:
 506                   error = ffetarget_convert_integer1_real2
 507                     (ffebld_cu_ptr_integer1 (u),
 508                      ffebld_constant_real2 (ffebld_conter (l)));
 509                   break;
 510 #endif
 511
 512 #if FFETARGET_okREAL3
 513                 case FFEINFO_kindtypeREAL3:
 514                   error = ffetarget_convert_integer1_real3
 515                     (ffebld_cu_ptr_integer1 (u),
 516                      ffebld_constant_real3 (ffebld_conter (l)));
 517                   break;
 518 #endif
 519
 520                 default:
 521                   assert ("INTEGER1/REAL bad source kind type" == NULL);
 522                   break;
 523                 }
 524               break;
 525
 526             case FFEINFO_basictypeCOMPLEX:
 527               switch (ffeinfo_kindtype (ffebld_info (l)))
 528                 {
 529 #if FFETARGET_okCOMPLEX1
 530                 case FFEINFO_kindtypeREAL1:
 531                   error = ffetarget_convert_integer1_complex1
 532                     (ffebld_cu_ptr_integer1 (u),
 533                      ffebld_constant_complex1 (ffebld_conter (l)));
 534                   break;
 535 #endif
 536
 537 #if FFETARGET_okCOMPLEX2
 538                 case FFEINFO_kindtypeREAL2:
 539                   error = ffetarget_convert_integer1_complex2
 540                     (ffebld_cu_ptr_integer1 (u),
 541                      ffebld_constant_complex2 (ffebld_conter (l)));
 542                   break;
 543 #endif
 544
 545 #if FFETARGET_okCOMPLEX3
 546                 case FFEINFO_kindtypeREAL3:
 547                   error = ffetarget_convert_integer1_complex3
 548                     (ffebld_cu_ptr_integer1 (u),
 549                      ffebld_constant_complex3 (ffebld_conter (l)));
 550                   break;
 551 #endif
 552
 553                 default:
 554                   assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
 555                   break;
 556                 }
 557               break;
 558
 559             case FFEINFO_basictypeLOGICAL:
 560               switch (ffeinfo_kindtype (ffebld_info (l)))
 561                 {
 562 #if FFETARGET_okLOGICAL1
 563                 case FFEINFO_kindtypeLOGICAL1:
 564                   error = ffetarget_convert_integer1_logical1
 565                     (ffebld_cu_ptr_integer1 (u),
 566                      ffebld_constant_logical1 (ffebld_conter (l)));
 567                   break;
 568 #endif
 569
 570 #if FFETARGET_okLOGICAL2
 571                 case FFEINFO_kindtypeLOGICAL2:
 572                   error = ffetarget_convert_integer1_logical2
 573                     (ffebld_cu_ptr_integer1 (u),
 574                      ffebld_constant_logical2 (ffebld_conter (l)));
 575                   break;
 576 #endif
 577
 578 #if FFETARGET_okLOGICAL3
 579                 case FFEINFO_kindtypeLOGICAL3:
 580                   error = ffetarget_convert_integer1_logical3
 581                     (ffebld_cu_ptr_integer1 (u),
 582                      ffebld_constant_logical3 (ffebld_conter (l)));
 583                   break;
 584 #endif
 585
 586 #if FFETARGET_okLOGICAL4
 587                 case FFEINFO_kindtypeLOGICAL4:
 588                   error = ffetarget_convert_integer1_logical4
 589                     (ffebld_cu_ptr_integer1 (u),
 590                      ffebld_constant_logical4 (ffebld_conter (l)));
 591                   break;
 592 #endif
 593
 594                 default:
 595                   assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
 596                   break;
 597                 }
 598               break;
 599
 600             case FFEINFO_basictypeCHARACTER:
 601               error = ffetarget_convert_integer1_character1
 602                 (ffebld_cu_ptr_integer1 (u),
 603                  ffebld_constant_character1 (ffebld_conter (l)));
 604               break;
 605
 606             case FFEINFO_basictypeHOLLERITH:
 607               error = ffetarget_convert_integer1_hollerith
 608                 (ffebld_cu_ptr_integer1 (u),
 609                  ffebld_constant_hollerith (ffebld_conter (l)));
 610               break;
 611
 612             case FFEINFO_basictypeTYPELESS:
 613               error = ffetarget_convert_integer1_typeless
 614                 (ffebld_cu_ptr_integer1 (u),
 615                  ffebld_constant_typeless (ffebld_conter (l)));
 616               break;
 617
 618             default:
 619               assert ("INTEGER1 bad type" == NULL);
 620               break;
 621             }
 622
 623           /* If conversion operation is not implemented, return original expr.  */
 624           if (error == FFEBAD_NOCANDO)
 625             return expr;
 626
 627           expr = ffebld_new_conter_with_orig
 628             (ffebld_constant_new_integer1_val
 629              (ffebld_cu_val_integer1 (u)), expr);
 630           break;
 631 #endif
 632
 633 #if FFETARGET_okINTEGER2
 634         case FFEINFO_kindtypeINTEGER2:
 635           switch (ffeinfo_basictype (ffebld_info (l)))
 636             {
 637             case FFEINFO_basictypeINTEGER:
 638               switch (ffeinfo_kindtype (ffebld_info (l)))
 639                 {
 640 #if FFETARGET_okINTEGER1
 641                 case FFEINFO_kindtypeINTEGER1:
 642                   error = ffetarget_convert_integer2_integer1
 643                     (ffebld_cu_ptr_integer2 (u),
 644                      ffebld_constant_integer1 (ffebld_conter (l)));
 645                   break;
 646 #endif
 647
 648 #if FFETARGET_okINTEGER3
 649                 case FFEINFO_kindtypeINTEGER3:
 650                   error = ffetarget_convert_integer2_integer3
 651                     (ffebld_cu_ptr_integer2 (u),
 652                      ffebld_constant_integer3 (ffebld_conter (l)));
 653                   break;
 654 #endif
 655
 656 #if FFETARGET_okINTEGER4
 657                 case FFEINFO_kindtypeINTEGER4:
 658                   error = ffetarget_convert_integer2_integer4
 659                     (ffebld_cu_ptr_integer2 (u),
 660                      ffebld_constant_integer4 (ffebld_conter (l)));
 661                   break;
 662 #endif
 663
 664                 default:
 665                   assert ("INTEGER2/INTEGER bad source kind type" == NULL);
 666                   break;
 667                 }
 668               break;
 669
 670             case FFEINFO_basictypeREAL:
 671               switch (ffeinfo_kindtype (ffebld_info (l)))
 672                 {
 673 #if FFETARGET_okREAL1
 674                 case FFEINFO_kindtypeREAL1:
 675                   error = ffetarget_convert_integer2_real1
 676                     (ffebld_cu_ptr_integer2 (u),
 677                      ffebld_constant_real1 (ffebld_conter (l)));
 678                   break;
 679 #endif
 680
 681 #if FFETARGET_okREAL2
 682                 case FFEINFO_kindtypeREAL2:
 683                   error = ffetarget_convert_integer2_real2
 684                     (ffebld_cu_ptr_integer2 (u),
 685                      ffebld_constant_real2 (ffebld_conter (l)));
 686                   break;
 687 #endif
 688
 689 #if FFETARGET_okREAL3
 690                 case FFEINFO_kindtypeREAL3:
 691                   error = ffetarget_convert_integer2_real3
 692                     (ffebld_cu_ptr_integer2 (u),
 693                      ffebld_constant_real3 (ffebld_conter (l)));
 694                   break;
 695 #endif
 696
 697                 default:
 698                   assert ("INTEGER2/REAL bad source kind type" == NULL);
 699                   break;
 700                 }
 701               break;
 702
 703             case FFEINFO_basictypeCOMPLEX:
 704               switch (ffeinfo_kindtype (ffebld_info (l)))
 705                 {
 706 #if FFETARGET_okCOMPLEX1
 707                 case FFEINFO_kindtypeREAL1:
 708                   error = ffetarget_convert_integer2_complex1
 709                     (ffebld_cu_ptr_integer2 (u),
 710                      ffebld_constant_complex1 (ffebld_conter (l)));
 711                   break;
 712 #endif
 713
 714 #if FFETARGET_okCOMPLEX2
 715                 case FFEINFO_kindtypeREAL2:
 716                   error = ffetarget_convert_integer2_complex2
 717                     (ffebld_cu_ptr_integer2 (u),
 718                      ffebld_constant_complex2 (ffebld_conter (l)));
 719                   break;
 720 #endif
 721
 722 #if FFETARGET_okCOMPLEX3
 723                 case FFEINFO_kindtypeREAL3:
 724                   error = ffetarget_convert_integer2_complex3
 725                     (ffebld_cu_ptr_integer2 (u),
 726                      ffebld_constant_complex3 (ffebld_conter (l)));
 727                   break;
 728 #endif
 729
 730                 default:
 731                   assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
 732                   break;
 733                 }
 734               break;
 735
 736             case FFEINFO_basictypeLOGICAL:
 737               switch (ffeinfo_kindtype (ffebld_info (l)))
 738                 {
 739 #if FFETARGET_okLOGICAL1
 740                 case FFEINFO_kindtypeLOGICAL1:
 741                   error = ffetarget_convert_integer2_logical1
 742                     (ffebld_cu_ptr_integer2 (u),
 743                      ffebld_constant_logical1 (ffebld_conter (l)));
 744                   break;
 745 #endif
 746
 747 #if FFETARGET_okLOGICAL2
 748                 case FFEINFO_kindtypeLOGICAL2:
 749                   error = ffetarget_convert_integer2_logical2
 750                     (ffebld_cu_ptr_integer2 (u),
 751                      ffebld_constant_logical2 (ffebld_conter (l)));
 752                   break;
 753 #endif
 754
 755 #if FFETARGET_okLOGICAL3
 756                 case FFEINFO_kindtypeLOGICAL3:
 757                   error = ffetarget_convert_integer2_logical3
 758                     (ffebld_cu_ptr_integer2 (u),
 759                      ffebld_constant_logical3 (ffebld_conter (l)));
 760                   break;
 761 #endif
 762
 763 #if FFETARGET_okLOGICAL4
 764                 case FFEINFO_kindtypeLOGICAL4:
 765                   error = ffetarget_convert_integer2_logical4
 766                     (ffebld_cu_ptr_integer2 (u),
 767                      ffebld_constant_logical4 (ffebld_conter (l)));
 768                   break;
 769 #endif
 770
 771                 default:
 772                   assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
 773                   break;
 774                 }
 775               break;
 776
 777             case FFEINFO_basictypeCHARACTER:
 778               error = ffetarget_convert_integer2_character1
 779                 (ffebld_cu_ptr_integer2 (u),
 780                  ffebld_constant_character1 (ffebld_conter (l)));
 781               break;
 782
 783             case FFEINFO_basictypeHOLLERITH:
 784               error = ffetarget_convert_integer2_hollerith
 785                 (ffebld_cu_ptr_integer2 (u),
 786                  ffebld_constant_hollerith (ffebld_conter (l)));
 787               break;
 788
 789             case FFEINFO_basictypeTYPELESS:
 790               error = ffetarget_convert_integer2_typeless
 791                 (ffebld_cu_ptr_integer2 (u),
 792                  ffebld_constant_typeless (ffebld_conter (l)));
 793               break;
 794
 795             default:
 796               assert ("INTEGER2 bad type" == NULL);
 797               break;
 798             }
 799
 800           /* If conversion operation is not implemented, return original expr.  */
 801           if (error == FFEBAD_NOCANDO)
 802             return expr;
 803
 804           expr = ffebld_new_conter_with_orig
 805             (ffebld_constant_new_integer2_val
 806              (ffebld_cu_val_integer2 (u)), expr);
 807           break;
 808 #endif
 809
 810 #if FFETARGET_okINTEGER3
 811         case FFEINFO_kindtypeINTEGER3:
 812           switch (ffeinfo_basictype (ffebld_info (l)))
 813             {
 814             case FFEINFO_basictypeINTEGER:
 815               switch (ffeinfo_kindtype (ffebld_info (l)))
 816                 {
 817 #if FFETARGET_okINTEGER1
 818                 case FFEINFO_kindtypeINTEGER1:
 819                   error = ffetarget_convert_integer3_integer1
 820                     (ffebld_cu_ptr_integer3 (u),
 821                      ffebld_constant_integer1 (ffebld_conter (l)));
 822                   break;
 823 #endif
 824
 825 #if FFETARGET_okINTEGER2
 826                 case FFEINFO_kindtypeINTEGER2:
 827                   error = ffetarget_convert_integer3_integer2
 828                     (ffebld_cu_ptr_integer3 (u),
 829                      ffebld_constant_integer2 (ffebld_conter (l)));
 830                   break;
 831 #endif
 832
 833 #if FFETARGET_okINTEGER4
 834                 case FFEINFO_kindtypeINTEGER4:
 835                   error = ffetarget_convert_integer3_integer4
 836                     (ffebld_cu_ptr_integer3 (u),
 837                      ffebld_constant_integer4 (ffebld_conter (l)));
 838                   break;
 839 #endif
 840
 841                 default:
 842                   assert ("INTEGER3/INTEGER bad source kind type" == NULL);
 843                   break;
 844                 }
 845               break;
 846
 847             case FFEINFO_basictypeREAL:
 848               switch (ffeinfo_kindtype (ffebld_info (l)))
 849                 {
 850 #if FFETARGET_okREAL1
 851                 case FFEINFO_kindtypeREAL1:
 852                   error = ffetarget_convert_integer3_real1
 853                     (ffebld_cu_ptr_integer3 (u),
 854                      ffebld_constant_real1 (ffebld_conter (l)));
 855                   break;
 856 #endif
 857
 858 #if FFETARGET_okREAL2
 859                 case FFEINFO_kindtypeREAL2:
 860                   error = ffetarget_convert_integer3_real2
 861                     (ffebld_cu_ptr_integer3 (u),
 862                      ffebld_constant_real2 (ffebld_conter (l)));
 863                   break;
 864 #endif
 865
 866 #if FFETARGET_okREAL3
 867                 case FFEINFO_kindtypeREAL3:
 868                   error = ffetarget_convert_integer3_real3
 869                     (ffebld_cu_ptr_integer3 (u),
 870                      ffebld_constant_real3 (ffebld_conter (l)));
 871                   break;
 872 #endif
 873
 874                 default:
 875                   assert ("INTEGER3/REAL bad source kind type" == NULL);
 876                   break;
 877                 }
 878               break;
 879
 880             case FFEINFO_basictypeCOMPLEX:
 881               switch (ffeinfo_kindtype (ffebld_info (l)))
 882                 {
 883 #if FFETARGET_okCOMPLEX1
 884                 case FFEINFO_kindtypeREAL1:
 885                   error = ffetarget_convert_integer3_complex1
 886                     (ffebld_cu_ptr_integer3 (u),
 887                      ffebld_constant_complex1 (ffebld_conter (l)));
 888                   break;
 889 #endif
 890
 891 #if FFETARGET_okCOMPLEX2
 892                 case FFEINFO_kindtypeREAL2:
 893                   error = ffetarget_convert_integer3_complex2
 894                     (ffebld_cu_ptr_integer3 (u),
 895                      ffebld_constant_complex2 (ffebld_conter (l)));
 896                   break;
 897 #endif
 898
 899 #if FFETARGET_okCOMPLEX3
 900                 case FFEINFO_kindtypeREAL3:
 901                   error = ffetarget_convert_integer3_complex3
 902                     (ffebld_cu_ptr_integer3 (u),
 903                      ffebld_constant_complex3 (ffebld_conter (l)));
 904                   break;
 905 #endif
 906
 907                 default:
 908                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
 909                   break;
 910                 }
 911               break;
 912
 913             case FFEINFO_basictypeLOGICAL:
 914               switch (ffeinfo_kindtype (ffebld_info (l)))
 915                 {
 916 #if FFETARGET_okLOGICAL1
 917                 case FFEINFO_kindtypeLOGICAL1:
 918                   error = ffetarget_convert_integer3_logical1
 919                     (ffebld_cu_ptr_integer3 (u),
 920                      ffebld_constant_logical1 (ffebld_conter (l)));
 921                   break;
 922 #endif
 923
 924 #if FFETARGET_okLOGICAL2
 925                 case FFEINFO_kindtypeLOGICAL2:
 926                   error = ffetarget_convert_integer3_logical2
 927                     (ffebld_cu_ptr_integer3 (u),
 928                      ffebld_constant_logical2 (ffebld_conter (l)));
 929                   break;
 930 #endif
 931
 932 #if FFETARGET_okLOGICAL3
 933                 case FFEINFO_kindtypeLOGICAL3:
 934                   error = ffetarget_convert_integer3_logical3
 935                     (ffebld_cu_ptr_integer3 (u),
 936                      ffebld_constant_logical3 (ffebld_conter (l)));
 937                   break;
 938 #endif
 939
 940 #if FFETARGET_okLOGICAL4
 941                 case FFEINFO_kindtypeLOGICAL4:
 942                   error = ffetarget_convert_integer3_logical4
 943                     (ffebld_cu_ptr_integer3 (u),
 944                      ffebld_constant_logical4 (ffebld_conter (l)));
 945                   break;
 946 #endif
 947
 948                 default:
 949                   assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
 950                   break;
 951                 }
 952               break;
 953
 954             case FFEINFO_basictypeCHARACTER:
 955               error = ffetarget_convert_integer3_character1
 956                 (ffebld_cu_ptr_integer3 (u),
 957                  ffebld_constant_character1 (ffebld_conter (l)));
 958               break;
 959
 960             case FFEINFO_basictypeHOLLERITH:
 961               error = ffetarget_convert_integer3_hollerith
 962                 (ffebld_cu_ptr_integer3 (u),
 963                  ffebld_constant_hollerith (ffebld_conter (l)));
 964               break;
 965
 966             case FFEINFO_basictypeTYPELESS:
 967               error = ffetarget_convert_integer3_typeless
 968                 (ffebld_cu_ptr_integer3 (u),
 969                  ffebld_constant_typeless (ffebld_conter (l)));
 970               break;
 971
 972             default:
 973               assert ("INTEGER3 bad type" == NULL);
 974               break;
 975             }
 976
 977           /* If conversion operation is not implemented, return original expr.  */
 978           if (error == FFEBAD_NOCANDO)
 979             return expr;
 980
 981           expr = ffebld_new_conter_with_orig
 982             (ffebld_constant_new_integer3_val
 983              (ffebld_cu_val_integer3 (u)), expr);
 984           break;
 985 #endif
 986
 987 #if FFETARGET_okINTEGER4
 988         case FFEINFO_kindtypeINTEGER4:
 989           switch (ffeinfo_basictype (ffebld_info (l)))
 990             {
 991             case FFEINFO_basictypeINTEGER:
 992               switch (ffeinfo_kindtype (ffebld_info (l)))
 993                 {
 994 #if FFETARGET_okINTEGER1
 995                 case FFEINFO_kindtypeINTEGER1:
 996                   error = ffetarget_convert_integer4_integer1
 997                     (ffebld_cu_ptr_integer4 (u),
 998                      ffebld_constant_integer1 (ffebld_conter (l)));
 999                   break;
1000 #endif
1001
1002 #if FFETARGET_okINTEGER2
1003                 case FFEINFO_kindtypeINTEGER2:
1004                   error = ffetarget_convert_integer4_integer2
1005                     (ffebld_cu_ptr_integer4 (u),
1006                      ffebld_constant_integer2 (ffebld_conter (l)));
1007                   break;
1008 #endif
1009
1010 #if FFETARGET_okINTEGER3
1011                 case FFEINFO_kindtypeINTEGER3:
1012                   error = ffetarget_convert_integer4_integer3
1013                     (ffebld_cu_ptr_integer4 (u),
1014                      ffebld_constant_integer3 (ffebld_conter (l)));
1015                   break;
1016 #endif
1017
1018                 default:
1019                   assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1020                   break;
1021                 }
1022               break;
1023
1024             case FFEINFO_basictypeREAL:
1025               switch (ffeinfo_kindtype (ffebld_info (l)))
1026                 {
1027 #if FFETARGET_okREAL1
1028                 case FFEINFO_kindtypeREAL1:
1029                   error = ffetarget_convert_integer4_real1
1030                     (ffebld_cu_ptr_integer4 (u),
1031                      ffebld_constant_real1 (ffebld_conter (l)));
1032                   break;
1033 #endif
1034
1035 #if FFETARGET_okREAL2
1036                 case FFEINFO_kindtypeREAL2:
1037                   error = ffetarget_convert_integer4_real2
1038                     (ffebld_cu_ptr_integer4 (u),
1039                      ffebld_constant_real2 (ffebld_conter (l)));
1040                   break;
1041 #endif
1042
1043 #if FFETARGET_okREAL3
1044                 case FFEINFO_kindtypeREAL3:
1045                   error = ffetarget_convert_integer4_real3
1046                     (ffebld_cu_ptr_integer4 (u),
1047                      ffebld_constant_real3 (ffebld_conter (l)));
1048                   break;
1049 #endif
1050
1051                 default:
1052                   assert ("INTEGER4/REAL bad source kind type" == NULL);
1053                   break;
1054                 }
1055               break;
1056
1057             case FFEINFO_basictypeCOMPLEX:
1058               switch (ffeinfo_kindtype (ffebld_info (l)))
1059                 {
1060 #if FFETARGET_okCOMPLEX1
1061                 case FFEINFO_kindtypeREAL1:
1062                   error = ffetarget_convert_integer4_complex1
1063                     (ffebld_cu_ptr_integer4 (u),
1064                      ffebld_constant_complex1 (ffebld_conter (l)));
1065                   break;
1066 #endif
1067
1068 #if FFETARGET_okCOMPLEX2
1069                 case FFEINFO_kindtypeREAL2:
1070                   error = ffetarget_convert_integer4_complex2
1071                     (ffebld_cu_ptr_integer4 (u),
1072                      ffebld_constant_complex2 (ffebld_conter (l)));
1073                   break;
1074 #endif
1075
1076 #if FFETARGET_okCOMPLEX3
1077                 case FFEINFO_kindtypeREAL3:
1078                   error = ffetarget_convert_integer4_complex3
1079                     (ffebld_cu_ptr_integer4 (u),
1080                      ffebld_constant_complex3 (ffebld_conter (l)));
1081                   break;
1082 #endif
1083
1084                 default:
1085                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1086                   break;
1087                 }
1088               break;
1089
1090             case FFEINFO_basictypeLOGICAL:
1091               switch (ffeinfo_kindtype (ffebld_info (l)))
1092                 {
1093 #if FFETARGET_okLOGICAL1
1094                 case FFEINFO_kindtypeLOGICAL1:
1095                   error = ffetarget_convert_integer4_logical1
1096                     (ffebld_cu_ptr_integer4 (u),
1097                      ffebld_constant_logical1 (ffebld_conter (l)));
1098                   break;
1099 #endif
1100
1101 #if FFETARGET_okLOGICAL2
1102                 case FFEINFO_kindtypeLOGICAL2:
1103                   error = ffetarget_convert_integer4_logical2
1104                     (ffebld_cu_ptr_integer4 (u),
1105                      ffebld_constant_logical2 (ffebld_conter (l)));
1106                   break;
1107 #endif
1108
1109 #if FFETARGET_okLOGICAL3
1110                 case FFEINFO_kindtypeLOGICAL3:
1111                   error = ffetarget_convert_integer4_logical3
1112                     (ffebld_cu_ptr_integer4 (u),
1113                      ffebld_constant_logical3 (ffebld_conter (l)));
1114                   break;
1115 #endif
1116
1117 #if FFETARGET_okLOGICAL4
1118                 case FFEINFO_kindtypeLOGICAL4:
1119                   error = ffetarget_convert_integer4_logical4
1120                     (ffebld_cu_ptr_integer4 (u),
1121                      ffebld_constant_logical4 (ffebld_conter (l)));
1122                   break;
1123 #endif
1124
1125                 default:
1126                   assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1127                   break;
1128                 }
1129               break;
1130
1131             case FFEINFO_basictypeCHARACTER:
1132               error = ffetarget_convert_integer4_character1
1133                 (ffebld_cu_ptr_integer4 (u),
1134                  ffebld_constant_character1 (ffebld_conter (l)));
1135               break;
1136
1137             case FFEINFO_basictypeHOLLERITH:
1138               error = ffetarget_convert_integer4_hollerith
1139                 (ffebld_cu_ptr_integer4 (u),
1140                  ffebld_constant_hollerith (ffebld_conter (l)));
1141               break;
1142
1143             case FFEINFO_basictypeTYPELESS:
1144               error = ffetarget_convert_integer4_typeless
1145                 (ffebld_cu_ptr_integer4 (u),
1146                  ffebld_constant_typeless (ffebld_conter (l)));
1147               break;
1148
1149             default:
1150               assert ("INTEGER4 bad type" == NULL);
1151               break;
1152             }
1153
1154           /* If conversion operation is not implemented, return original expr.  */
1155           if (error == FFEBAD_NOCANDO)
1156             return expr;
1157
1158           expr = ffebld_new_conter_with_orig
1159             (ffebld_constant_new_integer4_val
1160              (ffebld_cu_val_integer4 (u)), expr);
1161           break;
1162 #endif
1163
1164         default:
1165           assert ("bad integer kind type" == NULL);
1166           break;
1167         }
1168       break;
1169
1170     case FFEINFO_basictypeLOGICAL:
1171       sz = FFETARGET_charactersizeNONE;
1172       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1173         {
1174 #if FFETARGET_okLOGICAL1
1175         case FFEINFO_kindtypeLOGICAL1:
1176           switch (ffeinfo_basictype (ffebld_info (l)))
1177             {
1178             case FFEINFO_basictypeLOGICAL:
1179               switch (ffeinfo_kindtype (ffebld_info (l)))
1180                 {
1181 #if FFETARGET_okLOGICAL2
1182                 case FFEINFO_kindtypeLOGICAL2:
1183                   error = ffetarget_convert_logical1_logical2
1184                     (ffebld_cu_ptr_logical1 (u),
1185                      ffebld_constant_logical2 (ffebld_conter (l)));
1186                   break;
1187 #endif
1188
1189 #if FFETARGET_okLOGICAL3
1190                 case FFEINFO_kindtypeLOGICAL3:
1191                   error = ffetarget_convert_logical1_logical3
1192                     (ffebld_cu_ptr_logical1 (u),
1193                      ffebld_constant_logical3 (ffebld_conter (l)));
1194                   break;
1195 #endif
1196
1197 #if FFETARGET_okLOGICAL4
1198                 case FFEINFO_kindtypeLOGICAL4:
1199                   error = ffetarget_convert_logical1_logical4
1200                     (ffebld_cu_ptr_logical1 (u),
1201                      ffebld_constant_logical4 (ffebld_conter (l)));
1202                   break;
1203 #endif
1204
1205                 default:
1206                   assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1207                   break;
1208                 }
1209               break;
1210
1211             case FFEINFO_basictypeINTEGER:
1212               switch (ffeinfo_kindtype (ffebld_info (l)))
1213                 {
1214 #if FFETARGET_okINTEGER1
1215                 case FFEINFO_kindtypeINTEGER1:
1216                   error = ffetarget_convert_logical1_integer1
1217                     (ffebld_cu_ptr_logical1 (u),
1218                      ffebld_constant_integer1 (ffebld_conter (l)));
1219                   break;
1220 #endif
1221
1222 #if FFETARGET_okINTEGER2
1223                 case FFEINFO_kindtypeINTEGER2:
1224                   error = ffetarget_convert_logical1_integer2
1225                     (ffebld_cu_ptr_logical1 (u),
1226                      ffebld_constant_integer2 (ffebld_conter (l)));
1227                   break;
1228 #endif
1229
1230 #if FFETARGET_okINTEGER3
1231                 case FFEINFO_kindtypeINTEGER3:
1232                   error = ffetarget_convert_logical1_integer3
1233                     (ffebld_cu_ptr_logical1 (u),
1234                      ffebld_constant_integer3 (ffebld_conter (l)));
1235                   break;
1236 #endif
1237
1238 #if FFETARGET_okINTEGER4
1239                 case FFEINFO_kindtypeINTEGER4:
1240                   error = ffetarget_convert_logical1_integer4
1241                     (ffebld_cu_ptr_logical1 (u),
1242                      ffebld_constant_integer4 (ffebld_conter (l)));
1243                   break;
1244 #endif
1245
1246                 default:
1247                   assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1248                   break;
1249                 }
1250               break;
1251
1252             case FFEINFO_basictypeCHARACTER:
1253               error = ffetarget_convert_logical1_character1
1254                 (ffebld_cu_ptr_logical1 (u),
1255                  ffebld_constant_character1 (ffebld_conter (l)));
1256               break;
1257
1258             case FFEINFO_basictypeHOLLERITH:
1259               error = ffetarget_convert_logical1_hollerith
1260                 (ffebld_cu_ptr_logical1 (u),
1261                  ffebld_constant_hollerith (ffebld_conter (l)));
1262               break;
1263
1264             case FFEINFO_basictypeTYPELESS:
1265               error = ffetarget_convert_logical1_typeless
1266                 (ffebld_cu_ptr_logical1 (u),
1267                  ffebld_constant_typeless (ffebld_conter (l)));
1268               break;
1269
1270             default:
1271               assert ("LOGICAL1 bad type" == NULL);
1272               break;
1273             }
1274
1275           /* If conversion operation is not implemented, return original expr.  */
1276           if (error == FFEBAD_NOCANDO)
1277             return expr;
1278
1279           expr = ffebld_new_conter_with_orig
1280             (ffebld_constant_new_logical1_val
1281              (ffebld_cu_val_logical1 (u)), expr);
1282           break;
1283 #endif
1284
1285 #if FFETARGET_okLOGICAL2
1286         case FFEINFO_kindtypeLOGICAL2:
1287           switch (ffeinfo_basictype (ffebld_info (l)))
1288             {
1289             case FFEINFO_basictypeLOGICAL:
1290               switch (ffeinfo_kindtype (ffebld_info (l)))
1291                 {
1292 #if FFETARGET_okLOGICAL1
1293                 case FFEINFO_kindtypeLOGICAL1:
1294                   error = ffetarget_convert_logical2_logical1
1295                     (ffebld_cu_ptr_logical2 (u),
1296                      ffebld_constant_logical1 (ffebld_conter (l)));
1297                   break;
1298 #endif
1299
1300 #if FFETARGET_okLOGICAL3
1301                 case FFEINFO_kindtypeLOGICAL3:
1302                   error = ffetarget_convert_logical2_logical3
1303                     (ffebld_cu_ptr_logical2 (u),
1304                      ffebld_constant_logical3 (ffebld_conter (l)));
1305                   break;
1306 #endif
1307
1308 #if FFETARGET_okLOGICAL4
1309                 case FFEINFO_kindtypeLOGICAL4:
1310                   error = ffetarget_convert_logical2_logical4
1311                     (ffebld_cu_ptr_logical2 (u),
1312                      ffebld_constant_logical4 (ffebld_conter (l)));
1313                   break;
1314 #endif
1315
1316                 default:
1317                   assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1318                   break;
1319                 }
1320               break;
1321
1322             case FFEINFO_basictypeINTEGER:
1323               switch (ffeinfo_kindtype (ffebld_info (l)))
1324                 {
1325 #if FFETARGET_okINTEGER1
1326                 case FFEINFO_kindtypeINTEGER1:
1327                   error = ffetarget_convert_logical2_integer1
1328                     (ffebld_cu_ptr_logical2 (u),
1329                      ffebld_constant_integer1 (ffebld_conter (l)));
1330                   break;
1331 #endif
1332
1333 #if FFETARGET_okINTEGER2
1334                 case FFEINFO_kindtypeINTEGER2:
1335                   error = ffetarget_convert_logical2_integer2
1336                     (ffebld_cu_ptr_logical2 (u),
1337                      ffebld_constant_integer2 (ffebld_conter (l)));
1338                   break;
1339 #endif
1340
1341 #if FFETARGET_okINTEGER3
1342                 case FFEINFO_kindtypeINTEGER3:
1343                   error = ffetarget_convert_logical2_integer3
1344                     (ffebld_cu_ptr_logical2 (u),
1345                      ffebld_constant_integer3 (ffebld_conter (l)));
1346                   break;
1347 #endif
1348
1349 #if FFETARGET_okINTEGER4
1350                 case FFEINFO_kindtypeINTEGER4:
1351                   error = ffetarget_convert_logical2_integer4
1352                     (ffebld_cu_ptr_logical2 (u),
1353                      ffebld_constant_integer4 (ffebld_conter (l)));
1354                   break;
1355 #endif
1356
1357                 default:
1358                   assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1359                   break;
1360                 }
1361               break;
1362
1363             case FFEINFO_basictypeCHARACTER:
1364               error = ffetarget_convert_logical2_character1
1365                 (ffebld_cu_ptr_logical2 (u),
1366                  ffebld_constant_character1 (ffebld_conter (l)));
1367               break;
1368
1369             case FFEINFO_basictypeHOLLERITH:
1370               error = ffetarget_convert_logical2_hollerith
1371                 (ffebld_cu_ptr_logical2 (u),
1372                  ffebld_constant_hollerith (ffebld_conter (l)));
1373               break;
1374
1375             case FFEINFO_basictypeTYPELESS:
1376               error = ffetarget_convert_logical2_typeless
1377                 (ffebld_cu_ptr_logical2 (u),
1378                  ffebld_constant_typeless (ffebld_conter (l)));
1379               break;
1380
1381             default:
1382               assert ("LOGICAL2 bad type" == NULL);
1383               break;
1384             }
1385
1386           /* If conversion operation is not implemented, return original expr.  */
1387           if (error == FFEBAD_NOCANDO)
1388             return expr;
1389
1390           expr = ffebld_new_conter_with_orig
1391             (ffebld_constant_new_logical2_val
1392              (ffebld_cu_val_logical2 (u)), expr);
1393           break;
1394 #endif
1395
1396 #if FFETARGET_okLOGICAL3
1397         case FFEINFO_kindtypeLOGICAL3:
1398           switch (ffeinfo_basictype (ffebld_info (l)))
1399             {
1400             case FFEINFO_basictypeLOGICAL:
1401               switch (ffeinfo_kindtype (ffebld_info (l)))
1402                 {
1403 #if FFETARGET_okLOGICAL1
1404                 case FFEINFO_kindtypeLOGICAL1:
1405                   error = ffetarget_convert_logical3_logical1
1406                     (ffebld_cu_ptr_logical3 (u),
1407                      ffebld_constant_logical1 (ffebld_conter (l)));
1408                   break;
1409 #endif
1410
1411 #if FFETARGET_okLOGICAL2
1412                 case FFEINFO_kindtypeLOGICAL2:
1413                   error = ffetarget_convert_logical3_logical2
1414                     (ffebld_cu_ptr_logical3 (u),
1415                      ffebld_constant_logical2 (ffebld_conter (l)));
1416                   break;
1417 #endif
1418
1419 #if FFETARGET_okLOGICAL4
1420                 case FFEINFO_kindtypeLOGICAL4:
1421                   error = ffetarget_convert_logical3_logical4
1422                     (ffebld_cu_ptr_logical3 (u),
1423                      ffebld_constant_logical4 (ffebld_conter (l)));
1424                   break;
1425 #endif
1426
1427                 default:
1428                   assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1429                   break;
1430                 }
1431               break;
1432
1433             case FFEINFO_basictypeINTEGER:
1434               switch (ffeinfo_kindtype (ffebld_info (l)))
1435                 {
1436 #if FFETARGET_okINTEGER1
1437                 case FFEINFO_kindtypeINTEGER1:
1438                   error = ffetarget_convert_logical3_integer1
1439                     (ffebld_cu_ptr_logical3 (u),
1440                      ffebld_constant_integer1 (ffebld_conter (l)));
1441                   break;
1442 #endif
1443
1444 #if FFETARGET_okINTEGER2
1445                 case FFEINFO_kindtypeINTEGER2:
1446                   error = ffetarget_convert_logical3_integer2
1447                     (ffebld_cu_ptr_logical3 (u),
1448                      ffebld_constant_integer2 (ffebld_conter (l)));
1449                   break;
1450 #endif
1451
1452 #if FFETARGET_okINTEGER3
1453                 case FFEINFO_kindtypeINTEGER3:
1454                   error = ffetarget_convert_logical3_integer3
1455                     (ffebld_cu_ptr_logical3 (u),
1456                      ffebld_constant_integer3 (ffebld_conter (l)));
1457                   break;
1458 #endif
1459
1460 #if FFETARGET_okINTEGER4
1461                 case FFEINFO_kindtypeINTEGER4:
1462                   error = ffetarget_convert_logical3_integer4
1463                     (ffebld_cu_ptr_logical3 (u),
1464                      ffebld_constant_integer4 (ffebld_conter (l)));
1465                   break;
1466 #endif
1467
1468                 default:
1469                   assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1470                   break;
1471                 }
1472               break;
1473
1474             case FFEINFO_basictypeCHARACTER:
1475               error = ffetarget_convert_logical3_character1
1476                 (ffebld_cu_ptr_logical3 (u),
1477                  ffebld_constant_character1 (ffebld_conter (l)));
1478               break;
1479
1480             case FFEINFO_basictypeHOLLERITH:
1481               error = ffetarget_convert_logical3_hollerith
1482                 (ffebld_cu_ptr_logical3 (u),
1483                  ffebld_constant_hollerith (ffebld_conter (l)));
1484               break;
1485
1486             case FFEINFO_basictypeTYPELESS:
1487               error = ffetarget_convert_logical3_typeless
1488                 (ffebld_cu_ptr_logical3 (u),
1489                  ffebld_constant_typeless (ffebld_conter (l)));
1490               break;
1491
1492             default:
1493               assert ("LOGICAL3 bad type" == NULL);
1494               break;
1495             }
1496
1497           /* If conversion operation is not implemented, return original expr.  */
1498           if (error == FFEBAD_NOCANDO)
1499             return expr;
1500
1501           expr = ffebld_new_conter_with_orig
1502             (ffebld_constant_new_logical3_val
1503              (ffebld_cu_val_logical3 (u)), expr);
1504           break;
1505 #endif
1506
1507 #if FFETARGET_okLOGICAL4
1508         case FFEINFO_kindtypeLOGICAL4:
1509           switch (ffeinfo_basictype (ffebld_info (l)))
1510             {
1511             case FFEINFO_basictypeLOGICAL:
1512               switch (ffeinfo_kindtype (ffebld_info (l)))
1513                 {
1514 #if FFETARGET_okLOGICAL1
1515                 case FFEINFO_kindtypeLOGICAL1:
1516                   error = ffetarget_convert_logical4_logical1
1517                     (ffebld_cu_ptr_logical4 (u),
1518                      ffebld_constant_logical1 (ffebld_conter (l)));
1519                   break;
1520 #endif
1521
1522 #if FFETARGET_okLOGICAL2
1523                 case FFEINFO_kindtypeLOGICAL2:
1524                   error = ffetarget_convert_logical4_logical2
1525                     (ffebld_cu_ptr_logical4 (u),
1526                      ffebld_constant_logical2 (ffebld_conter (l)));
1527                   break;
1528 #endif
1529
1530 #if FFETARGET_okLOGICAL3
1531                 case FFEINFO_kindtypeLOGICAL3:
1532                   error = ffetarget_convert_logical4_logical3
1533                     (ffebld_cu_ptr_logical4 (u),
1534                      ffebld_constant_logical3 (ffebld_conter (l)));
1535                   break;
1536 #endif
1537
1538                 default:
1539                   assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1540                   break;
1541                 }
1542               break;
1543
1544             case FFEINFO_basictypeINTEGER:
1545               switch (ffeinfo_kindtype (ffebld_info (l)))
1546                 {
1547 #if FFETARGET_okINTEGER1
1548                 case FFEINFO_kindtypeINTEGER1:
1549                   error = ffetarget_convert_logical4_integer1
1550                     (ffebld_cu_ptr_logical4 (u),
1551                      ffebld_constant_integer1 (ffebld_conter (l)));
1552                   break;
1553 #endif
1554
1555 #if FFETARGET_okINTEGER2
1556                 case FFEINFO_kindtypeINTEGER2:
1557                   error = ffetarget_convert_logical4_integer2
1558                     (ffebld_cu_ptr_logical4 (u),
1559                      ffebld_constant_integer2 (ffebld_conter (l)));
1560                   break;
1561 #endif
1562
1563 #if FFETARGET_okINTEGER3
1564                 case FFEINFO_kindtypeINTEGER3:
1565                   error = ffetarget_convert_logical4_integer3
1566                     (ffebld_cu_ptr_logical4 (u),
1567                      ffebld_constant_integer3 (ffebld_conter (l)));
1568                   break;
1569 #endif
1570
1571 #if FFETARGET_okINTEGER4
1572                 case FFEINFO_kindtypeINTEGER4:
1573                   error = ffetarget_convert_logical4_integer4
1574                     (ffebld_cu_ptr_logical4 (u),
1575                      ffebld_constant_integer4 (ffebld_conter (l)));
1576                   break;
1577 #endif
1578
1579                 default:
1580                   assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1581                   break;
1582                 }
1583               break;
1584
1585             case FFEINFO_basictypeCHARACTER:
1586               error = ffetarget_convert_logical4_character1
1587                 (ffebld_cu_ptr_logical4 (u),
1588                  ffebld_constant_character1 (ffebld_conter (l)));
1589               break;
1590
1591             case FFEINFO_basictypeHOLLERITH:
1592               error = ffetarget_convert_logical4_hollerith
1593                 (ffebld_cu_ptr_logical4 (u),
1594                  ffebld_constant_hollerith (ffebld_conter (l)));
1595               break;
1596
1597             case FFEINFO_basictypeTYPELESS:
1598               error = ffetarget_convert_logical4_typeless
1599                 (ffebld_cu_ptr_logical4 (u),
1600                  ffebld_constant_typeless (ffebld_conter (l)));
1601               break;
1602
1603             default:
1604               assert ("LOGICAL4 bad type" == NULL);
1605               break;
1606             }
1607
1608           /* If conversion operation is not implemented, return original expr.  */
1609           if (error == FFEBAD_NOCANDO)
1610             return expr;
1611
1612           expr = ffebld_new_conter_with_orig
1613             (ffebld_constant_new_logical4_val
1614              (ffebld_cu_val_logical4 (u)), expr);
1615           break;
1616 #endif
1617
1618         default:
1619           assert ("bad logical kind type" == NULL);
1620           break;
1621         }
1622       break;
1623
1624     case FFEINFO_basictypeREAL:
1625       sz = FFETARGET_charactersizeNONE;
1626       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1627         {
1628 #if FFETARGET_okREAL1
1629         case FFEINFO_kindtypeREAL1:
1630           switch (ffeinfo_basictype (ffebld_info (l)))
1631             {
1632             case FFEINFO_basictypeINTEGER:
1633               switch (ffeinfo_kindtype (ffebld_info (l)))
1634                 {
1635 #if FFETARGET_okINTEGER1
1636                 case FFEINFO_kindtypeINTEGER1:
1637                   error = ffetarget_convert_real1_integer1
1638                     (ffebld_cu_ptr_real1 (u),
1639                      ffebld_constant_integer1 (ffebld_conter (l)));
1640                   break;
1641 #endif
1642
1643 #if FFETARGET_okINTEGER2
1644                 case FFEINFO_kindtypeINTEGER2:
1645                   error = ffetarget_convert_real1_integer2
1646                     (ffebld_cu_ptr_real1 (u),
1647                      ffebld_constant_integer2 (ffebld_conter (l)));
1648                   break;
1649 #endif
1650
1651 #if FFETARGET_okINTEGER3
1652                 case FFEINFO_kindtypeINTEGER3:
1653                   error = ffetarget_convert_real1_integer3
1654                     (ffebld_cu_ptr_real1 (u),
1655                      ffebld_constant_integer3 (ffebld_conter (l)));
1656                   break;
1657 #endif
1658
1659 #if FFETARGET_okINTEGER4
1660                 case FFEINFO_kindtypeINTEGER4:
1661                   error = ffetarget_convert_real1_integer4
1662                     (ffebld_cu_ptr_real1 (u),
1663                      ffebld_constant_integer4 (ffebld_conter (l)));
1664                   break;
1665 #endif
1666
1667                 default:
1668                   assert ("REAL1/INTEGER bad source kind type" == NULL);
1669                   break;
1670                 }
1671               break;
1672
1673             case FFEINFO_basictypeREAL:
1674               switch (ffeinfo_kindtype (ffebld_info (l)))
1675                 {
1676 #if FFETARGET_okREAL2
1677                 case FFEINFO_kindtypeREAL2:
1678                   error = ffetarget_convert_real1_real2
1679                     (ffebld_cu_ptr_real1 (u),
1680                      ffebld_constant_real2 (ffebld_conter (l)));
1681                   break;
1682 #endif
1683
1684 #if FFETARGET_okREAL3
1685                 case FFEINFO_kindtypeREAL3:
1686                   error = ffetarget_convert_real1_real3
1687                     (ffebld_cu_ptr_real1 (u),
1688                      ffebld_constant_real3 (ffebld_conter (l)));
1689                   break;
1690 #endif
1691
1692                 default:
1693                   assert ("REAL1/REAL bad source kind type" == NULL);
1694                   break;
1695                 }
1696               break;
1697
1698             case FFEINFO_basictypeCOMPLEX:
1699               switch (ffeinfo_kindtype (ffebld_info (l)))
1700                 {
1701 #if FFETARGET_okCOMPLEX1
1702                 case FFEINFO_kindtypeREAL1:
1703                   error = ffetarget_convert_real1_complex1
1704                     (ffebld_cu_ptr_real1 (u),
1705                      ffebld_constant_complex1 (ffebld_conter (l)));
1706                   break;
1707 #endif
1708
1709 #if FFETARGET_okCOMPLEX2
1710                 case FFEINFO_kindtypeREAL2:
1711                   error = ffetarget_convert_real1_complex2
1712                     (ffebld_cu_ptr_real1 (u),
1713                      ffebld_constant_complex2 (ffebld_conter (l)));
1714                   break;
1715 #endif
1716
1717 #if FFETARGET_okCOMPLEX3
1718                 case FFEINFO_kindtypeREAL3:
1719                   error = ffetarget_convert_real1_complex3
1720                     (ffebld_cu_ptr_real1 (u),
1721                      ffebld_constant_complex3 (ffebld_conter (l)));
1722                   break;
1723 #endif
1724
1725                 default:
1726                   assert ("REAL1/COMPLEX bad source kind type" == NULL);
1727                   break;
1728                 }
1729               break;
1730
1731             case FFEINFO_basictypeCHARACTER:
1732               error = ffetarget_convert_real1_character1
1733                 (ffebld_cu_ptr_real1 (u),
1734                  ffebld_constant_character1 (ffebld_conter (l)));
1735               break;
1736
1737             case FFEINFO_basictypeHOLLERITH:
1738               error = ffetarget_convert_real1_hollerith
1739                 (ffebld_cu_ptr_real1 (u),
1740                  ffebld_constant_hollerith (ffebld_conter (l)));
1741               break;
1742
1743             case FFEINFO_basictypeTYPELESS:
1744               error = ffetarget_convert_real1_typeless
1745                 (ffebld_cu_ptr_real1 (u),
1746                  ffebld_constant_typeless (ffebld_conter (l)));
1747               break;
1748
1749             default:
1750               assert ("REAL1 bad type" == NULL);
1751               break;
1752             }
1753
1754           /* If conversion operation is not implemented, return original expr.  */
1755           if (error == FFEBAD_NOCANDO)
1756             return expr;
1757
1758           expr = ffebld_new_conter_with_orig
1759             (ffebld_constant_new_real1_val
1760              (ffebld_cu_val_real1 (u)), expr);
1761           break;
1762 #endif
1763
1764 #if FFETARGET_okREAL2
1765         case FFEINFO_kindtypeREAL2:
1766           switch (ffeinfo_basictype (ffebld_info (l)))
1767             {
1768             case FFEINFO_basictypeINTEGER:
1769               switch (ffeinfo_kindtype (ffebld_info (l)))
1770                 {
1771 #if FFETARGET_okINTEGER1
1772                 case FFEINFO_kindtypeINTEGER1:
1773                   error = ffetarget_convert_real2_integer1
1774                     (ffebld_cu_ptr_real2 (u),
1775                      ffebld_constant_integer1 (ffebld_conter (l)));
1776                   break;
1777 #endif
1778
1779 #if FFETARGET_okINTEGER2
1780                 case FFEINFO_kindtypeINTEGER2:
1781                   error = ffetarget_convert_real2_integer2
1782                     (ffebld_cu_ptr_real2 (u),
1783                      ffebld_constant_integer2 (ffebld_conter (l)));
1784                   break;
1785 #endif
1786
1787 #if FFETARGET_okINTEGER3
1788                 case FFEINFO_kindtypeINTEGER3:
1789                   error = ffetarget_convert_real2_integer3
1790                     (ffebld_cu_ptr_real2 (u),
1791                      ffebld_constant_integer3 (ffebld_conter (l)));
1792                   break;
1793 #endif
1794
1795 #if FFETARGET_okINTEGER4
1796                 case FFEINFO_kindtypeINTEGER4:
1797                   error = ffetarget_convert_real2_integer4
1798                     (ffebld_cu_ptr_real2 (u),
1799                      ffebld_constant_integer4 (ffebld_conter (l)));
1800                   break;
1801 #endif
1802
1803                 default:
1804                   assert ("REAL2/INTEGER bad source kind type" == NULL);
1805                   break;
1806                 }
1807               break;
1808
1809             case FFEINFO_basictypeREAL:
1810               switch (ffeinfo_kindtype (ffebld_info (l)))
1811                 {
1812 #if FFETARGET_okREAL1
1813                 case FFEINFO_kindtypeREAL1:
1814                   error = ffetarget_convert_real2_real1
1815                     (ffebld_cu_ptr_real2 (u),
1816                      ffebld_constant_real1 (ffebld_conter (l)));
1817                   break;
1818 #endif
1819
1820 #if FFETARGET_okREAL3
1821                 case FFEINFO_kindtypeREAL3:
1822                   error = ffetarget_convert_real2_real3
1823                     (ffebld_cu_ptr_real2 (u),
1824                      ffebld_constant_real3 (ffebld_conter (l)));
1825                   break;
1826 #endif
1827
1828                 default:
1829                   assert ("REAL2/REAL bad source kind type" == NULL);
1830                   break;
1831                 }
1832               break;
1833
1834             case FFEINFO_basictypeCOMPLEX:
1835               switch (ffeinfo_kindtype (ffebld_info (l)))
1836                 {
1837 #if FFETARGET_okCOMPLEX1
1838                 case FFEINFO_kindtypeREAL1:
1839                   error = ffetarget_convert_real2_complex1
1840                     (ffebld_cu_ptr_real2 (u),
1841                      ffebld_constant_complex1 (ffebld_conter (l)));
1842                   break;
1843 #endif
1844
1845 #if FFETARGET_okCOMPLEX2
1846                 case FFEINFO_kindtypeREAL2:
1847                   error = ffetarget_convert_real2_complex2
1848                     (ffebld_cu_ptr_real2 (u),
1849                      ffebld_constant_complex2 (ffebld_conter (l)));
1850                   break;
1851 #endif
1852
1853 #if FFETARGET_okCOMPLEX3
1854                 case FFEINFO_kindtypeREAL3:
1855                   error = ffetarget_convert_real2_complex3
1856                     (ffebld_cu_ptr_real2 (u),
1857                      ffebld_constant_complex3 (ffebld_conter (l)));
1858                   break;
1859 #endif
1860
1861                 default:
1862                   assert ("REAL2/COMPLEX bad source kind type" == NULL);
1863                   break;
1864                 }
1865               break;
1866
1867             case FFEINFO_basictypeCHARACTER:
1868               error = ffetarget_convert_real2_character1
1869                 (ffebld_cu_ptr_real2 (u),
1870                  ffebld_constant_character1 (ffebld_conter (l)));
1871               break;
1872
1873             case FFEINFO_basictypeHOLLERITH:
1874               error = ffetarget_convert_real2_hollerith
1875                 (ffebld_cu_ptr_real2 (u),
1876                  ffebld_constant_hollerith (ffebld_conter (l)));
1877               break;
1878
1879             case FFEINFO_basictypeTYPELESS:
1880               error = ffetarget_convert_real2_typeless
1881                 (ffebld_cu_ptr_real2 (u),
1882                  ffebld_constant_typeless (ffebld_conter (l)));
1883               break;
1884
1885             default:
1886               assert ("REAL2 bad type" == NULL);
1887               break;
1888             }
1889
1890           /* If conversion operation is not implemented, return original expr.  */
1891           if (error == FFEBAD_NOCANDO)
1892             return expr;
1893
1894           expr = ffebld_new_conter_with_orig
1895             (ffebld_constant_new_real2_val
1896              (ffebld_cu_val_real2 (u)), expr);
1897           break;
1898 #endif
1899
1900 #if FFETARGET_okREAL3
1901         case FFEINFO_kindtypeREAL3:
1902           switch (ffeinfo_basictype (ffebld_info (l)))
1903             {
1904             case FFEINFO_basictypeINTEGER:
1905               switch (ffeinfo_kindtype (ffebld_info (l)))
1906                 {
1907 #if FFETARGET_okINTEGER1
1908                 case FFEINFO_kindtypeINTEGER1:
1909                   error = ffetarget_convert_real3_integer1
1910                     (ffebld_cu_ptr_real3 (u),
1911                      ffebld_constant_integer1 (ffebld_conter (l)));
1912                   break;
1913 #endif
1914
1915 #if FFETARGET_okINTEGER2
1916                 case FFEINFO_kindtypeINTEGER2:
1917                   error = ffetarget_convert_real3_integer2
1918                     (ffebld_cu_ptr_real3 (u),
1919                      ffebld_constant_integer2 (ffebld_conter (l)));
1920                   break;
1921 #endif
1922
1923 #if FFETARGET_okINTEGER3
1924                 case FFEINFO_kindtypeINTEGER3:
1925                   error = ffetarget_convert_real3_integer3
1926                     (ffebld_cu_ptr_real3 (u),
1927                      ffebld_constant_integer3 (ffebld_conter (l)));
1928                   break;
1929 #endif
1930
1931 #if FFETARGET_okINTEGER4
1932                 case FFEINFO_kindtypeINTEGER4:
1933                   error = ffetarget_convert_real3_integer4
1934                     (ffebld_cu_ptr_real3 (u),
1935                      ffebld_constant_integer4 (ffebld_conter (l)));
1936                   break;
1937 #endif
1938
1939                 default:
1940                   assert ("REAL3/INTEGER bad source kind type" == NULL);
1941                   break;
1942                 }
1943               break;
1944
1945             case FFEINFO_basictypeREAL:
1946               switch (ffeinfo_kindtype (ffebld_info (l)))
1947                 {
1948 #if FFETARGET_okREAL1
1949                 case FFEINFO_kindtypeREAL1:
1950                   error = ffetarget_convert_real3_real1
1951                     (ffebld_cu_ptr_real3 (u),
1952                      ffebld_constant_real1 (ffebld_conter (l)));
1953                   break;
1954 #endif
1955
1956 #if FFETARGET_okREAL2
1957                 case FFEINFO_kindtypeREAL2:
1958                   error = ffetarget_convert_real3_real2
1959                     (ffebld_cu_ptr_real3 (u),
1960                      ffebld_constant_real2 (ffebld_conter (l)));
1961                   break;
1962 #endif
1963
1964                 default:
1965                   assert ("REAL3/REAL bad source kind type" == NULL);
1966                   break;
1967                 }
1968               break;
1969
1970             case FFEINFO_basictypeCOMPLEX:
1971               switch (ffeinfo_kindtype (ffebld_info (l)))
1972                 {
1973 #if FFETARGET_okCOMPLEX1
1974                 case FFEINFO_kindtypeREAL1:
1975                   error = ffetarget_convert_real3_complex1
1976                     (ffebld_cu_ptr_real3 (u),
1977                      ffebld_constant_complex1 (ffebld_conter (l)));
1978                   break;
1979 #endif
1980
1981 #if FFETARGET_okCOMPLEX2
1982                 case FFEINFO_kindtypeREAL2:
1983                   error = ffetarget_convert_real3_complex2
1984                     (ffebld_cu_ptr_real3 (u),
1985                      ffebld_constant_complex2 (ffebld_conter (l)));
1986                   break;
1987 #endif
1988
1989 #if FFETARGET_okCOMPLEX3
1990                 case FFEINFO_kindtypeREAL3:
1991                   error = ffetarget_convert_real3_complex3
1992                     (ffebld_cu_ptr_real3 (u),
1993                      ffebld_constant_complex3 (ffebld_conter (l)));
1994                   break;
1995 #endif
1996
1997                 default:
1998                   assert ("REAL3/COMPLEX bad source kind type" == NULL);
1999                   break;
2000                 }
2001               break;
2002
2003             case FFEINFO_basictypeCHARACTER:
2004               error = ffetarget_convert_real3_character1
2005                 (ffebld_cu_ptr_real3 (u),
2006                  ffebld_constant_character1 (ffebld_conter (l)));
2007               break;
2008
2009             case FFEINFO_basictypeHOLLERITH:
2010               error = ffetarget_convert_real3_hollerith
2011                 (ffebld_cu_ptr_real3 (u),
2012                  ffebld_constant_hollerith (ffebld_conter (l)));
2013               break;
2014
2015             case FFEINFO_basictypeTYPELESS:
2016               error = ffetarget_convert_real3_typeless
2017                 (ffebld_cu_ptr_real3 (u),
2018                  ffebld_constant_typeless (ffebld_conter (l)));
2019               break;
2020
2021             default:
2022               assert ("REAL3 bad type" == NULL);
2023               break;
2024             }
2025
2026           /* If conversion operation is not implemented, return original expr.  */
2027           if (error == FFEBAD_NOCANDO)
2028             return expr;
2029
2030           expr = ffebld_new_conter_with_orig
2031             (ffebld_constant_new_real3_val
2032              (ffebld_cu_val_real3 (u)), expr);
2033           break;
2034 #endif
2035
2036         default:
2037           assert ("bad real kind type" == NULL);
2038           break;
2039         }
2040       break;
2041
2042     case FFEINFO_basictypeCOMPLEX:
2043       sz = FFETARGET_charactersizeNONE;
2044       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2045         {
2046 #if FFETARGET_okCOMPLEX1
2047         case FFEINFO_kindtypeREAL1:
2048           switch (ffeinfo_basictype (ffebld_info (l)))
2049             {
2050             case FFEINFO_basictypeINTEGER:
2051               switch (ffeinfo_kindtype (ffebld_info (l)))
2052                 {
2053 #if FFETARGET_okINTEGER1
2054                 case FFEINFO_kindtypeINTEGER1:
2055                   error = ffetarget_convert_complex1_integer1
2056                     (ffebld_cu_ptr_complex1 (u),
2057                      ffebld_constant_integer1 (ffebld_conter (l)));
2058                   break;
2059 #endif
2060
2061 #if FFETARGET_okINTEGER2
2062                 case FFEINFO_kindtypeINTEGER2:
2063                   error = ffetarget_convert_complex1_integer2
2064                     (ffebld_cu_ptr_complex1 (u),
2065                      ffebld_constant_integer2 (ffebld_conter (l)));
2066                   break;
2067 #endif
2068
2069 #if FFETARGET_okINTEGER3
2070                 case FFEINFO_kindtypeINTEGER3:
2071                   error = ffetarget_convert_complex1_integer3
2072                     (ffebld_cu_ptr_complex1 (u),
2073                      ffebld_constant_integer3 (ffebld_conter (l)));
2074                   break;
2075 #endif
2076
2077 #if FFETARGET_okINTEGER4
2078                 case FFEINFO_kindtypeINTEGER4:
2079                   error = ffetarget_convert_complex1_integer4
2080                     (ffebld_cu_ptr_complex1 (u),
2081                      ffebld_constant_integer4 (ffebld_conter (l)));
2082                   break;
2083 #endif
2084
2085                 default:
2086                   assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2087                   break;
2088                 }
2089               break;
2090
2091             case FFEINFO_basictypeREAL:
2092               switch (ffeinfo_kindtype (ffebld_info (l)))
2093                 {
2094 #if FFETARGET_okREAL1
2095                 case FFEINFO_kindtypeREAL1:
2096                   error = ffetarget_convert_complex1_real1
2097                     (ffebld_cu_ptr_complex1 (u),
2098                      ffebld_constant_real1 (ffebld_conter (l)));
2099                   break;
2100 #endif
2101
2102 #if FFETARGET_okREAL2
2103                 case FFEINFO_kindtypeREAL2:
2104                   error = ffetarget_convert_complex1_real2
2105                     (ffebld_cu_ptr_complex1 (u),
2106                      ffebld_constant_real2 (ffebld_conter (l)));
2107                   break;
2108 #endif
2109
2110 #if FFETARGET_okREAL3
2111                 case FFEINFO_kindtypeREAL3:
2112                   error = ffetarget_convert_complex1_real3
2113                     (ffebld_cu_ptr_complex1 (u),
2114                      ffebld_constant_real3 (ffebld_conter (l)));
2115                   break;
2116 #endif
2117
2118                 default:
2119                   assert ("COMPLEX1/REAL bad source kind type" == NULL);
2120                   break;
2121                 }
2122               break;
2123
2124             case FFEINFO_basictypeCOMPLEX:
2125               switch (ffeinfo_kindtype (ffebld_info (l)))
2126                 {
2127 #if FFETARGET_okCOMPLEX2
2128                 case FFEINFO_kindtypeREAL2:
2129                   error = ffetarget_convert_complex1_complex2
2130                     (ffebld_cu_ptr_complex1 (u),
2131                      ffebld_constant_complex2 (ffebld_conter (l)));
2132                   break;
2133 #endif
2134
2135 #if FFETARGET_okCOMPLEX3
2136                 case FFEINFO_kindtypeREAL3:
2137                   error = ffetarget_convert_complex1_complex3
2138                     (ffebld_cu_ptr_complex1 (u),
2139                      ffebld_constant_complex3 (ffebld_conter (l)));
2140                   break;
2141 #endif
2142
2143                 default:
2144                   assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2145                   break;
2146                 }
2147               break;
2148
2149             case FFEINFO_basictypeCHARACTER:
2150               error = ffetarget_convert_complex1_character1
2151                 (ffebld_cu_ptr_complex1 (u),
2152                  ffebld_constant_character1 (ffebld_conter (l)));
2153               break;
2154
2155             case FFEINFO_basictypeHOLLERITH:
2156               error = ffetarget_convert_complex1_hollerith
2157                 (ffebld_cu_ptr_complex1 (u),
2158                  ffebld_constant_hollerith (ffebld_conter (l)));
2159               break;
2160
2161             case FFEINFO_basictypeTYPELESS:
2162               error = ffetarget_convert_complex1_typeless
2163                 (ffebld_cu_ptr_complex1 (u),
2164                  ffebld_constant_typeless (ffebld_conter (l)));
2165               break;
2166
2167             default:
2168               assert ("COMPLEX1 bad type" == NULL);
2169               break;
2170             }
2171
2172           /* If conversion operation is not implemented, return original expr.  */
2173           if (error == FFEBAD_NOCANDO)
2174             return expr;
2175
2176           expr = ffebld_new_conter_with_orig
2177             (ffebld_constant_new_complex1_val
2178              (ffebld_cu_val_complex1 (u)), expr);
2179           break;
2180 #endif
2181
2182 #if FFETARGET_okCOMPLEX2
2183         case FFEINFO_kindtypeREAL2:
2184           switch (ffeinfo_basictype (ffebld_info (l)))
2185             {
2186             case FFEINFO_basictypeINTEGER:
2187               switch (ffeinfo_kindtype (ffebld_info (l)))
2188                 {
2189 #if FFETARGET_okINTEGER1
2190                 case FFEINFO_kindtypeINTEGER1:
2191                   error = ffetarget_convert_complex2_integer1
2192                     (ffebld_cu_ptr_complex2 (u),
2193                      ffebld_constant_integer1 (ffebld_conter (l)));
2194                   break;
2195 #endif
2196
2197 #if FFETARGET_okINTEGER2
2198                 case FFEINFO_kindtypeINTEGER2:
2199                   error = ffetarget_convert_complex2_integer2
2200                     (ffebld_cu_ptr_complex2 (u),
2201                      ffebld_constant_integer2 (ffebld_conter (l)));
2202                   break;
2203 #endif
2204
2205 #if FFETARGET_okINTEGER3
2206                 case FFEINFO_kindtypeINTEGER3:
2207                   error = ffetarget_convert_complex2_integer3
2208                     (ffebld_cu_ptr_complex2 (u),
2209                      ffebld_constant_integer3 (ffebld_conter (l)));
2210                   break;
2211 #endif
2212
2213 #if FFETARGET_okINTEGER4
2214                 case FFEINFO_kindtypeINTEGER4:
2215                   error = ffetarget_convert_complex2_integer4
2216                     (ffebld_cu_ptr_complex2 (u),
2217                      ffebld_constant_integer4 (ffebld_conter (l)));
2218                   break;
2219 #endif
2220
2221                 default:
2222                   assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2223                   break;
2224                 }
2225               break;
2226
2227             case FFEINFO_basictypeREAL:
2228               switch (ffeinfo_kindtype (ffebld_info (l)))
2229                 {
2230 #if FFETARGET_okREAL1
2231                 case FFEINFO_kindtypeREAL1:
2232                   error = ffetarget_convert_complex2_real1
2233                     (ffebld_cu_ptr_complex2 (u),
2234                      ffebld_constant_real1 (ffebld_conter (l)));
2235                   break;
2236 #endif
2237
2238 #if FFETARGET_okREAL2
2239                 case FFEINFO_kindtypeREAL2:
2240                   error = ffetarget_convert_complex2_real2
2241                     (ffebld_cu_ptr_complex2 (u),
2242                      ffebld_constant_real2 (ffebld_conter (l)));
2243                   break;
2244 #endif
2245
2246 #if FFETARGET_okREAL3
2247                 case FFEINFO_kindtypeREAL3:
2248                   error = ffetarget_convert_complex2_real3
2249                     (ffebld_cu_ptr_complex2 (u),
2250                      ffebld_constant_real3 (ffebld_conter (l)));
2251                   break;
2252 #endif
2253
2254                 default:
2255                   assert ("COMPLEX2/REAL bad source kind type" == NULL);
2256                   break;
2257                 }
2258               break;
2259
2260             case FFEINFO_basictypeCOMPLEX:
2261               switch (ffeinfo_kindtype (ffebld_info (l)))
2262                 {
2263 #if FFETARGET_okCOMPLEX1
2264                 case FFEINFO_kindtypeREAL1:
2265                   error = ffetarget_convert_complex2_complex1
2266                     (ffebld_cu_ptr_complex2 (u),
2267                      ffebld_constant_complex1 (ffebld_conter (l)));
2268                   break;
2269 #endif
2270
2271 #if FFETARGET_okCOMPLEX3
2272                 case FFEINFO_kindtypeREAL3:
2273                   error = ffetarget_convert_complex2_complex3
2274                     (ffebld_cu_ptr_complex2 (u),
2275                      ffebld_constant_complex3 (ffebld_conter (l)));
2276                   break;
2277 #endif
2278
2279                 default:
2280                   assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2281                   break;
2282                 }
2283               break;
2284
2285             case FFEINFO_basictypeCHARACTER:
2286               error = ffetarget_convert_complex2_character1
2287                 (ffebld_cu_ptr_complex2 (u),
2288                  ffebld_constant_character1 (ffebld_conter (l)));
2289               break;
2290
2291             case FFEINFO_basictypeHOLLERITH:
2292               error = ffetarget_convert_complex2_hollerith
2293                 (ffebld_cu_ptr_complex2 (u),
2294                  ffebld_constant_hollerith (ffebld_conter (l)));
2295               break;
2296
2297             case FFEINFO_basictypeTYPELESS:
2298               error = ffetarget_convert_complex2_typeless
2299                 (ffebld_cu_ptr_complex2 (u),
2300                  ffebld_constant_typeless (ffebld_conter (l)));
2301               break;
2302
2303             default:
2304               assert ("COMPLEX2 bad type" == NULL);
2305               break;
2306             }
2307
2308           /* If conversion operation is not implemented, return original expr.  */
2309           if (error == FFEBAD_NOCANDO)
2310             return expr;
2311
2312           expr = ffebld_new_conter_with_orig
2313             (ffebld_constant_new_complex2_val
2314              (ffebld_cu_val_complex2 (u)), expr);
2315           break;
2316 #endif
2317
2318 #if FFETARGET_okCOMPLEX3
2319         case FFEINFO_kindtypeREAL3:
2320           switch (ffeinfo_basictype (ffebld_info (l)))
2321             {
2322             case FFEINFO_basictypeINTEGER:
2323               switch (ffeinfo_kindtype (ffebld_info (l)))
2324                 {
2325 #if FFETARGET_okINTEGER1
2326                 case FFEINFO_kindtypeINTEGER1:
2327                   error = ffetarget_convert_complex3_integer1
2328                     (ffebld_cu_ptr_complex3 (u),
2329                      ffebld_constant_integer1 (ffebld_conter (l)));
2330                   break;
2331 #endif
2332
2333 #if FFETARGET_okINTEGER2
2334                 case FFEINFO_kindtypeINTEGER2:
2335                   error = ffetarget_convert_complex3_integer2
2336                     (ffebld_cu_ptr_complex3 (u),
2337                      ffebld_constant_integer2 (ffebld_conter (l)));
2338                   break;
2339 #endif
2340
2341 #if FFETARGET_okINTEGER3
2342                 case FFEINFO_kindtypeINTEGER3:
2343                   error = ffetarget_convert_complex3_integer3
2344                     (ffebld_cu_ptr_complex3 (u),
2345                      ffebld_constant_integer3 (ffebld_conter (l)));
2346                   break;
2347 #endif
2348
2349 #if FFETARGET_okINTEGER4
2350                 case FFEINFO_kindtypeINTEGER4:
2351                   error = ffetarget_convert_complex3_integer4
2352                     (ffebld_cu_ptr_complex3 (u),
2353                      ffebld_constant_integer4 (ffebld_conter (l)));
2354                   break;
2355 #endif
2356
2357                 default:
2358                   assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2359                   break;
2360                 }
2361               break;
2362
2363             case FFEINFO_basictypeREAL:
2364               switch (ffeinfo_kindtype (ffebld_info (l)))
2365                 {
2366 #if FFETARGET_okREAL1
2367                 case FFEINFO_kindtypeREAL1:
2368                   error = ffetarget_convert_complex3_real1
2369                     (ffebld_cu_ptr_complex3 (u),
2370                      ffebld_constant_real1 (ffebld_conter (l)));
2371                   break;
2372 #endif
2373
2374 #if FFETARGET_okREAL2
2375                 case FFEINFO_kindtypeREAL2:
2376                   error = ffetarget_convert_complex3_real2
2377                     (ffebld_cu_ptr_complex3 (u),
2378                      ffebld_constant_real2 (ffebld_conter (l)));
2379                   break;
2380 #endif
2381
2382 #if FFETARGET_okREAL3
2383                 case FFEINFO_kindtypeREAL3:
2384                   error = ffetarget_convert_complex3_real3
2385                     (ffebld_cu_ptr_complex3 (u),
2386                      ffebld_constant_real3 (ffebld_conter (l)));
2387                   break;
2388 #endif
2389
2390                 default:
2391                   assert ("COMPLEX3/REAL bad source kind type" == NULL);
2392                   break;
2393                 }
2394               break;
2395
2396             case FFEINFO_basictypeCOMPLEX:
2397               switch (ffeinfo_kindtype (ffebld_info (l)))
2398                 {
2399 #if FFETARGET_okCOMPLEX1
2400                 case FFEINFO_kindtypeREAL1:
2401                   error = ffetarget_convert_complex3_complex1
2402                     (ffebld_cu_ptr_complex3 (u),
2403                      ffebld_constant_complex1 (ffebld_conter (l)));
2404                   break;
2405 #endif
2406
2407 #if FFETARGET_okCOMPLEX2
2408                 case FFEINFO_kindtypeREAL2:
2409                   error = ffetarget_convert_complex3_complex2
2410                     (ffebld_cu_ptr_complex3 (u),
2411                      ffebld_constant_complex2 (ffebld_conter (l)));
2412                   break;
2413 #endif
2414
2415                 default:
2416                   assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2417                   break;
2418                 }
2419               break;
2420
2421             case FFEINFO_basictypeCHARACTER:
2422               error = ffetarget_convert_complex3_character1
2423                 (ffebld_cu_ptr_complex3 (u),
2424                  ffebld_constant_character1 (ffebld_conter (l)));
2425               break;
2426
2427             case FFEINFO_basictypeHOLLERITH:
2428               error = ffetarget_convert_complex3_hollerith
2429                 (ffebld_cu_ptr_complex3 (u),
2430                  ffebld_constant_hollerith (ffebld_conter (l)));
2431               break;
2432
2433             case FFEINFO_basictypeTYPELESS:
2434               error = ffetarget_convert_complex3_typeless
2435                 (ffebld_cu_ptr_complex3 (u),
2436                  ffebld_constant_typeless (ffebld_conter (l)));
2437               break;
2438
2439             default:
2440               assert ("COMPLEX3 bad type" == NULL);
2441               break;
2442             }
2443
2444           /* If conversion operation is not implemented, return original expr.  */
2445           if (error == FFEBAD_NOCANDO)
2446             return expr;
2447
2448           expr = ffebld_new_conter_with_orig
2449             (ffebld_constant_new_complex3_val
2450              (ffebld_cu_val_complex3 (u)), expr);
2451           break;
2452 #endif
2453
2454         default:
2455           assert ("bad complex kind type" == NULL);
2456           break;
2457         }
2458       break;
2459
2460     case FFEINFO_basictypeCHARACTER:
2461       if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2462         return expr;
2463       kt = ffeinfo_kindtype (ffebld_info (expr));
2464       switch (kt)
2465         {
2466 #if FFETARGET_okCHARACTER1
2467         case FFEINFO_kindtypeCHARACTER1:
2468           switch (ffeinfo_basictype (ffebld_info (l)))
2469             {
2470             case FFEINFO_basictypeCHARACTER:
2471               if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2472                 return expr;
2473               assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2474               assert (sz2 == ffetarget_length_character1
2475                       (ffebld_constant_character1
2476                        (ffebld_conter (l))));
2477               error
2478                 = ffetarget_convert_character1_character1
2479                 (ffebld_cu_ptr_character1 (u), sz,
2480                  ffebld_constant_character1 (ffebld_conter (l)),
2481                  ffebld_constant_pool ());
2482               break;
2483
2484             case FFEINFO_basictypeINTEGER:
2485               switch (ffeinfo_kindtype (ffebld_info (l)))
2486                 {
2487 #if FFETARGET_okINTEGER1
2488                 case FFEINFO_kindtypeINTEGER1:
2489                   error
2490                     = ffetarget_convert_character1_integer1
2491                       (ffebld_cu_ptr_character1 (u),
2492                        sz,
2493                        ffebld_constant_integer1 (ffebld_conter (l)),
2494                        ffebld_constant_pool ());
2495                   break;
2496 #endif
2497
2498 #if FFETARGET_okINTEGER2
2499                 case FFEINFO_kindtypeINTEGER2:
2500                   error
2501                     = ffetarget_convert_character1_integer2
2502                       (ffebld_cu_ptr_character1 (u),
2503                        sz,
2504                        ffebld_constant_integer2 (ffebld_conter (l)),
2505                        ffebld_constant_pool ());
2506                   break;
2507 #endif
2508
2509 #if FFETARGET_okINTEGER3
2510                 case FFEINFO_kindtypeINTEGER3:
2511                   error
2512                     = ffetarget_convert_character1_integer3
2513                       (ffebld_cu_ptr_character1 (u),
2514                        sz,
2515                        ffebld_constant_integer3 (ffebld_conter (l)),
2516                        ffebld_constant_pool ());
2517                   break;
2518 #endif
2519
2520 #if FFETARGET_okINTEGER4
2521                 case FFEINFO_kindtypeINTEGER4:
2522                   error
2523                     = ffetarget_convert_character1_integer4
2524                       (ffebld_cu_ptr_character1 (u),
2525                        sz,
2526                        ffebld_constant_integer4 (ffebld_conter (l)),
2527                        ffebld_constant_pool ());
2528                   break;
2529 #endif
2530
2531                 default:
2532                   assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2533                   break;
2534                 }
2535               break;
2536
2537             case FFEINFO_basictypeLOGICAL:
2538               switch (ffeinfo_kindtype (ffebld_info (l)))
2539                 {
2540 #if FFETARGET_okLOGICAL1
2541                 case FFEINFO_kindtypeLOGICAL1:
2542                   error
2543                     = ffetarget_convert_character1_logical1
2544                       (ffebld_cu_ptr_character1 (u),
2545                        sz,
2546                        ffebld_constant_logical1 (ffebld_conter (l)),
2547                        ffebld_constant_pool ());
2548                   break;
2549 #endif
2550
2551 #if FFETARGET_okLOGICAL2
2552                 case FFEINFO_kindtypeLOGICAL2:
2553                   error
2554                     = ffetarget_convert_character1_logical2
2555                       (ffebld_cu_ptr_character1 (u),
2556                        sz,
2557                        ffebld_constant_logical2 (ffebld_conter (l)),
2558                        ffebld_constant_pool ());
2559                   break;
2560 #endif
2561
2562 #if FFETARGET_okLOGICAL3
2563                 case FFEINFO_kindtypeLOGICAL3:
2564                   error
2565                     = ffetarget_convert_character1_logical3
2566                       (ffebld_cu_ptr_character1 (u),
2567                        sz,
2568                        ffebld_constant_logical3 (ffebld_conter (l)),
2569                        ffebld_constant_pool ());
2570                   break;
2571 #endif
2572
2573 #if FFETARGET_okLOGICAL4
2574                 case FFEINFO_kindtypeLOGICAL4:
2575                   error
2576                     = ffetarget_convert_character1_logical4
2577                       (ffebld_cu_ptr_character1 (u),
2578                        sz,
2579                        ffebld_constant_logical4 (ffebld_conter (l)),
2580                        ffebld_constant_pool ());
2581                   break;
2582 #endif
2583
2584                 default:
2585                   assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2586                   break;
2587                 }
2588               break;
2589
2590             case FFEINFO_basictypeHOLLERITH:
2591               error
2592                 = ffetarget_convert_character1_hollerith
2593                 (ffebld_cu_ptr_character1 (u),
2594                  sz,
2595                  ffebld_constant_hollerith (ffebld_conter (l)),
2596                  ffebld_constant_pool ());
2597               break;
2598
2599             case FFEINFO_basictypeTYPELESS:
2600               error
2601                 = ffetarget_convert_character1_typeless
2602                 (ffebld_cu_ptr_character1 (u),
2603                  sz,
2604                  ffebld_constant_typeless (ffebld_conter (l)),
2605                  ffebld_constant_pool ());
2606               break;
2607
2608             default:
2609               assert ("CHARACTER1 bad type" == NULL);
2610             }
2611
2612           expr
2613             = ffebld_new_conter_with_orig
2614             (ffebld_constant_new_character1_val
2615              (ffebld_cu_val_character1 (u)),
2616              expr);
2617           break;
2618 #endif
2619
2620         default:
2621           assert ("bad character kind type" == NULL);
2622           break;
2623         }
2624       break;
2625
2626     default:
2627       assert ("bad type" == NULL);
2628       return expr;
2629     }
2630
2631   ffebld_set_info (expr, ffeinfo_new
2632                    (bt,
2633                     kt,
2634                     0,
2635                     FFEINFO_kindENTITY,
2636                     FFEINFO_whereCONSTANT,
2637                     sz));
2638
2639   if ((error != FFEBAD)
2640       && ffebad_start (error))
2641     {
2642       assert (t != NULL);
2643       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2644       ffebad_finish ();
2645     }
2646
2647   return expr;
2648 }
2649
2650 /* ffeexpr_collapse_paren -- Collapse paren expr
2651
2652    ffebld expr;
2653    ffelexToken token;
2654    expr = ffeexpr_collapse_paren(expr,token);
2655
2656    If the result of the expr is a constant, replaces the expr with the
2657    computed constant.  */
2658
2659 ffebld
2660 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2661 {
2662   ffebld r;
2663   ffeinfoBasictype bt;
2664   ffeinfoKindtype kt;
2665   ffetargetCharacterSize len;
2666
2667   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2668     return expr;
2669
2670   r = ffebld_left (expr);
2671
2672   if (ffebld_op (r) != FFEBLD_opCONTER)
2673     return expr;
2674
2675   bt = ffeinfo_basictype (ffebld_info (r));
2676   kt = ffeinfo_kindtype (ffebld_info (r));
2677   len = ffebld_size (r);
2678
2679   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2680                                       expr);
2681
2682   ffebld_set_info (expr, ffeinfo_new
2683                    (bt,
2684                     kt,
2685                     0,
2686                     FFEINFO_kindENTITY,
2687                     FFEINFO_whereCONSTANT,
2688                     len));
2689
2690   return expr;
2691 }
2692
2693 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2694
2695    ffebld expr;
2696    ffelexToken token;
2697    expr = ffeexpr_collapse_uplus(expr,token);
2698
2699    If the result of the expr is a constant, replaces the expr with the
2700    computed constant.  */
2701
2702 ffebld
2703 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2704 {
2705   ffebld r;
2706   ffeinfoBasictype bt;
2707   ffeinfoKindtype kt;
2708   ffetargetCharacterSize len;
2709
2710   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2711     return expr;
2712
2713   r = ffebld_left (expr);
2714
2715   if (ffebld_op (r) != FFEBLD_opCONTER)
2716     return expr;
2717
2718   bt = ffeinfo_basictype (ffebld_info (r));
2719   kt = ffeinfo_kindtype (ffebld_info (r));
2720   len = ffebld_size (r);
2721
2722   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2723                                       expr);
2724
2725   ffebld_set_info (expr, ffeinfo_new
2726                    (bt,
2727                     kt,
2728                     0,
2729                     FFEINFO_kindENTITY,
2730                     FFEINFO_whereCONSTANT,
2731                     len));
2732
2733   return expr;
2734 }
2735
2736 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2737
2738    ffebld expr;
2739    ffelexToken token;
2740    expr = ffeexpr_collapse_uminus(expr,token);
2741
2742    If the result of the expr is a constant, replaces the expr with the
2743    computed constant.  */
2744
2745 ffebld
2746 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2747 {
2748   ffebad error = FFEBAD;
2749   ffebld r;
2750   ffebldConstantUnion u;
2751   ffeinfoBasictype bt;
2752   ffeinfoKindtype kt;
2753
2754   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2755     return expr;
2756
2757   r = ffebld_left (expr);
2758
2759   if (ffebld_op (r) != FFEBLD_opCONTER)
2760     return expr;
2761
2762   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2763     {
2764     case FFEINFO_basictypeANY:
2765       return expr;
2766
2767     case FFEINFO_basictypeINTEGER:
2768       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2769         {
2770 #if FFETARGET_okINTEGER1
2771         case FFEINFO_kindtypeINTEGER1:
2772           error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2773                               ffebld_constant_integer1 (ffebld_conter (r)));
2774           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2775                                         (ffebld_cu_val_integer1 (u)), expr);
2776           break;
2777 #endif
2778
2779 #if FFETARGET_okINTEGER2
2780         case FFEINFO_kindtypeINTEGER2:
2781           error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2782                               ffebld_constant_integer2 (ffebld_conter (r)));
2783           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2784                                         (ffebld_cu_val_integer2 (u)), expr);
2785           break;
2786 #endif
2787
2788 #if FFETARGET_okINTEGER3
2789         case FFEINFO_kindtypeINTEGER3:
2790           error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2791                               ffebld_constant_integer3 (ffebld_conter (r)));
2792           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2793                                         (ffebld_cu_val_integer3 (u)), expr);
2794           break;
2795 #endif
2796
2797 #if FFETARGET_okINTEGER4
2798         case FFEINFO_kindtypeINTEGER4:
2799           error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2800                               ffebld_constant_integer4 (ffebld_conter (r)));
2801           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2802                                         (ffebld_cu_val_integer4 (u)), expr);
2803           break;
2804 #endif
2805
2806         default:
2807           assert ("bad integer kind type" == NULL);
2808           break;
2809         }
2810       break;
2811
2812     case FFEINFO_basictypeREAL:
2813       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2814         {
2815 #if FFETARGET_okREAL1
2816         case FFEINFO_kindtypeREAL1:
2817           error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2818                                  ffebld_constant_real1 (ffebld_conter (r)));
2819           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2820                                            (ffebld_cu_val_real1 (u)), expr);
2821           break;
2822 #endif
2823
2824 #if FFETARGET_okREAL2
2825         case FFEINFO_kindtypeREAL2:
2826           error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2827                                  ffebld_constant_real2 (ffebld_conter (r)));
2828           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2829                                            (ffebld_cu_val_real2 (u)), expr);
2830           break;
2831 #endif
2832
2833 #if FFETARGET_okREAL3
2834         case FFEINFO_kindtypeREAL3:
2835           error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2836                                  ffebld_constant_real3 (ffebld_conter (r)));
2837           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2838                                            (ffebld_cu_val_real3 (u)), expr);
2839           break;
2840 #endif
2841
2842         default:
2843           assert ("bad real kind type" == NULL);
2844           break;
2845         }
2846       break;
2847
2848     case FFEINFO_basictypeCOMPLEX:
2849       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2850         {
2851 #if FFETARGET_okCOMPLEX1
2852         case FFEINFO_kindtypeREAL1:
2853           error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2854                               ffebld_constant_complex1 (ffebld_conter (r)));
2855           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2856                                         (ffebld_cu_val_complex1 (u)), expr);
2857           break;
2858 #endif
2859
2860 #if FFETARGET_okCOMPLEX2
2861         case FFEINFO_kindtypeREAL2:
2862           error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2863                               ffebld_constant_complex2 (ffebld_conter (r)));
2864           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2865                                         (ffebld_cu_val_complex2 (u)), expr);
2866           break;
2867 #endif
2868
2869 #if FFETARGET_okCOMPLEX3
2870         case FFEINFO_kindtypeREAL3:
2871           error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2872                               ffebld_constant_complex3 (ffebld_conter (r)));
2873           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2874                                         (ffebld_cu_val_complex3 (u)), expr);
2875           break;
2876 #endif
2877
2878         default:
2879           assert ("bad complex kind type" == NULL);
2880           break;
2881         }
2882       break;
2883
2884     default:
2885       assert ("bad type" == NULL);
2886       return expr;
2887     }
2888
2889   ffebld_set_info (expr, ffeinfo_new
2890                    (bt,
2891                     kt,
2892                     0,
2893                     FFEINFO_kindENTITY,
2894                     FFEINFO_whereCONSTANT,
2895                     FFETARGET_charactersizeNONE));
2896
2897   if ((error != FFEBAD)
2898       && ffebad_start (error))
2899     {
2900       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2901       ffebad_finish ();
2902     }
2903
2904   return expr;
2905 }
2906
2907 /* ffeexpr_collapse_not -- Collapse not expr
2908
2909    ffebld expr;
2910    ffelexToken token;
2911    expr = ffeexpr_collapse_not(expr,token);
2912
2913    If the result of the expr is a constant, replaces the expr with the
2914    computed constant.  */
2915
2916 ffebld
2917 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2918 {
2919   ffebad error = FFEBAD;
2920   ffebld r;
2921   ffebldConstantUnion u;
2922   ffeinfoBasictype bt;
2923   ffeinfoKindtype kt;
2924
2925   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2926     return expr;
2927
2928   r = ffebld_left (expr);
2929
2930   if (ffebld_op (r) != FFEBLD_opCONTER)
2931     return expr;
2932
2933   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2934     {
2935     case FFEINFO_basictypeANY:
2936       return expr;
2937
2938     case FFEINFO_basictypeINTEGER:
2939       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2940         {
2941 #if FFETARGET_okINTEGER1
2942         case FFEINFO_kindtypeINTEGER1:
2943           error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2944                               ffebld_constant_integer1 (ffebld_conter (r)));
2945           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2946                                         (ffebld_cu_val_integer1 (u)), expr);
2947           break;
2948 #endif
2949
2950 #if FFETARGET_okINTEGER2
2951         case FFEINFO_kindtypeINTEGER2:
2952           error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2953                               ffebld_constant_integer2 (ffebld_conter (r)));
2954           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2955                                         (ffebld_cu_val_integer2 (u)), expr);
2956           break;
2957 #endif
2958
2959 #if FFETARGET_okINTEGER3
2960         case FFEINFO_kindtypeINTEGER3:
2961           error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2962                               ffebld_constant_integer3 (ffebld_conter (r)));
2963           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2964                                         (ffebld_cu_val_integer3 (u)), expr);
2965           break;
2966 #endif
2967
2968 #if FFETARGET_okINTEGER4
2969         case FFEINFO_kindtypeINTEGER4:
2970           error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2971                               ffebld_constant_integer4 (ffebld_conter (r)));
2972           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2973                                         (ffebld_cu_val_integer4 (u)), expr);
2974           break;
2975 #endif
2976
2977         default:
2978           assert ("bad integer kind type" == NULL);
2979           break;
2980         }
2981       break;
2982
2983     case FFEINFO_basictypeLOGICAL:
2984       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2985         {
2986 #if FFETARGET_okLOGICAL1
2987         case FFEINFO_kindtypeLOGICAL1:
2988           error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2989                               ffebld_constant_logical1 (ffebld_conter (r)));
2990           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2991                                         (ffebld_cu_val_logical1 (u)), expr);
2992           break;
2993 #endif
2994
2995 #if FFETARGET_okLOGICAL2
2996         case FFEINFO_kindtypeLOGICAL2:
2997           error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2998                               ffebld_constant_logical2 (ffebld_conter (r)));
2999           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3000                                         (ffebld_cu_val_logical2 (u)), expr);
3001           break;
3002 #endif
3003
3004 #if FFETARGET_okLOGICAL3
3005         case FFEINFO_kindtypeLOGICAL3:
3006           error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3007                               ffebld_constant_logical3 (ffebld_conter (r)));
3008           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3009                                         (ffebld_cu_val_logical3 (u)), expr);
3010           break;
3011 #endif
3012
3013 #if FFETARGET_okLOGICAL4
3014         case FFEINFO_kindtypeLOGICAL4:
3015           error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3016                               ffebld_constant_logical4 (ffebld_conter (r)));
3017           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3018                                         (ffebld_cu_val_logical4 (u)), expr);
3019           break;
3020 #endif
3021
3022         default:
3023           assert ("bad logical kind type" == NULL);
3024           break;
3025         }
3026       break;
3027
3028     default:
3029       assert ("bad type" == NULL);
3030       return expr;
3031     }
3032
3033   ffebld_set_info (expr, ffeinfo_new
3034                    (bt,
3035                     kt,
3036                     0,
3037                     FFEINFO_kindENTITY,
3038                     FFEINFO_whereCONSTANT,
3039                     FFETARGET_charactersizeNONE));
3040
3041   if ((error != FFEBAD)
3042       && ffebad_start (error))
3043     {
3044       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3045       ffebad_finish ();
3046     }
3047
3048   return expr;
3049 }
3050
3051 /* ffeexpr_collapse_add -- Collapse add expr
3052
3053    ffebld expr;
3054    ffelexToken token;
3055    expr = ffeexpr_collapse_add(expr,token);
3056
3057    If the result of the expr is a constant, replaces the expr with the
3058    computed constant.  */
3059
3060 ffebld
3061 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3062 {
3063   ffebad error = FFEBAD;
3064   ffebld l;
3065   ffebld r;
3066   ffebldConstantUnion u;
3067   ffeinfoBasictype bt;
3068   ffeinfoKindtype kt;
3069
3070   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3071     return expr;
3072
3073   l = ffebld_left (expr);
3074   r = ffebld_right (expr);
3075
3076   if (ffebld_op (l) != FFEBLD_opCONTER)
3077     return expr;
3078   if (ffebld_op (r) != FFEBLD_opCONTER)
3079     return expr;
3080
3081   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3082     {
3083     case FFEINFO_basictypeANY:
3084       return expr;
3085
3086     case FFEINFO_basictypeINTEGER:
3087       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3088         {
3089 #if FFETARGET_okINTEGER1
3090         case FFEINFO_kindtypeINTEGER1:
3091           error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3092                                ffebld_constant_integer1 (ffebld_conter (l)),
3093                               ffebld_constant_integer1 (ffebld_conter (r)));
3094           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3095                                         (ffebld_cu_val_integer1 (u)), expr);
3096           break;
3097 #endif
3098
3099 #if FFETARGET_okINTEGER2
3100         case FFEINFO_kindtypeINTEGER2:
3101           error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3102                                ffebld_constant_integer2 (ffebld_conter (l)),
3103                               ffebld_constant_integer2 (ffebld_conter (r)));
3104           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3105                                         (ffebld_cu_val_integer2 (u)), expr);
3106           break;
3107 #endif
3108
3109 #if FFETARGET_okINTEGER3
3110         case FFEINFO_kindtypeINTEGER3:
3111           error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3112                                ffebld_constant_integer3 (ffebld_conter (l)),
3113                               ffebld_constant_integer3 (ffebld_conter (r)));
3114           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3115                                         (ffebld_cu_val_integer3 (u)), expr);
3116           break;
3117 #endif
3118
3119 #if FFETARGET_okINTEGER4
3120         case FFEINFO_kindtypeINTEGER4:
3121           error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3122                                ffebld_constant_integer4 (ffebld_conter (l)),
3123                               ffebld_constant_integer4 (ffebld_conter (r)));
3124           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3125                                         (ffebld_cu_val_integer4 (u)), expr);
3126           break;
3127 #endif
3128
3129         default:
3130           assert ("bad integer kind type" == NULL);
3131           break;
3132         }
3133       break;
3134
3135     case FFEINFO_basictypeREAL:
3136       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3137         {
3138 #if FFETARGET_okREAL1
3139         case FFEINFO_kindtypeREAL1:
3140           error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3141                                   ffebld_constant_real1 (ffebld_conter (l)),
3142                                  ffebld_constant_real1 (ffebld_conter (r)));
3143           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3144                                            (ffebld_cu_val_real1 (u)), expr);
3145           break;
3146 #endif
3147
3148 #if FFETARGET_okREAL2
3149         case FFEINFO_kindtypeREAL2:
3150           error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3151                                   ffebld_constant_real2 (ffebld_conter (l)),
3152                                  ffebld_constant_real2 (ffebld_conter (r)));
3153           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3154                                            (ffebld_cu_val_real2 (u)), expr);
3155           break;
3156 #endif
3157
3158 #if FFETARGET_okREAL3
3159         case FFEINFO_kindtypeREAL3:
3160           error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3161                                   ffebld_constant_real3 (ffebld_conter (l)),
3162                                  ffebld_constant_real3 (ffebld_conter (r)));
3163           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3164                                            (ffebld_cu_val_real3 (u)), expr);
3165           break;
3166 #endif
3167
3168         default:
3169           assert ("bad real kind type" == NULL);
3170           break;
3171         }
3172       break;
3173
3174     case FFEINFO_basictypeCOMPLEX:
3175       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3176         {
3177 #if FFETARGET_okCOMPLEX1
3178         case FFEINFO_kindtypeREAL1:
3179           error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3180                                ffebld_constant_complex1 (ffebld_conter (l)),
3181                               ffebld_constant_complex1 (ffebld_conter (r)));
3182           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3183                                         (ffebld_cu_val_complex1 (u)), expr);
3184           break;
3185 #endif
3186
3187 #if FFETARGET_okCOMPLEX2
3188         case FFEINFO_kindtypeREAL2:
3189           error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3190                                ffebld_constant_complex2 (ffebld_conter (l)),
3191                               ffebld_constant_complex2 (ffebld_conter (r)));
3192           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3193                                         (ffebld_cu_val_complex2 (u)), expr);
3194           break;
3195 #endif
3196
3197 #if FFETARGET_okCOMPLEX3
3198         case FFEINFO_kindtypeREAL3:
3199           error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3200                                ffebld_constant_complex3 (ffebld_conter (l)),
3201                               ffebld_constant_complex3 (ffebld_conter (r)));
3202           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3203                                         (ffebld_cu_val_complex3 (u)), expr);
3204           break;
3205 #endif
3206
3207         default:
3208           assert ("bad complex kind type" == NULL);
3209           break;
3210         }
3211       break;
3212
3213     default:
3214       assert ("bad type" == NULL);
3215       return expr;
3216     }
3217
3218   ffebld_set_info (expr, ffeinfo_new
3219                    (bt,
3220                     kt,
3221                     0,
3222                     FFEINFO_kindENTITY,
3223                     FFEINFO_whereCONSTANT,
3224                     FFETARGET_charactersizeNONE));
3225
3226   if ((error != FFEBAD)
3227       && ffebad_start (error))
3228     {
3229       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3230       ffebad_finish ();
3231     }
3232
3233   return expr;
3234 }
3235
3236 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3237
3238    ffebld expr;
3239    ffelexToken token;
3240    expr = ffeexpr_collapse_subtract(expr,token);
3241
3242    If the result of the expr is a constant, replaces the expr with the
3243    computed constant.  */
3244
3245 ffebld
3246 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3247 {
3248   ffebad error = FFEBAD;
3249   ffebld l;
3250   ffebld r;
3251   ffebldConstantUnion u;
3252   ffeinfoBasictype bt;
3253   ffeinfoKindtype kt;
3254
3255   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3256     return expr;
3257
3258   l = ffebld_left (expr);
3259   r = ffebld_right (expr);
3260
3261   if (ffebld_op (l) != FFEBLD_opCONTER)
3262     return expr;
3263   if (ffebld_op (r) != FFEBLD_opCONTER)
3264     return expr;
3265
3266   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3267     {
3268     case FFEINFO_basictypeANY:
3269       return expr;
3270
3271     case FFEINFO_basictypeINTEGER:
3272       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3273         {
3274 #if FFETARGET_okINTEGER1
3275         case FFEINFO_kindtypeINTEGER1:
3276           error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3277                                ffebld_constant_integer1 (ffebld_conter (l)),
3278                               ffebld_constant_integer1 (ffebld_conter (r)));
3279           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3280                                         (ffebld_cu_val_integer1 (u)), expr);
3281           break;
3282 #endif
3283
3284 #if FFETARGET_okINTEGER2
3285         case FFEINFO_kindtypeINTEGER2:
3286           error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3287                                ffebld_constant_integer2 (ffebld_conter (l)),
3288                               ffebld_constant_integer2 (ffebld_conter (r)));
3289           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3290                                         (ffebld_cu_val_integer2 (u)), expr);
3291           break;
3292 #endif
3293
3294 #if FFETARGET_okINTEGER3
3295         case FFEINFO_kindtypeINTEGER3:
3296           error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3297                                ffebld_constant_integer3 (ffebld_conter (l)),
3298                               ffebld_constant_integer3 (ffebld_conter (r)));
3299           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3300                                         (ffebld_cu_val_integer3 (u)), expr);
3301           break;
3302 #endif
3303
3304 #if FFETARGET_okINTEGER4
3305         case FFEINFO_kindtypeINTEGER4:
3306           error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3307                                ffebld_constant_integer4 (ffebld_conter (l)),
3308                               ffebld_constant_integer4 (ffebld_conter (r)));
3309           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3310                                         (ffebld_cu_val_integer4 (u)), expr);
3311           break;
3312 #endif
3313
3314         default:
3315           assert ("bad integer kind type" == NULL);
3316           break;
3317         }
3318       break;
3319
3320     case FFEINFO_basictypeREAL:
3321       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3322         {
3323 #if FFETARGET_okREAL1
3324         case FFEINFO_kindtypeREAL1:
3325           error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3326                                   ffebld_constant_real1 (ffebld_conter (l)),
3327                                  ffebld_constant_real1 (ffebld_conter (r)));
3328           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3329                                            (ffebld_cu_val_real1 (u)), expr);
3330           break;
3331 #endif
3332
3333 #if FFETARGET_okREAL2
3334         case FFEINFO_kindtypeREAL2:
3335           error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3336                                   ffebld_constant_real2 (ffebld_conter (l)),
3337                                  ffebld_constant_real2 (ffebld_conter (r)));
3338           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3339                                            (ffebld_cu_val_real2 (u)), expr);
3340           break;
3341 #endif
3342
3343 #if FFETARGET_okREAL3
3344         case FFEINFO_kindtypeREAL3:
3345           error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3346                                   ffebld_constant_real3 (ffebld_conter (l)),
3347                                  ffebld_constant_real3 (ffebld_conter (r)));
3348           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3349                                            (ffebld_cu_val_real3 (u)), expr);
3350           break;
3351 #endif
3352
3353         default:
3354           assert ("bad real kind type" == NULL);
3355           break;
3356         }
3357       break;
3358
3359     case FFEINFO_basictypeCOMPLEX:
3360       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3361         {
3362 #if FFETARGET_okCOMPLEX1
3363         case FFEINFO_kindtypeREAL1:
3364           error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3365                                ffebld_constant_complex1 (ffebld_conter (l)),
3366                               ffebld_constant_complex1 (ffebld_conter (r)));
3367           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3368                                         (ffebld_cu_val_complex1 (u)), expr);
3369           break;
3370 #endif
3371
3372 #if FFETARGET_okCOMPLEX2
3373         case FFEINFO_kindtypeREAL2:
3374           error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3375                                ffebld_constant_complex2 (ffebld_conter (l)),
3376                               ffebld_constant_complex2 (ffebld_conter (r)));
3377           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3378                                         (ffebld_cu_val_complex2 (u)), expr);
3379           break;
3380 #endif
3381
3382 #if FFETARGET_okCOMPLEX3
3383         case FFEINFO_kindtypeREAL3:
3384           error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3385                                ffebld_constant_complex3 (ffebld_conter (l)),
3386                               ffebld_constant_complex3 (ffebld_conter (r)));
3387           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3388                                         (ffebld_cu_val_complex3 (u)), expr);
3389           break;
3390 #endif
3391
3392         default:
3393           assert ("bad complex kind type" == NULL);
3394           break;
3395         }
3396       break;
3397
3398     default:
3399       assert ("bad type" == NULL);
3400       return expr;
3401     }
3402
3403   ffebld_set_info (expr, ffeinfo_new
3404                    (bt,
3405                     kt,
3406                     0,
3407                     FFEINFO_kindENTITY,
3408                     FFEINFO_whereCONSTANT,
3409                     FFETARGET_charactersizeNONE));
3410
3411   if ((error != FFEBAD)
3412       && ffebad_start (error))
3413     {
3414       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3415       ffebad_finish ();
3416     }
3417
3418   return expr;
3419 }
3420
3421 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3422
3423    ffebld expr;
3424    ffelexToken token;
3425    expr = ffeexpr_collapse_multiply(expr,token);
3426
3427    If the result of the expr is a constant, replaces the expr with the
3428    computed constant.  */
3429
3430 ffebld
3431 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3432 {
3433   ffebad error = FFEBAD;
3434   ffebld l;
3435   ffebld r;
3436   ffebldConstantUnion u;
3437   ffeinfoBasictype bt;
3438   ffeinfoKindtype kt;
3439
3440   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3441     return expr;
3442
3443   l = ffebld_left (expr);
3444   r = ffebld_right (expr);
3445
3446   if (ffebld_op (l) != FFEBLD_opCONTER)
3447     return expr;
3448   if (ffebld_op (r) != FFEBLD_opCONTER)
3449     return expr;
3450
3451   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3452     {
3453     case FFEINFO_basictypeANY:
3454       return expr;
3455
3456     case FFEINFO_basictypeINTEGER:
3457       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3458         {
3459 #if FFETARGET_okINTEGER1
3460         case FFEINFO_kindtypeINTEGER1:
3461           error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3462                                ffebld_constant_integer1 (ffebld_conter (l)),
3463                               ffebld_constant_integer1 (ffebld_conter (r)));
3464           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3465                                         (ffebld_cu_val_integer1 (u)), expr);
3466           break;
3467 #endif
3468
3469 #if FFETARGET_okINTEGER2
3470         case FFEINFO_kindtypeINTEGER2:
3471           error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3472                                ffebld_constant_integer2 (ffebld_conter (l)),
3473                               ffebld_constant_integer2 (ffebld_conter (r)));
3474           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3475                                         (ffebld_cu_val_integer2 (u)), expr);
3476           break;
3477 #endif
3478
3479 #if FFETARGET_okINTEGER3
3480         case FFEINFO_kindtypeINTEGER3:
3481           error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3482                                ffebld_constant_integer3 (ffebld_conter (l)),
3483                               ffebld_constant_integer3 (ffebld_conter (r)));
3484           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3485                                         (ffebld_cu_val_integer3 (u)), expr);
3486           break;
3487 #endif
3488
3489 #if FFETARGET_okINTEGER4
3490         case FFEINFO_kindtypeINTEGER4:
3491           error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3492                                ffebld_constant_integer4 (ffebld_conter (l)),
3493                               ffebld_constant_integer4 (ffebld_conter (r)));
3494           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3495                                         (ffebld_cu_val_integer4 (u)), expr);
3496           break;
3497 #endif
3498
3499         default:
3500           assert ("bad integer kind type" == NULL);
3501           break;
3502         }
3503       break;
3504
3505     case FFEINFO_basictypeREAL:
3506       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3507         {
3508 #if FFETARGET_okREAL1
3509         case FFEINFO_kindtypeREAL1:
3510           error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3511                                   ffebld_constant_real1 (ffebld_conter (l)),
3512                                  ffebld_constant_real1 (ffebld_conter (r)));
3513           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3514                                            (ffebld_cu_val_real1 (u)), expr);
3515           break;
3516 #endif
3517
3518 #if FFETARGET_okREAL2
3519         case FFEINFO_kindtypeREAL2:
3520           error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3521                                   ffebld_constant_real2 (ffebld_conter (l)),
3522                                  ffebld_constant_real2 (ffebld_conter (r)));
3523           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3524                                            (ffebld_cu_val_real2 (u)), expr);
3525           break;
3526 #endif
3527
3528 #if FFETARGET_okREAL3
3529         case FFEINFO_kindtypeREAL3:
3530           error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3531                                   ffebld_constant_real3 (ffebld_conter (l)),
3532                                  ffebld_constant_real3 (ffebld_conter (r)));
3533           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3534                                            (ffebld_cu_val_real3 (u)), expr);
3535           break;
3536 #endif
3537
3538         default:
3539           assert ("bad real kind type" == NULL);
3540           break;
3541         }
3542       break;
3543
3544     case FFEINFO_basictypeCOMPLEX:
3545       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3546         {
3547 #if FFETARGET_okCOMPLEX1
3548         case FFEINFO_kindtypeREAL1:
3549           error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3550                                ffebld_constant_complex1 (ffebld_conter (l)),
3551                               ffebld_constant_complex1 (ffebld_conter (r)));
3552           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3553                                         (ffebld_cu_val_complex1 (u)), expr);
3554           break;
3555 #endif
3556
3557 #if FFETARGET_okCOMPLEX2
3558         case FFEINFO_kindtypeREAL2:
3559           error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3560                                ffebld_constant_complex2 (ffebld_conter (l)),
3561                               ffebld_constant_complex2 (ffebld_conter (r)));
3562           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3563                                         (ffebld_cu_val_complex2 (u)), expr);
3564           break;
3565 #endif
3566
3567 #if FFETARGET_okCOMPLEX3
3568         case FFEINFO_kindtypeREAL3:
3569           error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3570                                ffebld_constant_complex3 (ffebld_conter (l)),
3571                               ffebld_constant_complex3 (ffebld_conter (r)));
3572           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3573                                         (ffebld_cu_val_complex3 (u)), expr);
3574           break;
3575 #endif
3576
3577         default:
3578           assert ("bad complex kind type" == NULL);
3579           break;
3580         }
3581       break;
3582
3583     default:
3584       assert ("bad type" == NULL);
3585       return expr;
3586     }
3587
3588   ffebld_set_info (expr, ffeinfo_new
3589                    (bt,
3590                     kt,
3591                     0,
3592                     FFEINFO_kindENTITY,
3593                     FFEINFO_whereCONSTANT,
3594                     FFETARGET_charactersizeNONE));
3595
3596   if ((error != FFEBAD)
3597       && ffebad_start (error))
3598     {
3599       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3600       ffebad_finish ();
3601     }
3602
3603   return expr;
3604 }
3605
3606 /* ffeexpr_collapse_divide -- Collapse divide expr
3607
3608    ffebld expr;
3609    ffelexToken token;
3610    expr = ffeexpr_collapse_divide(expr,token);
3611
3612    If the result of the expr is a constant, replaces the expr with the
3613    computed constant.  */
3614
3615 ffebld
3616 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3617 {
3618   ffebad error = FFEBAD;
3619   ffebld l;
3620   ffebld r;
3621   ffebldConstantUnion u;
3622   ffeinfoBasictype bt;
3623   ffeinfoKindtype kt;
3624
3625   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3626     return expr;
3627
3628   l = ffebld_left (expr);
3629   r = ffebld_right (expr);
3630
3631   if (ffebld_op (l) != FFEBLD_opCONTER)
3632     return expr;
3633   if (ffebld_op (r) != FFEBLD_opCONTER)
3634     return expr;
3635
3636   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3637     {
3638     case FFEINFO_basictypeANY:
3639       return expr;
3640
3641     case FFEINFO_basictypeINTEGER:
3642       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3643         {
3644 #if FFETARGET_okINTEGER1
3645         case FFEINFO_kindtypeINTEGER1:
3646           error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3647                                ffebld_constant_integer1 (ffebld_conter (l)),
3648                               ffebld_constant_integer1 (ffebld_conter (r)));
3649           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3650                                         (ffebld_cu_val_integer1 (u)), expr);
3651           break;
3652 #endif
3653
3654 #if FFETARGET_okINTEGER2
3655         case FFEINFO_kindtypeINTEGER2:
3656           error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3657                                ffebld_constant_integer2 (ffebld_conter (l)),
3658                               ffebld_constant_integer2 (ffebld_conter (r)));
3659           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3660                                         (ffebld_cu_val_integer2 (u)), expr);
3661           break;
3662 #endif
3663
3664 #if FFETARGET_okINTEGER3
3665         case FFEINFO_kindtypeINTEGER3:
3666           error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3667                                ffebld_constant_integer3 (ffebld_conter (l)),
3668                               ffebld_constant_integer3 (ffebld_conter (r)));
3669           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3670                                         (ffebld_cu_val_integer3 (u)), expr);
3671           break;
3672 #endif
3673
3674 #if FFETARGET_okINTEGER4
3675         case FFEINFO_kindtypeINTEGER4:
3676           error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3677                                ffebld_constant_integer4 (ffebld_conter (l)),
3678                               ffebld_constant_integer4 (ffebld_conter (r)));
3679           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3680                                         (ffebld_cu_val_integer4 (u)), expr);
3681           break;
3682 #endif
3683
3684         default:
3685           assert ("bad integer kind type" == NULL);
3686           break;
3687         }
3688       break;
3689
3690     case FFEINFO_basictypeREAL:
3691       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3692         {
3693 #if FFETARGET_okREAL1
3694         case FFEINFO_kindtypeREAL1:
3695           error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3696                                   ffebld_constant_real1 (ffebld_conter (l)),
3697                                  ffebld_constant_real1 (ffebld_conter (r)));
3698           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3699                                            (ffebld_cu_val_real1 (u)), expr);
3700           break;
3701 #endif
3702
3703 #if FFETARGET_okREAL2
3704         case FFEINFO_kindtypeREAL2:
3705           error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3706                                   ffebld_constant_real2 (ffebld_conter (l)),
3707                                  ffebld_constant_real2 (ffebld_conter (r)));
3708           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3709                                            (ffebld_cu_val_real2 (u)), expr);
3710           break;
3711 #endif
3712
3713 #if FFETARGET_okREAL3
3714         case FFEINFO_kindtypeREAL3:
3715           error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3716                                   ffebld_constant_real3 (ffebld_conter (l)),
3717                                  ffebld_constant_real3 (ffebld_conter (r)));
3718           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3719                                            (ffebld_cu_val_real3 (u)), expr);
3720           break;
3721 #endif
3722
3723         default:
3724           assert ("bad real kind type" == NULL);
3725           break;
3726         }
3727       break;
3728
3729     case FFEINFO_basictypeCOMPLEX:
3730       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3731         {
3732 #if FFETARGET_okCOMPLEX1
3733         case FFEINFO_kindtypeREAL1:
3734           error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3735                                ffebld_constant_complex1 (ffebld_conter (l)),
3736                               ffebld_constant_complex1 (ffebld_conter (r)));
3737           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3738                                         (ffebld_cu_val_complex1 (u)), expr);
3739           break;
3740 #endif
3741
3742 #if FFETARGET_okCOMPLEX2
3743         case FFEINFO_kindtypeREAL2:
3744           error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3745                                ffebld_constant_complex2 (ffebld_conter (l)),
3746                               ffebld_constant_complex2 (ffebld_conter (r)));
3747           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3748                                         (ffebld_cu_val_complex2 (u)), expr);
3749           break;
3750 #endif
3751
3752 #if FFETARGET_okCOMPLEX3
3753         case FFEINFO_kindtypeREAL3:
3754           error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3755                                ffebld_constant_complex3 (ffebld_conter (l)),
3756                               ffebld_constant_complex3 (ffebld_conter (r)));
3757           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3758                                         (ffebld_cu_val_complex3 (u)), expr);
3759           break;
3760 #endif
3761
3762         default:
3763           assert ("bad complex kind type" == NULL);
3764           break;
3765         }
3766       break;
3767
3768     default:
3769       assert ("bad type" == NULL);
3770       return expr;
3771     }
3772
3773   ffebld_set_info (expr, ffeinfo_new
3774                    (bt,
3775                     kt,
3776                     0,
3777                     FFEINFO_kindENTITY,
3778                     FFEINFO_whereCONSTANT,
3779                     FFETARGET_charactersizeNONE));
3780
3781   if ((error != FFEBAD)
3782       && ffebad_start (error))
3783     {
3784       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3785       ffebad_finish ();
3786     }
3787
3788   return expr;
3789 }
3790
3791 /* ffeexpr_collapse_power -- Collapse power expr
3792
3793    ffebld expr;
3794    ffelexToken token;
3795    expr = ffeexpr_collapse_power(expr,token);
3796
3797    If the result of the expr is a constant, replaces the expr with the
3798    computed constant.  */
3799
3800 ffebld
3801 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3802 {
3803   ffebad error = FFEBAD;
3804   ffebld l;
3805   ffebld r;
3806   ffebldConstantUnion u;
3807   ffeinfoBasictype bt;
3808   ffeinfoKindtype kt;
3809
3810   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3811     return expr;
3812
3813   l = ffebld_left (expr);
3814   r = ffebld_right (expr);
3815
3816   if (ffebld_op (l) != FFEBLD_opCONTER)
3817     return expr;
3818   if (ffebld_op (r) != FFEBLD_opCONTER)
3819     return expr;
3820
3821   if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3822   || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3823     return expr;
3824
3825   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3826     {
3827     case FFEINFO_basictypeANY:
3828       return expr;
3829
3830     case FFEINFO_basictypeINTEGER:
3831       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3832         {
3833         case FFEINFO_kindtypeINTEGERDEFAULT:
3834           error = ffetarget_power_integerdefault_integerdefault
3835             (ffebld_cu_ptr_integerdefault (u),
3836              ffebld_constant_integerdefault (ffebld_conter (l)),
3837              ffebld_constant_integerdefault (ffebld_conter (r)));
3838           expr = ffebld_new_conter_with_orig
3839             (ffebld_constant_new_integerdefault_val
3840              (ffebld_cu_val_integerdefault (u)), expr);
3841           break;
3842
3843         default:
3844           assert ("bad integer kind type" == NULL);
3845           break;
3846         }
3847       break;
3848
3849     case FFEINFO_basictypeREAL:
3850       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3851         {
3852         case FFEINFO_kindtypeREALDEFAULT:
3853           error = ffetarget_power_realdefault_integerdefault
3854             (ffebld_cu_ptr_realdefault (u),
3855              ffebld_constant_realdefault (ffebld_conter (l)),
3856              ffebld_constant_integerdefault (ffebld_conter (r)));
3857           expr = ffebld_new_conter_with_orig
3858             (ffebld_constant_new_realdefault_val
3859              (ffebld_cu_val_realdefault (u)), expr);
3860           break;
3861
3862         case FFEINFO_kindtypeREALDOUBLE:
3863           error = ffetarget_power_realdouble_integerdefault
3864             (ffebld_cu_ptr_realdouble (u),
3865              ffebld_constant_realdouble (ffebld_conter (l)),
3866              ffebld_constant_integerdefault (ffebld_conter (r)));
3867           expr = ffebld_new_conter_with_orig
3868             (ffebld_constant_new_realdouble_val
3869              (ffebld_cu_val_realdouble (u)), expr);
3870           break;
3871
3872 #if FFETARGET_okREALQUAD
3873         case FFEINFO_kindtypeREALQUAD:
3874           error = ffetarget_power_realquad_integerdefault
3875             (ffebld_cu_ptr_realquad (u),
3876              ffebld_constant_realquad (ffebld_conter (l)),
3877              ffebld_constant_integerdefault (ffebld_conter (r)));
3878           expr = ffebld_new_conter_with_orig
3879             (ffebld_constant_new_realquad_val
3880              (ffebld_cu_val_realquad (u)), expr);
3881           break;
3882 #endif
3883         default:
3884           assert ("bad real kind type" == NULL);
3885           break;
3886         }
3887       break;
3888
3889     case FFEINFO_basictypeCOMPLEX:
3890       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3891         {
3892         case FFEINFO_kindtypeREALDEFAULT:
3893           error = ffetarget_power_complexdefault_integerdefault
3894             (ffebld_cu_ptr_complexdefault (u),
3895              ffebld_constant_complexdefault (ffebld_conter (l)),
3896              ffebld_constant_integerdefault (ffebld_conter (r)));
3897           expr = ffebld_new_conter_with_orig
3898             (ffebld_constant_new_complexdefault_val
3899              (ffebld_cu_val_complexdefault (u)), expr);
3900           break;
3901
3902 #if FFETARGET_okCOMPLEXDOUBLE
3903         case FFEINFO_kindtypeREALDOUBLE:
3904           error = ffetarget_power_complexdouble_integerdefault
3905             (ffebld_cu_ptr_complexdouble (u),
3906              ffebld_constant_complexdouble (ffebld_conter (l)),
3907              ffebld_constant_integerdefault (ffebld_conter (r)));
3908           expr = ffebld_new_conter_with_orig
3909             (ffebld_constant_new_complexdouble_val
3910              (ffebld_cu_val_complexdouble (u)), expr);
3911           break;
3912 #endif
3913
3914 #if FFETARGET_okCOMPLEXQUAD
3915         case FFEINFO_kindtypeREALQUAD:
3916           error = ffetarget_power_complexquad_integerdefault
3917             (ffebld_cu_ptr_complexquad (u),
3918              ffebld_constant_complexquad (ffebld_conter (l)),
3919              ffebld_constant_integerdefault (ffebld_conter (r)));
3920           expr = ffebld_new_conter_with_orig
3921             (ffebld_constant_new_complexquad_val
3922              (ffebld_cu_val_complexquad (u)), expr);
3923           break;
3924 #endif
3925
3926         default:
3927           assert ("bad complex kind type" == NULL);
3928           break;
3929         }
3930       break;
3931
3932     default:
3933       assert ("bad type" == NULL);
3934       return expr;
3935     }
3936
3937   ffebld_set_info (expr, ffeinfo_new
3938                    (bt,
3939                     kt,
3940                     0,
3941                     FFEINFO_kindENTITY,
3942                     FFEINFO_whereCONSTANT,
3943                     FFETARGET_charactersizeNONE));
3944
3945   if ((error != FFEBAD)
3946       && ffebad_start (error))
3947     {
3948       ffebad_here (0, ffelex_token_where_line (t),
3949                    ffelex_token_where_column (t));
3950       ffebad_finish ();
3951     }
3952
3953   return expr;
3954 }
3955
3956 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3957
3958    ffebld expr;
3959    ffelexToken token;
3960    expr = ffeexpr_collapse_concatenate(expr,token);
3961
3962    If the result of the expr is a constant, replaces the expr with the
3963    computed constant.  */
3964
3965 ffebld
3966 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3967 {
3968   ffebad error = FFEBAD;
3969   ffebld l;
3970   ffebld r;
3971   ffebldConstantUnion u;
3972   ffeinfoKindtype kt;
3973   ffetargetCharacterSize len;
3974
3975   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3976     return expr;
3977
3978   l = ffebld_left (expr);
3979   r = ffebld_right (expr);
3980
3981   if (ffebld_op (l) != FFEBLD_opCONTER)
3982     return expr;
3983   if (ffebld_op (r) != FFEBLD_opCONTER)
3984     return expr;
3985
3986   switch (ffeinfo_basictype (ffebld_info (expr)))
3987     {
3988     case FFEINFO_basictypeANY:
3989       return expr;
3990
3991     case FFEINFO_basictypeCHARACTER:
3992       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3993         {
3994 #if FFETARGET_okCHARACTER1
3995         case FFEINFO_kindtypeCHARACTER1:
3996           error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3997                              ffebld_constant_character1 (ffebld_conter (l)),
3998                              ffebld_constant_character1 (ffebld_conter (r)),
3999                                    ffebld_constant_pool (), &len);
4000           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4001                                       (ffebld_cu_val_character1 (u)), expr);
4002           break;
4003 #endif
4004
4005         default:
4006           assert ("bad character kind type" == NULL);
4007           break;
4008         }
4009       break;
4010
4011     default:
4012       assert ("bad type" == NULL);
4013       return expr;
4014     }
4015
4016   ffebld_set_info (expr, ffeinfo_new
4017                    (FFEINFO_basictypeCHARACTER,
4018                     kt,
4019                     0,
4020                     FFEINFO_kindENTITY,
4021                     FFEINFO_whereCONSTANT,
4022                     len));
4023
4024   if ((error != FFEBAD)
4025       && ffebad_start (error))
4026     {
4027       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4028       ffebad_finish ();
4029     }
4030
4031   return expr;
4032 }
4033
4034 /* ffeexpr_collapse_eq -- Collapse eq expr
4035
4036    ffebld expr;
4037    ffelexToken token;
4038    expr = ffeexpr_collapse_eq(expr,token);
4039
4040    If the result of the expr is a constant, replaces the expr with the
4041    computed constant.  */
4042
4043 ffebld
4044 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4045 {
4046   ffebad error = FFEBAD;
4047   ffebld l;
4048   ffebld r;
4049   bool val;
4050
4051   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4052     return expr;
4053
4054   l = ffebld_left (expr);
4055   r = ffebld_right (expr);
4056
4057   if (ffebld_op (l) != FFEBLD_opCONTER)
4058     return expr;
4059   if (ffebld_op (r) != FFEBLD_opCONTER)
4060     return expr;
4061
4062   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4063     {
4064     case FFEINFO_basictypeANY:
4065       return expr;
4066
4067     case FFEINFO_basictypeINTEGER:
4068       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4069         {
4070 #if FFETARGET_okINTEGER1
4071         case FFEINFO_kindtypeINTEGER1:
4072           error = ffetarget_eq_integer1 (&val,
4073                                ffebld_constant_integer1 (ffebld_conter (l)),
4074                               ffebld_constant_integer1 (ffebld_conter (r)));
4075           expr = ffebld_new_conter_with_orig
4076             (ffebld_constant_new_logicaldefault (val), expr);
4077           break;
4078 #endif
4079
4080 #if FFETARGET_okINTEGER2
4081         case FFEINFO_kindtypeINTEGER2:
4082           error = ffetarget_eq_integer2 (&val,
4083                                ffebld_constant_integer2 (ffebld_conter (l)),
4084                               ffebld_constant_integer2 (ffebld_conter (r)));
4085           expr = ffebld_new_conter_with_orig
4086             (ffebld_constant_new_logicaldefault (val), expr);
4087           break;
4088 #endif
4089
4090 #if FFETARGET_okINTEGER3
4091         case FFEINFO_kindtypeINTEGER3:
4092           error = ffetarget_eq_integer3 (&val,
4093                                ffebld_constant_integer3 (ffebld_conter (l)),
4094                               ffebld_constant_integer3 (ffebld_conter (r)));
4095           expr = ffebld_new_conter_with_orig
4096             (ffebld_constant_new_logicaldefault (val), expr);
4097           break;
4098 #endif
4099
4100 #if FFETARGET_okINTEGER4
4101         case FFEINFO_kindtypeINTEGER4:
4102           error = ffetarget_eq_integer4 (&val,
4103                                ffebld_constant_integer4 (ffebld_conter (l)),
4104                               ffebld_constant_integer4 (ffebld_conter (r)));
4105           expr = ffebld_new_conter_with_orig
4106             (ffebld_constant_new_logicaldefault (val), expr);
4107           break;
4108 #endif
4109
4110         default:
4111           assert ("bad integer kind type" == NULL);
4112           break;
4113         }
4114       break;
4115
4116     case FFEINFO_basictypeREAL:
4117       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4118         {
4119 #if FFETARGET_okREAL1
4120         case FFEINFO_kindtypeREAL1:
4121           error = ffetarget_eq_real1 (&val,
4122                                   ffebld_constant_real1 (ffebld_conter (l)),
4123                                  ffebld_constant_real1 (ffebld_conter (r)));
4124           expr = ffebld_new_conter_with_orig
4125             (ffebld_constant_new_logicaldefault (val), expr);
4126           break;
4127 #endif
4128
4129 #if FFETARGET_okREAL2
4130         case FFEINFO_kindtypeREAL2:
4131           error = ffetarget_eq_real2 (&val,
4132                                   ffebld_constant_real2 (ffebld_conter (l)),
4133                                  ffebld_constant_real2 (ffebld_conter (r)));
4134           expr = ffebld_new_conter_with_orig
4135             (ffebld_constant_new_logicaldefault (val), expr);
4136           break;
4137 #endif
4138
4139 #if FFETARGET_okREAL3
4140         case FFEINFO_kindtypeREAL3:
4141           error = ffetarget_eq_real3 (&val,
4142                                   ffebld_constant_real3 (ffebld_conter (l)),
4143                                  ffebld_constant_real3 (ffebld_conter (r)));
4144           expr = ffebld_new_conter_with_orig
4145             (ffebld_constant_new_logicaldefault (val), expr);
4146           break;
4147 #endif
4148
4149         default:
4150           assert ("bad real kind type" == NULL);
4151           break;
4152         }
4153       break;
4154
4155     case FFEINFO_basictypeCOMPLEX:
4156       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4157         {
4158 #if FFETARGET_okCOMPLEX1
4159         case FFEINFO_kindtypeREAL1:
4160           error = ffetarget_eq_complex1 (&val,
4161                                ffebld_constant_complex1 (ffebld_conter (l)),
4162                               ffebld_constant_complex1 (ffebld_conter (r)));
4163           expr = ffebld_new_conter_with_orig
4164             (ffebld_constant_new_logicaldefault (val), expr);
4165           break;
4166 #endif
4167
4168 #if FFETARGET_okCOMPLEX2
4169         case FFEINFO_kindtypeREAL2:
4170           error = ffetarget_eq_complex2 (&val,
4171                                ffebld_constant_complex2 (ffebld_conter (l)),
4172                               ffebld_constant_complex2 (ffebld_conter (r)));
4173           expr = ffebld_new_conter_with_orig
4174             (ffebld_constant_new_logicaldefault (val), expr);
4175           break;
4176 #endif
4177
4178 #if FFETARGET_okCOMPLEX3
4179         case FFEINFO_kindtypeREAL3:
4180           error = ffetarget_eq_complex3 (&val,
4181                                ffebld_constant_complex3 (ffebld_conter (l)),
4182                               ffebld_constant_complex3 (ffebld_conter (r)));
4183           expr = ffebld_new_conter_with_orig
4184             (ffebld_constant_new_logicaldefault (val), expr);
4185           break;
4186 #endif
4187
4188         default:
4189           assert ("bad complex kind type" == NULL);
4190           break;
4191         }
4192       break;
4193
4194     case FFEINFO_basictypeCHARACTER:
4195       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4196         {
4197 #if FFETARGET_okCHARACTER1
4198         case FFEINFO_kindtypeCHARACTER1:
4199           error = ffetarget_eq_character1 (&val,
4200                              ffebld_constant_character1 (ffebld_conter (l)),
4201                             ffebld_constant_character1 (ffebld_conter (r)));
4202           expr = ffebld_new_conter_with_orig
4203             (ffebld_constant_new_logicaldefault (val), expr);
4204           break;
4205 #endif
4206
4207         default:
4208           assert ("bad character kind type" == NULL);
4209           break;
4210         }
4211       break;
4212
4213     default:
4214       assert ("bad type" == NULL);
4215       return expr;
4216     }
4217
4218   ffebld_set_info (expr, ffeinfo_new
4219                    (FFEINFO_basictypeLOGICAL,
4220                     FFEINFO_kindtypeLOGICALDEFAULT,
4221                     0,
4222                     FFEINFO_kindENTITY,
4223                     FFEINFO_whereCONSTANT,
4224                     FFETARGET_charactersizeNONE));
4225
4226   if ((error != FFEBAD)
4227       && ffebad_start (error))
4228     {
4229       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4230       ffebad_finish ();
4231     }
4232
4233   return expr;
4234 }
4235
4236 /* ffeexpr_collapse_ne -- Collapse ne expr
4237
4238    ffebld expr;
4239    ffelexToken token;
4240    expr = ffeexpr_collapse_ne(expr,token);
4241
4242    If the result of the expr is a constant, replaces the expr with the
4243    computed constant.  */
4244
4245 ffebld
4246 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4247 {
4248   ffebad error = FFEBAD;
4249   ffebld l;
4250   ffebld r;
4251   bool val;
4252
4253   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4254     return expr;
4255
4256   l = ffebld_left (expr);
4257   r = ffebld_right (expr);
4258
4259   if (ffebld_op (l) != FFEBLD_opCONTER)
4260     return expr;
4261   if (ffebld_op (r) != FFEBLD_opCONTER)
4262     return expr;
4263
4264   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4265     {
4266     case FFEINFO_basictypeANY:
4267       return expr;
4268
4269     case FFEINFO_basictypeINTEGER:
4270       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4271         {
4272 #if FFETARGET_okINTEGER1
4273         case FFEINFO_kindtypeINTEGER1:
4274           error = ffetarget_ne_integer1 (&val,
4275                                ffebld_constant_integer1 (ffebld_conter (l)),
4276                               ffebld_constant_integer1 (ffebld_conter (r)));
4277           expr = ffebld_new_conter_with_orig
4278             (ffebld_constant_new_logicaldefault (val), expr);
4279           break;
4280 #endif
4281
4282 #if FFETARGET_okINTEGER2
4283         case FFEINFO_kindtypeINTEGER2:
4284           error = ffetarget_ne_integer2 (&val,
4285                                ffebld_constant_integer2 (ffebld_conter (l)),
4286                               ffebld_constant_integer2 (ffebld_conter (r)));
4287           expr = ffebld_new_conter_with_orig
4288             (ffebld_constant_new_logicaldefault (val), expr);
4289           break;
4290 #endif
4291
4292 #if FFETARGET_okINTEGER3
4293         case FFEINFO_kindtypeINTEGER3:
4294           error = ffetarget_ne_integer3 (&val,
4295                                ffebld_constant_integer3 (ffebld_conter (l)),
4296                               ffebld_constant_integer3 (ffebld_conter (r)));
4297           expr = ffebld_new_conter_with_orig
4298             (ffebld_constant_new_logicaldefault (val), expr);
4299           break;
4300 #endif
4301
4302 #if FFETARGET_okINTEGER4
4303         case FFEINFO_kindtypeINTEGER4:
4304           error = ffetarget_ne_integer4 (&val,
4305                                ffebld_constant_integer4 (ffebld_conter (l)),
4306                               ffebld_constant_integer4 (ffebld_conter (r)));
4307           expr = ffebld_new_conter_with_orig
4308             (ffebld_constant_new_logicaldefault (val), expr);
4309           break;
4310 #endif
4311
4312         default:
4313           assert ("bad integer kind type" == NULL);
4314           break;
4315         }
4316       break;
4317
4318     case FFEINFO_basictypeREAL:
4319       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4320         {
4321 #if FFETARGET_okREAL1
4322         case FFEINFO_kindtypeREAL1:
4323           error = ffetarget_ne_real1 (&val,
4324                                   ffebld_constant_real1 (ffebld_conter (l)),
4325                                  ffebld_constant_real1 (ffebld_conter (r)));
4326           expr = ffebld_new_conter_with_orig
4327             (ffebld_constant_new_logicaldefault (val), expr);
4328           break;
4329 #endif
4330
4331 #if FFETARGET_okREAL2
4332         case FFEINFO_kindtypeREAL2:
4333           error = ffetarget_ne_real2 (&val,
4334                                   ffebld_constant_real2 (ffebld_conter (l)),
4335                                  ffebld_constant_real2 (ffebld_conter (r)));
4336           expr = ffebld_new_conter_with_orig
4337             (ffebld_constant_new_logicaldefault (val), expr);
4338           break;
4339 #endif
4340
4341 #if FFETARGET_okREAL3
4342         case FFEINFO_kindtypeREAL3:
4343           error = ffetarget_ne_real3 (&val,
4344                                   ffebld_constant_real3 (ffebld_conter (l)),
4345                                  ffebld_constant_real3 (ffebld_conter (r)));
4346           expr = ffebld_new_conter_with_orig
4347             (ffebld_constant_new_logicaldefault (val), expr);
4348           break;
4349 #endif
4350
4351         default:
4352           assert ("bad real kind type" == NULL);
4353           break;
4354         }
4355       break;
4356
4357     case FFEINFO_basictypeCOMPLEX:
4358       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4359         {
4360 #if FFETARGET_okCOMPLEX1
4361         case FFEINFO_kindtypeREAL1:
4362           error = ffetarget_ne_complex1 (&val,
4363                                ffebld_constant_complex1 (ffebld_conter (l)),
4364                               ffebld_constant_complex1 (ffebld_conter (r)));
4365           expr = ffebld_new_conter_with_orig
4366             (ffebld_constant_new_logicaldefault (val), expr);
4367           break;
4368 #endif
4369
4370 #if FFETARGET_okCOMPLEX2
4371         case FFEINFO_kindtypeREAL2:
4372           error = ffetarget_ne_complex2 (&val,
4373                                ffebld_constant_complex2 (ffebld_conter (l)),
4374                               ffebld_constant_complex2 (ffebld_conter (r)));
4375           expr = ffebld_new_conter_with_orig
4376             (ffebld_constant_new_logicaldefault (val), expr);
4377           break;
4378 #endif
4379
4380 #if FFETARGET_okCOMPLEX3
4381         case FFEINFO_kindtypeREAL3:
4382           error = ffetarget_ne_complex3 (&val,
4383                                ffebld_constant_complex3 (ffebld_conter (l)),
4384                               ffebld_constant_complex3 (ffebld_conter (r)));
4385           expr = ffebld_new_conter_with_orig
4386             (ffebld_constant_new_logicaldefault (val), expr);
4387           break;
4388 #endif
4389
4390         default:
4391           assert ("bad complex kind type" == NULL);
4392           break;
4393         }
4394       break;
4395
4396     case FFEINFO_basictypeCHARACTER:
4397       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4398         {
4399 #if FFETARGET_okCHARACTER1
4400         case FFEINFO_kindtypeCHARACTER1:
4401           error = ffetarget_ne_character1 (&val,
4402                              ffebld_constant_character1 (ffebld_conter (l)),
4403                             ffebld_constant_character1 (ffebld_conter (r)));
4404           expr = ffebld_new_conter_with_orig
4405             (ffebld_constant_new_logicaldefault (val), expr);
4406           break;
4407 #endif
4408
4409         default:
4410           assert ("bad character kind type" == NULL);
4411           break;
4412         }
4413       break;
4414
4415     default:
4416       assert ("bad type" == NULL);
4417       return expr;
4418     }
4419
4420   ffebld_set_info (expr, ffeinfo_new
4421                    (FFEINFO_basictypeLOGICAL,
4422                     FFEINFO_kindtypeLOGICALDEFAULT,
4423                     0,
4424                     FFEINFO_kindENTITY,
4425                     FFEINFO_whereCONSTANT,
4426                     FFETARGET_charactersizeNONE));
4427
4428   if ((error != FFEBAD)
4429       && ffebad_start (error))
4430     {
4431       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4432       ffebad_finish ();
4433     }
4434
4435   return expr;
4436 }
4437
4438 /* ffeexpr_collapse_ge -- Collapse ge expr
4439
4440    ffebld expr;
4441    ffelexToken token;
4442    expr = ffeexpr_collapse_ge(expr,token);
4443
4444    If the result of the expr is a constant, replaces the expr with the
4445    computed constant.  */
4446
4447 ffebld
4448 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4449 {
4450   ffebad error = FFEBAD;
4451   ffebld l;
4452   ffebld r;
4453   bool val;
4454
4455   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4456     return expr;
4457
4458   l = ffebld_left (expr);
4459   r = ffebld_right (expr);
4460
4461   if (ffebld_op (l) != FFEBLD_opCONTER)
4462     return expr;
4463   if (ffebld_op (r) != FFEBLD_opCONTER)
4464     return expr;
4465
4466   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4467     {
4468     case FFEINFO_basictypeANY:
4469       return expr;
4470
4471     case FFEINFO_basictypeINTEGER:
4472       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4473         {
4474 #if FFETARGET_okINTEGER1
4475         case FFEINFO_kindtypeINTEGER1:
4476           error = ffetarget_ge_integer1 (&val,
4477                                ffebld_constant_integer1 (ffebld_conter (l)),
4478                               ffebld_constant_integer1 (ffebld_conter (r)));
4479           expr = ffebld_new_conter_with_orig
4480             (ffebld_constant_new_logicaldefault (val), expr);
4481           break;
4482 #endif
4483
4484 #if FFETARGET_okINTEGER2
4485         case FFEINFO_kindtypeINTEGER2:
4486           error = ffetarget_ge_integer2 (&val,
4487                                ffebld_constant_integer2 (ffebld_conter (l)),
4488                               ffebld_constant_integer2 (ffebld_conter (r)));
4489           expr = ffebld_new_conter_with_orig
4490             (ffebld_constant_new_logicaldefault (val), expr);
4491           break;
4492 #endif
4493
4494 #if FFETARGET_okINTEGER3
4495         case FFEINFO_kindtypeINTEGER3:
4496           error = ffetarget_ge_integer3 (&val,
4497                                ffebld_constant_integer3 (ffebld_conter (l)),
4498                               ffebld_constant_integer3 (ffebld_conter (r)));
4499           expr = ffebld_new_conter_with_orig
4500             (ffebld_constant_new_logicaldefault (val), expr);
4501           break;
4502 #endif
4503
4504 #if FFETARGET_okINTEGER4
4505         case FFEINFO_kindtypeINTEGER4:
4506           error = ffetarget_ge_integer4 (&val,
4507                                ffebld_constant_integer4 (ffebld_conter (l)),
4508                               ffebld_constant_integer4 (ffebld_conter (r)));
4509           expr = ffebld_new_conter_with_orig
4510             (ffebld_constant_new_logicaldefault (val), expr);
4511           break;
4512 #endif
4513
4514         default:
4515           assert ("bad integer kind type" == NULL);
4516           break;
4517         }
4518       break;
4519
4520     case FFEINFO_basictypeREAL:
4521       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4522         {
4523 #if FFETARGET_okREAL1
4524         case FFEINFO_kindtypeREAL1:
4525           error = ffetarget_ge_real1 (&val,
4526                                   ffebld_constant_real1 (ffebld_conter (l)),
4527                                  ffebld_constant_real1 (ffebld_conter (r)));
4528           expr = ffebld_new_conter_with_orig
4529             (ffebld_constant_new_logicaldefault (val), expr);
4530           break;
4531 #endif
4532
4533 #if FFETARGET_okREAL2
4534         case FFEINFO_kindtypeREAL2:
4535           error = ffetarget_ge_real2 (&val,
4536                                   ffebld_constant_real2 (ffebld_conter (l)),
4537                                  ffebld_constant_real2 (ffebld_conter (r)));
4538           expr = ffebld_new_conter_with_orig
4539             (ffebld_constant_new_logicaldefault (val), expr);
4540           break;
4541 #endif
4542
4543 #if FFETARGET_okREAL3
4544         case FFEINFO_kindtypeREAL3:
4545           error = ffetarget_ge_real3 (&val,
4546                                   ffebld_constant_real3 (ffebld_conter (l)),
4547                                  ffebld_constant_real3 (ffebld_conter (r)));
4548           expr = ffebld_new_conter_with_orig
4549             (ffebld_constant_new_logicaldefault (val), expr);
4550           break;
4551 #endif
4552
4553         default:
4554           assert ("bad real kind type" == NULL);
4555           break;
4556         }
4557       break;
4558
4559     case FFEINFO_basictypeCHARACTER:
4560       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4561         {
4562 #if FFETARGET_okCHARACTER1
4563         case FFEINFO_kindtypeCHARACTER1:
4564           error = ffetarget_ge_character1 (&val,
4565                              ffebld_constant_character1 (ffebld_conter (l)),
4566                             ffebld_constant_character1 (ffebld_conter (r)));
4567           expr = ffebld_new_conter_with_orig
4568             (ffebld_constant_new_logicaldefault (val), expr);
4569           break;
4570 #endif
4571
4572         default:
4573           assert ("bad character kind type" == NULL);
4574           break;
4575         }
4576       break;
4577
4578     default:
4579       assert ("bad type" == NULL);
4580       return expr;
4581     }
4582
4583   ffebld_set_info (expr, ffeinfo_new
4584                    (FFEINFO_basictypeLOGICAL,
4585                     FFEINFO_kindtypeLOGICALDEFAULT,
4586                     0,
4587                     FFEINFO_kindENTITY,
4588                     FFEINFO_whereCONSTANT,
4589                     FFETARGET_charactersizeNONE));
4590
4591   if ((error != FFEBAD)
4592       && ffebad_start (error))
4593     {
4594       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4595       ffebad_finish ();
4596     }
4597
4598   return expr;
4599 }
4600
4601 /* ffeexpr_collapse_gt -- Collapse gt expr
4602
4603    ffebld expr;
4604    ffelexToken token;
4605    expr = ffeexpr_collapse_gt(expr,token);
4606
4607    If the result of the expr is a constant, replaces the expr with the
4608    computed constant.  */
4609
4610 ffebld
4611 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4612 {
4613   ffebad error = FFEBAD;
4614   ffebld l;
4615   ffebld r;
4616   bool val;
4617
4618   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4619     return expr;
4620
4621   l = ffebld_left (expr);
4622   r = ffebld_right (expr);
4623
4624   if (ffebld_op (l) != FFEBLD_opCONTER)
4625     return expr;
4626   if (ffebld_op (r) != FFEBLD_opCONTER)
4627     return expr;
4628
4629   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4630     {
4631     case FFEINFO_basictypeANY:
4632       return expr;
4633
4634     case FFEINFO_basictypeINTEGER:
4635       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4636         {
4637 #if FFETARGET_okINTEGER1
4638         case FFEINFO_kindtypeINTEGER1:
4639           error = ffetarget_gt_integer1 (&val,
4640                                ffebld_constant_integer1 (ffebld_conter (l)),
4641                               ffebld_constant_integer1 (ffebld_conter (r)));
4642           expr = ffebld_new_conter_with_orig
4643             (ffebld_constant_new_logicaldefault (val), expr);
4644           break;
4645 #endif
4646
4647 #if FFETARGET_okINTEGER2
4648         case FFEINFO_kindtypeINTEGER2:
4649           error = ffetarget_gt_integer2 (&val,
4650                                ffebld_constant_integer2 (ffebld_conter (l)),
4651                               ffebld_constant_integer2 (ffebld_conter (r)));
4652           expr = ffebld_new_conter_with_orig
4653             (ffebld_constant_new_logicaldefault (val), expr);
4654           break;
4655 #endif
4656
4657 #if FFETARGET_okINTEGER3
4658         case FFEINFO_kindtypeINTEGER3:
4659           error = ffetarget_gt_integer3 (&val,
4660                                ffebld_constant_integer3 (ffebld_conter (l)),
4661                               ffebld_constant_integer3 (ffebld_conter (r)));
4662           expr = ffebld_new_conter_with_orig
4663             (ffebld_constant_new_logicaldefault (val), expr);
4664           break;
4665 #endif
4666
4667 #if FFETARGET_okINTEGER4
4668         case FFEINFO_kindtypeINTEGER4:
4669           error = ffetarget_gt_integer4 (&val,
4670                                ffebld_constant_integer4 (ffebld_conter (l)),
4671                               ffebld_constant_integer4 (ffebld_conter (r)));
4672           expr = ffebld_new_conter_with_orig
4673             (ffebld_constant_new_logicaldefault (val), expr);
4674           break;
4675 #endif
4676
4677         default:
4678           assert ("bad integer kind type" == NULL);
4679           break;
4680         }
4681       break;
4682
4683     case FFEINFO_basictypeREAL:
4684       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4685         {
4686 #if FFETARGET_okREAL1
4687         case FFEINFO_kindtypeREAL1:
4688           error = ffetarget_gt_real1 (&val,
4689                                   ffebld_constant_real1 (ffebld_conter (l)),
4690                                  ffebld_constant_real1 (ffebld_conter (r)));
4691           expr = ffebld_new_conter_with_orig
4692             (ffebld_constant_new_logicaldefault (val), expr);
4693           break;
4694 #endif
4695
4696 #if FFETARGET_okREAL2
4697         case FFEINFO_kindtypeREAL2:
4698           error = ffetarget_gt_real2 (&val,
4699                                   ffebld_constant_real2 (ffebld_conter (l)),
4700                                  ffebld_constant_real2 (ffebld_conter (r)));
4701           expr = ffebld_new_conter_with_orig
4702             (ffebld_constant_new_logicaldefault (val), expr);
4703           break;
4704 #endif
4705
4706 #if FFETARGET_okREAL3
4707         case FFEINFO_kindtypeREAL3:
4708           error = ffetarget_gt_real3 (&val,
4709                                   ffebld_constant_real3 (ffebld_conter (l)),
4710                                  ffebld_constant_real3 (ffebld_conter (r)));
4711           expr = ffebld_new_conter_with_orig
4712             (ffebld_constant_new_logicaldefault (val), expr);
4713           break;
4714 #endif
4715
4716         default:
4717           assert ("bad real kind type" == NULL);
4718           break;
4719         }
4720       break;
4721
4722     case FFEINFO_basictypeCHARACTER:
4723       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4724         {
4725 #if FFETARGET_okCHARACTER1
4726         case FFEINFO_kindtypeCHARACTER1:
4727           error = ffetarget_gt_character1 (&val,
4728                              ffebld_constant_character1 (ffebld_conter (l)),
4729                             ffebld_constant_character1 (ffebld_conter (r)));
4730           expr = ffebld_new_conter_with_orig
4731             (ffebld_constant_new_logicaldefault (val), expr);
4732           break;
4733 #endif
4734
4735         default:
4736           assert ("bad character kind type" == NULL);
4737           break;
4738         }
4739       break;
4740
4741     default:
4742       assert ("bad type" == NULL);
4743       return expr;
4744     }
4745
4746   ffebld_set_info (expr, ffeinfo_new
4747                    (FFEINFO_basictypeLOGICAL,
4748                     FFEINFO_kindtypeLOGICALDEFAULT,
4749                     0,
4750                     FFEINFO_kindENTITY,
4751                     FFEINFO_whereCONSTANT,
4752                     FFETARGET_charactersizeNONE));
4753
4754   if ((error != FFEBAD)
4755       && ffebad_start (error))
4756     {
4757       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4758       ffebad_finish ();
4759     }
4760
4761   return expr;
4762 }
4763
4764 /* ffeexpr_collapse_le -- Collapse le expr
4765
4766    ffebld expr;
4767    ffelexToken token;
4768    expr = ffeexpr_collapse_le(expr,token);
4769
4770    If the result of the expr is a constant, replaces the expr with the
4771    computed constant.  */
4772
4773 ffebld
4774 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4775 {
4776   ffebad error = FFEBAD;
4777   ffebld l;
4778   ffebld r;
4779   bool val;
4780
4781   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4782     return expr;
4783
4784   l = ffebld_left (expr);
4785   r = ffebld_right (expr);
4786
4787   if (ffebld_op (l) != FFEBLD_opCONTER)
4788     return expr;
4789   if (ffebld_op (r) != FFEBLD_opCONTER)
4790     return expr;
4791
4792   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4793     {
4794     case FFEINFO_basictypeANY:
4795       return expr;
4796
4797     case FFEINFO_basictypeINTEGER:
4798       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4799         {
4800 #if FFETARGET_okINTEGER1
4801         case FFEINFO_kindtypeINTEGER1:
4802           error = ffetarget_le_integer1 (&val,
4803                                ffebld_constant_integer1 (ffebld_conter (l)),
4804                               ffebld_constant_integer1 (ffebld_conter (r)));
4805           expr = ffebld_new_conter_with_orig
4806             (ffebld_constant_new_logicaldefault (val), expr);
4807           break;
4808 #endif
4809
4810 #if FFETARGET_okINTEGER2
4811         case FFEINFO_kindtypeINTEGER2:
4812           error = ffetarget_le_integer2 (&val,
4813                                ffebld_constant_integer2 (ffebld_conter (l)),
4814                               ffebld_constant_integer2 (ffebld_conter (r)));
4815           expr = ffebld_new_conter_with_orig
4816             (ffebld_constant_new_logicaldefault (val), expr);
4817           break;
4818 #endif
4819
4820 #if FFETARGET_okINTEGER3
4821         case FFEINFO_kindtypeINTEGER3:
4822           error = ffetarget_le_integer3 (&val,
4823                                ffebld_constant_integer3 (ffebld_conter (l)),
4824                               ffebld_constant_integer3 (ffebld_conter (r)));
4825           expr = ffebld_new_conter_with_orig
4826             (ffebld_constant_new_logicaldefault (val), expr);
4827           break;
4828 #endif
4829
4830 #if FFETARGET_okINTEGER4
4831         case FFEINFO_kindtypeINTEGER4:
4832           error = ffetarget_le_integer4 (&val,
4833                                ffebld_constant_integer4 (ffebld_conter (l)),
4834                               ffebld_constant_integer4 (ffebld_conter (r)));
4835           expr = ffebld_new_conter_with_orig
4836             (ffebld_constant_new_logicaldefault (val), expr);
4837           break;
4838 #endif
4839
4840         default:
4841           assert ("bad integer kind type" == NULL);
4842           break;
4843         }
4844       break;
4845
4846     case FFEINFO_basictypeREAL:
4847       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4848         {
4849 #if FFETARGET_okREAL1
4850         case FFEINFO_kindtypeREAL1:
4851           error = ffetarget_le_real1 (&val,
4852                                   ffebld_constant_real1 (ffebld_conter (l)),
4853                                  ffebld_constant_real1 (ffebld_conter (r)));
4854           expr = ffebld_new_conter_with_orig
4855             (ffebld_constant_new_logicaldefault (val), expr);
4856           break;
4857 #endif
4858
4859 #if FFETARGET_okREAL2
4860         case FFEINFO_kindtypeREAL2:
4861           error = ffetarget_le_real2 (&val,
4862                                   ffebld_constant_real2 (ffebld_conter (l)),
4863                                  ffebld_constant_real2 (ffebld_conter (r)));
4864           expr = ffebld_new_conter_with_orig
4865             (ffebld_constant_new_logicaldefault (val), expr);
4866           break;
4867 #endif
4868
4869 #if FFETARGET_okREAL3
4870         case FFEINFO_kindtypeREAL3:
4871           error = ffetarget_le_real3 (&val,
4872                                   ffebld_constant_real3 (ffebld_conter (l)),
4873                                  ffebld_constant_real3 (ffebld_conter (r)));
4874           expr = ffebld_new_conter_with_orig
4875             (ffebld_constant_new_logicaldefault (val), expr);
4876           break;
4877 #endif
4878
4879         default:
4880           assert ("bad real kind type" == NULL);
4881           break;
4882         }
4883       break;
4884
4885     case FFEINFO_basictypeCHARACTER:
4886       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4887         {
4888 #if FFETARGET_okCHARACTER1
4889         case FFEINFO_kindtypeCHARACTER1:
4890           error = ffetarget_le_character1 (&val,
4891                              ffebld_constant_character1 (ffebld_conter (l)),
4892                             ffebld_constant_character1 (ffebld_conter (r)));
4893           expr = ffebld_new_conter_with_orig
4894             (ffebld_constant_new_logicaldefault (val), expr);
4895           break;
4896 #endif
4897
4898         default:
4899           assert ("bad character kind type" == NULL);
4900           break;
4901         }
4902       break;
4903
4904     default:
4905       assert ("bad type" == NULL);
4906       return expr;
4907     }
4908
4909   ffebld_set_info (expr, ffeinfo_new
4910                    (FFEINFO_basictypeLOGICAL,
4911                     FFEINFO_kindtypeLOGICALDEFAULT,
4912                     0,
4913                     FFEINFO_kindENTITY,
4914                     FFEINFO_whereCONSTANT,
4915                     FFETARGET_charactersizeNONE));
4916
4917   if ((error != FFEBAD)
4918       && ffebad_start (error))
4919     {
4920       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4921       ffebad_finish ();
4922     }
4923
4924   return expr;
4925 }
4926
4927 /* ffeexpr_collapse_lt -- Collapse lt expr
4928
4929    ffebld expr;
4930    ffelexToken token;
4931    expr = ffeexpr_collapse_lt(expr,token);
4932
4933    If the result of the expr is a constant, replaces the expr with the
4934    computed constant.  */
4935
4936 ffebld
4937 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4938 {
4939   ffebad error = FFEBAD;
4940   ffebld l;
4941   ffebld r;
4942   bool val;
4943
4944   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4945     return expr;
4946
4947   l = ffebld_left (expr);
4948   r = ffebld_right (expr);
4949
4950   if (ffebld_op (l) != FFEBLD_opCONTER)
4951     return expr;
4952   if (ffebld_op (r) != FFEBLD_opCONTER)
4953     return expr;
4954
4955   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4956     {
4957     case FFEINFO_basictypeANY:
4958       return expr;
4959
4960     case FFEINFO_basictypeINTEGER:
4961       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4962         {
4963 #if FFETARGET_okINTEGER1
4964         case FFEINFO_kindtypeINTEGER1:
4965           error = ffetarget_lt_integer1 (&val,
4966                                ffebld_constant_integer1 (ffebld_conter (l)),
4967                               ffebld_constant_integer1 (ffebld_conter (r)));
4968           expr = ffebld_new_conter_with_orig
4969             (ffebld_constant_new_logicaldefault (val), expr);
4970           break;
4971 #endif
4972
4973 #if FFETARGET_okINTEGER2
4974         case FFEINFO_kindtypeINTEGER2:
4975           error = ffetarget_lt_integer2 (&val,
4976                                ffebld_constant_integer2 (ffebld_conter (l)),
4977                               ffebld_constant_integer2 (ffebld_conter (r)));
4978           expr = ffebld_new_conter_with_orig
4979             (ffebld_constant_new_logicaldefault (val), expr);
4980           break;
4981 #endif
4982
4983 #if FFETARGET_okINTEGER3
4984         case FFEINFO_kindtypeINTEGER3:
4985           error = ffetarget_lt_integer3 (&val,
4986                                ffebld_constant_integer3 (ffebld_conter (l)),
4987                               ffebld_constant_integer3 (ffebld_conter (r)));
4988           expr = ffebld_new_conter_with_orig
4989             (ffebld_constant_new_logicaldefault (val), expr);
4990           break;
4991 #endif
4992
4993 #if FFETARGET_okINTEGER4
4994         case FFEINFO_kindtypeINTEGER4:
4995           error = ffetarget_lt_integer4 (&val,
4996                                ffebld_constant_integer4 (ffebld_conter (l)),
4997                               ffebld_constant_integer4 (ffebld_conter (r)));
4998           expr = ffebld_new_conter_with_orig
4999             (ffebld_constant_new_logicaldefault (val), expr);
5000           break;
5001 #endif
5002
5003         default:
5004           assert ("bad integer kind type" == NULL);
5005           break;
5006         }
5007       break;
5008
5009     case FFEINFO_basictypeREAL:
5010       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5011         {
5012 #if FFETARGET_okREAL1
5013         case FFEINFO_kindtypeREAL1:
5014           error = ffetarget_lt_real1 (&val,
5015                                   ffebld_constant_real1 (ffebld_conter (l)),
5016                                  ffebld_constant_real1 (ffebld_conter (r)));
5017           expr = ffebld_new_conter_with_orig
5018             (ffebld_constant_new_logicaldefault (val), expr);
5019           break;
5020 #endif
5021
5022 #if FFETARGET_okREAL2
5023         case FFEINFO_kindtypeREAL2:
5024           error = ffetarget_lt_real2 (&val,
5025                                   ffebld_constant_real2 (ffebld_conter (l)),
5026                                  ffebld_constant_real2 (ffebld_conter (r)));
5027           expr = ffebld_new_conter_with_orig
5028             (ffebld_constant_new_logicaldefault (val), expr);
5029           break;
5030 #endif
5031
5032 #if FFETARGET_okREAL3
5033         case FFEINFO_kindtypeREAL3:
5034           error = ffetarget_lt_real3 (&val,
5035                                   ffebld_constant_real3 (ffebld_conter (l)),
5036                                  ffebld_constant_real3 (ffebld_conter (r)));
5037           expr = ffebld_new_conter_with_orig
5038             (ffebld_constant_new_logicaldefault (val), expr);
5039           break;
5040 #endif
5041
5042         default:
5043           assert ("bad real kind type" == NULL);
5044           break;
5045         }
5046       break;
5047
5048     case FFEINFO_basictypeCHARACTER:
5049       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5050         {
5051 #if FFETARGET_okCHARACTER1
5052         case FFEINFO_kindtypeCHARACTER1:
5053           error = ffetarget_lt_character1 (&val,
5054                              ffebld_constant_character1 (ffebld_conter (l)),
5055                             ffebld_constant_character1 (ffebld_conter (r)));
5056           expr = ffebld_new_conter_with_orig
5057             (ffebld_constant_new_logicaldefault (val), expr);
5058           break;
5059 #endif
5060
5061         default:
5062           assert ("bad character kind type" == NULL);
5063           break;
5064         }
5065       break;
5066
5067     default:
5068       assert ("bad type" == NULL);
5069       return expr;
5070     }
5071
5072   ffebld_set_info (expr, ffeinfo_new
5073                    (FFEINFO_basictypeLOGICAL,
5074                     FFEINFO_kindtypeLOGICALDEFAULT,
5075                     0,
5076                     FFEINFO_kindENTITY,
5077                     FFEINFO_whereCONSTANT,
5078                     FFETARGET_charactersizeNONE));
5079
5080   if ((error != FFEBAD)
5081       && ffebad_start (error))
5082     {
5083       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5084       ffebad_finish ();
5085     }
5086
5087   return expr;
5088 }
5089
5090 /* ffeexpr_collapse_and -- Collapse and expr
5091
5092    ffebld expr;
5093    ffelexToken token;
5094    expr = ffeexpr_collapse_and(expr,token);
5095
5096    If the result of the expr is a constant, replaces the expr with the
5097    computed constant.  */
5098
5099 ffebld
5100 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5101 {
5102   ffebad error = FFEBAD;
5103   ffebld l;
5104   ffebld r;
5105   ffebldConstantUnion u;
5106   ffeinfoBasictype bt;
5107   ffeinfoKindtype kt;
5108
5109   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5110     return expr;
5111
5112   l = ffebld_left (expr);
5113   r = ffebld_right (expr);
5114
5115   if (ffebld_op (l) != FFEBLD_opCONTER)
5116     return expr;
5117   if (ffebld_op (r) != FFEBLD_opCONTER)
5118     return expr;
5119
5120   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5121     {
5122     case FFEINFO_basictypeANY:
5123       return expr;
5124
5125     case FFEINFO_basictypeINTEGER:
5126       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5127         {
5128 #if FFETARGET_okINTEGER1
5129         case FFEINFO_kindtypeINTEGER1:
5130           error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5131                                ffebld_constant_integer1 (ffebld_conter (l)),
5132                               ffebld_constant_integer1 (ffebld_conter (r)));
5133           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5134                                         (ffebld_cu_val_integer1 (u)), expr);
5135           break;
5136 #endif
5137
5138 #if FFETARGET_okINTEGER2
5139         case FFEINFO_kindtypeINTEGER2:
5140           error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5141                                ffebld_constant_integer2 (ffebld_conter (l)),
5142                               ffebld_constant_integer2 (ffebld_conter (r)));
5143           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5144                                         (ffebld_cu_val_integer2 (u)), expr);
5145           break;
5146 #endif
5147
5148 #if FFETARGET_okINTEGER3
5149         case FFEINFO_kindtypeINTEGER3:
5150           error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5151                                ffebld_constant_integer3 (ffebld_conter (l)),
5152                               ffebld_constant_integer3 (ffebld_conter (r)));
5153           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5154                                         (ffebld_cu_val_integer3 (u)), expr);
5155           break;
5156 #endif
5157
5158 #if FFETARGET_okINTEGER4
5159         case FFEINFO_kindtypeINTEGER4:
5160           error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5161                                ffebld_constant_integer4 (ffebld_conter (l)),
5162                               ffebld_constant_integer4 (ffebld_conter (r)));
5163           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5164                                         (ffebld_cu_val_integer4 (u)), expr);
5165           break;
5166 #endif
5167
5168         default:
5169           assert ("bad integer kind type" == NULL);
5170           break;
5171         }
5172       break;
5173
5174     case FFEINFO_basictypeLOGICAL:
5175       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5176         {
5177 #if FFETARGET_okLOGICAL1
5178         case FFEINFO_kindtypeLOGICAL1:
5179           error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5180                                ffebld_constant_logical1 (ffebld_conter (l)),
5181                               ffebld_constant_logical1 (ffebld_conter (r)));
5182           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5183                                         (ffebld_cu_val_logical1 (u)), expr);
5184           break;
5185 #endif
5186
5187 #if FFETARGET_okLOGICAL2
5188         case FFEINFO_kindtypeLOGICAL2:
5189           error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5190                                ffebld_constant_logical2 (ffebld_conter (l)),
5191                               ffebld_constant_logical2 (ffebld_conter (r)));
5192           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5193                                         (ffebld_cu_val_logical2 (u)), expr);
5194           break;
5195 #endif
5196
5197 #if FFETARGET_okLOGICAL3
5198         case FFEINFO_kindtypeLOGICAL3:
5199           error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5200                                ffebld_constant_logical3 (ffebld_conter (l)),
5201                               ffebld_constant_logical3 (ffebld_conter (r)));
5202           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5203                                         (ffebld_cu_val_logical3 (u)), expr);
5204           break;
5205 #endif
5206
5207 #if FFETARGET_okLOGICAL4
5208         case FFEINFO_kindtypeLOGICAL4:
5209           error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5210                                ffebld_constant_logical4 (ffebld_conter (l)),
5211                               ffebld_constant_logical4 (ffebld_conter (r)));
5212           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5213                                         (ffebld_cu_val_logical4 (u)), expr);
5214           break;
5215 #endif
5216
5217         default:
5218           assert ("bad logical kind type" == NULL);
5219           break;
5220         }
5221       break;
5222
5223     default:
5224       assert ("bad type" == NULL);
5225       return expr;
5226     }
5227
5228   ffebld_set_info (expr, ffeinfo_new
5229                    (bt,
5230                     kt,
5231                     0,
5232                     FFEINFO_kindENTITY,
5233                     FFEINFO_whereCONSTANT,
5234                     FFETARGET_charactersizeNONE));
5235
5236   if ((error != FFEBAD)
5237       && ffebad_start (error))
5238     {
5239       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5240       ffebad_finish ();
5241     }
5242
5243   return expr;
5244 }
5245
5246 /* ffeexpr_collapse_or -- Collapse or expr
5247
5248    ffebld expr;
5249    ffelexToken token;
5250    expr = ffeexpr_collapse_or(expr,token);
5251
5252    If the result of the expr is a constant, replaces the expr with the
5253    computed constant.  */
5254
5255 ffebld
5256 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5257 {
5258   ffebad error = FFEBAD;
5259   ffebld l;
5260   ffebld r;
5261   ffebldConstantUnion u;
5262   ffeinfoBasictype bt;
5263   ffeinfoKindtype kt;
5264
5265   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5266     return expr;
5267
5268   l = ffebld_left (expr);
5269   r = ffebld_right (expr);
5270
5271   if (ffebld_op (l) != FFEBLD_opCONTER)
5272     return expr;
5273   if (ffebld_op (r) != FFEBLD_opCONTER)
5274     return expr;
5275
5276   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5277     {
5278     case FFEINFO_basictypeANY:
5279       return expr;
5280
5281     case FFEINFO_basictypeINTEGER:
5282       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5283         {
5284 #if FFETARGET_okINTEGER1
5285         case FFEINFO_kindtypeINTEGER1:
5286           error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5287                                ffebld_constant_integer1 (ffebld_conter (l)),
5288                               ffebld_constant_integer1 (ffebld_conter (r)));
5289           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5290                                         (ffebld_cu_val_integer1 (u)), expr);
5291           break;
5292 #endif
5293
5294 #if FFETARGET_okINTEGER2
5295         case FFEINFO_kindtypeINTEGER2:
5296           error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5297                                ffebld_constant_integer2 (ffebld_conter (l)),
5298                               ffebld_constant_integer2 (ffebld_conter (r)));
5299           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5300                                         (ffebld_cu_val_integer2 (u)), expr);
5301           break;
5302 #endif
5303
5304 #if FFETARGET_okINTEGER3
5305         case FFEINFO_kindtypeINTEGER3:
5306           error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5307                                ffebld_constant_integer3 (ffebld_conter (l)),
5308                               ffebld_constant_integer3 (ffebld_conter (r)));
5309           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5310                                         (ffebld_cu_val_integer3 (u)), expr);
5311           break;
5312 #endif
5313
5314 #if FFETARGET_okINTEGER4
5315         case FFEINFO_kindtypeINTEGER4:
5316           error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5317                                ffebld_constant_integer4 (ffebld_conter (l)),
5318                               ffebld_constant_integer4 (ffebld_conter (r)));
5319           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5320                                         (ffebld_cu_val_integer4 (u)), expr);
5321           break;
5322 #endif
5323
5324         default:
5325           assert ("bad integer kind type" == NULL);
5326           break;
5327         }
5328       break;
5329
5330     case FFEINFO_basictypeLOGICAL:
5331       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5332         {
5333 #if FFETARGET_okLOGICAL1
5334         case FFEINFO_kindtypeLOGICAL1:
5335           error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5336                                ffebld_constant_logical1 (ffebld_conter (l)),
5337                               ffebld_constant_logical1 (ffebld_conter (r)));
5338           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5339                                         (ffebld_cu_val_logical1 (u)), expr);
5340           break;
5341 #endif
5342
5343 #if FFETARGET_okLOGICAL2
5344         case FFEINFO_kindtypeLOGICAL2:
5345           error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5346                                ffebld_constant_logical2 (ffebld_conter (l)),
5347                               ffebld_constant_logical2 (ffebld_conter (r)));
5348           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5349                                         (ffebld_cu_val_logical2 (u)), expr);
5350           break;
5351 #endif
5352
5353 #if FFETARGET_okLOGICAL3
5354         case FFEINFO_kindtypeLOGICAL3:
5355           error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5356                                ffebld_constant_logical3 (ffebld_conter (l)),
5357                               ffebld_constant_logical3 (ffebld_conter (r)));
5358           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5359                                         (ffebld_cu_val_logical3 (u)), expr);
5360           break;
5361 #endif
5362
5363 #if FFETARGET_okLOGICAL4
5364         case FFEINFO_kindtypeLOGICAL4:
5365           error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5366                                ffebld_constant_logical4 (ffebld_conter (l)),
5367                               ffebld_constant_logical4 (ffebld_conter (r)));
5368           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5369                                         (ffebld_cu_val_logical4 (u)), expr);
5370           break;
5371 #endif
5372
5373         default:
5374           assert ("bad logical kind type" == NULL);
5375           break;
5376         }
5377       break;
5378
5379     default:
5380       assert ("bad type" == NULL);
5381       return expr;
5382     }
5383
5384   ffebld_set_info (expr, ffeinfo_new
5385                    (bt,
5386                     kt,
5387                     0,
5388                     FFEINFO_kindENTITY,
5389                     FFEINFO_whereCONSTANT,
5390                     FFETARGET_charactersizeNONE));
5391
5392   if ((error != FFEBAD)
5393       && ffebad_start (error))
5394     {
5395       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5396       ffebad_finish ();
5397     }
5398
5399   return expr;
5400 }
5401
5402 /* ffeexpr_collapse_xor -- Collapse xor expr
5403
5404    ffebld expr;
5405    ffelexToken token;
5406    expr = ffeexpr_collapse_xor(expr,token);
5407
5408    If the result of the expr is a constant, replaces the expr with the
5409    computed constant.  */
5410
5411 ffebld
5412 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5413 {
5414   ffebad error = FFEBAD;
5415   ffebld l;
5416   ffebld r;
5417   ffebldConstantUnion u;
5418   ffeinfoBasictype bt;
5419   ffeinfoKindtype kt;
5420
5421   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5422     return expr;
5423
5424   l = ffebld_left (expr);
5425   r = ffebld_right (expr);
5426
5427   if (ffebld_op (l) != FFEBLD_opCONTER)
5428     return expr;
5429   if (ffebld_op (r) != FFEBLD_opCONTER)
5430     return expr;
5431
5432   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5433     {
5434     case FFEINFO_basictypeANY:
5435       return expr;
5436
5437     case FFEINFO_basictypeINTEGER:
5438       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5439         {
5440 #if FFETARGET_okINTEGER1
5441         case FFEINFO_kindtypeINTEGER1:
5442           error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5443                                ffebld_constant_integer1 (ffebld_conter (l)),
5444                               ffebld_constant_integer1 (ffebld_conter (r)));
5445           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5446                                         (ffebld_cu_val_integer1 (u)), expr);
5447           break;
5448 #endif
5449
5450 #if FFETARGET_okINTEGER2
5451         case FFEINFO_kindtypeINTEGER2:
5452           error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5453                                ffebld_constant_integer2 (ffebld_conter (l)),
5454                               ffebld_constant_integer2 (ffebld_conter (r)));
5455           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5456                                         (ffebld_cu_val_integer2 (u)), expr);
5457           break;
5458 #endif
5459
5460 #if FFETARGET_okINTEGER3
5461         case FFEINFO_kindtypeINTEGER3:
5462           error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5463                                ffebld_constant_integer3 (ffebld_conter (l)),
5464                               ffebld_constant_integer3 (ffebld_conter (r)));
5465           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5466                                         (ffebld_cu_val_integer3 (u)), expr);
5467           break;
5468 #endif
5469
5470 #if FFETARGET_okINTEGER4
5471         case FFEINFO_kindtypeINTEGER4:
5472           error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5473                                ffebld_constant_integer4 (ffebld_conter (l)),
5474                               ffebld_constant_integer4 (ffebld_conter (r)));
5475           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5476                                         (ffebld_cu_val_integer4 (u)), expr);
5477           break;
5478 #endif
5479
5480         default:
5481           assert ("bad integer kind type" == NULL);
5482           break;
5483         }
5484       break;
5485
5486     case FFEINFO_basictypeLOGICAL:
5487       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5488         {
5489 #if FFETARGET_okLOGICAL1
5490         case FFEINFO_kindtypeLOGICAL1:
5491           error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5492                                ffebld_constant_logical1 (ffebld_conter (l)),
5493                               ffebld_constant_logical1 (ffebld_conter (r)));
5494           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5495                                         (ffebld_cu_val_logical1 (u)), expr);
5496           break;
5497 #endif
5498
5499 #if FFETARGET_okLOGICAL2
5500         case FFEINFO_kindtypeLOGICAL2:
5501           error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5502                                ffebld_constant_logical2 (ffebld_conter (l)),
5503                               ffebld_constant_logical2 (ffebld_conter (r)));
5504           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5505                                         (ffebld_cu_val_logical2 (u)), expr);
5506           break;
5507 #endif
5508
5509 #if FFETARGET_okLOGICAL3
5510         case FFEINFO_kindtypeLOGICAL3:
5511           error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5512                                ffebld_constant_logical3 (ffebld_conter (l)),
5513                               ffebld_constant_logical3 (ffebld_conter (r)));
5514           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5515                                         (ffebld_cu_val_logical3 (u)), expr);
5516           break;
5517 #endif
5518
5519 #if FFETARGET_okLOGICAL4
5520         case FFEINFO_kindtypeLOGICAL4:
5521           error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5522                                ffebld_constant_logical4 (ffebld_conter (l)),
5523                               ffebld_constant_logical4 (ffebld_conter (r)));
5524           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5525                                         (ffebld_cu_val_logical4 (u)), expr);
5526           break;
5527 #endif
5528
5529         default:
5530           assert ("bad logical kind type" == NULL);
5531           break;
5532         }
5533       break;
5534
5535     default:
5536       assert ("bad type" == NULL);
5537       return expr;
5538     }
5539
5540   ffebld_set_info (expr, ffeinfo_new
5541                    (bt,
5542                     kt,
5543                     0,
5544                     FFEINFO_kindENTITY,
5545                     FFEINFO_whereCONSTANT,
5546                     FFETARGET_charactersizeNONE));
5547
5548   if ((error != FFEBAD)
5549       && ffebad_start (error))
5550     {
5551       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5552       ffebad_finish ();
5553     }
5554
5555   return expr;
5556 }
5557
5558 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5559
5560    ffebld expr;
5561    ffelexToken token;
5562    expr = ffeexpr_collapse_eqv(expr,token);
5563
5564    If the result of the expr is a constant, replaces the expr with the
5565    computed constant.  */
5566
5567 ffebld
5568 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5569 {
5570   ffebad error = FFEBAD;
5571   ffebld l;
5572   ffebld r;
5573   ffebldConstantUnion u;
5574   ffeinfoBasictype bt;
5575   ffeinfoKindtype kt;
5576
5577   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5578     return expr;
5579
5580   l = ffebld_left (expr);
5581   r = ffebld_right (expr);
5582
5583   if (ffebld_op (l) != FFEBLD_opCONTER)
5584     return expr;
5585   if (ffebld_op (r) != FFEBLD_opCONTER)
5586     return expr;
5587
5588   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5589     {
5590     case FFEINFO_basictypeANY:
5591       return expr;
5592
5593     case FFEINFO_basictypeINTEGER:
5594       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5595         {
5596 #if FFETARGET_okINTEGER1
5597         case FFEINFO_kindtypeINTEGER1:
5598           error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5599                                ffebld_constant_integer1 (ffebld_conter (l)),
5600                               ffebld_constant_integer1 (ffebld_conter (r)));
5601           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5602                                         (ffebld_cu_val_integer1 (u)), expr);
5603           break;
5604 #endif
5605
5606 #if FFETARGET_okINTEGER2
5607         case FFEINFO_kindtypeINTEGER2:
5608           error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5609                                ffebld_constant_integer2 (ffebld_conter (l)),
5610                               ffebld_constant_integer2 (ffebld_conter (r)));
5611           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5612                                         (ffebld_cu_val_integer2 (u)), expr);
5613           break;
5614 #endif
5615
5616 #if FFETARGET_okINTEGER3
5617         case FFEINFO_kindtypeINTEGER3:
5618           error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5619                                ffebld_constant_integer3 (ffebld_conter (l)),
5620                               ffebld_constant_integer3 (ffebld_conter (r)));
5621           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5622                                         (ffebld_cu_val_integer3 (u)), expr);
5623           break;
5624 #endif
5625
5626 #if FFETARGET_okINTEGER4
5627         case FFEINFO_kindtypeINTEGER4:
5628           error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5629                                ffebld_constant_integer4 (ffebld_conter (l)),
5630                               ffebld_constant_integer4 (ffebld_conter (r)));
5631           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5632                                         (ffebld_cu_val_integer4 (u)), expr);
5633           break;
5634 #endif
5635
5636         default:
5637           assert ("bad integer kind type" == NULL);
5638           break;
5639         }
5640       break;
5641
5642     case FFEINFO_basictypeLOGICAL:
5643       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5644         {
5645 #if FFETARGET_okLOGICAL1
5646         case FFEINFO_kindtypeLOGICAL1:
5647           error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5648                                ffebld_constant_logical1 (ffebld_conter (l)),
5649                               ffebld_constant_logical1 (ffebld_conter (r)));
5650           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5651                                         (ffebld_cu_val_logical1 (u)), expr);
5652           break;
5653 #endif
5654
5655 #if FFETARGET_okLOGICAL2
5656         case FFEINFO_kindtypeLOGICAL2:
5657           error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5658                                ffebld_constant_logical2 (ffebld_conter (l)),
5659                               ffebld_constant_logical2 (ffebld_conter (r)));
5660           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5661                                         (ffebld_cu_val_logical2 (u)), expr);
5662           break;
5663 #endif
5664
5665 #if FFETARGET_okLOGICAL3
5666         case FFEINFO_kindtypeLOGICAL3:
5667           error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5668                                ffebld_constant_logical3 (ffebld_conter (l)),
5669                               ffebld_constant_logical3 (ffebld_conter (r)));
5670           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5671                                         (ffebld_cu_val_logical3 (u)), expr);
5672           break;
5673 #endif
5674
5675 #if FFETARGET_okLOGICAL4
5676         case FFEINFO_kindtypeLOGICAL4:
5677           error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5678                                ffebld_constant_logical4 (ffebld_conter (l)),
5679                               ffebld_constant_logical4 (ffebld_conter (r)));
5680           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5681                                         (ffebld_cu_val_logical4 (u)), expr);
5682           break;
5683 #endif
5684
5685         default:
5686           assert ("bad logical kind type" == NULL);
5687           break;
5688         }
5689       break;
5690
5691     default:
5692       assert ("bad type" == NULL);
5693       return expr;
5694     }
5695
5696   ffebld_set_info (expr, ffeinfo_new
5697                    (bt,
5698                     kt,
5699                     0,
5700                     FFEINFO_kindENTITY,
5701                     FFEINFO_whereCONSTANT,
5702                     FFETARGET_charactersizeNONE));
5703
5704   if ((error != FFEBAD)
5705       && ffebad_start (error))
5706     {
5707       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5708       ffebad_finish ();
5709     }
5710
5711   return expr;
5712 }
5713
5714 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5715
5716    ffebld expr;
5717    ffelexToken token;
5718    expr = ffeexpr_collapse_neqv(expr,token);
5719
5720    If the result of the expr is a constant, replaces the expr with the
5721    computed constant.  */
5722
5723 ffebld
5724 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5725 {
5726   ffebad error = FFEBAD;
5727   ffebld l;
5728   ffebld r;
5729   ffebldConstantUnion u;
5730   ffeinfoBasictype bt;
5731   ffeinfoKindtype kt;
5732
5733   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5734     return expr;
5735
5736   l = ffebld_left (expr);
5737   r = ffebld_right (expr);
5738
5739   if (ffebld_op (l) != FFEBLD_opCONTER)
5740     return expr;
5741   if (ffebld_op (r) != FFEBLD_opCONTER)
5742     return expr;
5743
5744   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5745     {
5746     case FFEINFO_basictypeANY:
5747       return expr;
5748
5749     case FFEINFO_basictypeINTEGER:
5750       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5751         {
5752 #if FFETARGET_okINTEGER1
5753         case FFEINFO_kindtypeINTEGER1:
5754           error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5755                                ffebld_constant_integer1 (ffebld_conter (l)),
5756                               ffebld_constant_integer1 (ffebld_conter (r)));
5757           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5758                                         (ffebld_cu_val_integer1 (u)), expr);
5759           break;
5760 #endif
5761
5762 #if FFETARGET_okINTEGER2
5763         case FFEINFO_kindtypeINTEGER2:
5764           error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5765                                ffebld_constant_integer2 (ffebld_conter (l)),
5766                               ffebld_constant_integer2 (ffebld_conter (r)));
5767           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5768                                         (ffebld_cu_val_integer2 (u)), expr);
5769           break;
5770 #endif
5771
5772 #if FFETARGET_okINTEGER3
5773         case FFEINFO_kindtypeINTEGER3:
5774           error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5775                                ffebld_constant_integer3 (ffebld_conter (l)),
5776                               ffebld_constant_integer3 (ffebld_conter (r)));
5777           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5778                                         (ffebld_cu_val_integer3 (u)), expr);
5779           break;
5780 #endif
5781
5782 #if FFETARGET_okINTEGER4
5783         case FFEINFO_kindtypeINTEGER4:
5784           error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5785                                ffebld_constant_integer4 (ffebld_conter (l)),
5786                               ffebld_constant_integer4 (ffebld_conter (r)));
5787           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5788                                         (ffebld_cu_val_integer4 (u)), expr);
5789           break;
5790 #endif
5791
5792         default:
5793           assert ("bad integer kind type" == NULL);
5794           break;
5795         }
5796       break;
5797
5798     case FFEINFO_basictypeLOGICAL:
5799       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5800         {
5801 #if FFETARGET_okLOGICAL1
5802         case FFEINFO_kindtypeLOGICAL1:
5803           error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5804                                ffebld_constant_logical1 (ffebld_conter (l)),
5805                               ffebld_constant_logical1 (ffebld_conter (r)));
5806           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5807                                         (ffebld_cu_val_logical1 (u)), expr);
5808           break;
5809 #endif
5810
5811 #if FFETARGET_okLOGICAL2
5812         case FFEINFO_kindtypeLOGICAL2:
5813           error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5814                                ffebld_constant_logical2 (ffebld_conter (l)),
5815                               ffebld_constant_logical2 (ffebld_conter (r)));
5816           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5817                                         (ffebld_cu_val_logical2 (u)), expr);
5818           break;
5819 #endif
5820
5821 #if FFETARGET_okLOGICAL3
5822         case FFEINFO_kindtypeLOGICAL3:
5823           error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5824                                ffebld_constant_logical3 (ffebld_conter (l)),
5825                               ffebld_constant_logical3 (ffebld_conter (r)));
5826           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5827                                         (ffebld_cu_val_logical3 (u)), expr);
5828           break;
5829 #endif
5830
5831 #if FFETARGET_okLOGICAL4
5832         case FFEINFO_kindtypeLOGICAL4:
5833           error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5834                                ffebld_constant_logical4 (ffebld_conter (l)),
5835                               ffebld_constant_logical4 (ffebld_conter (r)));
5836           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5837                                         (ffebld_cu_val_logical4 (u)), expr);
5838           break;
5839 #endif
5840
5841         default:
5842           assert ("bad logical kind type" == NULL);
5843           break;
5844         }
5845       break;
5846
5847     default:
5848       assert ("bad type" == NULL);
5849       return expr;
5850     }
5851
5852   ffebld_set_info (expr, ffeinfo_new
5853                    (bt,
5854                     kt,
5855                     0,
5856                     FFEINFO_kindENTITY,
5857                     FFEINFO_whereCONSTANT,
5858                     FFETARGET_charactersizeNONE));
5859
5860   if ((error != FFEBAD)
5861       && ffebad_start (error))
5862     {
5863       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5864       ffebad_finish ();
5865     }
5866
5867   return expr;
5868 }
5869
5870 /* ffeexpr_collapse_symter -- Collapse symter expr
5871
5872    ffebld expr;
5873    ffelexToken token;
5874    expr = ffeexpr_collapse_symter(expr,token);
5875
5876    If the result of the expr is a constant, replaces the expr with the
5877    computed constant.  */
5878
5879 ffebld
5880 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5881 {
5882   ffebld r;
5883   ffeinfoBasictype bt;
5884   ffeinfoKindtype kt;
5885   ffetargetCharacterSize len;
5886
5887   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5888     return expr;
5889
5890   if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5891     return expr;                /* A PARAMETER lhs in progress. */
5892
5893   switch (ffebld_op (r))
5894     {
5895     case FFEBLD_opCONTER:
5896       break;
5897
5898     case FFEBLD_opANY:
5899       return r;
5900
5901     default:
5902       return expr;
5903     }
5904
5905   bt = ffeinfo_basictype (ffebld_info (r));
5906   kt = ffeinfo_kindtype (ffebld_info (r));
5907   len = ffebld_size (r);
5908
5909   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5910                                       expr);
5911
5912   ffebld_set_info (expr, ffeinfo_new
5913                    (bt,
5914                     kt,
5915                     0,
5916                     FFEINFO_kindENTITY,
5917                     FFEINFO_whereCONSTANT,
5918                     len));
5919
5920   return expr;
5921 }
5922
5923 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5924
5925    ffebld expr;
5926    ffelexToken token;
5927    expr = ffeexpr_collapse_funcref(expr,token);
5928
5929    If the result of the expr is a constant, replaces the expr with the
5930    computed constant.  */
5931
5932 ffebld
5933 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5934 {
5935   return expr;                  /* ~~someday go ahead and collapse these,
5936                                    though not required */
5937 }
5938
5939 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5940
5941    ffebld expr;
5942    ffelexToken token;
5943    expr = ffeexpr_collapse_arrayref(expr,token);
5944
5945    If the result of the expr is a constant, replaces the expr with the
5946    computed constant.  */
5947
5948 ffebld
5949 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5950 {
5951   return expr;
5952 }
5953
5954 /* ffeexpr_collapse_substr -- Collapse substr expr
5955
5956    ffebld expr;
5957    ffelexToken token;
5958    expr = ffeexpr_collapse_substr(expr,token);
5959
5960    If the result of the expr is a constant, replaces the expr with the
5961    computed constant.  */
5962
5963 ffebld
5964 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5965 {
5966   ffebad error = FFEBAD;
5967   ffebld l;
5968   ffebld r;
5969   ffebld start;
5970   ffebld stop;
5971   ffebldConstantUnion u;
5972   ffeinfoKindtype kt;
5973   ffetargetCharacterSize len;
5974   ffetargetIntegerDefault first;
5975   ffetargetIntegerDefault last;
5976
5977   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5978     return expr;
5979
5980   l = ffebld_left (expr);
5981   r = ffebld_right (expr);      /* opITEM. */
5982
5983   if (ffebld_op (l) != FFEBLD_opCONTER)
5984     return expr;
5985
5986   kt = ffeinfo_kindtype (ffebld_info (l));
5987   len = ffebld_size (l);
5988
5989   start = ffebld_head (r);
5990   stop = ffebld_head (ffebld_trail (r));
5991   if (start == NULL)
5992     first = 1;
5993   else
5994     {
5995       if ((ffebld_op (start) != FFEBLD_opCONTER)
5996           || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5997           || (ffeinfo_kindtype (ffebld_info (start))
5998               != FFEINFO_kindtypeINTEGERDEFAULT))
5999         return expr;
6000       first = ffebld_constant_integerdefault (ffebld_conter (start));
6001     }
6002   if (stop == NULL)
6003     last = len;
6004   else
6005     {
6006       if ((ffebld_op (stop) != FFEBLD_opCONTER)
6007       || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6008           || (ffeinfo_kindtype (ffebld_info (stop))
6009               != FFEINFO_kindtypeINTEGERDEFAULT))
6010         return expr;
6011       last = ffebld_constant_integerdefault (ffebld_conter (stop));
6012     }
6013
6014   /* Handle problems that should have already been diagnosed, but
6015      left in the expression tree.  */
6016
6017   if (first <= 0)
6018     first = 1;
6019   if (last < first)
6020     last = first + len - 1;
6021
6022   if ((first == 1) && (last == len))
6023     {                           /* Same as original. */
6024       expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6025                                           (ffebld_conter (l)), expr);
6026       ffebld_set_info (expr, ffeinfo_new
6027                        (FFEINFO_basictypeCHARACTER,
6028                         kt,
6029                         0,
6030                         FFEINFO_kindENTITY,
6031                         FFEINFO_whereCONSTANT,
6032                         len));
6033
6034       return expr;
6035     }
6036
6037   switch (ffeinfo_basictype (ffebld_info (expr)))
6038     {
6039     case FFEINFO_basictypeANY:
6040       return expr;
6041
6042     case FFEINFO_basictypeCHARACTER:
6043       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6044         {
6045 #if FFETARGET_okCHARACTER1
6046         case FFEINFO_kindtypeCHARACTER1:
6047           error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6048                 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6049                                    ffebld_constant_pool (), &len);
6050           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6051                                       (ffebld_cu_val_character1 (u)), expr);
6052           break;
6053 #endif
6054
6055         default:
6056           assert ("bad character kind type" == NULL);
6057           break;
6058         }
6059       break;
6060
6061     default:
6062       assert ("bad type" == NULL);
6063       return expr;
6064     }
6065
6066   ffebld_set_info (expr, ffeinfo_new
6067                    (FFEINFO_basictypeCHARACTER,
6068                     kt,
6069                     0,
6070                     FFEINFO_kindENTITY,
6071                     FFEINFO_whereCONSTANT,
6072                     len));
6073
6074   if ((error != FFEBAD)
6075       && ffebad_start (error))
6076     {
6077       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6078       ffebad_finish ();
6079     }
6080
6081   return expr;
6082 }
6083
6084 /* ffeexpr_convert -- Convert source expression to given type
6085
6086    ffebld source;
6087    ffelexToken source_token;
6088    ffelexToken dest_token;  // Any appropriate token for "destination".
6089    ffeinfoBasictype bt;
6090    ffeinfoKindtype kt;
6091    ffetargetCharactersize sz;
6092    ffeexprContext context;  // Mainly LET or DATA.
6093    source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6094
6095    If the expression conforms, returns the source expression.  Otherwise
6096    returns source wrapped in a convert node doing the conversion, or
6097    ANY wrapped in convert if there is a conversion error (and issues an
6098    error message).  Be sensitive to the context for certain aspects of
6099    the conversion.  */
6100
6101 ffebld
6102 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6103                  ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6104                  ffetargetCharacterSize sz, ffeexprContext context)
6105 {
6106   bool bad;
6107   ffeinfo info;
6108   ffeinfoWhere wh;
6109
6110   info = ffebld_info (source);
6111   if ((bt != ffeinfo_basictype (info))
6112       || (kt != ffeinfo_kindtype (info))
6113       || (rk != 0)              /* Can't convert from or to arrays yet. */
6114       || (ffeinfo_rank (info) != 0)
6115       || (sz != ffebld_size_known (source)))
6116 #if 0   /* Nobody seems to need this spurious CONVERT node. */
6117       || ((context != FFEEXPR_contextLET)
6118           && (bt == FFEINFO_basictypeCHARACTER)
6119           && (sz == FFETARGET_charactersizeNONE)))
6120 #endif
6121     {
6122       switch (ffeinfo_basictype (info))
6123         {
6124         case FFEINFO_basictypeLOGICAL:
6125           switch (bt)
6126             {
6127             case FFEINFO_basictypeLOGICAL:
6128               bad = FALSE;
6129               break;
6130
6131             case FFEINFO_basictypeINTEGER:
6132               bad = !ffe_is_ugly_logint ();
6133               break;
6134
6135             case FFEINFO_basictypeCHARACTER:
6136               bad = ffe_is_pedantic ()
6137                 || !(ffe_is_ugly_init ()
6138                      && (context == FFEEXPR_contextDATA));
6139               break;
6140
6141             default:
6142               bad = TRUE;
6143               break;
6144             }
6145           break;
6146
6147         case FFEINFO_basictypeINTEGER:
6148           switch (bt)
6149             {
6150             case FFEINFO_basictypeINTEGER:
6151             case FFEINFO_basictypeREAL:
6152             case FFEINFO_basictypeCOMPLEX:
6153               bad = FALSE;
6154               break;
6155
6156             case FFEINFO_basictypeLOGICAL:
6157               bad = !ffe_is_ugly_logint ();
6158               break;
6159
6160             case FFEINFO_basictypeCHARACTER:
6161               bad = ffe_is_pedantic ()
6162                 || !(ffe_is_ugly_init ()
6163                      && (context == FFEEXPR_contextDATA));
6164               break;
6165
6166             default:
6167               bad = TRUE;
6168               break;
6169             }
6170           break;
6171
6172         case FFEINFO_basictypeREAL:
6173         case FFEINFO_basictypeCOMPLEX:
6174           switch (bt)
6175             {
6176             case FFEINFO_basictypeINTEGER:
6177             case FFEINFO_basictypeREAL:
6178             case FFEINFO_basictypeCOMPLEX:
6179               bad = FALSE;
6180               break;
6181
6182             case FFEINFO_basictypeCHARACTER:
6183               bad = TRUE;
6184               break;
6185
6186             default:
6187               bad = TRUE;
6188               break;
6189             }
6190           break;
6191
6192         case FFEINFO_basictypeCHARACTER:
6193           bad = (bt != FFEINFO_basictypeCHARACTER)
6194             && (ffe_is_pedantic ()
6195                 || (bt != FFEINFO_basictypeINTEGER)
6196                 || !(ffe_is_ugly_init ()
6197                      && (context == FFEEXPR_contextDATA)));
6198           break;
6199
6200         case FFEINFO_basictypeTYPELESS:
6201         case FFEINFO_basictypeHOLLERITH:
6202           bad = ffe_is_pedantic ()
6203             || !(ffe_is_ugly_init ()
6204                  && ((context == FFEEXPR_contextDATA)
6205                      || (context == FFEEXPR_contextLET)));
6206           break;
6207
6208         default:
6209           bad = TRUE;
6210           break;
6211         }
6212
6213       if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6214         bad = TRUE;
6215
6216       if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6217           && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6218           && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6219           && (ffeinfo_where (info) != FFEINFO_whereANY))
6220         {
6221           if (ffebad_start (FFEBAD_BAD_TYPES))
6222             {
6223               if (dest_token == NULL)
6224                 ffebad_here (0, ffewhere_line_unknown (),
6225                              ffewhere_column_unknown ());
6226               else
6227                 ffebad_here (0, ffelex_token_where_line (dest_token),
6228                              ffelex_token_where_column (dest_token));
6229               assert (source_token != NULL);
6230               ffebad_here (1, ffelex_token_where_line (source_token),
6231                            ffelex_token_where_column (source_token));
6232               ffebad_finish ();
6233             }
6234
6235           source = ffebld_new_any ();
6236           ffebld_set_info (source, ffeinfo_new_any ());
6237         }
6238       else
6239         {
6240           switch (ffeinfo_where (info))
6241             {
6242             case FFEINFO_whereCONSTANT:
6243               wh = FFEINFO_whereCONSTANT;
6244               break;
6245
6246             case FFEINFO_whereIMMEDIATE:
6247               wh = FFEINFO_whereIMMEDIATE;
6248               break;
6249
6250             default:
6251               wh = FFEINFO_whereFLEETING;
6252               break;
6253             }
6254           source = ffebld_new_convert (source);
6255           ffebld_set_info (source, ffeinfo_new
6256                            (bt,
6257                             kt,
6258                             0,
6259                             FFEINFO_kindENTITY,
6260                             wh,
6261                             sz));
6262           source = ffeexpr_collapse_convert (source, source_token);
6263         }
6264     }
6265
6266   return source;
6267 }
6268
6269 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6270
6271    ffebld source;
6272    ffebld dest;
6273    ffelexToken source_token;
6274    ffelexToken dest_token;
6275    ffeexprContext context;
6276    source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6277
6278    If the expressions conform, returns the source expression.  Otherwise
6279    returns source wrapped in a convert node doing the conversion, or
6280    ANY wrapped in convert if there is a conversion error (and issues an
6281    error message).  Be sensitive to the context, such as LET or DATA.  */
6282
6283 ffebld
6284 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6285                       ffelexToken dest_token, ffeexprContext context)
6286 {
6287   ffeinfo info;
6288
6289   info = ffebld_info (dest);
6290   return ffeexpr_convert (source, source_token, dest_token,
6291                           ffeinfo_basictype (info),
6292                           ffeinfo_kindtype (info),
6293                           ffeinfo_rank (info),
6294                           ffebld_size_known (dest),
6295                           context);
6296 }
6297
6298 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6299
6300    ffebld source;
6301    ffesymbol dest;
6302    ffelexToken source_token;
6303    ffelexToken dest_token;
6304    source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6305
6306    If the expressions conform, returns the source expression.  Otherwise
6307    returns source wrapped in a convert node doing the conversion, or
6308    ANY wrapped in convert if there is a conversion error (and issues an
6309    error message).  */
6310
6311 ffebld
6312 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6313                         ffesymbol dest, ffelexToken dest_token)
6314 {
6315   return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6316     ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6317                           FFEEXPR_contextLET);
6318 }
6319
6320 /* Initializes the module.  */
6321
6322 void
6323 ffeexpr_init_2 (void)
6324 {
6325   ffeexpr_stack_ = NULL;
6326   ffeexpr_level_ = 0;
6327 }
6328
6329 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6330
6331    Prepares cluster for delivery of lexer tokens representing an expression
6332    in a left-hand-side context (A in A=B, for example).  ffebld is used
6333    to build expressions in the given pool.  The appropriate lexer-token
6334    handling routine within ffeexpr is returned.  When the end of the
6335    expression is detected, mycallbackroutine is called with the resulting
6336    single ffebld object specifying the entire expression and the first
6337    lexer token that is not considered part of the expression.  This caller-
6338    supplied routine itself returns a lexer-token handling routine.  Thus,
6339    if necessary, ffeexpr can return several tokens as end-of-expression
6340    tokens if it needs to scan forward more than one in any instance.  */
6341
6342 ffelexHandler
6343 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6344 {
6345   ffeexprStack_ s;
6346
6347   ffebld_pool_push (pool);
6348   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6349   s->previous = ffeexpr_stack_;
6350   s->pool = pool;
6351   s->context = context;
6352   s->callback = callback;
6353   s->first_token = NULL;
6354   s->exprstack = NULL;
6355   s->is_rhs = FALSE;
6356   ffeexpr_stack_ = s;
6357   return (ffelexHandler) ffeexpr_token_first_lhs_;
6358 }
6359
6360 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6361
6362    return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
6363
6364    Prepares cluster for delivery of lexer tokens representing an expression
6365    in a right-hand-side context (B in A=B, for example).  ffebld is used
6366    to build expressions in the given pool.  The appropriate lexer-token
6367    handling routine within ffeexpr is returned.  When the end of the
6368    expression is detected, mycallbackroutine is called with the resulting
6369    single ffebld object specifying the entire expression and the first
6370    lexer token that is not considered part of the expression.  This caller-
6371    supplied routine itself returns a lexer-token handling routine.  Thus,
6372    if necessary, ffeexpr can return several tokens as end-of-expression
6373    tokens if it needs to scan forward more than one in any instance.  */
6374
6375 ffelexHandler
6376 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6377 {
6378   ffeexprStack_ s;
6379
6380   ffebld_pool_push (pool);
6381   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6382   s->previous = ffeexpr_stack_;
6383   s->pool = pool;
6384   s->context = context;
6385   s->callback = callback;
6386   s->first_token = NULL;
6387   s->exprstack = NULL;
6388   s->is_rhs = TRUE;
6389   ffeexpr_stack_ = s;
6390   return (ffelexHandler) ffeexpr_token_first_rhs_;
6391 }
6392
6393 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6394
6395    Pass it to ffeexpr_rhs as the callback routine.
6396
6397    Makes sure the end token is close-paren and swallows it, else issues
6398    an error message and doesn't swallow the token (passing it along instead).
6399    In either case wraps up subexpression construction by enclosing the
6400    ffebld expression in a paren.  */
6401
6402 static ffelexHandler
6403 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6404 {
6405   ffeexprExpr_ e;
6406
6407   if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6408     {
6409       /* Oops, naughty user didn't specify the close paren! */
6410
6411       if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6412         {
6413           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6414           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6415                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6416           ffebad_finish ();
6417         }
6418
6419       e = ffeexpr_expr_new_ ();
6420       e->type = FFEEXPR_exprtypeOPERAND_;
6421       e->u.operand = ffebld_new_any ();
6422       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6423       ffeexpr_exprstack_push_operand_ (e);
6424
6425       return
6426         (ffelexHandler) ffeexpr_find_close_paren_ (t,
6427                                                    (ffelexHandler)
6428                                                    ffeexpr_token_binary_);
6429     }
6430
6431   if (expr->op == FFEBLD_opIMPDO)
6432     {
6433       if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6434         {
6435           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6436                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6437           ffebad_finish ();
6438         }
6439     }
6440   else
6441     {
6442       expr = ffebld_new_paren (expr);
6443       ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6444     }
6445
6446   /* Now push the (parenthesized) expression as an operand onto the
6447      expression stack. */
6448
6449   e = ffeexpr_expr_new_ ();
6450   e->type = FFEEXPR_exprtypeOPERAND_;
6451   e->u.operand = expr;
6452   e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6453   e->token = ffeexpr_stack_->tokens[0];
6454   ffeexpr_exprstack_push_operand_ (e);
6455
6456   return (ffelexHandler) ffeexpr_token_binary_;
6457 }
6458
6459 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6460
6461    Pass it to ffeexpr_rhs as the callback routine.
6462
6463    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6464    with the next token in t.  If the next token is possibly a binary
6465    operator, continue processing the outer expression.  If the next
6466    token is COMMA, then the expression is a unit specifier, and
6467    parentheses should not be added to it because it surrounds the
6468    I/O control list that starts with the unit specifier (and continues
6469    on from here -- we haven't seen the CLOSE_PAREN that matches the
6470    OPEN_PAREN, it is up to the callback function to expect to see it
6471    at some point).  In this case, we notify the callback function that
6472    the COMMA is inside, not outside, the parens by wrapping the expression
6473    in an opITEM (with a NULL trail) -- the callback function presumably
6474    unwraps it after seeing this kludgey indicator.
6475
6476    If the next token is CLOSE_PAREN, then we go to the _1_ state to
6477    decide what to do with the token after that.
6478
6479    15-Feb-91  JCB  1.1
6480       Use an extra state for the CLOSE_PAREN case to make READ &co really
6481       work right.  */
6482
6483 static ffelexHandler
6484 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6485 {
6486   ffeexprCallback callback;
6487   ffeexprStack_ s;
6488
6489   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6490     {                           /* Need to see the next token before we
6491                                    decide anything. */
6492       ffeexpr_stack_->expr = expr;
6493       ffeexpr_tokens_[0] = ffelex_token_use (ft);
6494       ffeexpr_tokens_[1] = ffelex_token_use (t);
6495       return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6496     }
6497
6498   expr = ffeexpr_finished_ambig_ (ft, expr);
6499
6500   /* Let the callback function handle the case where t isn't COMMA. */
6501
6502   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6503      that preceded the expression starts a list of expressions, and the expr
6504      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6505      node.  The callback function should extract the real expr from the head
6506      of this opITEM node after testing it. */
6507
6508   expr = ffebld_new_item (expr, NULL);
6509
6510   ffebld_pool_pop ();
6511   callback = ffeexpr_stack_->callback;
6512   ffelex_token_kill (ffeexpr_stack_->first_token);
6513   s = ffeexpr_stack_->previous;
6514   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6515   ffeexpr_stack_ = s;
6516   return (ffelexHandler) (*callback) (ft, expr, t);
6517 }
6518
6519 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6520
6521    See ffeexpr_cb_close_paren_ambig_.
6522
6523    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6524    with the next token in t.  If the next token is possibly a binary
6525    operator, continue processing the outer expression.  If the next
6526    token is COMMA, the expression is a parenthesized format specifier.
6527    If the next token is not EOS or SEMICOLON, then because it is not a
6528    binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6529    a unit specifier, and parentheses should not be added to it because
6530    they surround the I/O control list that consists of only the unit
6531    specifier.  If the next token is EOS or SEMICOLON, the statement
6532    must be disambiguated by looking at the type of the expression -- a
6533    character expression is a parenthesized format specifier, while a
6534    non-character expression is a unit specifier.
6535
6536    Another issue is how to do the callback so the recipient of the
6537    next token knows how to handle it if it is a COMMA.  In all other
6538    cases, disambiguation is straightforward: the same approach as the
6539    above is used.
6540
6541    EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6542    as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6543    and apparently other compilers do, as well, and some code out there
6544    uses this "feature".
6545
6546    19-Feb-91  JCB  1.1
6547       Extend to allow COMMA as nondisambiguating by itself.  Remember
6548       to not try and check info field for opSTAR, since that expr doesn't
6549       have a valid info field.  */
6550
6551 static ffelexHandler
6552 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6553 {
6554   ffeexprCallback callback;
6555   ffeexprStack_ s;
6556   ffelexHandler next;
6557   ffelexToken orig_ft = ffeexpr_tokens_[0];     /* In case callback clobbers
6558                                                    these. */
6559   ffelexToken orig_t = ffeexpr_tokens_[1];
6560   ffebld expr = ffeexpr_stack_->expr;
6561
6562   switch (ffelex_token_type (t))
6563     {
6564     case FFELEX_typeCOMMA:      /* Subexpr is parenthesized format specifier. */
6565       if (ffe_is_pedantic ())
6566         goto pedantic_comma;    /* :::::::::::::::::::: */
6567       /* Fall through. */
6568     case FFELEX_typeEOS:        /* Ambiguous; use type of expr to
6569                                    disambiguate. */
6570     case FFELEX_typeSEMICOLON:
6571       if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6572           || (ffebld_op (expr) == FFEBLD_opSTAR)
6573           || (ffeinfo_basictype (ffebld_info (expr))
6574               != FFEINFO_basictypeCHARACTER))
6575         break;                  /* Not a valid CHARACTER entity, can't be a
6576                                    format spec. */
6577       /* Fall through. */
6578     default:                    /* Binary op (we assume; error otherwise);
6579                                    format specifier. */
6580
6581     pedantic_comma:             /* :::::::::::::::::::: */
6582
6583       switch (ffeexpr_stack_->context)
6584         {
6585         case FFEEXPR_contextFILENUMAMBIG:
6586           ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6587           break;
6588
6589         case FFEEXPR_contextFILEUNITAMBIG:
6590           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6591           break;
6592
6593         default:
6594           assert ("bad context" == NULL);
6595           break;
6596         }
6597
6598       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6599       next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6600       ffelex_token_kill (orig_ft);
6601       ffelex_token_kill (orig_t);
6602       return (ffelexHandler) (*next) (t);
6603
6604     case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6605     case FFELEX_typeNAME:
6606       break;
6607     }
6608
6609   expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6610
6611   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6612      that preceded the expression starts a list of expressions, and the expr
6613      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6614      node.  The callback function should extract the real expr from the head
6615      of this opITEM node after testing it. */
6616
6617   expr = ffebld_new_item (expr, NULL);
6618
6619   ffebld_pool_pop ();
6620   callback = ffeexpr_stack_->callback;
6621   ffelex_token_kill (ffeexpr_stack_->first_token);
6622   s = ffeexpr_stack_->previous;
6623   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6624   ffeexpr_stack_ = s;
6625   next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6626   ffelex_token_kill (orig_ft);
6627   ffelex_token_kill (orig_t);
6628   return (ffelexHandler) (*next) (t);
6629 }
6630
6631 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6632
6633    Pass it to ffeexpr_rhs as the callback routine.
6634
6635    Makes sure the end token is close-paren and swallows it, or a comma
6636    and handles complex/implied-do possibilities, else issues
6637    an error message and doesn't swallow the token (passing it along instead).  */
6638
6639 static ffelexHandler
6640 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6641 {
6642   /* First check to see if this is a possible complex entity.  It is if the
6643      token is a comma. */
6644
6645   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6646     {
6647       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6648       ffeexpr_stack_->expr = expr;
6649       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6650                                 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6651     }
6652
6653   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6654 }
6655
6656 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6657
6658    Pass it to ffeexpr_rhs as the callback routine.
6659
6660    If this token is not a comma, we have a complex constant (or an attempt
6661    at one), so handle it accordingly, displaying error messages if the token
6662    is not a close-paren.  */
6663
6664 static ffelexHandler
6665 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6666 {
6667   ffeexprExpr_ e;
6668   ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6669     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6670   ffeinfoBasictype rty = (expr == NULL)
6671     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6672   ffeinfoKindtype lkt;
6673   ffeinfoKindtype rkt;
6674   ffeinfoKindtype nkt;
6675   bool ok = TRUE;
6676   ffebld orig;
6677
6678   if ((ffeexpr_stack_->expr == NULL)
6679       || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6680       || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6681           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6682                && (ffebld_op (orig) != FFEBLD_opUPLUS))
6683               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6684       || ((lty != FFEINFO_basictypeINTEGER)
6685           && (lty != FFEINFO_basictypeREAL)))
6686     {
6687       if ((lty != FFEINFO_basictypeANY)
6688           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6689         {
6690           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6691                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6692           ffebad_string ("Real");
6693           ffebad_finish ();
6694         }
6695       ok = FALSE;
6696     }
6697   if ((expr == NULL)
6698       || (ffebld_op (expr) != FFEBLD_opCONTER)
6699       || (((orig = ffebld_conter_orig (expr)) != NULL)
6700           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6701                && (ffebld_op (orig) != FFEBLD_opUPLUS))
6702               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6703       || ((rty != FFEINFO_basictypeINTEGER)
6704           && (rty != FFEINFO_basictypeREAL)))
6705     {
6706       if ((rty != FFEINFO_basictypeANY)
6707           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6708         {
6709           ffebad_here (0, ffelex_token_where_line (ft),
6710                        ffelex_token_where_column (ft));
6711           ffebad_string ("Imaginary");
6712           ffebad_finish ();
6713         }
6714       ok = FALSE;
6715     }
6716
6717   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6718
6719   /* Push the (parenthesized) expression as an operand onto the expression
6720      stack. */
6721
6722   e = ffeexpr_expr_new_ ();
6723   e->type = FFEEXPR_exprtypeOPERAND_;
6724   e->token = ffeexpr_stack_->tokens[0];
6725
6726   if (ok)
6727     {
6728       if (lty == FFEINFO_basictypeINTEGER)
6729         lkt = FFEINFO_kindtypeREALDEFAULT;
6730       else
6731         lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6732       if (rty == FFEINFO_basictypeINTEGER)
6733         rkt = FFEINFO_kindtypeREALDEFAULT;
6734       else
6735         rkt = ffeinfo_kindtype (ffebld_info (expr));
6736
6737       nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6738       ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6739                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6740                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6741                                               FFEEXPR_contextLET);
6742       expr = ffeexpr_convert (expr,
6743                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6744                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6745                               FFEEXPR_contextLET);
6746     }
6747   else
6748     nkt = FFEINFO_kindtypeANY;
6749
6750   switch (nkt)
6751     {
6752 #if FFETARGET_okCOMPLEX1
6753     case FFEINFO_kindtypeREAL1:
6754       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6755               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6756       ffebld_set_info (e->u.operand,
6757                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6758                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6759                                     FFETARGET_charactersizeNONE));
6760       break;
6761 #endif
6762
6763 #if FFETARGET_okCOMPLEX2
6764     case FFEINFO_kindtypeREAL2:
6765       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6766               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6767       ffebld_set_info (e->u.operand,
6768                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6769                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6770                                     FFETARGET_charactersizeNONE));
6771       break;
6772 #endif
6773
6774 #if FFETARGET_okCOMPLEX3
6775     case FFEINFO_kindtypeREAL3:
6776       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6777               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6778       ffebld_set_info (e->u.operand,
6779                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6780                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6781                                     FFETARGET_charactersizeNONE));
6782       break;
6783 #endif
6784
6785     default:
6786       if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6787                         ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6788         {
6789           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6790                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6791           ffebad_finish ();
6792         }
6793       /* Fall through. */
6794     case FFEINFO_kindtypeANY:
6795       e->u.operand = ffebld_new_any ();
6796       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6797       break;
6798     }
6799   ffeexpr_exprstack_push_operand_ (e);
6800
6801   /* Now, if the token is a close parenthese, we're in great shape so return
6802      the next handler. */
6803
6804   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6805     return (ffelexHandler) ffeexpr_token_binary_;
6806
6807   /* Oops, naughty user didn't specify the close paren! */
6808
6809   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6810     {
6811       ffebad_here (0, ffelex_token_where_line (t),
6812                    ffelex_token_where_column (t));
6813       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6814                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6815       ffebad_finish ();
6816     }
6817
6818   return
6819     (ffelexHandler) ffeexpr_find_close_paren_ (t,
6820                                                (ffelexHandler)
6821                                                ffeexpr_token_binary_);
6822 }
6823
6824 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6825                                     implied-DO construct)
6826
6827    Pass it to ffeexpr_rhs as the callback routine.
6828
6829    Makes sure the end token is close-paren and swallows it, or a comma
6830    and handles complex/implied-do possibilities, else issues
6831    an error message and doesn't swallow the token (passing it along instead).  */
6832
6833 static ffelexHandler
6834 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6835 {
6836   ffeexprContext ctx;
6837
6838   /* First check to see if this is a possible complex or implied-DO entity.
6839      It is if the token is a comma. */
6840
6841   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6842     {
6843       switch (ffeexpr_stack_->context)
6844         {
6845         case FFEEXPR_contextIOLIST:
6846         case FFEEXPR_contextIMPDOITEM_:
6847           ctx = FFEEXPR_contextIMPDOITEM_;
6848           break;
6849
6850         case FFEEXPR_contextIOLISTDF:
6851         case FFEEXPR_contextIMPDOITEMDF_:
6852           ctx = FFEEXPR_contextIMPDOITEMDF_;
6853           break;
6854
6855         default:
6856           assert ("bad context" == NULL);
6857           ctx = FFEEXPR_contextIMPDOITEM_;
6858           break;
6859         }
6860
6861       ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6862       ffeexpr_stack_->expr = expr;
6863       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6864                                           ctx, ffeexpr_cb_comma_ci_);
6865     }
6866
6867   ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6868   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6869 }
6870
6871 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6872
6873    Pass it to ffeexpr_rhs as the callback routine.
6874
6875    If this token is not a comma, we have a complex constant (or an attempt
6876    at one), so handle it accordingly, displaying error messages if the token
6877    is not a close-paren.  If we have a comma here, it is an attempt at an
6878    implied-DO, so start making a list accordingly.  Oh, it might be an
6879    equal sign also, meaning an implied-DO with only one item in its list.  */
6880
6881 static ffelexHandler
6882 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6883 {
6884   ffebld fexpr;
6885
6886   /* First check to see if this is a possible complex constant.  It is if the
6887      token is not a comma or an equals sign, in which case it should be a
6888      close-paren. */
6889
6890   if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6891       && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6892     {
6893       ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6894       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6895       return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6896     }
6897
6898   /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6899      construct.  Make a list and handle accordingly. */
6900
6901   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6902   fexpr = ffeexpr_stack_->expr;
6903   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6904   ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6905   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6906 }
6907
6908 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6909
6910    Pass it to ffeexpr_rhs as the callback routine.
6911
6912    Handle first item in an implied-DO construct.  */
6913
6914 static ffelexHandler
6915 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6916 {
6917   if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6918     {
6919       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6920         {
6921           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6922           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6923                    ffelex_token_where_column (ffeexpr_stack_->first_token));
6924           ffebad_finish ();
6925         }
6926       ffebld_end_list (&ffeexpr_stack_->bottom);
6927       ffeexpr_stack_->expr = ffebld_new_any ();
6928       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6929       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6930         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6931       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6932     }
6933
6934   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6935 }
6936
6937 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6938
6939    Pass it to ffeexpr_rhs as the callback routine.
6940
6941    Handle first item in an implied-DO construct.  */
6942
6943 static ffelexHandler
6944 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6945 {
6946   ffeexprContext ctxi;
6947   ffeexprContext ctxc;
6948
6949   switch (ffeexpr_stack_->context)
6950     {
6951     case FFEEXPR_contextDATA:
6952     case FFEEXPR_contextDATAIMPDOITEM_:
6953       ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6954       ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6955       break;
6956
6957     case FFEEXPR_contextIOLIST:
6958     case FFEEXPR_contextIMPDOITEM_:
6959       ctxi = FFEEXPR_contextIMPDOITEM_;
6960       ctxc = FFEEXPR_contextIMPDOCTRL_;
6961       break;
6962
6963     case FFEEXPR_contextIOLISTDF:
6964     case FFEEXPR_contextIMPDOITEMDF_:
6965       ctxi = FFEEXPR_contextIMPDOITEMDF_;
6966       ctxc = FFEEXPR_contextIMPDOCTRL_;
6967       break;
6968
6969     default:
6970       assert ("bad context" == NULL);
6971       ctxi = FFEEXPR_context;
6972       ctxc = FFEEXPR_context;
6973       break;
6974     }
6975
6976   switch (ffelex_token_type (t))
6977     {
6978     case FFELEX_typeCOMMA:
6979       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6980       if (ffeexpr_stack_->is_rhs)
6981         return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6982                                             ctxi, ffeexpr_cb_comma_i_1_);
6983       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6984                                           ctxi, ffeexpr_cb_comma_i_1_);
6985
6986     case FFELEX_typeEQUALS:
6987       ffebld_end_list (&ffeexpr_stack_->bottom);
6988
6989       /* Complain if implied-DO variable in list of items to be read.  */
6990
6991       if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6992         ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6993                               ffeexpr_stack_->first_token, expr, ft);
6994
6995       /* Set doiter flag for all appropriate SYMTERs.  */
6996
6997       ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6998
6999       ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7000       ffebld_set_info (ffeexpr_stack_->expr,
7001                        ffeinfo_new (FFEINFO_basictypeNONE,
7002                                     FFEINFO_kindtypeNONE,
7003                                     0,
7004                                     FFEINFO_kindNONE,
7005                                     FFEINFO_whereNONE,
7006                                     FFETARGET_charactersizeNONE));
7007       ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7008                         &ffeexpr_stack_->bottom);
7009       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7010       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7011                                           ctxc, ffeexpr_cb_comma_i_2_);
7012
7013     default:
7014       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7015         {
7016           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7017           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7018                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7019           ffebad_finish ();
7020         }
7021       ffebld_end_list (&ffeexpr_stack_->bottom);
7022       ffeexpr_stack_->expr = ffebld_new_any ();
7023       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7024       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7025         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7026       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7027     }
7028 }
7029
7030 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7031
7032    Pass it to ffeexpr_rhs as the callback routine.
7033
7034    Handle start-value in an implied-DO construct.  */
7035
7036 static ffelexHandler
7037 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7038 {
7039   ffeexprContext ctx;
7040
7041   switch (ffeexpr_stack_->context)
7042     {
7043     case FFEEXPR_contextDATA:
7044     case FFEEXPR_contextDATAIMPDOITEM_:
7045       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7046       break;
7047
7048     case FFEEXPR_contextIOLIST:
7049     case FFEEXPR_contextIOLISTDF:
7050     case FFEEXPR_contextIMPDOITEM_:
7051     case FFEEXPR_contextIMPDOITEMDF_:
7052       ctx = FFEEXPR_contextIMPDOCTRL_;
7053       break;
7054
7055     default:
7056       assert ("bad context" == NULL);
7057       ctx = FFEEXPR_context;
7058       break;
7059     }
7060
7061   switch (ffelex_token_type (t))
7062     {
7063     case FFELEX_typeCOMMA:
7064       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7065       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7066                                           ctx, ffeexpr_cb_comma_i_3_);
7067       break;
7068
7069     default:
7070       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7071         {
7072           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7073           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7074                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7075           ffebad_finish ();
7076         }
7077       ffebld_end_list (&ffeexpr_stack_->bottom);
7078       ffeexpr_stack_->expr = ffebld_new_any ();
7079       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7080       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7081         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7082       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7083     }
7084 }
7085
7086 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7087
7088    Pass it to ffeexpr_rhs as the callback routine.
7089
7090    Handle end-value in an implied-DO construct.  */
7091
7092 static ffelexHandler
7093 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7094 {
7095   ffeexprContext ctx;
7096
7097   switch (ffeexpr_stack_->context)
7098     {
7099     case FFEEXPR_contextDATA:
7100     case FFEEXPR_contextDATAIMPDOITEM_:
7101       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7102       break;
7103
7104     case FFEEXPR_contextIOLIST:
7105     case FFEEXPR_contextIOLISTDF:
7106     case FFEEXPR_contextIMPDOITEM_:
7107     case FFEEXPR_contextIMPDOITEMDF_:
7108       ctx = FFEEXPR_contextIMPDOCTRL_;
7109       break;
7110
7111     default:
7112       assert ("bad context" == NULL);
7113       ctx = FFEEXPR_context;
7114       break;
7115     }
7116
7117   switch (ffelex_token_type (t))
7118     {
7119     case FFELEX_typeCOMMA:
7120       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7121       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7122                                           ctx, ffeexpr_cb_comma_i_4_);
7123       break;
7124
7125     case FFELEX_typeCLOSE_PAREN:
7126       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7127       return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7128       break;
7129
7130     default:
7131       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7132         {
7133           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7134           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7135                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7136           ffebad_finish ();
7137         }
7138       ffebld_end_list (&ffeexpr_stack_->bottom);
7139       ffeexpr_stack_->expr = ffebld_new_any ();
7140       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7141       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7142         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7143       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7144     }
7145 }
7146
7147 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7148                                [COMMA expr]
7149
7150    Pass it to ffeexpr_rhs as the callback routine.
7151
7152    Handle incr-value in an implied-DO construct.  */
7153
7154 static ffelexHandler
7155 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7156 {
7157   switch (ffelex_token_type (t))
7158     {
7159     case FFELEX_typeCLOSE_PAREN:
7160       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7161       ffebld_end_list (&ffeexpr_stack_->bottom);
7162       {
7163         ffebld item;
7164
7165         for (item = ffebld_left (ffeexpr_stack_->expr);
7166              item != NULL;
7167              item = ffebld_trail (item))
7168           if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7169             goto replace_with_any;      /* :::::::::::::::::::: */
7170
7171         for (item = ffebld_right (ffeexpr_stack_->expr);
7172              item != NULL;
7173              item = ffebld_trail (item))
7174           if ((ffebld_head (item) != NULL)      /* Increment may be NULL. */
7175               && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7176             goto replace_with_any;      /* :::::::::::::::::::: */
7177       }
7178       break;
7179
7180     default:
7181       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7182         {
7183           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7184           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7185                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7186           ffebad_finish ();
7187         }
7188       ffebld_end_list (&ffeexpr_stack_->bottom);
7189
7190     replace_with_any:           /* :::::::::::::::::::: */
7191
7192       ffeexpr_stack_->expr = ffebld_new_any ();
7193       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7194       break;
7195     }
7196
7197   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7198     return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7199   return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7200 }
7201
7202 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7203                                [COMMA expr] CLOSE_PAREN
7204
7205    Pass it to ffeexpr_rhs as the callback routine.
7206
7207    Collects token following implied-DO construct for callback function.  */
7208
7209 static ffelexHandler
7210 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7211 {
7212   ffeexprCallback callback;
7213   ffeexprStack_ s;
7214   ffelexHandler next;
7215   ffelexToken ft;
7216   ffebld expr;
7217   bool terminate;
7218
7219   switch (ffeexpr_stack_->context)
7220     {
7221     case FFEEXPR_contextDATA:
7222     case FFEEXPR_contextDATAIMPDOITEM_:
7223       terminate = TRUE;
7224       break;
7225
7226     case FFEEXPR_contextIOLIST:
7227     case FFEEXPR_contextIOLISTDF:
7228     case FFEEXPR_contextIMPDOITEM_:
7229     case FFEEXPR_contextIMPDOITEMDF_:
7230       terminate = FALSE;
7231       break;
7232
7233     default:
7234       assert ("bad context" == NULL);
7235       terminate = FALSE;
7236       break;
7237     }
7238
7239   ffebld_pool_pop ();
7240   callback = ffeexpr_stack_->callback;
7241   ft = ffeexpr_stack_->first_token;
7242   expr = ffeexpr_stack_->expr;
7243   s = ffeexpr_stack_->previous;
7244   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7245                   sizeof (*ffeexpr_stack_));
7246   ffeexpr_stack_ = s;
7247   next = (ffelexHandler) (*callback) (ft, expr, t);
7248   ffelex_token_kill (ft);
7249   if (terminate)
7250     {
7251       ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7252       --ffeexpr_level_;
7253       if (ffeexpr_level_ == 0)
7254         ffe_terminate_4 ();
7255     }
7256   return (ffelexHandler) next;
7257 }
7258
7259 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7260
7261    Makes sure the end token is close-paren and swallows it, else issues
7262    an error message and doesn't swallow the token (passing it along instead).
7263    In either case wraps up subexpression construction by enclosing the
7264    ffebld expression in a %LOC.  */
7265
7266 static ffelexHandler
7267 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7268 {
7269   ffeexprExpr_ e;
7270
7271   /* First push the (%LOC) expression as an operand onto the expression
7272      stack. */
7273
7274   e = ffeexpr_expr_new_ ();
7275   e->type = FFEEXPR_exprtypeOPERAND_;
7276   e->token = ffeexpr_stack_->tokens[0];
7277   e->u.operand = ffebld_new_percent_loc (expr);
7278   ffebld_set_info (e->u.operand,
7279                    ffeinfo_new (FFEINFO_basictypeINTEGER,
7280                                 ffecom_pointer_kind (),
7281                                 0,
7282                                 FFEINFO_kindENTITY,
7283                                 FFEINFO_whereFLEETING,
7284                                 FFETARGET_charactersizeNONE));
7285 #if 0                           /* ~~ */
7286   e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7287 #endif
7288   ffeexpr_exprstack_push_operand_ (e);
7289
7290   /* Now, if the token is a close parenthese, we're in great shape so return
7291      the next handler. */
7292
7293   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7294     {
7295       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7296       return (ffelexHandler) ffeexpr_token_binary_;
7297     }
7298
7299   /* Oops, naughty user didn't specify the close paren! */
7300
7301   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7302     {
7303       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7304       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7305                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7306       ffebad_finish ();
7307     }
7308
7309   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7310   return
7311     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7312                                                (ffelexHandler)
7313                                                ffeexpr_token_binary_);
7314 }
7315
7316 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7317
7318    Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
7319
7320 static ffelexHandler
7321 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7322 {
7323   ffeexprExpr_ e;
7324   ffebldOp op;
7325
7326   /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7327      such things until the lowest-level expression is reached.  */
7328
7329   op = ffebld_op (expr);
7330   if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7331       || (op == FFEBLD_opPERCENT_DESCR))
7332     {
7333       if (ffebad_start (FFEBAD_NESTED_PERCENT))
7334         {
7335           ffebad_here (0, ffelex_token_where_line (ft),
7336                        ffelex_token_where_column (ft));
7337           ffebad_finish ();
7338         }
7339
7340       do
7341         {
7342           expr = ffebld_left (expr);
7343           op = ffebld_op (expr);
7344         }
7345       while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7346              || (op == FFEBLD_opPERCENT_DESCR));
7347     }
7348
7349   /* Push the expression as an operand onto the expression stack. */
7350
7351   e = ffeexpr_expr_new_ ();
7352   e->type = FFEEXPR_exprtypeOPERAND_;
7353   e->token = ffeexpr_stack_->tokens[0];
7354   switch (ffeexpr_stack_->percent)
7355     {
7356     case FFEEXPR_percentVAL_:
7357       e->u.operand = ffebld_new_percent_val (expr);
7358       break;
7359
7360     case FFEEXPR_percentREF_:
7361       e->u.operand = ffebld_new_percent_ref (expr);
7362       break;
7363
7364     case FFEEXPR_percentDESCR_:
7365       e->u.operand = ffebld_new_percent_descr (expr);
7366       break;
7367
7368     default:
7369       assert ("%lossage" == NULL);
7370       e->u.operand = expr;
7371       break;
7372     }
7373   ffebld_set_info (e->u.operand, ffebld_info (expr));
7374 #if 0                           /* ~~ */
7375   e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7376 #endif
7377   ffeexpr_exprstack_push_operand_ (e);
7378
7379   /* Now, if the token is a close parenthese, we're in great shape so return
7380      the next handler. */
7381
7382   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7383     return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7384
7385   /* Oops, naughty user didn't specify the close paren! */
7386
7387   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7388     {
7389       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7390       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7391                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7392       ffebad_finish ();
7393     }
7394
7395   ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7396
7397   switch (ffeexpr_stack_->context)
7398     {
7399     case FFEEXPR_contextACTUALARG_:
7400       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7401       break;
7402
7403     case FFEEXPR_contextINDEXORACTUALARG_:
7404       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7405       break;
7406
7407     case FFEEXPR_contextSFUNCDEFACTUALARG_:
7408       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7409       break;
7410
7411     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7412       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7413       break;
7414
7415     default:
7416       assert ("bad context?!?!" == NULL);
7417       break;
7418     }
7419
7420   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7421   return
7422     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7423                                                (ffelexHandler)
7424                                                ffeexpr_cb_end_notloc_1_);
7425 }
7426
7427 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7428    CLOSE_PAREN
7429
7430    Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
7431
7432 static ffelexHandler
7433 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7434 {
7435   switch (ffelex_token_type (t))
7436     {
7437     case FFELEX_typeCOMMA:
7438     case FFELEX_typeCLOSE_PAREN:
7439       switch (ffeexpr_stack_->context)
7440         {
7441         case FFEEXPR_contextACTUALARG_:
7442         case FFEEXPR_contextSFUNCDEFACTUALARG_:
7443           break;
7444
7445         case FFEEXPR_contextINDEXORACTUALARG_:
7446           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7447           break;
7448
7449         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7450           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7451           break;
7452
7453         default:
7454           assert ("bad context?!?!" == NULL);
7455           break;
7456         }
7457       break;
7458
7459     default:
7460       if (ffebad_start (FFEBAD_INVALID_PERCENT))
7461         {
7462           ffebad_here (0,
7463                        ffelex_token_where_line (ffeexpr_stack_->first_token),
7464                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7465           ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7466           ffebad_finish ();
7467         }
7468
7469       ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7470                      FFEBLD_opPERCENT_LOC);
7471
7472       switch (ffeexpr_stack_->context)
7473         {
7474         case FFEEXPR_contextACTUALARG_:
7475           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7476           break;
7477
7478         case FFEEXPR_contextINDEXORACTUALARG_:
7479           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7480           break;
7481
7482         case FFEEXPR_contextSFUNCDEFACTUALARG_:
7483           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7484           break;
7485
7486         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7487           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7488           break;
7489
7490         default:
7491           assert ("bad context?!?!" == NULL);
7492           break;
7493         }
7494     }
7495
7496   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7497   return
7498     (ffelexHandler) ffeexpr_token_binary_ (t);
7499 }
7500
7501 /* Process DATA implied-DO iterator variables as this implied-DO level
7502    terminates.  At this point, ffeexpr_level_ == 1 when we see the
7503    last right-paren in "DATA (A(I),I=1,10)/.../".  */
7504
7505 static ffesymbol
7506 ffeexpr_check_impctrl_ (ffesymbol s)
7507 {
7508   assert (s != NULL);
7509   assert (ffesymbol_sfdummyparent (s) != NULL);
7510
7511   switch (ffesymbol_state (s))
7512     {
7513     case FFESYMBOL_stateNONE:   /* Used as iterator already. Now let symbol
7514                                    be used as iterator at any level at or
7515                                    innermore than the outermost of the
7516                                    current level and the symbol's current
7517                                    level. */
7518       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7519         {
7520           ffesymbol_signal_change (s);
7521           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7522           ffesymbol_signal_unreported (s);
7523         }
7524       break;
7525
7526     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
7527                                    Error if at outermost level, else it can
7528                                    still become an iterator. */
7529       if ((ffeexpr_level_ == 1)
7530           && ffebad_start (FFEBAD_BAD_IMPDCL))
7531         {
7532           ffebad_string (ffesymbol_text (s));
7533           ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7534           ffebad_finish ();
7535         }
7536       break;
7537
7538     case FFESYMBOL_stateUNCERTAIN:      /* Iterator. */
7539       assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7540       ffesymbol_signal_change (s);
7541       ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7542       ffesymbol_signal_unreported (s);
7543       break;
7544
7545     case FFESYMBOL_stateUNDERSTOOD:
7546       break;                    /* ANY. */
7547
7548     default:
7549       assert ("Sasha Foo!!" == NULL);
7550       break;
7551     }
7552
7553   return s;
7554 }
7555
7556 /* Issue diagnostic if implied-DO variable appears in list of lhs
7557    expressions (as in "READ *, (I,I=1,10)").  */
7558
7559 static void
7560 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7561                       ffebld dovar, ffelexToken dovar_t)
7562 {
7563   ffebld item;
7564   ffesymbol dovar_sym;
7565   int itemnum;
7566
7567   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7568     return;                     /* Presumably opANY. */
7569
7570   dovar_sym = ffebld_symter (dovar);
7571
7572   for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7573     {
7574       if (((item = ffebld_head (list)) != NULL)
7575           && (ffebld_op (item) == FFEBLD_opSYMTER)
7576           && (ffebld_symter (item) == dovar_sym))
7577         {
7578           char itemno[20];
7579
7580           sprintf (&itemno[0], "%d", itemnum);
7581           if (ffebad_start (FFEBAD_DOITER_IMPDO))
7582             {
7583               ffebad_here (0, ffelex_token_where_line (list_t),
7584                            ffelex_token_where_column (list_t));
7585               ffebad_here (1, ffelex_token_where_line (dovar_t),
7586                            ffelex_token_where_column (dovar_t));
7587               ffebad_string (ffesymbol_text (dovar_sym));
7588               ffebad_string (itemno);
7589               ffebad_finish ();
7590             }
7591         }
7592     }
7593 }
7594
7595 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7596    flag.  */
7597
7598 static void
7599 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7600 {
7601   ffesymbol dovar_sym;
7602
7603   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7604     return;                     /* Presumably opANY. */
7605
7606   dovar_sym = ffebld_symter (dovar);
7607
7608   ffeexpr_update_impdo_sym_ (list, dovar_sym);  /* Recurse! */
7609 }
7610
7611 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7612    if they refer to the given variable.  */
7613
7614 static void
7615 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7616 {
7617   tail_recurse:                 /* :::::::::::::::::::: */
7618
7619   if (expr == NULL)
7620     return;
7621
7622   switch (ffebld_op (expr))
7623     {
7624     case FFEBLD_opSYMTER:
7625       if (ffebld_symter (expr) == dovar)
7626         ffebld_symter_set_is_doiter (expr, TRUE);
7627       break;
7628
7629     case FFEBLD_opITEM:
7630       ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7631       expr = ffebld_trail (expr);
7632       goto tail_recurse;        /* :::::::::::::::::::: */
7633
7634     default:
7635       break;
7636     }
7637
7638   switch (ffebld_arity (expr))
7639     {
7640     case 2:
7641       ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7642       expr = ffebld_right (expr);
7643       goto tail_recurse;        /* :::::::::::::::::::: */
7644
7645     case 1:
7646       expr = ffebld_left (expr);
7647       goto tail_recurse;        /* :::::::::::::::::::: */
7648
7649     default:
7650       break;
7651     }
7652
7653   return;
7654 }
7655
7656 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7657
7658    if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7659        // After zero or more PAREN_ contexts, an IF context exists  */
7660
7661 static ffeexprContext
7662 ffeexpr_context_outer_ (ffeexprStack_ s)
7663 {
7664   assert (s != NULL);
7665
7666   for (;;)
7667     {
7668       switch (s->context)
7669         {
7670         case FFEEXPR_contextPAREN_:
7671         case FFEEXPR_contextPARENFILENUM_:
7672         case FFEEXPR_contextPARENFILEUNIT_:
7673           break;
7674
7675         default:
7676           return s->context;
7677         }
7678       s = s->previous;
7679       assert (s != NULL);
7680     }
7681 }
7682
7683 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7684
7685    ffeexprPercent_ p;
7686    ffelexToken t;
7687    p = ffeexpr_percent_(t);
7688
7689    Returns the identifier for the name, or the NONE identifier.  */
7690
7691 static ffeexprPercent_
7692 ffeexpr_percent_ (ffelexToken t)
7693 {
7694   const char *p;
7695
7696   switch (ffelex_token_length (t))
7697     {
7698     case 3:
7699       switch (*(p = ffelex_token_text (t)))
7700         {
7701         case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7702           if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7703               && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7704             return FFEEXPR_percentLOC_;
7705           return FFEEXPR_percentNONE_;
7706
7707         case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7708           if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7709               && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7710             return FFEEXPR_percentREF_;
7711           return FFEEXPR_percentNONE_;
7712
7713         case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7714           if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7715               && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7716             return FFEEXPR_percentVAL_;
7717           return FFEEXPR_percentNONE_;
7718
7719         default:
7720         no_match_3:             /* :::::::::::::::::::: */
7721           return FFEEXPR_percentNONE_;
7722         }
7723
7724     case 5:
7725       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7726                             "descr", "Descr") == 0)
7727         return FFEEXPR_percentDESCR_;
7728       return FFEEXPR_percentNONE_;
7729
7730     default:
7731       return FFEEXPR_percentNONE_;
7732     }
7733 }
7734
7735 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7736
7737    See prototype.
7738
7739    If combining the two basictype/kindtype pairs produces a COMPLEX with an
7740    unsupported kind type, complain and use the default kind type for
7741    COMPLEX.  */
7742
7743 void
7744 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7745                       ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7746                       ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7747                       ffelexToken t)
7748 {
7749   ffeinfoBasictype nbt;
7750   ffeinfoKindtype nkt;
7751
7752   nbt = ffeinfo_basictype_combine (lbt, rbt);
7753   if ((nbt == FFEINFO_basictypeCOMPLEX)
7754       && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7755       && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7756     {
7757       nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7758       if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7759         nkt = FFEINFO_kindtypeNONE;     /* Force error. */
7760       switch (nkt)
7761         {
7762 #if FFETARGET_okCOMPLEX1
7763         case FFEINFO_kindtypeREAL1:
7764 #endif
7765 #if FFETARGET_okCOMPLEX2
7766         case FFEINFO_kindtypeREAL2:
7767 #endif
7768 #if FFETARGET_okCOMPLEX3
7769         case FFEINFO_kindtypeREAL3:
7770 #endif
7771           break;                /* Fine and dandy. */
7772
7773         default:
7774           if (t != NULL)
7775             {
7776               ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7777                             ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7778               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7779               ffebad_finish ();
7780             }
7781           nbt = FFEINFO_basictypeNONE;
7782           nkt = FFEINFO_kindtypeNONE;
7783           break;
7784
7785         case FFEINFO_kindtypeANY:
7786           nkt = FFEINFO_kindtypeREALDEFAULT;
7787           break;
7788         }
7789     }
7790   else
7791     {                           /* The normal stuff. */
7792       if (nbt == lbt)
7793         {
7794           if (nbt == rbt)
7795             nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7796           else
7797             nkt = lkt;
7798         }
7799       else if (nbt == rbt)
7800         nkt = rkt;
7801       else
7802         {                       /* Let the caller do the complaining. */
7803           nbt = FFEINFO_basictypeNONE;
7804           nkt = FFEINFO_kindtypeNONE;
7805         }
7806     }
7807
7808   /* Always a good idea to avoid aliasing problems.  */
7809
7810   *xnbt = nbt;
7811   *xnkt = nkt;
7812 }
7813
7814 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7815
7816    Return a pointer to this function to the lexer (ffelex), which will
7817    invoke it for the next token.
7818
7819    Record line and column of first token in expression, then invoke the
7820    initial-state lhs handler.  */
7821
7822 static ffelexHandler
7823 ffeexpr_token_first_lhs_ (ffelexToken t)
7824 {
7825   ffeexpr_stack_->first_token = ffelex_token_use (t);
7826
7827   /* When changing the list of valid initial lhs tokens, check whether to
7828      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7829      READ (expr) <token> case -- it assumes it knows which tokens <token> can
7830      be to indicate an lhs (or implied DO), which right now is the set
7831      {NAME,OPEN_PAREN}.
7832
7833      This comment also appears in ffeexpr_token_lhs_. */
7834
7835   switch (ffelex_token_type (t))
7836     {
7837     case FFELEX_typeOPEN_PAREN:
7838       switch (ffeexpr_stack_->context)
7839         {
7840         case FFEEXPR_contextDATA:
7841           ffe_init_4 ();
7842           ffeexpr_level_ = 1;   /* Level of DATA implied-DO construct. */
7843           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7844           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7845                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7846
7847         case FFEEXPR_contextDATAIMPDOITEM_:
7848           ++ffeexpr_level_;     /* Level of DATA implied-DO construct. */
7849           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7850           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7851                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7852
7853         case FFEEXPR_contextIOLIST:
7854         case FFEEXPR_contextIMPDOITEM_:
7855           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7856           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7857                             FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7858
7859         case FFEEXPR_contextIOLISTDF:
7860         case FFEEXPR_contextIMPDOITEMDF_:
7861           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7862           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7863                           FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7864
7865         case FFEEXPR_contextFILEEXTFUNC:
7866           assert (ffeexpr_stack_->exprstack == NULL);
7867           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7868
7869         default:
7870           break;
7871         }
7872       break;
7873
7874     case FFELEX_typeNAME:
7875       switch (ffeexpr_stack_->context)
7876         {
7877         case FFEEXPR_contextFILENAMELIST:
7878           assert (ffeexpr_stack_->exprstack == NULL);
7879           return (ffelexHandler) ffeexpr_token_namelist_;
7880
7881         case FFEEXPR_contextFILEEXTFUNC:
7882           assert (ffeexpr_stack_->exprstack == NULL);
7883           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7884
7885         default:
7886           break;
7887         }
7888       break;
7889
7890     default:
7891       switch (ffeexpr_stack_->context)
7892         {
7893         case FFEEXPR_contextFILEEXTFUNC:
7894           assert (ffeexpr_stack_->exprstack == NULL);
7895           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7896
7897         default:
7898           break;
7899         }
7900       break;
7901     }
7902
7903   return (ffelexHandler) ffeexpr_token_lhs_ (t);
7904 }
7905
7906 /* ffeexpr_token_first_lhs_1_ -- NAME
7907
7908    return ffeexpr_token_first_lhs_1_;  // to lexer
7909
7910    Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7911    statement).  */
7912
7913 static ffelexHandler
7914 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7915 {
7916   ffeexprCallback callback;
7917   ffeexprStack_ s;
7918   ffelexHandler next;
7919   ffelexToken ft;
7920   ffesymbol sy = NULL;
7921   ffebld expr;
7922
7923   ffebld_pool_pop ();
7924   callback = ffeexpr_stack_->callback;
7925   ft = ffeexpr_stack_->first_token;
7926   s = ffeexpr_stack_->previous;
7927
7928   if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7929       || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7930           & FFESYMBOL_attrANY))
7931     {
7932       if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7933           || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7934         {
7935           ffebad_start (FFEBAD_EXPR_WRONG);
7936           ffebad_here (0, ffelex_token_where_line (ft),
7937                        ffelex_token_where_column (ft));
7938           ffebad_finish ();
7939         }
7940       expr = ffebld_new_any ();
7941       ffebld_set_info (expr, ffeinfo_new_any ());
7942     }
7943   else
7944     {
7945       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7946                                 FFEINTRIN_impNONE);
7947       ffebld_set_info (expr, ffesymbol_info (sy));
7948     }
7949
7950   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7951                   sizeof (*ffeexpr_stack_));
7952   ffeexpr_stack_ = s;
7953
7954   next = (ffelexHandler) (*callback) (ft, expr, t);
7955   ffelex_token_kill (ft);
7956   return (ffelexHandler) next;
7957 }
7958
7959 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7960
7961    Record line and column of first token in expression, then invoke the
7962    initial-state rhs handler.
7963
7964    19-Feb-91  JCB  1.1
7965       Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7966       (i.e. only as in READ(*), not READ((*))).  */
7967
7968 static ffelexHandler
7969 ffeexpr_token_first_rhs_ (ffelexToken t)
7970 {
7971   ffesymbol s;
7972
7973   ffeexpr_stack_->first_token = ffelex_token_use (t);
7974
7975   switch (ffelex_token_type (t))
7976     {
7977     case FFELEX_typeASTERISK:
7978       switch (ffeexpr_stack_->context)
7979         {
7980         case FFEEXPR_contextFILEFORMATNML:
7981           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7982           /* Fall through.  */
7983         case FFEEXPR_contextFILEUNIT:
7984         case FFEEXPR_contextDIMLIST:
7985         case FFEEXPR_contextFILEFORMAT:
7986         case FFEEXPR_contextCHARACTERSIZE:
7987           if (ffeexpr_stack_->previous != NULL)
7988             break;              /* Valid only on first level. */
7989           assert (ffeexpr_stack_->exprstack == NULL);
7990           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7991
7992         case FFEEXPR_contextPARENFILEUNIT_:
7993           if (ffeexpr_stack_->previous->previous != NULL)
7994             break;              /* Valid only on second level. */
7995           assert (ffeexpr_stack_->exprstack == NULL);
7996           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7997
7998         case FFEEXPR_contextACTUALARG_:
7999           if (ffeexpr_stack_->previous->context
8000               != FFEEXPR_contextSUBROUTINEREF)
8001             {
8002               ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8003               break;
8004             }
8005           assert (ffeexpr_stack_->exprstack == NULL);
8006           return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8007
8008         case FFEEXPR_contextINDEXORACTUALARG_:
8009           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8010           break;
8011
8012         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8013           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8014           break;
8015
8016         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8017           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8018           break;
8019
8020         default:
8021           break;
8022         }
8023       break;
8024
8025     case FFELEX_typeOPEN_PAREN:
8026       switch (ffeexpr_stack_->context)
8027         {
8028         case FFEEXPR_contextFILENUMAMBIG:
8029           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8030                                               FFEEXPR_contextPARENFILENUM_,
8031                                               ffeexpr_cb_close_paren_ambig_);
8032
8033         case FFEEXPR_contextFILEUNITAMBIG:
8034           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8035                                               FFEEXPR_contextPARENFILEUNIT_,
8036                                               ffeexpr_cb_close_paren_ambig_);
8037
8038         case FFEEXPR_contextIOLIST:
8039         case FFEEXPR_contextIMPDOITEM_:
8040           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8041                                               FFEEXPR_contextIMPDOITEM_,
8042                                               ffeexpr_cb_close_paren_ci_);
8043
8044         case FFEEXPR_contextIOLISTDF:
8045         case FFEEXPR_contextIMPDOITEMDF_:
8046           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8047                                               FFEEXPR_contextIMPDOITEMDF_,
8048                                               ffeexpr_cb_close_paren_ci_);
8049
8050         case FFEEXPR_contextFILEFORMATNML:
8051           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8052           break;
8053
8054         case FFEEXPR_contextACTUALARG_:
8055           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8056           break;
8057
8058         case FFEEXPR_contextINDEXORACTUALARG_:
8059           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8060           break;
8061
8062         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8063           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8064           break;
8065
8066         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8067           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8068           break;
8069
8070         default:
8071           break;
8072         }
8073       break;
8074
8075     case FFELEX_typeNUMBER:
8076       switch (ffeexpr_stack_->context)
8077         {
8078         case FFEEXPR_contextFILEFORMATNML:
8079           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8080           /* Fall through.  */
8081         case FFEEXPR_contextFILEFORMAT:
8082           if (ffeexpr_stack_->previous != NULL)
8083             break;              /* Valid only on first level. */
8084           assert (ffeexpr_stack_->exprstack == NULL);
8085           return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8086
8087         case FFEEXPR_contextACTUALARG_:
8088           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8089           break;
8090
8091         case FFEEXPR_contextINDEXORACTUALARG_:
8092           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8093           break;
8094
8095         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8096           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8097           break;
8098
8099         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8100           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8101           break;
8102
8103         default:
8104           break;
8105         }
8106       break;
8107
8108     case FFELEX_typeNAME:
8109       switch (ffeexpr_stack_->context)
8110         {
8111         case FFEEXPR_contextFILEFORMATNML:
8112           assert (ffeexpr_stack_->exprstack == NULL);
8113           s = ffesymbol_lookup_local (t);
8114           if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8115             return (ffelexHandler) ffeexpr_token_namelist_;
8116           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8117           break;
8118
8119         default:
8120           break;
8121         }
8122       break;
8123
8124     case FFELEX_typePERCENT:
8125       switch (ffeexpr_stack_->context)
8126         {
8127         case FFEEXPR_contextACTUALARG_:
8128         case FFEEXPR_contextINDEXORACTUALARG_:
8129         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8130         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8131           return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8132
8133         case FFEEXPR_contextFILEFORMATNML:
8134           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8135           break;
8136
8137         default:
8138           break;
8139         }
8140
8141     default:
8142       switch (ffeexpr_stack_->context)
8143         {
8144         case FFEEXPR_contextACTUALARG_:
8145           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8146           break;
8147
8148         case FFEEXPR_contextINDEXORACTUALARG_:
8149           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8150           break;
8151
8152         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8153           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8154           break;
8155
8156         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8157           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8158           break;
8159
8160         case FFEEXPR_contextFILEFORMATNML:
8161           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8162           break;
8163
8164         default:
8165           break;
8166         }
8167       break;
8168     }
8169
8170   return (ffelexHandler) ffeexpr_token_rhs_ (t);
8171 }
8172
8173 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8174
8175    return ffeexpr_token_first_rhs_1_;  // to lexer
8176
8177    Return STAR as expression.  */
8178
8179 static ffelexHandler
8180 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8181 {
8182   ffebld expr;
8183   ffeexprCallback callback;
8184   ffeexprStack_ s;
8185   ffelexHandler next;
8186   ffelexToken ft;
8187
8188   expr = ffebld_new_star ();
8189   ffebld_pool_pop ();
8190   callback = ffeexpr_stack_->callback;
8191   ft = ffeexpr_stack_->first_token;
8192   s = ffeexpr_stack_->previous;
8193   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8194   ffeexpr_stack_ = s;
8195   next = (ffelexHandler) (*callback) (ft, expr, t);
8196   ffelex_token_kill (ft);
8197   return (ffelexHandler) next;
8198 }
8199
8200 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8201
8202    return ffeexpr_token_first_rhs_2_;  // to lexer
8203
8204    Return NULL as expression; NUMBER as first (and only) token, unless the
8205    current token is not a terminating token, in which case run normal
8206    expression handling.  */
8207
8208 static ffelexHandler
8209 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8210 {
8211   ffeexprCallback callback;
8212   ffeexprStack_ s;
8213   ffelexHandler next;
8214   ffelexToken ft;
8215
8216   switch (ffelex_token_type (t))
8217     {
8218     case FFELEX_typeCLOSE_PAREN:
8219     case FFELEX_typeCOMMA:
8220     case FFELEX_typeEOS:
8221     case FFELEX_typeSEMICOLON:
8222       break;
8223
8224     default:
8225       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8226       return (ffelexHandler) (*next) (t);
8227     }
8228
8229   ffebld_pool_pop ();
8230   callback = ffeexpr_stack_->callback;
8231   ft = ffeexpr_stack_->first_token;
8232   s = ffeexpr_stack_->previous;
8233   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8234                   sizeof (*ffeexpr_stack_));
8235   ffeexpr_stack_ = s;
8236   next = (ffelexHandler) (*callback) (ft, NULL, t);
8237   ffelex_token_kill (ft);
8238   return (ffelexHandler) next;
8239 }
8240
8241 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8242
8243    return ffeexpr_token_first_rhs_3_;  // to lexer
8244
8245    Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8246    confirming, else NULL).  */
8247
8248 static ffelexHandler
8249 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8250 {
8251   ffelexHandler next;
8252
8253   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8254     {                           /* An error, but let normal processing handle
8255                                    it. */
8256       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8257       return (ffelexHandler) (*next) (t);
8258     }
8259
8260   /* Special case: when we see "*10" as an argument to a subroutine
8261      reference, we confirm the current statement and, if not inhibited at
8262      this point, put a copy of the token into a LABTOK node.  We do this
8263      instead of just resolving the label directly via ffelab and putting it
8264      into a LABTER simply to improve error reporting and consistency in
8265      ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
8266      doesn't have to worry about killing off any tokens when retracting. */
8267
8268   ffest_confirmed ();
8269   if (ffest_is_inhibited ())
8270     ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8271   else
8272     ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8273   ffebld_set_info (ffeexpr_stack_->expr,
8274                    ffeinfo_new (FFEINFO_basictypeNONE,
8275                                 FFEINFO_kindtypeNONE,
8276                                 0,
8277                                 FFEINFO_kindNONE,
8278                                 FFEINFO_whereNONE,
8279                                 FFETARGET_charactersizeNONE));
8280
8281   return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8282 }
8283
8284 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8285
8286    return ffeexpr_token_first_rhs_4_;  // to lexer
8287
8288    Collect/flush appropriate stuff, send token to callback function.  */
8289
8290 static ffelexHandler
8291 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8292 {
8293   ffebld expr;
8294   ffeexprCallback callback;
8295   ffeexprStack_ s;
8296   ffelexHandler next;
8297   ffelexToken ft;
8298
8299   expr = ffeexpr_stack_->expr;
8300   ffebld_pool_pop ();
8301   callback = ffeexpr_stack_->callback;
8302   ft = ffeexpr_stack_->first_token;
8303   s = ffeexpr_stack_->previous;
8304   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8305   ffeexpr_stack_ = s;
8306   next = (ffelexHandler) (*callback) (ft, expr, t);
8307   ffelex_token_kill (ft);
8308   return (ffelexHandler) next;
8309 }
8310
8311 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8312
8313    Should be NAME, or pass through original mechanism.  If NAME is LOC,
8314    pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8315    in which case handle the argument (in parentheses), etc.  */
8316
8317 static ffelexHandler
8318 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8319 {
8320   ffelexHandler next;
8321
8322   if (ffelex_token_type (t) == FFELEX_typeNAME)
8323     {
8324       ffeexprPercent_ p = ffeexpr_percent_ (t);
8325
8326       switch (p)
8327         {
8328         case FFEEXPR_percentNONE_:
8329         case FFEEXPR_percentLOC_:
8330           break;                /* Treat %LOC as any other expression. */
8331
8332         case FFEEXPR_percentVAL_:
8333         case FFEEXPR_percentREF_:
8334         case FFEEXPR_percentDESCR_:
8335           ffeexpr_stack_->percent = p;
8336           ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8337           return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8338
8339         default:
8340           assert ("bad percent?!?" == NULL);
8341           break;
8342         }
8343     }
8344
8345   switch (ffeexpr_stack_->context)
8346     {
8347     case FFEEXPR_contextACTUALARG_:
8348       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8349       break;
8350
8351     case FFEEXPR_contextINDEXORACTUALARG_:
8352       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8353       break;
8354
8355     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8356       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8357       break;
8358
8359     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8360       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8361       break;
8362
8363     default:
8364       assert ("bad context?!?!" == NULL);
8365       break;
8366     }
8367
8368   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8369   return (ffelexHandler) (*next) (t);
8370 }
8371
8372 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8373
8374    Should be OPEN_PAREN, or pass through original mechanism.  */
8375
8376 static ffelexHandler
8377 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8378 {
8379   ffelexHandler next;
8380   ffelexToken ft;
8381
8382   if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8383     {
8384       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8385       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8386                                           ffeexpr_stack_->context,
8387                                           ffeexpr_cb_end_notloc_);
8388     }
8389
8390   switch (ffeexpr_stack_->context)
8391     {
8392     case FFEEXPR_contextACTUALARG_:
8393       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8394       break;
8395
8396     case FFEEXPR_contextINDEXORACTUALARG_:
8397       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8398       break;
8399
8400     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8401       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8402       break;
8403
8404     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8405       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8406       break;
8407
8408     default:
8409       assert ("bad context?!?!" == NULL);
8410       break;
8411     }
8412
8413   ft = ffeexpr_stack_->tokens[0];
8414   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8415   next = (ffelexHandler) (*next) (ft);
8416   ffelex_token_kill (ft);
8417   return (ffelexHandler) (*next) (t);
8418 }
8419
8420 /* ffeexpr_token_namelist_ -- NAME
8421
8422    return ffeexpr_token_namelist_;  // to lexer
8423
8424    Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8425    return.  */
8426
8427 static ffelexHandler
8428 ffeexpr_token_namelist_ (ffelexToken t)
8429 {
8430   ffeexprCallback callback;
8431   ffeexprStack_ s;
8432   ffelexHandler next;
8433   ffelexToken ft;
8434   ffesymbol sy;
8435   ffebld expr;
8436
8437   ffebld_pool_pop ();
8438   callback = ffeexpr_stack_->callback;
8439   ft = ffeexpr_stack_->first_token;
8440   s = ffeexpr_stack_->previous;
8441   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8442   ffeexpr_stack_ = s;
8443
8444   sy = ffesymbol_lookup_local (ft);
8445   if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8446     {
8447       ffebad_start (FFEBAD_EXPR_WRONG);
8448       ffebad_here (0, ffelex_token_where_line (ft),
8449                    ffelex_token_where_column (ft));
8450       ffebad_finish ();
8451       expr = ffebld_new_any ();
8452       ffebld_set_info (expr, ffeinfo_new_any ());
8453     }
8454   else
8455     {
8456       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8457                                 FFEINTRIN_impNONE);
8458       ffebld_set_info (expr, ffesymbol_info (sy));
8459     }
8460   next = (ffelexHandler) (*callback) (ft, expr, t);
8461   ffelex_token_kill (ft);
8462   return (ffelexHandler) next;
8463 }
8464
8465 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8466
8467    ffeexprExpr_ e;
8468    ffeexpr_expr_kill_(e);
8469
8470    Kills the ffewhere info, if necessary, then kills the object.  */
8471
8472 static void
8473 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8474 {
8475   if (e->token != NULL)
8476     ffelex_token_kill (e->token);
8477   malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8478 }
8479
8480 /* ffeexpr_expr_new_ -- Make a new internal expression object
8481
8482    ffeexprExpr_ e;
8483    e = ffeexpr_expr_new_();
8484
8485    Allocates and initializes a new expression object, returns it.  */
8486
8487 static ffeexprExpr_
8488 ffeexpr_expr_new_ (void)
8489 {
8490   ffeexprExpr_ e;
8491
8492   e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
8493   e->previous = NULL;
8494   e->type = FFEEXPR_exprtypeUNKNOWN_;
8495   e->token = NULL;
8496   return e;
8497 }
8498
8499 /* Verify that call to global is valid, and register whatever
8500    new information about a global might be discoverable by looking
8501    at the call.  */
8502
8503 static void
8504 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
8505 {
8506   int n_args;
8507   ffebld list;
8508   ffebld item;
8509   ffesymbol s;
8510
8511   assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
8512           || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
8513
8514   if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
8515     return;
8516
8517   if (ffesymbol_retractable ())
8518     return;
8519
8520   s = ffebld_symter (ffebld_left (*expr));
8521   if (ffesymbol_global (s) == NULL)
8522     return;
8523
8524   for (n_args = 0, list = ffebld_right (*expr);
8525        list != NULL;
8526        list = ffebld_trail (list), ++n_args)
8527     ;
8528
8529   if (ffeglobal_proc_ref_nargs (s, n_args, t))
8530     {
8531       ffeglobalArgSummary as;
8532       ffeinfoBasictype bt;
8533       ffeinfoKindtype kt;
8534       bool array;
8535       bool fail = FALSE;
8536
8537       for (n_args = 0, list = ffebld_right (*expr);
8538            list != NULL;
8539            list = ffebld_trail (list), ++n_args)
8540         {
8541           item = ffebld_head (list);
8542           if (item != NULL)
8543             {
8544               bt = ffeinfo_basictype (ffebld_info (item));
8545               kt = ffeinfo_kindtype (ffebld_info (item));
8546               array = (ffeinfo_rank (ffebld_info (item)) > 0);
8547               switch (ffebld_op (item))
8548                 {
8549                 case FFEBLD_opLABTOK:
8550                 case FFEBLD_opLABTER:
8551                   as = FFEGLOBAL_argsummaryALTRTN;
8552                   break;
8553
8554 #if 0
8555                   /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8556                      expression, so don't treat it specially.  */
8557                 case FFEBLD_opPERCENT_LOC:
8558                   as = FFEGLOBAL_argsummaryPTR;
8559                   break;
8560 #endif
8561
8562                 case FFEBLD_opPERCENT_VAL:
8563                   as = FFEGLOBAL_argsummaryVAL;
8564                   break;
8565
8566                 case FFEBLD_opPERCENT_REF:
8567                   as = FFEGLOBAL_argsummaryREF;
8568                   break;
8569
8570                 case FFEBLD_opPERCENT_DESCR:
8571                   as = FFEGLOBAL_argsummaryDESCR;
8572                   break;
8573
8574                 case FFEBLD_opFUNCREF:
8575 #if 0
8576                   /* No, LOC(foo) is just like any INTEGER(KIND=7)
8577                      expression, so don't treat it specially.  */
8578                   if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
8579                       && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
8580                           == FFEINTRIN_specLOC))
8581                     {
8582                       as = FFEGLOBAL_argsummaryPTR;
8583                       break;
8584                     }
8585 #endif
8586                   /* Fall through.  */
8587                 default:
8588                   if (ffebld_op (item) == FFEBLD_opSYMTER)
8589                     {
8590                       as = FFEGLOBAL_argsummaryNONE;
8591
8592                       switch (ffeinfo_kind (ffebld_info (item)))
8593                         {
8594                         case FFEINFO_kindFUNCTION:
8595                           as = FFEGLOBAL_argsummaryFUNC;
8596                           break;
8597
8598                         case FFEINFO_kindSUBROUTINE:
8599                           as = FFEGLOBAL_argsummarySUBR;
8600                           break;
8601
8602                         case FFEINFO_kindNONE:
8603                           as = FFEGLOBAL_argsummaryPROC;
8604                           break;
8605
8606                         default:
8607                           break;
8608                         }
8609
8610                       if (as != FFEGLOBAL_argsummaryNONE)
8611                         break;
8612                     }
8613
8614                   if (bt == FFEINFO_basictypeCHARACTER)
8615                     as = FFEGLOBAL_argsummaryDESCR;
8616                   else
8617                     as = FFEGLOBAL_argsummaryREF;
8618                   break;
8619                 }
8620             }
8621           else
8622             {
8623               array = FALSE;
8624               as = FFEGLOBAL_argsummaryNONE;
8625               bt = FFEINFO_basictypeNONE;
8626               kt = FFEINFO_kindtypeNONE;
8627             }
8628
8629           if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
8630             fail = TRUE;
8631         }
8632       if (! fail)
8633         return;
8634     }
8635
8636   *expr = ffebld_new_any ();
8637   ffebld_set_info (*expr, ffeinfo_new_any ());
8638 }
8639
8640 /* Check whether rest of string is all decimal digits.  */
8641
8642 static bool
8643 ffeexpr_isdigits_ (const char *p)
8644 {
8645   for (; *p != '\0'; ++p)
8646     if (! ISDIGIT (*p))
8647       return FALSE;
8648   return TRUE;
8649 }
8650
8651 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8652
8653    ffeexprExpr_ e;
8654    ffeexpr_exprstack_push_(e);
8655
8656    Pushes the expression onto the stack without any analysis of the existing
8657    contents of the stack.  */
8658
8659 static void
8660 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
8661 {
8662   e->previous = ffeexpr_stack_->exprstack;
8663   ffeexpr_stack_->exprstack = e;
8664 }
8665
8666 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8667
8668    ffeexprExpr_ e;
8669    ffeexpr_exprstack_push_operand_(e);
8670
8671    Pushes the expression already containing an operand (a constant, variable,
8672    or more complicated expression that has already been fully resolved) after
8673    analyzing the stack and checking for possible reduction (which will never
8674    happen here since the highest precedence operator is ** and it has right-
8675    to-left associativity).  */
8676
8677 static void
8678 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
8679 {
8680   ffeexpr_exprstack_push_ (e);
8681 }
8682
8683 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8684
8685    ffeexprExpr_ e;
8686    ffeexpr_exprstack_push_unary_(e);
8687
8688    Pushes the expression already containing a unary operator.  Reduction can
8689    never happen since unary operators are themselves always R-L; that is, the
8690    top of the expression stack is not an operand, in that it is either empty,
8691    has a binary operator at the top, or a unary operator at the top.  In any
8692    of these cases, reduction is impossible.  */
8693
8694 static void
8695 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
8696 {
8697   if ((ffe_is_pedantic ()
8698        || ffe_is_warn_surprising ())
8699       && (ffeexpr_stack_->exprstack != NULL)
8700       && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
8701       && (ffeexpr_stack_->exprstack->u.operator.prec
8702           <= FFEEXPR_operatorprecedenceLOWARITH_)
8703       && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
8704     {
8705       /* xgettext:no-c-format */
8706       ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8707                         ffe_is_pedantic ()
8708                         ? FFEBAD_severityPEDANTIC
8709                         : FFEBAD_severityWARNING);
8710       ffebad_here (0,
8711                   ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
8712                ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
8713       ffebad_here (1,
8714                    ffelex_token_where_line (e->token),
8715                    ffelex_token_where_column (e->token));
8716       ffebad_finish ();
8717     }
8718
8719   ffeexpr_exprstack_push_ (e);
8720 }
8721
8722 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8723
8724    ffeexprExpr_ e;
8725    ffeexpr_exprstack_push_binary_(e);
8726
8727    Pushes the expression already containing a binary operator after checking
8728    whether reduction is possible.  If the stack is not empty, the top of the
8729    stack must be an operand or syntactic analysis has failed somehow.  If
8730    the operand is preceded by a unary operator of higher (or equal and L-R
8731    associativity) precedence than the new binary operator, then reduce that
8732    preceding operator and its operand(s) before pushing the new binary
8733    operator.  */
8734
8735 static void
8736 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
8737 {
8738   ffeexprExpr_ ce;
8739
8740   if (ffe_is_warn_surprising ()
8741       /* These next two are always true (see assertions below).  */
8742       && (ffeexpr_stack_->exprstack != NULL)
8743       && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
8744       /* If the previous operator is a unary minus, and the binary op
8745          is of higher precedence, might not do what user expects,
8746          e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8747          yield "4".  */
8748       && (ffeexpr_stack_->exprstack->previous != NULL)
8749       && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
8750       && (ffeexpr_stack_->exprstack->previous->u.operator.op
8751           == FFEEXPR_operatorSUBTRACT_)
8752       && (e->u.operator.prec
8753           < ffeexpr_stack_->exprstack->previous->u.operator.prec))
8754     {
8755       /* xgettext:no-c-format */
8756       ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
8757       ffebad_here (0,
8758          ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
8759       ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
8760       ffebad_here (1,
8761                    ffelex_token_where_line (e->token),
8762                    ffelex_token_where_column (e->token));
8763       ffebad_finish ();
8764     }
8765
8766 again:
8767   assert (ffeexpr_stack_->exprstack != NULL);
8768   assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
8769   if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
8770     {
8771       assert (ce->type != FFEEXPR_exprtypeOPERAND_);
8772       if ((ce->u.operator.prec < e->u.operator.prec)
8773           || ((ce->u.operator.prec == e->u.operator.prec)
8774               && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
8775         {
8776           ffeexpr_reduce_ ();
8777           goto again;   /* :::::::::::::::::::: */
8778         }
8779     }
8780
8781   ffeexpr_exprstack_push_ (e);
8782 }
8783
8784 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8785
8786    ffeexpr_reduce_();
8787
8788    Converts operand binop operand or unop operand at top of stack to a
8789    single operand having the appropriate ffebld expression, and makes
8790    sure that the expression is proper (like not trying to add two character
8791    variables, not trying to concatenate two numbers).  Also does the
8792    requisite type-assignment.  */
8793
8794 static void
8795 ffeexpr_reduce_ (void)
8796 {
8797   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
8798   ffeexprExpr_ left_operand;    /* When operator is binary, this is A in A+B. */
8799   ffeexprExpr_ operator;        /* This is + in A+B. */
8800   ffebld reduced;               /* This is +(A,B) in A+B or u-(B) in -B. */
8801   ffebldConstant constnode;     /* For checking magical numbers (where mag ==
8802                                    -mag). */
8803   ffebld expr;
8804   ffebld left_expr;
8805   bool submag = FALSE;
8806   bool bothlogical;
8807
8808   operand = ffeexpr_stack_->exprstack;
8809   assert (operand != NULL);
8810   assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8811   operator = operand->previous;
8812   assert (operator != NULL);
8813   assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8814   if (operator->type == FFEEXPR_exprtypeUNARY_)
8815     {
8816       expr = operand->u.operand;
8817       switch (operator->u.operator.op)
8818         {
8819         case FFEEXPR_operatorADD_:
8820           reduced = ffebld_new_uplus (expr);
8821           if (ffe_is_ugly_logint ())
8822             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8823           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8824           reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8825           break;
8826
8827         case FFEEXPR_operatorSUBTRACT_:
8828           submag = TRUE;        /* Ok to negate a magic number. */
8829           reduced = ffebld_new_uminus (expr);
8830           if (ffe_is_ugly_logint ())
8831             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8832           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8833           reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8834           break;
8835
8836         case FFEEXPR_operatorNOT_:
8837           reduced = ffebld_new_not (expr);
8838           if (ffe_is_ugly_logint ())
8839             reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8840           reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8841           reduced = ffeexpr_collapse_not (reduced, operator->token);
8842           break;
8843
8844         default:
8845           assert ("unexpected unary op" != NULL);
8846           reduced = NULL;
8847           break;
8848         }
8849       if (!submag
8850           && (ffebld_op (expr) == FFEBLD_opCONTER)
8851           && (ffebld_conter_orig (expr) == NULL)
8852           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8853         {
8854           ffetarget_integer_bad_magical (operand->token);
8855         }
8856       ffeexpr_stack_->exprstack = operator->previous;   /* Pops unary-op operand
8857                                                            off stack. */
8858       ffeexpr_expr_kill_ (operand);
8859       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
8860                                                            save */
8861       operator->u.operand = reduced;    /* the line/column ffewhere info. */
8862       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
8863                                                            stack. */
8864     }
8865   else
8866     {
8867       assert (operator->type == FFEEXPR_exprtypeBINARY_);
8868       left_operand = operator->previous;
8869       assert (left_operand != NULL);
8870       assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8871       expr = operand->u.operand;
8872       left_expr = left_operand->u.operand;
8873       switch (operator->u.operator.op)
8874         {
8875         case FFEEXPR_operatorADD_:
8876           reduced = ffebld_new_add (left_expr, expr);
8877           if (ffe_is_ugly_logint ())
8878             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8879                                               operand);
8880           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8881                                             operand);
8882           reduced = ffeexpr_collapse_add (reduced, operator->token);
8883           break;
8884
8885         case FFEEXPR_operatorSUBTRACT_:
8886           submag = TRUE;        /* Just to pick the right error if magic
8887                                    number. */
8888           reduced = ffebld_new_subtract (left_expr, expr);
8889           if (ffe_is_ugly_logint ())
8890             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8891                                               operand);
8892           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8893                                             operand);
8894           reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8895           break;
8896
8897         case FFEEXPR_operatorMULTIPLY_:
8898           reduced = ffebld_new_multiply (left_expr, expr);
8899           if (ffe_is_ugly_logint ())
8900             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8901                                               operand);
8902           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8903                                             operand);
8904           reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8905           break;
8906
8907         case FFEEXPR_operatorDIVIDE_:
8908           reduced = ffebld_new_divide (left_expr, expr);
8909           if (ffe_is_ugly_logint ())
8910             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8911                                               operand);
8912           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8913                                             operand);
8914           reduced = ffeexpr_collapse_divide (reduced, operator->token);
8915           break;
8916
8917         case FFEEXPR_operatorPOWER_:
8918           reduced = ffebld_new_power (left_expr, expr);
8919           if (ffe_is_ugly_logint ())
8920             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8921                                               operand);
8922           reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8923                                             operand);
8924           reduced = ffeexpr_collapse_power (reduced, operator->token);
8925           break;
8926
8927         case FFEEXPR_operatorCONCATENATE_:
8928           reduced = ffebld_new_concatenate (left_expr, expr);
8929           reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8930                                                   operand);
8931           reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8932           break;
8933
8934         case FFEEXPR_operatorLT_:
8935           reduced = ffebld_new_lt (left_expr, expr);
8936           if (ffe_is_ugly_logint ())
8937             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8938                                               operand);
8939           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8940                                              operand);
8941           reduced = ffeexpr_collapse_lt (reduced, operator->token);
8942           break;
8943
8944         case FFEEXPR_operatorLE_:
8945           reduced = ffebld_new_le (left_expr, expr);
8946           if (ffe_is_ugly_logint ())
8947             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8948                                               operand);
8949           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8950                                              operand);
8951           reduced = ffeexpr_collapse_le (reduced, operator->token);
8952           break;
8953
8954         case FFEEXPR_operatorEQ_:
8955           reduced = ffebld_new_eq (left_expr, expr);
8956           if (ffe_is_ugly_logint ())
8957             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8958                                               operand);
8959           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8960                                             operand);
8961           reduced = ffeexpr_collapse_eq (reduced, operator->token);
8962           break;
8963
8964         case FFEEXPR_operatorNE_:
8965           reduced = ffebld_new_ne (left_expr, expr);
8966           if (ffe_is_ugly_logint ())
8967             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8968                                               operand);
8969           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8970                                             operand);
8971           reduced = ffeexpr_collapse_ne (reduced, operator->token);
8972           break;
8973
8974         case FFEEXPR_operatorGT_:
8975           reduced = ffebld_new_gt (left_expr, expr);
8976           if (ffe_is_ugly_logint ())
8977             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8978                                               operand);
8979           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8980                                              operand);
8981           reduced = ffeexpr_collapse_gt (reduced, operator->token);
8982           break;
8983
8984         case FFEEXPR_operatorGE_:
8985           reduced = ffebld_new_ge (left_expr, expr);
8986           if (ffe_is_ugly_logint ())
8987             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8988                                               operand);
8989           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8990                                              operand);
8991           reduced = ffeexpr_collapse_ge (reduced, operator->token);
8992           break;
8993
8994         case FFEEXPR_operatorAND_:
8995           reduced = ffebld_new_and (left_expr, expr);
8996           if (ffe_is_ugly_logint ())
8997             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8998                                                  operand, &bothlogical);
8999           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9000                                             operand);
9001           reduced = ffeexpr_collapse_and (reduced, operator->token);
9002           if (ffe_is_ugly_logint() && bothlogical)
9003             reduced = ffeexpr_convert (reduced, left_operand->token,
9004                                        operator->token,
9005                                        FFEINFO_basictypeLOGICAL,
9006                                        FFEINFO_kindtypeLOGICALDEFAULT, 0,
9007                                        FFETARGET_charactersizeNONE,
9008                                        FFEEXPR_contextLET);
9009           break;
9010
9011         case FFEEXPR_operatorOR_:
9012           reduced = ffebld_new_or (left_expr, expr);
9013           if (ffe_is_ugly_logint ())
9014             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9015                                                  operand, &bothlogical);
9016           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9017                                             operand);
9018           reduced = ffeexpr_collapse_or (reduced, operator->token);
9019           if (ffe_is_ugly_logint() && bothlogical)
9020             reduced = ffeexpr_convert (reduced, left_operand->token,
9021                                        operator->token,
9022                                        FFEINFO_basictypeLOGICAL,
9023                                        FFEINFO_kindtypeLOGICALDEFAULT, 0,
9024                                        FFETARGET_charactersizeNONE,
9025                                        FFEEXPR_contextLET);
9026           break;
9027
9028         case FFEEXPR_operatorXOR_:
9029           reduced = ffebld_new_xor (left_expr, expr);
9030           if (ffe_is_ugly_logint ())
9031             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9032                                                  operand, &bothlogical);
9033           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9034                                             operand);
9035           reduced = ffeexpr_collapse_xor (reduced, operator->token);
9036           if (ffe_is_ugly_logint() && bothlogical)
9037             reduced = ffeexpr_convert (reduced, left_operand->token,
9038                                        operator->token,
9039                                        FFEINFO_basictypeLOGICAL,
9040                                        FFEINFO_kindtypeLOGICALDEFAULT, 0,
9041                                        FFETARGET_charactersizeNONE,
9042                                        FFEEXPR_contextLET);
9043           break;
9044
9045         case FFEEXPR_operatorEQV_:
9046           reduced = ffebld_new_eqv (left_expr, expr);
9047           if (ffe_is_ugly_logint ())
9048             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9049                                                  operand, NULL);
9050           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9051                                             operand);
9052           reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9053           break;
9054
9055         case FFEEXPR_operatorNEQV_:
9056           reduced = ffebld_new_neqv (left_expr, expr);
9057           if (ffe_is_ugly_logint ())
9058             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9059                                                  operand, NULL);
9060           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9061                                             operand);
9062           reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9063           break;
9064
9065         default:
9066           assert ("bad bin op" == NULL);
9067           reduced = expr;
9068           break;
9069         }
9070       if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9071           && (ffebld_conter_orig (expr) == NULL)
9072       && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9073         {
9074           if ((left_operand->previous != NULL)
9075               && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9076               && (left_operand->previous->u.operator.op
9077                   == FFEEXPR_operatorSUBTRACT_))
9078             {
9079               if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9080                 ffetarget_integer_bad_magical_precedence (left_operand->token,
9081                                                           left_operand->previous->token,
9082                                                           operator->token);
9083               else
9084                 ffetarget_integer_bad_magical_precedence_binary
9085                   (left_operand->token,
9086                    left_operand->previous->token,
9087                    operator->token);
9088             }
9089           else
9090             ffetarget_integer_bad_magical (left_operand->token);
9091         }
9092       if ((ffebld_op (expr) == FFEBLD_opCONTER)
9093           && (ffebld_conter_orig (expr) == NULL)
9094           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9095         {
9096           if (submag)
9097             ffetarget_integer_bad_magical_binary (operand->token,
9098                                                   operator->token);
9099           else
9100             ffetarget_integer_bad_magical (operand->token);
9101         }
9102       ffeexpr_stack_->exprstack = left_operand->previous;       /* Pops binary-op
9103                                                                    operands off stack. */
9104       ffeexpr_expr_kill_ (left_operand);
9105       ffeexpr_expr_kill_ (operand);
9106       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
9107                                                            save */
9108       operator->u.operand = reduced;    /* the line/column ffewhere info. */
9109       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
9110                                                            stack. */
9111     }
9112 }
9113
9114 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9115
9116    reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9117
9118    Makes sure the argument for reduced has basictype of
9119    LOGICAL or (ugly) INTEGER.  If
9120    argument has where of CONSTANT, assign where CONSTANT to
9121    reduced, else assign where FLEETING.
9122
9123    If these requirements cannot be met, generate error message.  */
9124
9125 static ffebld
9126 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9127 {
9128   ffeinfo rinfo, ninfo;
9129   ffeinfoBasictype rbt;
9130   ffeinfoKindtype rkt;
9131   ffeinfoRank rrk;
9132   ffeinfoKind rkd;
9133   ffeinfoWhere rwh, nwh;
9134
9135   rinfo = ffebld_info (ffebld_left (reduced));
9136   rbt = ffeinfo_basictype (rinfo);
9137   rkt = ffeinfo_kindtype (rinfo);
9138   rrk = ffeinfo_rank (rinfo);
9139   rkd = ffeinfo_kind (rinfo);
9140   rwh = ffeinfo_where (rinfo);
9141
9142   if (((rbt == FFEINFO_basictypeLOGICAL)
9143        || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9144       && (rrk == 0))
9145     {
9146       switch (rwh)
9147         {
9148         case FFEINFO_whereCONSTANT:
9149           nwh = FFEINFO_whereCONSTANT;
9150           break;
9151
9152         case FFEINFO_whereIMMEDIATE:
9153           nwh = FFEINFO_whereIMMEDIATE;
9154           break;
9155
9156         default:
9157           nwh = FFEINFO_whereFLEETING;
9158           break;
9159         }
9160
9161       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9162                            FFETARGET_charactersizeNONE);
9163       ffebld_set_info (reduced, ninfo);
9164       return reduced;
9165     }
9166
9167   if ((rbt != FFEINFO_basictypeLOGICAL)
9168       && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9169     {
9170       if ((rbt != FFEINFO_basictypeANY)
9171           && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9172         {
9173           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9174           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9175           ffebad_finish ();
9176         }
9177     }
9178   else
9179     {
9180       if ((rkd != FFEINFO_kindANY)
9181           && ffebad_start (FFEBAD_NOT_ARG_KIND))
9182         {
9183           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9184           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9185           ffebad_string ("an array");
9186           ffebad_finish ();
9187         }
9188     }
9189
9190   reduced = ffebld_new_any ();
9191   ffebld_set_info (reduced, ffeinfo_new_any ());
9192   return reduced;
9193 }
9194
9195 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9196
9197    reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9198
9199    Makes sure the left and right arguments for reduced have basictype of
9200    LOGICAL or (ugly) INTEGER.  Determine common basictype and
9201    size for reduction (flag expression for combined hollerith/typeless
9202    situations for later determination of effective basictype).  If both left
9203    and right arguments have where of CONSTANT, assign where CONSTANT to
9204    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9205    needed.  Convert typeless
9206    constants to the desired type/size explicitly.
9207
9208    If these requirements cannot be met, generate error message.  */
9209
9210 static ffebld
9211 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9212                         ffeexprExpr_ r)
9213 {
9214   ffeinfo linfo, rinfo, ninfo;
9215   ffeinfoBasictype lbt, rbt, nbt;
9216   ffeinfoKindtype lkt, rkt, nkt;
9217   ffeinfoRank lrk, rrk;
9218   ffeinfoKind lkd, rkd;
9219   ffeinfoWhere lwh, rwh, nwh;
9220
9221   linfo = ffebld_info (ffebld_left (reduced));
9222   lbt = ffeinfo_basictype (linfo);
9223   lkt = ffeinfo_kindtype (linfo);
9224   lrk = ffeinfo_rank (linfo);
9225   lkd = ffeinfo_kind (linfo);
9226   lwh = ffeinfo_where (linfo);
9227
9228   rinfo = ffebld_info (ffebld_right (reduced));
9229   rbt = ffeinfo_basictype (rinfo);
9230   rkt = ffeinfo_kindtype (rinfo);
9231   rrk = ffeinfo_rank (rinfo);
9232   rkd = ffeinfo_kind (rinfo);
9233   rwh = ffeinfo_where (rinfo);
9234
9235   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9236
9237   if (((nbt == FFEINFO_basictypeLOGICAL)
9238        || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9239       && (lrk == 0) && (rrk == 0))
9240     {
9241       switch (lwh)
9242         {
9243         case FFEINFO_whereCONSTANT:
9244           switch (rwh)
9245             {
9246             case FFEINFO_whereCONSTANT:
9247               nwh = FFEINFO_whereCONSTANT;
9248               break;
9249
9250             case FFEINFO_whereIMMEDIATE:
9251               nwh = FFEINFO_whereIMMEDIATE;
9252               break;
9253
9254             default:
9255               nwh = FFEINFO_whereFLEETING;
9256               break;
9257             }
9258           break;
9259
9260         case FFEINFO_whereIMMEDIATE:
9261           switch (rwh)
9262             {
9263             case FFEINFO_whereCONSTANT:
9264             case FFEINFO_whereIMMEDIATE:
9265               nwh = FFEINFO_whereIMMEDIATE;
9266               break;
9267
9268             default:
9269               nwh = FFEINFO_whereFLEETING;
9270               break;
9271             }
9272           break;
9273
9274         default:
9275           nwh = FFEINFO_whereFLEETING;
9276           break;
9277         }
9278
9279       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9280                            FFETARGET_charactersizeNONE);
9281       ffebld_set_info (reduced, ninfo);
9282       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9283               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9284                                                  FFEEXPR_contextLET));
9285       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9286               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9287                                                   FFEEXPR_contextLET));
9288       return reduced;
9289     }
9290
9291   if ((lbt != FFEINFO_basictypeLOGICAL)
9292       && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9293     {
9294       if ((rbt != FFEINFO_basictypeLOGICAL)
9295           && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9296         {
9297           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9298               && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9299             {
9300               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9301               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9302               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9303               ffebad_finish ();
9304             }
9305         }
9306       else
9307         {
9308           if ((lbt != FFEINFO_basictypeANY)
9309               && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9310             {
9311               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9312               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9313               ffebad_finish ();
9314             }
9315         }
9316     }
9317   else if ((rbt != FFEINFO_basictypeLOGICAL)
9318            && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9319     {
9320       if ((rbt != FFEINFO_basictypeANY)
9321           && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9322         {
9323           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9324           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9325           ffebad_finish ();
9326         }
9327     }
9328   else if (lrk != 0)
9329     {
9330       if ((lkd != FFEINFO_kindANY)
9331           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9332         {
9333           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9334           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9335           ffebad_string ("an array");
9336           ffebad_finish ();
9337         }
9338     }
9339   else
9340     {
9341       if ((rkd != FFEINFO_kindANY)
9342           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9343         {
9344           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9345           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9346           ffebad_string ("an array");
9347           ffebad_finish ();
9348         }
9349     }
9350
9351   reduced = ffebld_new_any ();
9352   ffebld_set_info (reduced, ffeinfo_new_any ());
9353   return reduced;
9354 }
9355
9356 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9357
9358    reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9359
9360    Makes sure the left and right arguments for reduced have basictype of
9361    CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
9362    basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
9363    size of concatenation and assign that size to reduced.  If both left and
9364    right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9365    else assign where FLEETING.
9366
9367    If these requirements cannot be met, generate error message using the
9368    info in l, op, and r arguments and assign basictype, size, kind, and where
9369    of ANY.  */
9370
9371 static ffebld
9372 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9373                               ffeexprExpr_ r)
9374 {
9375   ffeinfo linfo, rinfo, ninfo;
9376   ffeinfoBasictype lbt, rbt, nbt;
9377   ffeinfoKindtype lkt, rkt, nkt;
9378   ffeinfoRank lrk, rrk;
9379   ffeinfoKind lkd, rkd, nkd;
9380   ffeinfoWhere lwh, rwh, nwh;
9381   ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9382
9383   linfo = ffebld_info (ffebld_left (reduced));
9384   lbt = ffeinfo_basictype (linfo);
9385   lkt = ffeinfo_kindtype (linfo);
9386   lrk = ffeinfo_rank (linfo);
9387   lkd = ffeinfo_kind (linfo);
9388   lwh = ffeinfo_where (linfo);
9389   lszk = ffeinfo_size (linfo);  /* Known size. */
9390   lszm = ffebld_size_max (ffebld_left (reduced));
9391
9392   rinfo = ffebld_info (ffebld_right (reduced));
9393   rbt = ffeinfo_basictype (rinfo);
9394   rkt = ffeinfo_kindtype (rinfo);
9395   rrk = ffeinfo_rank (rinfo);
9396   rkd = ffeinfo_kind (rinfo);
9397   rwh = ffeinfo_where (rinfo);
9398   rszk = ffeinfo_size (rinfo);  /* Known size. */
9399   rszm = ffebld_size_max (ffebld_right (reduced));
9400
9401   if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9402       && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9403       && (((lszm != FFETARGET_charactersizeNONE)
9404            && (rszm != FFETARGET_charactersizeNONE))
9405           || (ffeexpr_context_outer_ (ffeexpr_stack_)
9406               == FFEEXPR_contextLET)
9407           || (ffeexpr_context_outer_ (ffeexpr_stack_)
9408               == FFEEXPR_contextSFUNCDEF)))
9409     {
9410       nbt = FFEINFO_basictypeCHARACTER;
9411       nkd = FFEINFO_kindENTITY;
9412       if ((lszk == FFETARGET_charactersizeNONE)
9413           || (rszk == FFETARGET_charactersizeNONE))
9414         nszk = FFETARGET_charactersizeNONE;     /* Ok only in rhs of LET
9415                                                    stmt. */
9416       else
9417         nszk = lszk + rszk;
9418
9419       switch (lwh)
9420         {
9421         case FFEINFO_whereCONSTANT:
9422           switch (rwh)
9423             {
9424             case FFEINFO_whereCONSTANT:
9425               nwh = FFEINFO_whereCONSTANT;
9426               break;
9427
9428             case FFEINFO_whereIMMEDIATE:
9429               nwh = FFEINFO_whereIMMEDIATE;
9430               break;
9431
9432             default:
9433               nwh = FFEINFO_whereFLEETING;
9434               break;
9435             }
9436           break;
9437
9438         case FFEINFO_whereIMMEDIATE:
9439           switch (rwh)
9440             {
9441             case FFEINFO_whereCONSTANT:
9442             case FFEINFO_whereIMMEDIATE:
9443               nwh = FFEINFO_whereIMMEDIATE;
9444               break;
9445
9446             default:
9447               nwh = FFEINFO_whereFLEETING;
9448               break;
9449             }
9450           break;
9451
9452         default:
9453           nwh = FFEINFO_whereFLEETING;
9454           break;
9455         }
9456
9457       nkt = lkt;
9458       ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9459       ffebld_set_info (reduced, ninfo);
9460       return reduced;
9461     }
9462
9463   if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9464     {
9465       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9466           && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9467         {
9468           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9469           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9470           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9471           ffebad_finish ();
9472         }
9473     }
9474   else if (lbt != FFEINFO_basictypeCHARACTER)
9475     {
9476       if ((lbt != FFEINFO_basictypeANY)
9477           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9478         {
9479           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9480           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9481           ffebad_finish ();
9482         }
9483     }
9484   else if (rbt != FFEINFO_basictypeCHARACTER)
9485     {
9486       if ((rbt != FFEINFO_basictypeANY)
9487           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9488         {
9489           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9490           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9491           ffebad_finish ();
9492         }
9493     }
9494   else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9495     {
9496       if ((lkd != FFEINFO_kindANY)
9497           && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9498         {
9499           const char *what;
9500
9501           if (lrk != 0)
9502             what = "an array";
9503           else
9504             what = "of indeterminate length";
9505           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9506           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9507           ffebad_string (what);
9508           ffebad_finish ();
9509         }
9510     }
9511   else
9512     {
9513       if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9514         {
9515           const char *what;
9516
9517           if (rrk != 0)
9518             what = "an array";
9519           else
9520             what = "of indeterminate length";
9521           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9522           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9523           ffebad_string (what);
9524           ffebad_finish ();
9525         }
9526     }
9527
9528   reduced = ffebld_new_any ();
9529   ffebld_set_info (reduced, ffeinfo_new_any ());
9530   return reduced;
9531 }
9532
9533 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9534
9535    reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9536
9537    Makes sure the left and right arguments for reduced have basictype of
9538    INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
9539    size for reduction.  If both left
9540    and right arguments have where of CONSTANT, assign where CONSTANT to
9541    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9542    needed.  Convert typeless
9543    constants to the desired type/size explicitly.
9544
9545    If these requirements cannot be met, generate error message.  */
9546
9547 static ffebld
9548 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9549                         ffeexprExpr_ r)
9550 {
9551   ffeinfo linfo, rinfo, ninfo;
9552   ffeinfoBasictype lbt, rbt, nbt;
9553   ffeinfoKindtype lkt, rkt, nkt;
9554   ffeinfoRank lrk, rrk;
9555   ffeinfoKind lkd, rkd;
9556   ffeinfoWhere lwh, rwh, nwh;
9557   ffetargetCharacterSize lsz, rsz;
9558
9559   linfo = ffebld_info (ffebld_left (reduced));
9560   lbt = ffeinfo_basictype (linfo);
9561   lkt = ffeinfo_kindtype (linfo);
9562   lrk = ffeinfo_rank (linfo);
9563   lkd = ffeinfo_kind (linfo);
9564   lwh = ffeinfo_where (linfo);
9565   lsz = ffebld_size_known (ffebld_left (reduced));
9566
9567   rinfo = ffebld_info (ffebld_right (reduced));
9568   rbt = ffeinfo_basictype (rinfo);
9569   rkt = ffeinfo_kindtype (rinfo);
9570   rrk = ffeinfo_rank (rinfo);
9571   rkd = ffeinfo_kind (rinfo);
9572   rwh = ffeinfo_where (rinfo);
9573   rsz = ffebld_size_known (ffebld_right (reduced));
9574
9575   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9576
9577   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9578        || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9579       && (lrk == 0) && (rrk == 0))
9580     {
9581       switch (lwh)
9582         {
9583         case FFEINFO_whereCONSTANT:
9584           switch (rwh)
9585             {
9586             case FFEINFO_whereCONSTANT:
9587               nwh = FFEINFO_whereCONSTANT;
9588               break;
9589
9590             case FFEINFO_whereIMMEDIATE:
9591               nwh = FFEINFO_whereIMMEDIATE;
9592               break;
9593
9594             default:
9595               nwh = FFEINFO_whereFLEETING;
9596               break;
9597             }
9598           break;
9599
9600         case FFEINFO_whereIMMEDIATE:
9601           switch (rwh)
9602             {
9603             case FFEINFO_whereCONSTANT:
9604             case FFEINFO_whereIMMEDIATE:
9605               nwh = FFEINFO_whereIMMEDIATE;
9606               break;
9607
9608             default:
9609               nwh = FFEINFO_whereFLEETING;
9610               break;
9611             }
9612           break;
9613
9614         default:
9615           nwh = FFEINFO_whereFLEETING;
9616           break;
9617         }
9618
9619       if ((lsz != FFETARGET_charactersizeNONE)
9620           && (rsz != FFETARGET_charactersizeNONE))
9621         lsz = rsz = (lsz > rsz) ? lsz : rsz;
9622
9623       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9624                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9625       ffebld_set_info (reduced, ninfo);
9626       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9627                                       l->token, op->token, nbt, nkt, 0, lsz,
9628                                                  FFEEXPR_contextLET));
9629       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9630                                       r->token, op->token, nbt, nkt, 0, rsz,
9631                                                   FFEEXPR_contextLET));
9632       return reduced;
9633     }
9634
9635   if ((lbt == FFEINFO_basictypeLOGICAL)
9636       && (rbt == FFEINFO_basictypeLOGICAL))
9637     {
9638       /* xgettext:no-c-format */
9639       if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9640                             FFEBAD_severityFATAL))
9641         {
9642           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9643           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9644           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9645           ffebad_finish ();
9646         }
9647     }
9648   else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9649       && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9650     {
9651       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9652           && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9653         {
9654           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9655               && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9656             {
9657               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9658               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9659               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9660               ffebad_finish ();
9661             }
9662         }
9663       else
9664         {
9665           if ((lbt != FFEINFO_basictypeANY)
9666               && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9667             {
9668               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9669               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9670               ffebad_finish ();
9671             }
9672         }
9673     }
9674   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9675            && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9676     {
9677       if ((rbt != FFEINFO_basictypeANY)
9678           && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9679         {
9680           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9681           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9682           ffebad_finish ();
9683         }
9684     }
9685   else if (lrk != 0)
9686     {
9687       if ((lkd != FFEINFO_kindANY)
9688           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9689         {
9690           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9691           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9692           ffebad_string ("an array");
9693           ffebad_finish ();
9694         }
9695     }
9696   else
9697     {
9698       if ((rkd != FFEINFO_kindANY)
9699           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9700         {
9701           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9702           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9703           ffebad_string ("an array");
9704           ffebad_finish ();
9705         }
9706     }
9707
9708   reduced = ffebld_new_any ();
9709   ffebld_set_info (reduced, ffeinfo_new_any ());
9710   return reduced;
9711 }
9712
9713 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9714
9715    reduced = ffeexpr_reduced_math1_(reduced,op,r);
9716
9717    Makes sure the argument for reduced has basictype of
9718    INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
9719    assign where CONSTANT to
9720    reduced, else assign where FLEETING.
9721
9722    If these requirements cannot be met, generate error message.  */
9723
9724 static ffebld
9725 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9726 {
9727   ffeinfo rinfo, ninfo;
9728   ffeinfoBasictype rbt;
9729   ffeinfoKindtype rkt;
9730   ffeinfoRank rrk;
9731   ffeinfoKind rkd;
9732   ffeinfoWhere rwh, nwh;
9733
9734   rinfo = ffebld_info (ffebld_left (reduced));
9735   rbt = ffeinfo_basictype (rinfo);
9736   rkt = ffeinfo_kindtype (rinfo);
9737   rrk = ffeinfo_rank (rinfo);
9738   rkd = ffeinfo_kind (rinfo);
9739   rwh = ffeinfo_where (rinfo);
9740
9741   if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9742        || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9743     {
9744       switch (rwh)
9745         {
9746         case FFEINFO_whereCONSTANT:
9747           nwh = FFEINFO_whereCONSTANT;
9748           break;
9749
9750         case FFEINFO_whereIMMEDIATE:
9751           nwh = FFEINFO_whereIMMEDIATE;
9752           break;
9753
9754         default:
9755           nwh = FFEINFO_whereFLEETING;
9756           break;
9757         }
9758
9759       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9760                            FFETARGET_charactersizeNONE);
9761       ffebld_set_info (reduced, ninfo);
9762       return reduced;
9763     }
9764
9765   if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9766       && (rbt != FFEINFO_basictypeCOMPLEX))
9767     {
9768       if ((rbt != FFEINFO_basictypeANY)
9769           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9770         {
9771           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9772           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9773           ffebad_finish ();
9774         }
9775     }
9776   else
9777     {
9778       if ((rkd != FFEINFO_kindANY)
9779           && ffebad_start (FFEBAD_MATH_ARG_KIND))
9780         {
9781           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9782           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9783           ffebad_string ("an array");
9784           ffebad_finish ();
9785         }
9786     }
9787
9788   reduced = ffebld_new_any ();
9789   ffebld_set_info (reduced, ffeinfo_new_any ());
9790   return reduced;
9791 }
9792
9793 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9794
9795    reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9796
9797    Makes sure the left and right arguments for reduced have basictype of
9798    INTEGER, REAL, or COMPLEX.  Determine common basictype and
9799    size for reduction (flag expression for combined hollerith/typeless
9800    situations for later determination of effective basictype).  If both left
9801    and right arguments have where of CONSTANT, assign where CONSTANT to
9802    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9803    needed.  Convert typeless
9804    constants to the desired type/size explicitly.
9805
9806    If these requirements cannot be met, generate error message.  */
9807
9808 static ffebld
9809 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9810                         ffeexprExpr_ r)
9811 {
9812   ffeinfo linfo, rinfo, ninfo;
9813   ffeinfoBasictype lbt, rbt, nbt;
9814   ffeinfoKindtype lkt, rkt, nkt;
9815   ffeinfoRank lrk, rrk;
9816   ffeinfoKind lkd, rkd;
9817   ffeinfoWhere lwh, rwh, nwh;
9818
9819   linfo = ffebld_info (ffebld_left (reduced));
9820   lbt = ffeinfo_basictype (linfo);
9821   lkt = ffeinfo_kindtype (linfo);
9822   lrk = ffeinfo_rank (linfo);
9823   lkd = ffeinfo_kind (linfo);
9824   lwh = ffeinfo_where (linfo);
9825
9826   rinfo = ffebld_info (ffebld_right (reduced));
9827   rbt = ffeinfo_basictype (rinfo);
9828   rkt = ffeinfo_kindtype (rinfo);
9829   rrk = ffeinfo_rank (rinfo);
9830   rkd = ffeinfo_kind (rinfo);
9831   rwh = ffeinfo_where (rinfo);
9832
9833   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9834
9835   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9836        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9837     {
9838       switch (lwh)
9839         {
9840         case FFEINFO_whereCONSTANT:
9841           switch (rwh)
9842             {
9843             case FFEINFO_whereCONSTANT:
9844               nwh = FFEINFO_whereCONSTANT;
9845               break;
9846
9847             case FFEINFO_whereIMMEDIATE:
9848               nwh = FFEINFO_whereIMMEDIATE;
9849               break;
9850
9851             default:
9852               nwh = FFEINFO_whereFLEETING;
9853               break;
9854             }
9855           break;
9856
9857         case FFEINFO_whereIMMEDIATE:
9858           switch (rwh)
9859             {
9860             case FFEINFO_whereCONSTANT:
9861             case FFEINFO_whereIMMEDIATE:
9862               nwh = FFEINFO_whereIMMEDIATE;
9863               break;
9864
9865             default:
9866               nwh = FFEINFO_whereFLEETING;
9867               break;
9868             }
9869           break;
9870
9871         default:
9872           nwh = FFEINFO_whereFLEETING;
9873           break;
9874         }
9875
9876       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9877                            FFETARGET_charactersizeNONE);
9878       ffebld_set_info (reduced, ninfo);
9879       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9880               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9881                                                  FFEEXPR_contextLET));
9882       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9883               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9884                                                   FFEEXPR_contextLET));
9885       return reduced;
9886     }
9887
9888   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9889       && (lbt != FFEINFO_basictypeCOMPLEX))
9890     {
9891       if ((rbt != FFEINFO_basictypeINTEGER)
9892       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9893         {
9894           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9895               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9896             {
9897               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9898               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9899               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9900               ffebad_finish ();
9901             }
9902         }
9903       else
9904         {
9905           if ((lbt != FFEINFO_basictypeANY)
9906               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9907             {
9908               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9909               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9910               ffebad_finish ();
9911             }
9912         }
9913     }
9914   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9915            && (rbt != FFEINFO_basictypeCOMPLEX))
9916     {
9917       if ((rbt != FFEINFO_basictypeANY)
9918           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9919         {
9920           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9921           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9922           ffebad_finish ();
9923         }
9924     }
9925   else if (lrk != 0)
9926     {
9927       if ((lkd != FFEINFO_kindANY)
9928           && ffebad_start (FFEBAD_MATH_ARG_KIND))
9929         {
9930           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9931           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9932           ffebad_string ("an array");
9933           ffebad_finish ();
9934         }
9935     }
9936   else
9937     {
9938       if ((rkd != FFEINFO_kindANY)
9939           && ffebad_start (FFEBAD_MATH_ARG_KIND))
9940         {
9941           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9942           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9943           ffebad_string ("an array");
9944           ffebad_finish ();
9945         }
9946     }
9947
9948   reduced = ffebld_new_any ();
9949   ffebld_set_info (reduced, ffeinfo_new_any ());
9950   return reduced;
9951 }
9952
9953 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9954
9955    reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9956
9957    Makes sure the left and right arguments for reduced have basictype of
9958    INTEGER, REAL, or COMPLEX.  Determine common basictype and
9959    size for reduction (flag expression for combined hollerith/typeless
9960    situations for later determination of effective basictype).  If both left
9961    and right arguments have where of CONSTANT, assign where CONSTANT to
9962    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9963    needed.  Note that real**int or complex**int
9964    comes out as int = real**int etc with no conversions.
9965
9966    If these requirements cannot be met, generate error message using the
9967    info in l, op, and r arguments and assign basictype, size, kind, and where
9968    of ANY.  */
9969
9970 static ffebld
9971 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9972                         ffeexprExpr_ r)
9973 {
9974   ffeinfo linfo, rinfo, ninfo;
9975   ffeinfoBasictype lbt, rbt, nbt;
9976   ffeinfoKindtype lkt, rkt, nkt;
9977   ffeinfoRank lrk, rrk;
9978   ffeinfoKind lkd, rkd;
9979   ffeinfoWhere lwh, rwh, nwh;
9980
9981   linfo = ffebld_info (ffebld_left (reduced));
9982   lbt = ffeinfo_basictype (linfo);
9983   lkt = ffeinfo_kindtype (linfo);
9984   lrk = ffeinfo_rank (linfo);
9985   lkd = ffeinfo_kind (linfo);
9986   lwh = ffeinfo_where (linfo);
9987
9988   rinfo = ffebld_info (ffebld_right (reduced));
9989   rbt = ffeinfo_basictype (rinfo);
9990   rkt = ffeinfo_kindtype (rinfo);
9991   rrk = ffeinfo_rank (rinfo);
9992   rkd = ffeinfo_kind (rinfo);
9993   rwh = ffeinfo_where (rinfo);
9994
9995   if ((rbt == FFEINFO_basictypeINTEGER)
9996       && ((lbt == FFEINFO_basictypeREAL)
9997           || (lbt == FFEINFO_basictypeCOMPLEX)))
9998     {
9999       nbt = lbt;
10000       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10001       if (nkt != FFEINFO_kindtypeREALDEFAULT)
10002         {
10003           nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10004           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10005             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10006         }
10007       if (rkt == FFEINFO_kindtypeINTEGER4)
10008         {
10009           /* xgettext:no-c-format */
10010           ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10011                             FFEBAD_severityWARNING);
10012           ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10013           ffebad_finish ();
10014         }
10015       if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10016         {
10017           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10018                                                       r->token, op->token,
10019                 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10020                                                 FFETARGET_charactersizeNONE,
10021                                                       FFEEXPR_contextLET));
10022           rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10023         }
10024     }
10025   else
10026     {
10027       ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10028
10029 #if 0   /* INTEGER4**INTEGER4 works now. */
10030       if ((nbt == FFEINFO_basictypeINTEGER)
10031           && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10032         nkt = FFEINFO_kindtypeINTEGERDEFAULT;   /* Highest kt we can power! */
10033 #endif
10034       if (((nbt == FFEINFO_basictypeREAL)
10035            || (nbt == FFEINFO_basictypeCOMPLEX))
10036           && (nkt != FFEINFO_kindtypeREALDEFAULT))
10037         {
10038           nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10039           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10040             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10041         }
10042       /* else Gonna turn into an error below. */
10043     }
10044
10045   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10046        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10047     {
10048       switch (lwh)
10049         {
10050         case FFEINFO_whereCONSTANT:
10051           switch (rwh)
10052             {
10053             case FFEINFO_whereCONSTANT:
10054               nwh = FFEINFO_whereCONSTANT;
10055               break;
10056
10057             case FFEINFO_whereIMMEDIATE:
10058               nwh = FFEINFO_whereIMMEDIATE;
10059               break;
10060
10061             default:
10062               nwh = FFEINFO_whereFLEETING;
10063               break;
10064             }
10065           break;
10066
10067         case FFEINFO_whereIMMEDIATE:
10068           switch (rwh)
10069             {
10070             case FFEINFO_whereCONSTANT:
10071             case FFEINFO_whereIMMEDIATE:
10072               nwh = FFEINFO_whereIMMEDIATE;
10073               break;
10074
10075             default:
10076               nwh = FFEINFO_whereFLEETING;
10077               break;
10078             }
10079           break;
10080
10081         default:
10082           nwh = FFEINFO_whereFLEETING;
10083           break;
10084         }
10085
10086       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10087                            FFETARGET_charactersizeNONE);
10088       ffebld_set_info (reduced, ninfo);
10089       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10090               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10091                                                  FFEEXPR_contextLET));
10092       if (rbt != FFEINFO_basictypeINTEGER)
10093         ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10094               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10095                                                     FFEEXPR_contextLET));
10096       return reduced;
10097     }
10098
10099   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10100       && (lbt != FFEINFO_basictypeCOMPLEX))
10101     {
10102       if ((rbt != FFEINFO_basictypeINTEGER)
10103       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10104         {
10105           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10106               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10107             {
10108               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10109               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10110               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10111               ffebad_finish ();
10112             }
10113         }
10114       else
10115         {
10116           if ((lbt != FFEINFO_basictypeANY)
10117               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10118             {
10119               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10120               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10121               ffebad_finish ();
10122             }
10123         }
10124     }
10125   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10126            && (rbt != FFEINFO_basictypeCOMPLEX))
10127     {
10128       if ((rbt != FFEINFO_basictypeANY)
10129           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10130         {
10131           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10132           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10133           ffebad_finish ();
10134         }
10135     }
10136   else if (lrk != 0)
10137     {
10138       if ((lkd != FFEINFO_kindANY)
10139           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10140         {
10141           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10142           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10143           ffebad_string ("an array");
10144           ffebad_finish ();
10145         }
10146     }
10147   else
10148     {
10149       if ((rkd != FFEINFO_kindANY)
10150           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10151         {
10152           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10153           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10154           ffebad_string ("an array");
10155           ffebad_finish ();
10156         }
10157     }
10158
10159   reduced = ffebld_new_any ();
10160   ffebld_set_info (reduced, ffeinfo_new_any ());
10161   return reduced;
10162 }
10163
10164 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10165
10166    reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10167
10168    Makes sure the left and right arguments for reduced have basictype of
10169    INTEGER, REAL, or CHARACTER.  Determine common basictype and
10170    size for reduction.  If both left
10171    and right arguments have where of CONSTANT, assign where CONSTANT to
10172    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10173    needed.  Convert typeless
10174    constants to the desired type/size explicitly.
10175
10176    If these requirements cannot be met, generate error message.  */
10177
10178 static ffebld
10179 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10180                          ffeexprExpr_ r)
10181 {
10182   ffeinfo linfo, rinfo, ninfo;
10183   ffeinfoBasictype lbt, rbt, nbt;
10184   ffeinfoKindtype lkt, rkt, nkt;
10185   ffeinfoRank lrk, rrk;
10186   ffeinfoKind lkd, rkd;
10187   ffeinfoWhere lwh, rwh, nwh;
10188   ffetargetCharacterSize lsz, rsz;
10189
10190   linfo = ffebld_info (ffebld_left (reduced));
10191   lbt = ffeinfo_basictype (linfo);
10192   lkt = ffeinfo_kindtype (linfo);
10193   lrk = ffeinfo_rank (linfo);
10194   lkd = ffeinfo_kind (linfo);
10195   lwh = ffeinfo_where (linfo);
10196   lsz = ffebld_size_known (ffebld_left (reduced));
10197
10198   rinfo = ffebld_info (ffebld_right (reduced));
10199   rbt = ffeinfo_basictype (rinfo);
10200   rkt = ffeinfo_kindtype (rinfo);
10201   rrk = ffeinfo_rank (rinfo);
10202   rkd = ffeinfo_kind (rinfo);
10203   rwh = ffeinfo_where (rinfo);
10204   rsz = ffebld_size_known (ffebld_right (reduced));
10205
10206   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10207
10208   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10209        || (nbt == FFEINFO_basictypeCHARACTER))
10210       && (lrk == 0) && (rrk == 0))
10211     {
10212       switch (lwh)
10213         {
10214         case FFEINFO_whereCONSTANT:
10215           switch (rwh)
10216             {
10217             case FFEINFO_whereCONSTANT:
10218               nwh = FFEINFO_whereCONSTANT;
10219               break;
10220
10221             case FFEINFO_whereIMMEDIATE:
10222               nwh = FFEINFO_whereIMMEDIATE;
10223               break;
10224
10225             default:
10226               nwh = FFEINFO_whereFLEETING;
10227               break;
10228             }
10229           break;
10230
10231         case FFEINFO_whereIMMEDIATE:
10232           switch (rwh)
10233             {
10234             case FFEINFO_whereCONSTANT:
10235             case FFEINFO_whereIMMEDIATE:
10236               nwh = FFEINFO_whereIMMEDIATE;
10237               break;
10238
10239             default:
10240               nwh = FFEINFO_whereFLEETING;
10241               break;
10242             }
10243           break;
10244
10245         default:
10246           nwh = FFEINFO_whereFLEETING;
10247           break;
10248         }
10249
10250       if ((lsz != FFETARGET_charactersizeNONE)
10251           && (rsz != FFETARGET_charactersizeNONE))
10252         lsz = rsz = (lsz > rsz) ? lsz : rsz;
10253
10254       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10255                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10256       ffebld_set_info (reduced, ninfo);
10257       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10258                                       l->token, op->token, nbt, nkt, 0, lsz,
10259                                                  FFEEXPR_contextLET));
10260       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10261                                       r->token, op->token, nbt, nkt, 0, rsz,
10262                                                   FFEEXPR_contextLET));
10263       return reduced;
10264     }
10265
10266   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10267       && (lbt != FFEINFO_basictypeCHARACTER))
10268     {
10269       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10270           && (rbt != FFEINFO_basictypeCHARACTER))
10271         {
10272           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10273               && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10274             {
10275               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10276               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10277               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10278               ffebad_finish ();
10279             }
10280         }
10281       else
10282         {
10283           if ((lbt != FFEINFO_basictypeANY)
10284               && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10285             {
10286               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10287               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10288               ffebad_finish ();
10289             }
10290         }
10291     }
10292   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10293            && (rbt != FFEINFO_basictypeCHARACTER))
10294     {
10295       if ((rbt != FFEINFO_basictypeANY)
10296           && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10297         {
10298           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10299           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10300           ffebad_finish ();
10301         }
10302     }
10303   else if (lrk != 0)
10304     {
10305       if ((lkd != FFEINFO_kindANY)
10306           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10307         {
10308           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10309           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10310           ffebad_string ("an array");
10311           ffebad_finish ();
10312         }
10313     }
10314   else
10315     {
10316       if ((rkd != FFEINFO_kindANY)
10317           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10318         {
10319           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10320           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10321           ffebad_string ("an array");
10322           ffebad_finish ();
10323         }
10324     }
10325
10326   reduced = ffebld_new_any ();
10327   ffebld_set_info (reduced, ffeinfo_new_any ());
10328   return reduced;
10329 }
10330
10331 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10332
10333    reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10334
10335    Sigh.  */
10336
10337 static ffebld
10338 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10339 {
10340   ffeinfo rinfo;
10341   ffeinfoBasictype rbt;
10342   ffeinfoKindtype rkt;
10343   ffeinfoRank rrk;
10344   ffeinfoKind rkd;
10345   ffeinfoWhere rwh;
10346
10347   rinfo = ffebld_info (ffebld_left (reduced));
10348   rbt = ffeinfo_basictype (rinfo);
10349   rkt = ffeinfo_kindtype (rinfo);
10350   rrk = ffeinfo_rank (rinfo);
10351   rkd = ffeinfo_kind (rinfo);
10352   rwh = ffeinfo_where (rinfo);
10353
10354   if ((rbt == FFEINFO_basictypeTYPELESS)
10355       || (rbt == FFEINFO_basictypeHOLLERITH))
10356     {
10357       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10358                               r->token, op->token, FFEINFO_basictypeINTEGER,
10359                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10360                                                  FFETARGET_charactersizeNONE,
10361                                                  FFEEXPR_contextLET));
10362       rinfo = ffebld_info (ffebld_left (reduced));
10363       rbt = FFEINFO_basictypeINTEGER;
10364       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10365       rrk = 0;
10366       rkd = FFEINFO_kindENTITY;
10367       rwh = ffeinfo_where (rinfo);
10368     }
10369
10370   if (rbt == FFEINFO_basictypeLOGICAL)
10371     {
10372       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10373                               r->token, op->token, FFEINFO_basictypeINTEGER,
10374                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10375                                                  FFETARGET_charactersizeNONE,
10376                                                  FFEEXPR_contextLET));
10377     }
10378
10379   return reduced;
10380 }
10381
10382 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10383
10384    reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10385
10386    Sigh.  */
10387
10388 static ffebld
10389 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10390 {
10391   ffeinfo rinfo;
10392   ffeinfoBasictype rbt;
10393   ffeinfoKindtype rkt;
10394   ffeinfoRank rrk;
10395   ffeinfoKind rkd;
10396   ffeinfoWhere rwh;
10397
10398   rinfo = ffebld_info (ffebld_left (reduced));
10399   rbt = ffeinfo_basictype (rinfo);
10400   rkt = ffeinfo_kindtype (rinfo);
10401   rrk = ffeinfo_rank (rinfo);
10402   rkd = ffeinfo_kind (rinfo);
10403   rwh = ffeinfo_where (rinfo);
10404
10405   if ((rbt == FFEINFO_basictypeTYPELESS)
10406       || (rbt == FFEINFO_basictypeHOLLERITH))
10407     {
10408       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10409                            r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10410                                              FFEINFO_kindtypeLOGICALDEFAULT,
10411                                                  FFETARGET_charactersizeNONE,
10412                                                  FFEEXPR_contextLET));
10413       rinfo = ffebld_info (ffebld_left (reduced));
10414       rbt = FFEINFO_basictypeLOGICAL;
10415       rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10416       rrk = 0;
10417       rkd = FFEINFO_kindENTITY;
10418       rwh = ffeinfo_where (rinfo);
10419     }
10420
10421   return reduced;
10422 }
10423
10424 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10425
10426    reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10427
10428    Sigh.  */
10429
10430 static ffebld
10431 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10432                         ffeexprExpr_ r)
10433 {
10434   ffeinfo linfo, rinfo;
10435   ffeinfoBasictype lbt, rbt;
10436   ffeinfoKindtype lkt, rkt;
10437   ffeinfoRank lrk, rrk;
10438   ffeinfoKind lkd, rkd;
10439   ffeinfoWhere lwh, rwh;
10440
10441   linfo = ffebld_info (ffebld_left (reduced));
10442   lbt = ffeinfo_basictype (linfo);
10443   lkt = ffeinfo_kindtype (linfo);
10444   lrk = ffeinfo_rank (linfo);
10445   lkd = ffeinfo_kind (linfo);
10446   lwh = ffeinfo_where (linfo);
10447
10448   rinfo = ffebld_info (ffebld_right (reduced));
10449   rbt = ffeinfo_basictype (rinfo);
10450   rkt = ffeinfo_kindtype (rinfo);
10451   rrk = ffeinfo_rank (rinfo);
10452   rkd = ffeinfo_kind (rinfo);
10453   rwh = ffeinfo_where (rinfo);
10454
10455   if ((lbt == FFEINFO_basictypeTYPELESS)
10456       || (lbt == FFEINFO_basictypeHOLLERITH))
10457     {
10458       if ((rbt == FFEINFO_basictypeTYPELESS)
10459           || (rbt == FFEINFO_basictypeHOLLERITH))
10460         {
10461           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10462                               l->token, op->token, FFEINFO_basictypeINTEGER,
10463                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10464                                                 FFETARGET_charactersizeNONE,
10465                                                      FFEEXPR_contextLET));
10466           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10467                            r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10468                                              FFEINFO_kindtypeINTEGERDEFAULT,
10469                                                 FFETARGET_charactersizeNONE,
10470                                                       FFEEXPR_contextLET));
10471           linfo = ffebld_info (ffebld_left (reduced));
10472           rinfo = ffebld_info (ffebld_right (reduced));
10473           lbt = rbt = FFEINFO_basictypeINTEGER;
10474           lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10475           lrk = rrk = 0;
10476           lkd = rkd = FFEINFO_kindENTITY;
10477           lwh = ffeinfo_where (linfo);
10478           rwh = ffeinfo_where (rinfo);
10479         }
10480       else
10481         {
10482           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10483                                  l->token, ffebld_right (reduced), r->token,
10484                                                        FFEEXPR_contextLET));
10485           linfo = ffebld_info (ffebld_left (reduced));
10486           lbt = ffeinfo_basictype (linfo);
10487           lkt = ffeinfo_kindtype (linfo);
10488           lrk = ffeinfo_rank (linfo);
10489           lkd = ffeinfo_kind (linfo);
10490           lwh = ffeinfo_where (linfo);
10491         }
10492     }
10493   else
10494     {
10495       if ((rbt == FFEINFO_basictypeTYPELESS)
10496           || (rbt == FFEINFO_basictypeHOLLERITH))
10497         {
10498           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10499                                   r->token, ffebld_left (reduced), l->token,
10500                                                        FFEEXPR_contextLET));
10501           rinfo = ffebld_info (ffebld_right (reduced));
10502           rbt = ffeinfo_basictype (rinfo);
10503           rkt = ffeinfo_kindtype (rinfo);
10504           rrk = ffeinfo_rank (rinfo);
10505           rkd = ffeinfo_kind (rinfo);
10506           rwh = ffeinfo_where (rinfo);
10507         }
10508       /* else Leave it alone. */
10509     }
10510
10511   if (lbt == FFEINFO_basictypeLOGICAL)
10512     {
10513       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10514                               l->token, op->token, FFEINFO_basictypeINTEGER,
10515                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10516                                                  FFETARGET_charactersizeNONE,
10517                                                  FFEEXPR_contextLET));
10518     }
10519
10520   if (rbt == FFEINFO_basictypeLOGICAL)
10521     {
10522       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10523                               r->token, op->token, FFEINFO_basictypeINTEGER,
10524                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10525                                                 FFETARGET_charactersizeNONE,
10526                                                   FFEEXPR_contextLET));
10527     }
10528
10529   return reduced;
10530 }
10531
10532 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10533
10534    reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10535
10536    Sigh.  */
10537
10538 static ffebld
10539 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10540                            ffeexprExpr_ r, bool *bothlogical)
10541 {
10542   ffeinfo linfo, rinfo;
10543   ffeinfoBasictype lbt, rbt;
10544   ffeinfoKindtype lkt, rkt;
10545   ffeinfoRank lrk, rrk;
10546   ffeinfoKind lkd, rkd;
10547   ffeinfoWhere lwh, rwh;
10548
10549   linfo = ffebld_info (ffebld_left (reduced));
10550   lbt = ffeinfo_basictype (linfo);
10551   lkt = ffeinfo_kindtype (linfo);
10552   lrk = ffeinfo_rank (linfo);
10553   lkd = ffeinfo_kind (linfo);
10554   lwh = ffeinfo_where (linfo);
10555
10556   rinfo = ffebld_info (ffebld_right (reduced));
10557   rbt = ffeinfo_basictype (rinfo);
10558   rkt = ffeinfo_kindtype (rinfo);
10559   rrk = ffeinfo_rank (rinfo);
10560   rkd = ffeinfo_kind (rinfo);
10561   rwh = ffeinfo_where (rinfo);
10562
10563   if ((lbt == FFEINFO_basictypeTYPELESS)
10564       || (lbt == FFEINFO_basictypeHOLLERITH))
10565     {
10566       if ((rbt == FFEINFO_basictypeTYPELESS)
10567           || (rbt == FFEINFO_basictypeHOLLERITH))
10568         {
10569           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10570                               l->token, op->token, FFEINFO_basictypeLOGICAL,
10571                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
10572                                                 FFETARGET_charactersizeNONE,
10573                                                      FFEEXPR_contextLET));
10574           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10575                               r->token, op->token, FFEINFO_basictypeLOGICAL,
10576                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
10577                                                 FFETARGET_charactersizeNONE,
10578                                                       FFEEXPR_contextLET));
10579           linfo = ffebld_info (ffebld_left (reduced));
10580           rinfo = ffebld_info (ffebld_right (reduced));
10581           lbt = rbt = FFEINFO_basictypeLOGICAL;
10582           lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10583           lrk = rrk = 0;
10584           lkd = rkd = FFEINFO_kindENTITY;
10585           lwh = ffeinfo_where (linfo);
10586           rwh = ffeinfo_where (rinfo);
10587         }
10588       else
10589         {
10590           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10591                                  l->token, ffebld_right (reduced), r->token,
10592                                                        FFEEXPR_contextLET));
10593           linfo = ffebld_info (ffebld_left (reduced));
10594           lbt = ffeinfo_basictype (linfo);
10595           lkt = ffeinfo_kindtype (linfo);
10596           lrk = ffeinfo_rank (linfo);
10597           lkd = ffeinfo_kind (linfo);
10598           lwh = ffeinfo_where (linfo);
10599         }
10600     }
10601   else
10602     {
10603       if ((rbt == FFEINFO_basictypeTYPELESS)
10604           || (rbt == FFEINFO_basictypeHOLLERITH))
10605         {
10606           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10607                                   r->token, ffebld_left (reduced), l->token,
10608                                                        FFEEXPR_contextLET));
10609           rinfo = ffebld_info (ffebld_right (reduced));
10610           rbt = ffeinfo_basictype (rinfo);
10611           rkt = ffeinfo_kindtype (rinfo);
10612           rrk = ffeinfo_rank (rinfo);
10613           rkd = ffeinfo_kind (rinfo);
10614           rwh = ffeinfo_where (rinfo);
10615         }
10616       /* else Leave it alone. */
10617     }
10618
10619   if (lbt == FFEINFO_basictypeLOGICAL)
10620     {
10621       ffebld_set_left (reduced,
10622                        ffeexpr_convert (ffebld_left (reduced),
10623                                         l->token, op->token,
10624                                         FFEINFO_basictypeINTEGER,
10625                                         FFEINFO_kindtypeINTEGERDEFAULT, 0,
10626                                         FFETARGET_charactersizeNONE,
10627                                         FFEEXPR_contextLET));
10628     }
10629
10630   if (rbt == FFEINFO_basictypeLOGICAL)
10631     {
10632       ffebld_set_right (reduced,
10633                         ffeexpr_convert (ffebld_right (reduced),
10634                                          r->token, op->token,
10635                                          FFEINFO_basictypeINTEGER,
10636                                          FFEINFO_kindtypeINTEGERDEFAULT, 0,
10637                                          FFETARGET_charactersizeNONE,
10638                                          FFEEXPR_contextLET));
10639     }
10640
10641   if (bothlogical != NULL)
10642     *bothlogical = (lbt == FFEINFO_basictypeLOGICAL
10643                     && rbt == FFEINFO_basictypeLOGICAL);
10644
10645   return reduced;
10646 }
10647
10648 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10649    is found.
10650
10651    The idea is to process the tokens as they would be done by normal
10652    expression processing, with the key things being telling the lexer
10653    when hollerith/character constants are about to happen, until the
10654    true closing token is found.  */
10655
10656 static ffelexHandler
10657 ffeexpr_find_close_paren_ (ffelexToken t,
10658                            ffelexHandler after)
10659 {
10660   ffeexpr_find_.after = after;
10661   ffeexpr_find_.level = 1;
10662   return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10663 }
10664
10665 static ffelexHandler
10666 ffeexpr_nil_finished_ (ffelexToken t)
10667 {
10668   switch (ffelex_token_type (t))
10669     {
10670     case FFELEX_typeCLOSE_PAREN:
10671       if (--ffeexpr_find_.level == 0)
10672         return (ffelexHandler) ffeexpr_find_.after;
10673       return (ffelexHandler) ffeexpr_nil_binary_;
10674
10675     case FFELEX_typeCOMMA:
10676     case FFELEX_typeCOLON:
10677     case FFELEX_typeEQUALS:
10678     case FFELEX_typePOINTS:
10679       return (ffelexHandler) ffeexpr_nil_rhs_;
10680
10681     default:
10682       if (--ffeexpr_find_.level == 0)
10683         return (ffelexHandler) ffeexpr_find_.after (t);
10684       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10685     }
10686 }
10687
10688 static ffelexHandler
10689 ffeexpr_nil_rhs_ (ffelexToken t)
10690 {
10691   switch (ffelex_token_type (t))
10692     {
10693     case FFELEX_typeQUOTE:
10694       if (ffe_is_vxt ())
10695         return (ffelexHandler) ffeexpr_nil_quote_;
10696       ffelex_set_expecting_hollerith (-1, '\"',
10697                                       ffelex_token_where_line (t),
10698                                       ffelex_token_where_column (t));
10699       return (ffelexHandler) ffeexpr_nil_apostrophe_;
10700
10701     case FFELEX_typeAPOSTROPHE:
10702       ffelex_set_expecting_hollerith (-1, '\'',
10703                                       ffelex_token_where_line (t),
10704                                       ffelex_token_where_column (t));
10705       return (ffelexHandler) ffeexpr_nil_apostrophe_;
10706
10707     case FFELEX_typePERCENT:
10708       return (ffelexHandler) ffeexpr_nil_percent_;
10709
10710     case FFELEX_typeOPEN_PAREN:
10711       ++ffeexpr_find_.level;
10712       return (ffelexHandler) ffeexpr_nil_rhs_;
10713
10714     case FFELEX_typePLUS:
10715     case FFELEX_typeMINUS:
10716       return (ffelexHandler) ffeexpr_nil_rhs_;
10717
10718     case FFELEX_typePERIOD:
10719       return (ffelexHandler) ffeexpr_nil_period_;
10720
10721     case FFELEX_typeNUMBER:
10722       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10723       if (ffeexpr_hollerith_count_ > 0)
10724         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10725                                         '\0',
10726                                         ffelex_token_where_line (t),
10727                                         ffelex_token_where_column (t));
10728       return (ffelexHandler) ffeexpr_nil_number_;
10729
10730     case FFELEX_typeNAME:
10731     case FFELEX_typeNAMES:
10732       return (ffelexHandler) ffeexpr_nil_name_rhs_;
10733
10734     case FFELEX_typeASTERISK:
10735     case FFELEX_typeSLASH:
10736     case FFELEX_typePOWER:
10737     case FFELEX_typeCONCAT:
10738     case FFELEX_typeREL_EQ:
10739     case FFELEX_typeREL_NE:
10740     case FFELEX_typeREL_LE:
10741     case FFELEX_typeREL_GE:
10742       return (ffelexHandler) ffeexpr_nil_rhs_;
10743
10744     default:
10745       return (ffelexHandler) ffeexpr_nil_finished_ (t);
10746     }
10747 }
10748
10749 static ffelexHandler
10750 ffeexpr_nil_period_ (ffelexToken t)
10751 {
10752   switch (ffelex_token_type (t))
10753     {
10754     case FFELEX_typeNAME:
10755     case FFELEX_typeNAMES:
10756       ffeexpr_current_dotdot_ = ffestr_other (t);
10757       switch (ffeexpr_current_dotdot_)
10758         {
10759         case FFESTR_otherNone:
10760           return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10761
10762         case FFESTR_otherTRUE:
10763         case FFESTR_otherFALSE:
10764         case FFESTR_otherNOT:
10765           return (ffelexHandler) ffeexpr_nil_end_period_;
10766
10767         default:
10768           return (ffelexHandler) ffeexpr_nil_swallow_period_;
10769         }
10770       break;                    /* Nothing really reaches here. */
10771
10772     case FFELEX_typeNUMBER:
10773       return (ffelexHandler) ffeexpr_nil_real_;
10774
10775     default:
10776       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10777     }
10778 }
10779
10780 static ffelexHandler
10781 ffeexpr_nil_end_period_ (ffelexToken t)
10782 {
10783   switch (ffeexpr_current_dotdot_)
10784     {
10785     case FFESTR_otherNOT:
10786       if (ffelex_token_type (t) != FFELEX_typePERIOD)
10787         return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10788       return (ffelexHandler) ffeexpr_nil_rhs_;
10789
10790     case FFESTR_otherTRUE:
10791     case FFESTR_otherFALSE:
10792       if (ffelex_token_type (t) != FFELEX_typePERIOD)
10793         return (ffelexHandler) ffeexpr_nil_binary_ (t);
10794       return (ffelexHandler) ffeexpr_nil_binary_;
10795
10796     default:
10797       assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10798       exit (0);
10799       return NULL;
10800     }
10801 }
10802
10803 static ffelexHandler
10804 ffeexpr_nil_swallow_period_ (ffelexToken t)
10805 {
10806   if (ffelex_token_type (t) != FFELEX_typePERIOD)
10807     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10808   return (ffelexHandler) ffeexpr_nil_rhs_;
10809 }
10810
10811 static ffelexHandler
10812 ffeexpr_nil_real_ (ffelexToken t)
10813 {
10814   char d;
10815   const char *p;
10816
10817   if (((ffelex_token_type (t) != FFELEX_typeNAME)
10818        && (ffelex_token_type (t) != FFELEX_typeNAMES))
10819       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10820                                      'D', 'd')
10821              || ffesrc_char_match_init (d, 'E', 'e')
10822              || ffesrc_char_match_init (d, 'Q', 'q')))
10823            && ffeexpr_isdigits_ (++p)))
10824     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10825
10826   if (*p == '\0')
10827     return (ffelexHandler) ffeexpr_nil_real_exponent_;
10828   return (ffelexHandler) ffeexpr_nil_binary_;
10829 }
10830
10831 static ffelexHandler
10832 ffeexpr_nil_real_exponent_ (ffelexToken t)
10833 {
10834   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10835       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10836     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10837
10838   return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10839 }
10840
10841 static ffelexHandler
10842 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10843 {
10844   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10845     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10846   return (ffelexHandler) ffeexpr_nil_binary_;
10847 }
10848
10849 static ffelexHandler
10850 ffeexpr_nil_number_ (ffelexToken t)
10851 {
10852   char d;
10853   const char *p;
10854
10855   if (ffeexpr_hollerith_count_ > 0)
10856     ffelex_set_expecting_hollerith (0, '\0',
10857                                     ffewhere_line_unknown (),
10858                                     ffewhere_column_unknown ());
10859
10860   switch (ffelex_token_type (t))
10861     {
10862     case FFELEX_typeNAME:
10863     case FFELEX_typeNAMES:
10864       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10865                                    'D', 'd')
10866            || ffesrc_char_match_init (d, 'E', 'e')
10867            || ffesrc_char_match_init (d, 'Q', 'q'))
10868           && ffeexpr_isdigits_ (++p))
10869         {
10870           if (*p == '\0')
10871             {
10872               ffeexpr_find_.t = ffelex_token_use (t);
10873               return (ffelexHandler) ffeexpr_nil_number_exponent_;
10874             }
10875           return (ffelexHandler) ffeexpr_nil_binary_;
10876         }
10877       break;
10878
10879     case FFELEX_typePERIOD:
10880       ffeexpr_find_.t = ffelex_token_use (t);
10881       return (ffelexHandler) ffeexpr_nil_number_period_;
10882
10883     case FFELEX_typeHOLLERITH:
10884       return (ffelexHandler) ffeexpr_nil_binary_;
10885
10886     default:
10887       break;
10888     }
10889   return (ffelexHandler) ffeexpr_nil_binary_ (t);
10890 }
10891
10892 /* Expects ffeexpr_find_.t.  */
10893
10894 static ffelexHandler
10895 ffeexpr_nil_number_exponent_ (ffelexToken t)
10896 {
10897   ffelexHandler nexthandler;
10898
10899   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10900       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10901     {
10902       nexthandler
10903         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10904       ffelex_token_kill (ffeexpr_find_.t);
10905       return (ffelexHandler) (*nexthandler) (t);
10906     }
10907
10908   ffelex_token_kill (ffeexpr_find_.t);
10909   return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10910 }
10911
10912 static ffelexHandler
10913 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10914 {
10915   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10916     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10917
10918   return (ffelexHandler) ffeexpr_nil_binary_;
10919 }
10920
10921 /* Expects ffeexpr_find_.t.  */
10922
10923 static ffelexHandler
10924 ffeexpr_nil_number_period_ (ffelexToken t)
10925 {
10926   ffelexHandler nexthandler;
10927   char d;
10928   const char *p;
10929
10930   switch (ffelex_token_type (t))
10931     {
10932     case FFELEX_typeNAME:
10933     case FFELEX_typeNAMES:
10934       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10935                                    'D', 'd')
10936            || ffesrc_char_match_init (d, 'E', 'e')
10937            || ffesrc_char_match_init (d, 'Q', 'q'))
10938           && ffeexpr_isdigits_ (++p))
10939         {
10940           if (*p == '\0')
10941             return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10942           ffelex_token_kill (ffeexpr_find_.t);
10943           return (ffelexHandler) ffeexpr_nil_binary_;
10944         }
10945       nexthandler
10946         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10947       ffelex_token_kill (ffeexpr_find_.t);
10948       return (ffelexHandler) (*nexthandler) (t);
10949
10950     case FFELEX_typeNUMBER:
10951       ffelex_token_kill (ffeexpr_find_.t);
10952       return (ffelexHandler) ffeexpr_nil_number_real_;
10953
10954     default:
10955       break;
10956     }
10957   ffelex_token_kill (ffeexpr_find_.t);
10958   return (ffelexHandler) ffeexpr_nil_binary_ (t);
10959 }
10960
10961 /* Expects ffeexpr_find_.t.  */
10962
10963 static ffelexHandler
10964 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10965 {
10966   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10967       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10968     {
10969       ffelexHandler nexthandler;
10970
10971       nexthandler
10972         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10973       ffelex_token_kill (ffeexpr_find_.t);
10974       return (ffelexHandler) (*nexthandler) (t);
10975     }
10976
10977   ffelex_token_kill (ffeexpr_find_.t);
10978   return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10979 }
10980
10981 static ffelexHandler
10982 ffeexpr_nil_number_real_ (ffelexToken t)
10983 {
10984   char d;
10985   const char *p;
10986
10987   if (((ffelex_token_type (t) != FFELEX_typeNAME)
10988        && (ffelex_token_type (t) != FFELEX_typeNAMES))
10989       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10990                                      'D', 'd')
10991              || ffesrc_char_match_init (d, 'E', 'e')
10992              || ffesrc_char_match_init (d, 'Q', 'q')))
10993            && ffeexpr_isdigits_ (++p)))
10994     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10995
10996   if (*p == '\0')
10997     return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10998
10999   return (ffelexHandler) ffeexpr_nil_binary_;
11000 }
11001
11002 static ffelexHandler
11003 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11004 {
11005   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11006     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11007   return (ffelexHandler) ffeexpr_nil_binary_;
11008 }
11009
11010 static ffelexHandler
11011 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11012 {
11013   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11014       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11015     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11016   return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11017 }
11018
11019 static ffelexHandler
11020 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11021 {
11022   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11023     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11024   return (ffelexHandler) ffeexpr_nil_binary_;
11025 }
11026
11027 static ffelexHandler
11028 ffeexpr_nil_binary_ (ffelexToken t)
11029 {
11030   switch (ffelex_token_type (t))
11031     {
11032     case FFELEX_typePLUS:
11033     case FFELEX_typeMINUS:
11034     case FFELEX_typeASTERISK:
11035     case FFELEX_typeSLASH:
11036     case FFELEX_typePOWER:
11037     case FFELEX_typeCONCAT:
11038     case FFELEX_typeOPEN_ANGLE:
11039     case FFELEX_typeCLOSE_ANGLE:
11040     case FFELEX_typeREL_EQ:
11041     case FFELEX_typeREL_NE:
11042     case FFELEX_typeREL_GE:
11043     case FFELEX_typeREL_LE:
11044       return (ffelexHandler) ffeexpr_nil_rhs_;
11045
11046     case FFELEX_typePERIOD:
11047       return (ffelexHandler) ffeexpr_nil_binary_period_;
11048
11049     default:
11050       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11051     }
11052 }
11053
11054 static ffelexHandler
11055 ffeexpr_nil_binary_period_ (ffelexToken t)
11056 {
11057   switch (ffelex_token_type (t))
11058     {
11059     case FFELEX_typeNAME:
11060     case FFELEX_typeNAMES:
11061       ffeexpr_current_dotdot_ = ffestr_other (t);
11062       switch (ffeexpr_current_dotdot_)
11063         {
11064         case FFESTR_otherTRUE:
11065         case FFESTR_otherFALSE:
11066         case FFESTR_otherNOT:
11067           return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11068
11069         default:
11070           return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11071         }
11072       break;                    /* Nothing really reaches here. */
11073
11074     default:
11075       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11076     }
11077 }
11078
11079 static ffelexHandler
11080 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11081 {
11082   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11083     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11084   return (ffelexHandler) ffeexpr_nil_rhs_;
11085 }
11086
11087 static ffelexHandler
11088 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11089 {
11090   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11091     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11092   return (ffelexHandler) ffeexpr_nil_binary_;
11093 }
11094
11095 static ffelexHandler
11096 ffeexpr_nil_quote_ (ffelexToken t)
11097 {
11098   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11099     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11100   return (ffelexHandler) ffeexpr_nil_binary_;
11101 }
11102
11103 static ffelexHandler
11104 ffeexpr_nil_apostrophe_ (ffelexToken t)
11105 {
11106   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11107   return (ffelexHandler) ffeexpr_nil_apos_char_;
11108 }
11109
11110 static ffelexHandler
11111 ffeexpr_nil_apos_char_ (ffelexToken t)
11112 {
11113   char c;
11114
11115   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11116       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11117     {
11118       if ((ffelex_token_length (t) == 1)
11119           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11120                                       'B', 'b')
11121               || ffesrc_char_match_init (c, 'O', 'o')
11122               || ffesrc_char_match_init (c, 'X', 'x')
11123               || ffesrc_char_match_init (c, 'Z', 'z')))
11124         return (ffelexHandler) ffeexpr_nil_binary_;
11125     }
11126   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11127       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11128     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11129   return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11130 }
11131
11132 static ffelexHandler
11133 ffeexpr_nil_name_rhs_ (ffelexToken t)
11134 {
11135   switch (ffelex_token_type (t))
11136     {
11137     case FFELEX_typeQUOTE:
11138     case FFELEX_typeAPOSTROPHE:
11139       ffelex_set_hexnum (TRUE);
11140       return (ffelexHandler) ffeexpr_nil_name_apos_;
11141
11142     case FFELEX_typeOPEN_PAREN:
11143       ++ffeexpr_find_.level;
11144       return (ffelexHandler) ffeexpr_nil_rhs_;
11145
11146     default:
11147       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11148     }
11149 }
11150
11151 static ffelexHandler
11152 ffeexpr_nil_name_apos_ (ffelexToken t)
11153 {
11154   if (ffelex_token_type (t) == FFELEX_typeNAME)
11155     return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11156   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11157 }
11158
11159 static ffelexHandler
11160 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11161 {
11162   switch (ffelex_token_type (t))
11163     {
11164     case FFELEX_typeAPOSTROPHE:
11165     case FFELEX_typeQUOTE:
11166       return (ffelexHandler) ffeexpr_nil_finished_;
11167
11168     default:
11169       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11170     }
11171 }
11172
11173 static ffelexHandler
11174 ffeexpr_nil_percent_ (ffelexToken t)
11175 {
11176   switch (ffelex_token_type (t))
11177     {
11178     case FFELEX_typeNAME:
11179     case FFELEX_typeNAMES:
11180       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11181       ffeexpr_find_.t = ffelex_token_use (t);
11182       return (ffelexHandler) ffeexpr_nil_percent_name_;
11183
11184     default:
11185       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11186     }
11187 }
11188
11189 /* Expects ffeexpr_find_.t.  */
11190
11191 static ffelexHandler
11192 ffeexpr_nil_percent_name_ (ffelexToken t)
11193 {
11194   ffelexHandler nexthandler;
11195
11196   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11197     {
11198       nexthandler
11199         = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11200       ffelex_token_kill (ffeexpr_find_.t);
11201       return (ffelexHandler) (*nexthandler) (t);
11202     }
11203
11204   ffelex_token_kill (ffeexpr_find_.t);
11205   ++ffeexpr_find_.level;
11206   return (ffelexHandler) ffeexpr_nil_rhs_;
11207 }
11208
11209 static ffelexHandler
11210 ffeexpr_nil_substrp_ (ffelexToken t)
11211 {
11212   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11213     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11214
11215   ++ffeexpr_find_.level;
11216   return (ffelexHandler) ffeexpr_nil_rhs_;
11217 }
11218
11219 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11220
11221    ffelexToken t;
11222    return ffeexpr_finished_(t);
11223
11224    Reduces expression stack to one (or zero) elements by repeatedly reducing
11225    the top operator on the stack (or, if the top element on the stack is
11226    itself an operator, issuing an error message and discarding it).  Calls
11227    finishing routine with the expression, returning the ffelexHandler it
11228    returns to the caller.  */
11229
11230 static ffelexHandler
11231 ffeexpr_finished_ (ffelexToken t)
11232 {
11233   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
11234   ffebld expr;
11235   ffeexprCallback callback;
11236   ffeexprStack_ s;
11237   ffebldConstant constnode;     /* For detecting magical number. */
11238   ffelexToken ft;               /* Temporary copy of first token in
11239                                    expression. */
11240   ffelexHandler next;
11241   ffeinfo info;
11242   bool error = FALSE;
11243
11244   while (((operand = ffeexpr_stack_->exprstack) != NULL)
11245          && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11246     {
11247       if (operand->type == FFEEXPR_exprtypeOPERAND_)
11248         ffeexpr_reduce_ ();
11249       else
11250         {
11251           if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11252             {
11253               ffebad_here (0, ffelex_token_where_line (t),
11254                            ffelex_token_where_column (t));
11255               ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11256               ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11257               ffebad_finish ();
11258             }
11259           ffeexpr_stack_->exprstack = operand->previous;        /* Pop the useless
11260                                                                    operator. */
11261           ffeexpr_expr_kill_ (operand);
11262         }
11263     }
11264
11265   assert ((operand == NULL) || (operand->previous == NULL));
11266
11267   ffebld_pool_pop ();
11268   if (operand == NULL)
11269     expr = NULL;
11270   else
11271     {
11272       expr = operand->u.operand;
11273       info = ffebld_info (expr);
11274       if ((ffebld_op (expr) == FFEBLD_opCONTER)
11275           && (ffebld_conter_orig (expr) == NULL)
11276           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11277         {
11278           ffetarget_integer_bad_magical (operand->token);
11279         }
11280       ffeexpr_expr_kill_ (operand);
11281       ffeexpr_stack_->exprstack = NULL;
11282     }
11283
11284   ft = ffeexpr_stack_->first_token;
11285
11286 again:                          /* :::::::::::::::::::: */
11287   switch (ffeexpr_stack_->context)
11288     {
11289     case FFEEXPR_contextLET:
11290     case FFEEXPR_contextSFUNCDEF:
11291       error = (expr == NULL)
11292         || (ffeinfo_rank (info) != 0);
11293       break;
11294
11295     case FFEEXPR_contextPAREN_:
11296       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11297         break;
11298       switch (ffeinfo_basictype (info))
11299         {
11300         case FFEINFO_basictypeHOLLERITH:
11301         case FFEINFO_basictypeTYPELESS:
11302           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11303              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11304                                   FFEEXPR_contextLET);
11305           break;
11306
11307         default:
11308           break;
11309         }
11310       break;
11311
11312     case FFEEXPR_contextPARENFILENUM_:
11313       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11314         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11315       else
11316         ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11317       goto again;               /* :::::::::::::::::::: */
11318
11319     case FFEEXPR_contextPARENFILEUNIT_:
11320       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11321         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11322       else
11323         ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11324       goto again;               /* :::::::::::::::::::: */
11325
11326     case FFEEXPR_contextACTUALARGEXPR_:
11327     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11328       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11329               : ffeinfo_basictype (info))
11330         {
11331         case FFEINFO_basictypeHOLLERITH:
11332         case FFEINFO_basictypeTYPELESS:
11333           if (!ffe_is_ugly_args ()
11334               && ffebad_start (FFEBAD_ACTUALARG))
11335             {
11336               ffebad_here (0, ffelex_token_where_line (ft),
11337                            ffelex_token_where_column (ft));
11338               ffebad_finish ();
11339             }
11340           break;
11341
11342         default:
11343           break;
11344         }
11345       error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11346       break;
11347
11348     case FFEEXPR_contextACTUALARG_:
11349     case FFEEXPR_contextSFUNCDEFACTUALARG_:
11350       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11351               : ffeinfo_basictype (info))
11352         {
11353         case FFEINFO_basictypeHOLLERITH:
11354         case FFEINFO_basictypeTYPELESS:
11355 #if 0                           /* Should never get here. */
11356           expr = ffeexpr_convert (expr, ft, ft,
11357                                   FFEINFO_basictypeINTEGER,
11358                                   FFEINFO_kindtypeINTEGERDEFAULT,
11359                                   0,
11360                                   FFETARGET_charactersizeNONE,
11361                                   FFEEXPR_contextLET);
11362 #else
11363           assert ("why hollerith/typeless in actualarg_?" == NULL);
11364 #endif
11365           break;
11366
11367         default:
11368           break;
11369         }
11370       switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11371         {
11372         case FFEBLD_opSYMTER:
11373         case FFEBLD_opPERCENT_LOC:
11374         case FFEBLD_opPERCENT_VAL:
11375         case FFEBLD_opPERCENT_REF:
11376         case FFEBLD_opPERCENT_DESCR:
11377           error = FALSE;
11378           break;
11379
11380         default:
11381           error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11382           break;
11383         }
11384       {
11385         ffesymbol s;
11386         ffeinfoWhere where;
11387         ffeinfoKind kind;
11388
11389         if (!error
11390             && (expr != NULL)
11391             && (ffebld_op (expr) == FFEBLD_opSYMTER)
11392             && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11393                 (where == FFEINFO_whereINTRINSIC)
11394                 || (where == FFEINFO_whereGLOBAL)
11395                 || ((where == FFEINFO_whereDUMMY)
11396                     && ((kind = ffesymbol_kind (s)),
11397                         (kind == FFEINFO_kindFUNCTION)
11398                         || (kind == FFEINFO_kindSUBROUTINE))))
11399             && !ffesymbol_explicitwhere (s))
11400           {
11401             ffebad_start (where == FFEINFO_whereINTRINSIC
11402                           ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11403             ffebad_here (0, ffelex_token_where_line (ft),
11404                          ffelex_token_where_column (ft));
11405             ffebad_string (ffesymbol_text (s));
11406             ffebad_finish ();
11407             ffesymbol_signal_change (s);
11408             ffesymbol_set_explicitwhere (s, TRUE);
11409             ffesymbol_signal_unreported (s);
11410           }
11411       }
11412       break;
11413
11414     case FFEEXPR_contextINDEX_:
11415     case FFEEXPR_contextSFUNCDEFINDEX_:
11416       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11417         break;
11418       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11419               : ffeinfo_basictype (info))
11420         {
11421         case FFEINFO_basictypeNONE:
11422           error = FALSE;
11423           break;
11424
11425         case FFEINFO_basictypeLOGICAL:
11426           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11427              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11428                                   FFEEXPR_contextLET);
11429           /* Fall through. */
11430         case FFEINFO_basictypeREAL:
11431         case FFEINFO_basictypeCOMPLEX:
11432           if (ffe_is_pedantic ())
11433             {
11434               error = TRUE;
11435               break;
11436             }
11437           /* Fall through. */
11438         case FFEINFO_basictypeHOLLERITH:
11439         case FFEINFO_basictypeTYPELESS:
11440           error = FALSE;
11441           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11442              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11443                                   FFEEXPR_contextLET);
11444           break;
11445
11446         case FFEINFO_basictypeINTEGER:
11447           /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11448              unmolested.  Leave it to downstream to handle kinds.  */
11449           break;
11450
11451         default:
11452           error = TRUE;
11453           break;
11454         }
11455       break;                    /* expr==NULL ok for substring; element case
11456                                    caught by callback. */
11457
11458     case FFEEXPR_contextRETURN:
11459       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11460         break;
11461       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11462               : ffeinfo_basictype (info))
11463         {
11464         case FFEINFO_basictypeNONE:
11465           error = FALSE;
11466           break;
11467
11468         case FFEINFO_basictypeLOGICAL:
11469           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11470              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11471                                   FFEEXPR_contextLET);
11472           /* Fall through. */
11473         case FFEINFO_basictypeREAL:
11474         case FFEINFO_basictypeCOMPLEX:
11475           if (ffe_is_pedantic ())
11476             {
11477               error = TRUE;
11478               break;
11479             }
11480           /* Fall through. */
11481         case FFEINFO_basictypeINTEGER:
11482         case FFEINFO_basictypeHOLLERITH:
11483         case FFEINFO_basictypeTYPELESS:
11484           error = FALSE;
11485           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11486              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11487                                   FFEEXPR_contextLET);
11488           break;
11489
11490         default:
11491           error = TRUE;
11492           break;
11493         }
11494       break;
11495
11496     case FFEEXPR_contextDO:
11497       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11498         break;
11499       switch (ffeinfo_basictype (info))
11500         {
11501         case FFEINFO_basictypeLOGICAL:
11502           error = !ffe_is_ugly_logint ();
11503           if (!ffeexpr_stack_->is_rhs)
11504             break;              /* Don't convert lhs variable. */
11505           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11506                                   ffeinfo_kindtype (ffebld_info (expr)), 0,
11507                                   FFETARGET_charactersizeNONE,
11508                                   FFEEXPR_contextLET);
11509           break;
11510
11511         case FFEINFO_basictypeHOLLERITH:
11512         case FFEINFO_basictypeTYPELESS:
11513           if (!ffeexpr_stack_->is_rhs)
11514             {
11515               error = TRUE;
11516               break;            /* Don't convert lhs variable. */
11517             }
11518           break;
11519
11520         case FFEINFO_basictypeINTEGER:
11521         case FFEINFO_basictypeREAL:
11522           break;
11523
11524         default:
11525           error = TRUE;
11526           break;
11527         }
11528       if (!ffeexpr_stack_->is_rhs
11529           && (ffebld_op (expr) != FFEBLD_opSYMTER))
11530         error = TRUE;
11531       break;
11532
11533     case FFEEXPR_contextDOWHILE:
11534     case FFEEXPR_contextIF:
11535       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11536         break;
11537       switch (ffeinfo_basictype (info))
11538         {
11539         case FFEINFO_basictypeINTEGER:
11540           error = FALSE;
11541           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11542              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11543                                   FFEEXPR_contextLET);
11544           /* Fall through. */
11545         case FFEINFO_basictypeLOGICAL:
11546         case FFEINFO_basictypeHOLLERITH:
11547         case FFEINFO_basictypeTYPELESS:
11548           error = FALSE;
11549           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11550              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11551                                   FFEEXPR_contextLET);
11552           break;
11553
11554         default:
11555           error = TRUE;
11556           break;
11557         }
11558       break;
11559
11560     case FFEEXPR_contextASSIGN:
11561     case FFEEXPR_contextAGOTO:
11562       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11563               : ffeinfo_basictype (info))
11564         {
11565         case FFEINFO_basictypeINTEGER:
11566           error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11567           break;
11568
11569         case FFEINFO_basictypeLOGICAL:
11570           error = !ffe_is_ugly_logint ()
11571             || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11572           break;
11573
11574         default:
11575           error = TRUE;
11576           break;
11577         }
11578       if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11579           || (ffebld_op (expr) != FFEBLD_opSYMTER))
11580         error = TRUE;
11581       break;
11582
11583     case FFEEXPR_contextCGOTO:
11584     case FFEEXPR_contextFORMAT:
11585     case FFEEXPR_contextDIMLIST:
11586     case FFEEXPR_contextFILENUM:        /* See equiv code in _ambig_. */
11587       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11588         break;
11589       switch (ffeinfo_basictype (info))
11590         {
11591         case FFEINFO_basictypeLOGICAL:
11592           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11593              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11594                                   FFEEXPR_contextLET);
11595           /* Fall through. */
11596         case FFEINFO_basictypeREAL:
11597         case FFEINFO_basictypeCOMPLEX:
11598           if (ffe_is_pedantic ())
11599             {
11600               error = TRUE;
11601               break;
11602             }
11603           /* Fall through. */
11604         case FFEINFO_basictypeINTEGER:
11605         case FFEINFO_basictypeHOLLERITH:
11606         case FFEINFO_basictypeTYPELESS:
11607           error = FALSE;
11608           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11609              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11610                                   FFEEXPR_contextLET);
11611           break;
11612
11613         default:
11614           error = TRUE;
11615           break;
11616         }
11617       break;
11618
11619     case FFEEXPR_contextARITHIF:
11620       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11621         break;
11622       switch (ffeinfo_basictype (info))
11623         {
11624         case FFEINFO_basictypeLOGICAL:
11625           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11626              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11627                                   FFEEXPR_contextLET);
11628           if (ffe_is_pedantic ())
11629             {
11630               error = TRUE;
11631               break;
11632             }
11633           /* Fall through. */
11634         case FFEINFO_basictypeHOLLERITH:
11635         case FFEINFO_basictypeTYPELESS:
11636           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11637              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11638                                   FFEEXPR_contextLET);
11639           /* Fall through. */
11640         case FFEINFO_basictypeINTEGER:
11641         case FFEINFO_basictypeREAL:
11642           error = FALSE;
11643           break;
11644
11645         default:
11646           error = TRUE;
11647           break;
11648         }
11649       break;
11650
11651     case FFEEXPR_contextSTOP:
11652       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11653         break;
11654       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11655               : ffeinfo_basictype (info))
11656         {
11657         case FFEINFO_basictypeINTEGER:
11658           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11659           break;
11660
11661         case FFEINFO_basictypeCHARACTER:
11662           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11663           break;
11664
11665         case FFEINFO_basictypeHOLLERITH:
11666         case FFEINFO_basictypeTYPELESS:
11667           error = FALSE;
11668           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11669              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11670                                   FFEEXPR_contextLET);
11671           break;
11672
11673         case FFEINFO_basictypeNONE:
11674           error = FALSE;
11675           break;
11676
11677         default:
11678           error = TRUE;
11679           break;
11680         }
11681       if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11682                              || (ffebld_conter_orig (expr) != NULL)))
11683         error = TRUE;
11684       break;
11685
11686     case FFEEXPR_contextINCLUDE:
11687       error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11688         || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11689         || (ffebld_op (expr) != FFEBLD_opCONTER)
11690         || (ffebld_conter_orig (expr) != NULL);
11691       break;
11692
11693     case FFEEXPR_contextSELECTCASE:
11694       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11695         break;
11696       switch (ffeinfo_basictype (info))
11697         {
11698         case FFEINFO_basictypeINTEGER:
11699         case FFEINFO_basictypeCHARACTER:
11700         case FFEINFO_basictypeLOGICAL:
11701           error = FALSE;
11702           break;
11703
11704         case FFEINFO_basictypeHOLLERITH:
11705         case FFEINFO_basictypeTYPELESS:
11706           error = FALSE;
11707           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11708              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11709                                   FFEEXPR_contextLET);
11710           break;
11711
11712         default:
11713           error = TRUE;
11714           break;
11715         }
11716       break;
11717
11718     case FFEEXPR_contextCASE:
11719       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11720         break;
11721       switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11722               : ffeinfo_basictype (info))
11723         {
11724         case FFEINFO_basictypeINTEGER:
11725         case FFEINFO_basictypeCHARACTER:
11726         case FFEINFO_basictypeLOGICAL:
11727           error = FALSE;
11728           break;
11729
11730         case FFEINFO_basictypeHOLLERITH:
11731         case FFEINFO_basictypeTYPELESS:
11732           error = FALSE;
11733           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11734              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11735                                   FFEEXPR_contextLET);
11736           break;
11737
11738         default:
11739           error = TRUE;
11740           break;
11741         }
11742       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11743         error = TRUE;
11744       break;
11745
11746     case FFEEXPR_contextCHARACTERSIZE:
11747     case FFEEXPR_contextKINDTYPE:
11748     case FFEEXPR_contextDIMLISTCOMMON:
11749       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11750         break;
11751       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11752               : ffeinfo_basictype (info))
11753         {
11754         case FFEINFO_basictypeLOGICAL:
11755           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11756              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11757                                   FFEEXPR_contextLET);
11758           /* Fall through. */
11759         case FFEINFO_basictypeREAL:
11760         case FFEINFO_basictypeCOMPLEX:
11761           if (ffe_is_pedantic ())
11762             {
11763               error = TRUE;
11764               break;
11765             }
11766           /* Fall through. */
11767         case FFEINFO_basictypeINTEGER:
11768         case FFEINFO_basictypeHOLLERITH:
11769         case FFEINFO_basictypeTYPELESS:
11770           error = FALSE;
11771           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11772              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11773                                   FFEEXPR_contextLET);
11774           break;
11775
11776         default:
11777           error = TRUE;
11778           break;
11779         }
11780       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11781         error = TRUE;
11782       break;
11783
11784     case FFEEXPR_contextEQVINDEX_:
11785       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11786         break;
11787       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11788               : ffeinfo_basictype (info))
11789         {
11790         case FFEINFO_basictypeNONE:
11791           error = FALSE;
11792           break;
11793
11794         case FFEINFO_basictypeLOGICAL:
11795           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11796              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11797                                   FFEEXPR_contextLET);
11798           /* Fall through. */
11799         case FFEINFO_basictypeREAL:
11800         case FFEINFO_basictypeCOMPLEX:
11801           if (ffe_is_pedantic ())
11802             {
11803               error = TRUE;
11804               break;
11805             }
11806           /* Fall through. */
11807         case FFEINFO_basictypeINTEGER:
11808         case FFEINFO_basictypeHOLLERITH:
11809         case FFEINFO_basictypeTYPELESS:
11810           error = FALSE;
11811           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11812              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11813                                   FFEEXPR_contextLET);
11814           break;
11815
11816         default:
11817           error = TRUE;
11818           break;
11819         }
11820       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11821         error = TRUE;
11822       break;
11823
11824     case FFEEXPR_contextPARAMETER:
11825       if (ffeexpr_stack_->is_rhs)
11826         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11827           || (ffebld_op (expr) != FFEBLD_opCONTER);
11828       else
11829         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11830           || (ffebld_op (expr) != FFEBLD_opSYMTER);
11831       break;
11832
11833     case FFEEXPR_contextINDEXORACTUALARG_:
11834       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11835         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11836       else
11837         ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11838       goto again;               /* :::::::::::::::::::: */
11839
11840     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11841       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11842         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11843       else
11844         ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11845       goto again;               /* :::::::::::::::::::: */
11846
11847     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11848       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11849         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11850       else
11851         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11852       goto again;               /* :::::::::::::::::::: */
11853
11854     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11855       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11856         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11857       else
11858         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11859       goto again;               /* :::::::::::::::::::: */
11860
11861     case FFEEXPR_contextIMPDOCTRL_:
11862       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11863         break;
11864       if (!ffeexpr_stack_->is_rhs
11865           && (ffebld_op (expr) != FFEBLD_opSYMTER))
11866         error = TRUE;
11867       switch (ffeinfo_basictype (info))
11868         {
11869         case FFEINFO_basictypeLOGICAL:
11870           if (! ffe_is_ugly_logint ())
11871             error = TRUE;
11872           if (! ffeexpr_stack_->is_rhs)
11873             break;
11874           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11875                                   ffeinfo_kindtype (info), 0,
11876                                   FFETARGET_charactersizeNONE,
11877                                   FFEEXPR_contextLET);
11878           break;
11879
11880         case FFEINFO_basictypeINTEGER:
11881         case FFEINFO_basictypeHOLLERITH:
11882         case FFEINFO_basictypeTYPELESS:
11883           break;
11884
11885         case FFEINFO_basictypeREAL:
11886           if (!ffeexpr_stack_->is_rhs
11887               && ffe_is_warn_surprising ()
11888               && !error)
11889             {
11890               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
11891               ffebad_here (0, ffelex_token_where_line (ft),
11892                            ffelex_token_where_column (ft));
11893               ffebad_string (ffelex_token_text (ft));
11894               ffebad_finish ();
11895             }
11896           break;
11897
11898         default:
11899           error = TRUE;
11900           break;
11901         }
11902       break;
11903
11904     case FFEEXPR_contextDATAIMPDOCTRL_:
11905       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11906         break;
11907       if (ffeexpr_stack_->is_rhs)
11908         {
11909           if ((ffebld_op (expr) != FFEBLD_opCONTER)
11910               && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11911             error = TRUE;
11912         }
11913       else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11914                || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11915         error = TRUE;
11916       switch (ffeinfo_basictype (info))
11917         {
11918         case FFEINFO_basictypeLOGICAL:
11919           if (! ffeexpr_stack_->is_rhs)
11920             break;
11921           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11922                                   ffeinfo_kindtype (info), 0,
11923                                   FFETARGET_charactersizeNONE,
11924                                   FFEEXPR_contextLET);
11925           /* Fall through.  */
11926         case FFEINFO_basictypeINTEGER:
11927           if (ffeexpr_stack_->is_rhs
11928               && (ffeinfo_kindtype (ffebld_info (expr))
11929                   != FFEINFO_kindtypeINTEGERDEFAULT))
11930             expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11931                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
11932                                     FFETARGET_charactersizeNONE,
11933                                     FFEEXPR_contextLET);
11934           break;
11935
11936         case FFEINFO_basictypeHOLLERITH:
11937         case FFEINFO_basictypeTYPELESS:
11938           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11939              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11940                                   FFEEXPR_contextLET);
11941           break;
11942
11943         case FFEINFO_basictypeREAL:
11944           if (!ffeexpr_stack_->is_rhs
11945               && ffe_is_warn_surprising ()
11946               && !error)
11947             {
11948               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
11949               ffebad_here (0, ffelex_token_where_line (ft),
11950                            ffelex_token_where_column (ft));
11951               ffebad_string (ffelex_token_text (ft));
11952               ffebad_finish ();
11953             }
11954           break;
11955
11956         default:
11957           error = TRUE;
11958           break;
11959         }
11960       break;
11961
11962     case FFEEXPR_contextIMPDOITEM_:
11963       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11964         {
11965           ffeexpr_stack_->is_rhs = FALSE;
11966           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11967           goto again;           /* :::::::::::::::::::: */
11968         }
11969       /* Fall through. */
11970     case FFEEXPR_contextIOLIST:
11971     case FFEEXPR_contextFILEVXTCODE:
11972       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11973               : ffeinfo_basictype (info))
11974         {
11975         case FFEINFO_basictypeHOLLERITH:
11976         case FFEINFO_basictypeTYPELESS:
11977           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11978              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11979                                   FFEEXPR_contextLET);
11980           break;
11981
11982         default:
11983           break;
11984         }
11985       error = (expr == NULL)
11986         || ((ffeinfo_rank (info) != 0)
11987             && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11988                 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11989                 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11990                     == FFEBLD_opSTAR)));        /* Bad if null expr, or if
11991                                                    array that is not a SYMTER
11992                                                    (can't happen yet, I
11993                                                    think) or has a NULL or
11994                                                    STAR (assumed) array
11995                                                    size. */
11996       break;
11997
11998     case FFEEXPR_contextIMPDOITEMDF_:
11999       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12000         {
12001           ffeexpr_stack_->is_rhs = FALSE;
12002           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12003           goto again;           /* :::::::::::::::::::: */
12004         }
12005       /* Fall through. */
12006     case FFEEXPR_contextIOLISTDF:
12007       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12008               : ffeinfo_basictype (info))
12009         {
12010         case FFEINFO_basictypeHOLLERITH:
12011         case FFEINFO_basictypeTYPELESS:
12012           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12013              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12014                                   FFEEXPR_contextLET);
12015           break;
12016
12017         default:
12018           break;
12019         }
12020       error
12021         = (expr == NULL)
12022           || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12023               && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12024             || ((ffeinfo_rank (info) != 0)
12025                 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12026                     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12027                     || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12028                         == FFEBLD_opSTAR)));    /* Bad if null expr,
12029                                                    non-default-kindtype
12030                                                    character expr, or if
12031                                                    array that is not a SYMTER
12032                                                    (can't happen yet, I
12033                                                    think) or has a NULL or
12034                                                    STAR (assumed) array
12035                                                    size. */
12036       break;
12037
12038     case FFEEXPR_contextDATAIMPDOITEM_:
12039       error = (expr == NULL)
12040         || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12041         || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12042             && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12043       break;
12044
12045     case FFEEXPR_contextDATAIMPDOINDEX_:
12046       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12047         break;
12048       switch (ffeinfo_basictype (info))
12049         {
12050         case FFEINFO_basictypeLOGICAL:
12051           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12052              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12053                                   FFEEXPR_contextLET);
12054           /* Fall through. */
12055         case FFEINFO_basictypeREAL:
12056         case FFEINFO_basictypeCOMPLEX:
12057           if (ffe_is_pedantic ())
12058             {
12059               error = TRUE;
12060               break;
12061             }
12062           /* Fall through. */
12063         case FFEINFO_basictypeINTEGER:
12064         case FFEINFO_basictypeHOLLERITH:
12065         case FFEINFO_basictypeTYPELESS:
12066           error = FALSE;
12067           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12068              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12069                                   FFEEXPR_contextLET);
12070           break;
12071
12072         default:
12073           error = TRUE;
12074           break;
12075         }
12076       if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12077           && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12078         error = TRUE;
12079       break;
12080
12081     case FFEEXPR_contextDATA:
12082       if (expr == NULL)
12083         error = TRUE;
12084       else if (ffeexpr_stack_->is_rhs)
12085         error = (ffebld_op (expr) != FFEBLD_opCONTER);
12086       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12087         error = FALSE;
12088       else
12089         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12090       break;
12091
12092     case FFEEXPR_contextINITVAL:
12093       error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12094       break;
12095
12096     case FFEEXPR_contextEQUIVALENCE:
12097       if (expr == NULL)
12098         error = TRUE;
12099       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12100         error = FALSE;
12101       else
12102         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12103       break;
12104
12105     case FFEEXPR_contextFILEASSOC:
12106     case FFEEXPR_contextFILEINT:
12107       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12108               : ffeinfo_basictype (info))
12109         {
12110         case FFEINFO_basictypeINTEGER:
12111           /* Maybe this should be supported someday, but, right now,
12112              g77 can't generate a call to libf2c to write to an
12113              integer other than the default size.  */
12114           error = ((! ffeexpr_stack_->is_rhs)
12115                    && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12116           break;
12117
12118         default:
12119           error = TRUE;
12120           break;
12121         }
12122       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12123         error = TRUE;
12124       break;
12125
12126     case FFEEXPR_contextFILEDFINT:
12127       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12128               : ffeinfo_basictype (info))
12129         {
12130         case FFEINFO_basictypeINTEGER:
12131           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12132           break;
12133
12134         default:
12135           error = TRUE;
12136           break;
12137         }
12138       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12139         error = TRUE;
12140       break;
12141
12142     case FFEEXPR_contextFILELOG:
12143       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12144               : ffeinfo_basictype (info))
12145         {
12146         case FFEINFO_basictypeLOGICAL:
12147           error = FALSE;
12148           break;
12149
12150         default:
12151           error = TRUE;
12152           break;
12153         }
12154       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12155         error = TRUE;
12156       break;
12157
12158     case FFEEXPR_contextFILECHAR:
12159       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12160               : ffeinfo_basictype (info))
12161         {
12162         case FFEINFO_basictypeCHARACTER:
12163           error = FALSE;
12164           break;
12165
12166         default:
12167           error = TRUE;
12168           break;
12169         }
12170       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12171         error = TRUE;
12172       break;
12173
12174     case FFEEXPR_contextFILENUMCHAR:
12175       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12176         break;
12177       switch (ffeinfo_basictype (info))
12178         {
12179         case FFEINFO_basictypeLOGICAL:
12180           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12181              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12182                                   FFEEXPR_contextLET);
12183           /* Fall through. */
12184         case FFEINFO_basictypeREAL:
12185         case FFEINFO_basictypeCOMPLEX:
12186           if (ffe_is_pedantic ())
12187             {
12188               error = TRUE;
12189               break;
12190             }
12191           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12192              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12193                                   FFEEXPR_contextLET);
12194           break;
12195
12196         case FFEINFO_basictypeINTEGER:
12197         case FFEINFO_basictypeCHARACTER:
12198           error = FALSE;
12199           break;
12200
12201         default:
12202           error = TRUE;
12203           break;
12204         }
12205       break;
12206
12207     case FFEEXPR_contextFILEDFCHAR:
12208       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12209         break;
12210       switch (ffeinfo_basictype (info))
12211         {
12212         case FFEINFO_basictypeCHARACTER:
12213           error
12214             = (ffeinfo_kindtype (info)
12215                != FFEINFO_kindtypeCHARACTERDEFAULT);
12216           break;
12217
12218         default:
12219           error = TRUE;
12220           break;
12221         }
12222       if (!ffeexpr_stack_->is_rhs
12223           && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12224         error = TRUE;
12225       break;
12226
12227     case FFEEXPR_contextFILEUNIT:       /* See equiv code in _ambig_. */
12228       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12229               : ffeinfo_basictype (info))
12230         {
12231         case FFEINFO_basictypeLOGICAL:
12232           if ((error = (ffeinfo_rank (info) != 0)))
12233             break;
12234           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12235              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12236                                   FFEEXPR_contextLET);
12237           /* Fall through. */
12238         case FFEINFO_basictypeREAL:
12239         case FFEINFO_basictypeCOMPLEX:
12240           if ((error = (ffeinfo_rank (info) != 0)))
12241             break;
12242           if (ffe_is_pedantic ())
12243             {
12244               error = TRUE;
12245               break;
12246             }
12247           /* Fall through. */
12248         case FFEINFO_basictypeINTEGER:
12249         case FFEINFO_basictypeHOLLERITH:
12250         case FFEINFO_basictypeTYPELESS:
12251           if ((error = (ffeinfo_rank (info) != 0)))
12252             break;
12253           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12254              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12255                                   FFEEXPR_contextLET);
12256           break;
12257
12258         case FFEINFO_basictypeCHARACTER:
12259           switch (ffebld_op (expr))
12260             {                   /* As if _lhs had been called instead of
12261                                    _rhs. */
12262             case FFEBLD_opSYMTER:
12263               error
12264                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12265               break;
12266
12267             case FFEBLD_opSUBSTR:
12268               error = (ffeinfo_where (ffebld_info (expr))
12269                        == FFEINFO_whereCONSTANT_SUBOBJECT);
12270               break;
12271
12272             case FFEBLD_opARRAYREF:
12273               error = FALSE;
12274               break;
12275
12276             default:
12277               error = TRUE;
12278               break;
12279             }
12280           if (!error
12281            && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12282                || ((ffeinfo_rank (info) != 0)
12283                    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12284                      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12285                   || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12286                       == FFEBLD_opSTAR)))))     /* Bad if
12287                                                    non-default-kindtype
12288                                                    character expr, or if
12289                                                    array that is not a SYMTER
12290                                                    (can't happen yet, I
12291                                                    think), or has a NULL or
12292                                                    STAR (assumed) array
12293                                                    size. */
12294             error = TRUE;
12295           break;
12296
12297         default:
12298           error = TRUE;
12299           break;
12300         }
12301       break;
12302
12303     case FFEEXPR_contextFILEFORMAT:
12304       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12305               : ffeinfo_basictype (info))
12306         {
12307         case FFEINFO_basictypeINTEGER:
12308           error = (expr == NULL)
12309             || ((ffeinfo_rank (info) != 0) ?
12310                 ffe_is_pedantic ()      /* F77 C5. */
12311                 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12312             || (ffebld_op (expr) != FFEBLD_opSYMTER);
12313           break;
12314
12315         case FFEINFO_basictypeLOGICAL:
12316         case FFEINFO_basictypeREAL:
12317         case FFEINFO_basictypeCOMPLEX:
12318           /* F77 C5 -- must be an array of hollerith.  */
12319           error
12320             = ffe_is_pedantic ()
12321               || (ffeinfo_rank (info) == 0);
12322           break;
12323
12324         case FFEINFO_basictypeCHARACTER:
12325           if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12326               || ((ffeinfo_rank (info) != 0)
12327                   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12328                       || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12329                       || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12330                           == FFEBLD_opSTAR))))  /* Bad if
12331                                                    non-default-kindtype
12332                                                    character expr, or if
12333                                                    array that is not a SYMTER
12334                                                    (can't happen yet, I
12335                                                    think), or has a NULL or
12336                                                    STAR (assumed) array
12337                                                    size. */
12338             error = TRUE;
12339           else
12340             error = FALSE;
12341           break;
12342
12343         default:
12344           error = TRUE;
12345           break;
12346         }
12347       break;
12348
12349     case FFEEXPR_contextLOC_:
12350       /* See also ffeintrin_check_loc_.  */
12351       if ((expr == NULL)
12352           || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12353           || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12354               && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12355               && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12356         error = TRUE;
12357       break;
12358
12359     default:
12360       error = FALSE;
12361       break;
12362     }
12363
12364   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12365     {
12366       ffebad_start (FFEBAD_EXPR_WRONG);
12367       ffebad_here (0, ffelex_token_where_line (ft),
12368                    ffelex_token_where_column (ft));
12369       ffebad_finish ();
12370       expr = ffebld_new_any ();
12371       ffebld_set_info (expr, ffeinfo_new_any ());
12372     }
12373
12374   callback = ffeexpr_stack_->callback;
12375   s = ffeexpr_stack_->previous;
12376   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12377                   sizeof (*ffeexpr_stack_));
12378   ffeexpr_stack_ = s;
12379   next = (ffelexHandler) (*callback) (ft, expr, t);
12380   ffelex_token_kill (ft);
12381   return (ffelexHandler) next;
12382 }
12383
12384 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12385
12386    ffebld expr;
12387    expr = ffeexpr_finished_ambig_(expr);
12388
12389    Replicates a bit of ffeexpr_finished_'s task when in a context
12390    of UNIT or FORMAT.  */
12391
12392 static ffebld
12393 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12394 {
12395   ffeinfo info = ffebld_info (expr);
12396   bool error;
12397
12398   switch (ffeexpr_stack_->context)
12399     {
12400     case FFEEXPR_contextFILENUMAMBIG:   /* Same as FILENUM in _finished_. */
12401       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12402               : ffeinfo_basictype (info))
12403         {
12404         case FFEINFO_basictypeLOGICAL:
12405           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12406              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12407                                   FFEEXPR_contextLET);
12408           /* Fall through. */
12409         case FFEINFO_basictypeREAL:
12410         case FFEINFO_basictypeCOMPLEX:
12411           if (ffe_is_pedantic ())
12412             {
12413               error = TRUE;
12414               break;
12415             }
12416           /* Fall through. */
12417         case FFEINFO_basictypeINTEGER:
12418         case FFEINFO_basictypeHOLLERITH:
12419         case FFEINFO_basictypeTYPELESS:
12420           error = FALSE;
12421           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12422              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12423                                   FFEEXPR_contextLET);
12424           break;
12425
12426         default:
12427           error = TRUE;
12428           break;
12429         }
12430       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12431         error = TRUE;
12432       break;
12433
12434     case FFEEXPR_contextFILEUNITAMBIG:  /* Same as FILEUNIT in _finished_. */
12435       if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12436         {
12437           error = FALSE;
12438           break;
12439         }
12440       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12441               : ffeinfo_basictype (info))
12442         {
12443         case FFEINFO_basictypeLOGICAL:
12444           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12445              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12446                                   FFEEXPR_contextLET);
12447           /* Fall through. */
12448         case FFEINFO_basictypeREAL:
12449         case FFEINFO_basictypeCOMPLEX:
12450           if (ffe_is_pedantic ())
12451             {
12452               error = TRUE;
12453               break;
12454             }
12455           /* Fall through. */
12456         case FFEINFO_basictypeINTEGER:
12457         case FFEINFO_basictypeHOLLERITH:
12458         case FFEINFO_basictypeTYPELESS:
12459           error = (ffeinfo_rank (info) != 0);
12460           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12461              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12462                                   FFEEXPR_contextLET);
12463           break;
12464
12465         case FFEINFO_basictypeCHARACTER:
12466           switch (ffebld_op (expr))
12467             {                   /* As if _lhs had been called instead of
12468                                    _rhs. */
12469             case FFEBLD_opSYMTER:
12470               error
12471                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12472               break;
12473
12474             case FFEBLD_opSUBSTR:
12475               error = (ffeinfo_where (ffebld_info (expr))
12476                        == FFEINFO_whereCONSTANT_SUBOBJECT);
12477               break;
12478
12479             case FFEBLD_opARRAYREF:
12480               error = FALSE;
12481               break;
12482
12483             default:
12484               error = TRUE;
12485               break;
12486             }
12487           break;
12488
12489         default:
12490           error = TRUE;
12491           break;
12492         }
12493       break;
12494
12495     default:
12496       assert ("bad context" == NULL);
12497       error = TRUE;
12498       break;
12499     }
12500
12501   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12502     {
12503       ffebad_start (FFEBAD_EXPR_WRONG);
12504       ffebad_here (0, ffelex_token_where_line (ft),
12505                    ffelex_token_where_column (ft));
12506       ffebad_finish ();
12507       expr = ffebld_new_any ();
12508       ffebld_set_info (expr, ffeinfo_new_any ());
12509     }
12510
12511   return expr;
12512 }
12513
12514 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12515
12516    Return a pointer to this function to the lexer (ffelex), which will
12517    invoke it for the next token.
12518
12519    Basically a smaller version of _rhs_; keep them both in sync, of course.  */
12520
12521 static ffelexHandler
12522 ffeexpr_token_lhs_ (ffelexToken t)
12523 {
12524
12525   /* When changing the list of valid initial lhs tokens, check whether to
12526      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12527      READ (expr) <token> case -- it assumes it knows which tokens <token> can
12528      be to indicate an lhs (or implied DO), which right now is the set
12529      {NAME,OPEN_PAREN}.
12530
12531      This comment also appears in ffeexpr_token_first_lhs_. */
12532
12533   switch (ffelex_token_type (t))
12534     {
12535     case FFELEX_typeNAME:
12536     case FFELEX_typeNAMES:
12537       ffeexpr_tokens_[0] = ffelex_token_use (t);
12538       return (ffelexHandler) ffeexpr_token_name_lhs_;
12539
12540     default:
12541       return (ffelexHandler) ffeexpr_finished_ (t);
12542     }
12543 }
12544
12545 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12546
12547    Return a pointer to this function to the lexer (ffelex), which will
12548    invoke it for the next token.
12549
12550    The initial state and the post-binary-operator state are the same and
12551    both handled here, with the expression stack used to distinguish
12552    between them.  Binary operators are invalid here; unary operators,
12553    constants, subexpressions, and name references are valid.  */
12554
12555 static ffelexHandler
12556 ffeexpr_token_rhs_ (ffelexToken t)
12557 {
12558   ffeexprExpr_ e;
12559
12560   switch (ffelex_token_type (t))
12561     {
12562     case FFELEX_typeQUOTE:
12563       if (ffe_is_vxt ())
12564         {
12565           ffeexpr_tokens_[0] = ffelex_token_use (t);
12566           return (ffelexHandler) ffeexpr_token_quote_;
12567         }
12568       ffeexpr_tokens_[0] = ffelex_token_use (t);
12569       ffelex_set_expecting_hollerith (-1, '\"',
12570                                       ffelex_token_where_line (t),
12571                                       ffelex_token_where_column (t));
12572       /* Don't have to unset this one. */
12573       return (ffelexHandler) ffeexpr_token_apostrophe_;
12574
12575     case FFELEX_typeAPOSTROPHE:
12576       ffeexpr_tokens_[0] = ffelex_token_use (t);
12577       ffelex_set_expecting_hollerith (-1, '\'',
12578                                       ffelex_token_where_line (t),
12579                                       ffelex_token_where_column (t));
12580       /* Don't have to unset this one. */
12581       return (ffelexHandler) ffeexpr_token_apostrophe_;
12582
12583     case FFELEX_typePERCENT:
12584       ffeexpr_tokens_[0] = ffelex_token_use (t);
12585       return (ffelexHandler) ffeexpr_token_percent_;
12586
12587     case FFELEX_typeOPEN_PAREN:
12588       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12589       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12590                                           FFEEXPR_contextPAREN_,
12591                                           ffeexpr_cb_close_paren_c_);
12592
12593     case FFELEX_typePLUS:
12594       e = ffeexpr_expr_new_ ();
12595       e->type = FFEEXPR_exprtypeUNARY_;
12596       e->token = ffelex_token_use (t);
12597       e->u.operator.op = FFEEXPR_operatorADD_;
12598       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12599       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12600       ffeexpr_exprstack_push_unary_ (e);
12601       return (ffelexHandler) ffeexpr_token_rhs_;
12602
12603     case FFELEX_typeMINUS:
12604       e = ffeexpr_expr_new_ ();
12605       e->type = FFEEXPR_exprtypeUNARY_;
12606       e->token = ffelex_token_use (t);
12607       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12608       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12609       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12610       ffeexpr_exprstack_push_unary_ (e);
12611       return (ffelexHandler) ffeexpr_token_rhs_;
12612
12613     case FFELEX_typePERIOD:
12614       ffeexpr_tokens_[0] = ffelex_token_use (t);
12615       return (ffelexHandler) ffeexpr_token_period_;
12616
12617     case FFELEX_typeNUMBER:
12618       ffeexpr_tokens_[0] = ffelex_token_use (t);
12619       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12620       if (ffeexpr_hollerith_count_ > 0)
12621         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12622                                         '\0',
12623                                         ffelex_token_where_line (t),
12624                                         ffelex_token_where_column (t));
12625       return (ffelexHandler) ffeexpr_token_number_;
12626
12627     case FFELEX_typeNAME:
12628     case FFELEX_typeNAMES:
12629       ffeexpr_tokens_[0] = ffelex_token_use (t);
12630       switch (ffeexpr_stack_->context)
12631         {
12632         case FFEEXPR_contextACTUALARG_:
12633         case FFEEXPR_contextINDEXORACTUALARG_:
12634         case FFEEXPR_contextSFUNCDEFACTUALARG_:
12635         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12636           return (ffelexHandler) ffeexpr_token_name_arg_;
12637
12638         default:
12639           return (ffelexHandler) ffeexpr_token_name_rhs_;
12640         }
12641
12642     case FFELEX_typeASTERISK:
12643     case FFELEX_typeSLASH:
12644     case FFELEX_typePOWER:
12645     case FFELEX_typeCONCAT:
12646     case FFELEX_typeREL_EQ:
12647     case FFELEX_typeREL_NE:
12648     case FFELEX_typeREL_LE:
12649     case FFELEX_typeREL_GE:
12650       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12651         {
12652           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12653           ffebad_finish ();
12654         }
12655       return (ffelexHandler) ffeexpr_token_rhs_;
12656
12657 #if 0
12658     case FFELEX_typeEQUALS:
12659     case FFELEX_typePOINTS:
12660     case FFELEX_typeCLOSE_ANGLE:
12661     case FFELEX_typeCLOSE_PAREN:
12662     case FFELEX_typeCOMMA:
12663     case FFELEX_typeCOLON:
12664     case FFELEX_typeEOS:
12665     case FFELEX_typeSEMICOLON:
12666 #endif
12667     default:
12668       return (ffelexHandler) ffeexpr_finished_ (t);
12669     }
12670 }
12671
12672 /* ffeexpr_token_period_ -- Rhs PERIOD
12673
12674    Return a pointer to this function to the lexer (ffelex), which will
12675    invoke it for the next token.
12676
12677    Handle a period detected at rhs (expecting unary op or operand) state.
12678    Must begin a floating-point value (as in .12) or a dot-dot name, of
12679    which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
12680    valid names represent binary operators, which are invalid here because
12681    there isn't an operand at the top of the stack.  */
12682
12683 static ffelexHandler
12684 ffeexpr_token_period_ (ffelexToken t)
12685 {
12686   switch (ffelex_token_type (t))
12687     {
12688     case FFELEX_typeNAME:
12689     case FFELEX_typeNAMES:
12690       ffeexpr_current_dotdot_ = ffestr_other (t);
12691       switch (ffeexpr_current_dotdot_)
12692         {
12693         case FFESTR_otherNone:
12694           if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12695             {
12696               ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12697                            ffelex_token_where_column (ffeexpr_tokens_[0]));
12698               ffebad_finish ();
12699             }
12700           ffelex_token_kill (ffeexpr_tokens_[0]);
12701           return (ffelexHandler) ffeexpr_token_rhs_ (t);
12702
12703         case FFESTR_otherTRUE:
12704         case FFESTR_otherFALSE:
12705         case FFESTR_otherNOT:
12706           ffeexpr_tokens_[1] = ffelex_token_use (t);
12707           return (ffelexHandler) ffeexpr_token_end_period_;
12708
12709         default:
12710           if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12711             {
12712               ffebad_here (0, ffelex_token_where_line (t),
12713                            ffelex_token_where_column (t));
12714               ffebad_finish ();
12715             }
12716           ffelex_token_kill (ffeexpr_tokens_[0]);
12717           return (ffelexHandler) ffeexpr_token_swallow_period_;
12718         }
12719       break;                    /* Nothing really reaches here. */
12720
12721     case FFELEX_typeNUMBER:
12722       ffeexpr_tokens_[1] = ffelex_token_use (t);
12723       return (ffelexHandler) ffeexpr_token_real_;
12724
12725     default:
12726       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12727         {
12728           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12729                        ffelex_token_where_column (ffeexpr_tokens_[0]));
12730           ffebad_finish ();
12731         }
12732       ffelex_token_kill (ffeexpr_tokens_[0]);
12733       return (ffelexHandler) ffeexpr_token_rhs_ (t);
12734     }
12735 }
12736
12737 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12738
12739    Return a pointer to this function to the lexer (ffelex), which will
12740    invoke it for the next token.
12741
12742    Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12743    or operator) state.  If period isn't found, issue a diagnostic but
12744    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
12745    dotdot representation of the name in between the two PERIOD tokens.  */
12746
12747 static ffelexHandler
12748 ffeexpr_token_end_period_ (ffelexToken t)
12749 {
12750   ffeexprExpr_ e;
12751
12752   if (ffelex_token_type (t) != FFELEX_typePERIOD)
12753     {
12754       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12755         {
12756           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12757                        ffelex_token_where_column (ffeexpr_tokens_[0]));
12758           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12759           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12760           ffebad_finish ();
12761         }
12762     }
12763
12764   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill "NOT"/"TRUE"/"FALSE"
12765                                                    token. */
12766
12767   e = ffeexpr_expr_new_ ();
12768   e->token = ffeexpr_tokens_[0];
12769
12770   switch (ffeexpr_current_dotdot_)
12771     {
12772     case FFESTR_otherNOT:
12773       e->type = FFEEXPR_exprtypeUNARY_;
12774       e->u.operator.op = FFEEXPR_operatorNOT_;
12775       e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12776       e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12777       ffeexpr_exprstack_push_unary_ (e);
12778       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12779         return (ffelexHandler) ffeexpr_token_rhs_ (t);
12780       return (ffelexHandler) ffeexpr_token_rhs_;
12781
12782     case FFESTR_otherTRUE:
12783       e->type = FFEEXPR_exprtypeOPERAND_;
12784       e->u.operand
12785         = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12786       ffebld_set_info (e->u.operand,
12787       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12788                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12789       ffeexpr_exprstack_push_operand_ (e);
12790       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12791         return (ffelexHandler) ffeexpr_token_binary_ (t);
12792       return (ffelexHandler) ffeexpr_token_binary_;
12793
12794     case FFESTR_otherFALSE:
12795       e->type = FFEEXPR_exprtypeOPERAND_;
12796       e->u.operand
12797         = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12798       ffebld_set_info (e->u.operand,
12799       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12800                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12801       ffeexpr_exprstack_push_operand_ (e);
12802       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12803         return (ffelexHandler) ffeexpr_token_binary_ (t);
12804       return (ffelexHandler) ffeexpr_token_binary_;
12805
12806     default:
12807       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12808       exit (0);
12809       return NULL;
12810     }
12811 }
12812
12813 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12814
12815    Return a pointer to this function to the lexer (ffelex), which will
12816    invoke it for the next token.
12817
12818    A diagnostic has already been issued; just swallow a period if there is
12819    one, then continue with ffeexpr_token_rhs_.  */
12820
12821 static ffelexHandler
12822 ffeexpr_token_swallow_period_ (ffelexToken t)
12823 {
12824   if (ffelex_token_type (t) != FFELEX_typePERIOD)
12825     return (ffelexHandler) ffeexpr_token_rhs_ (t);
12826
12827   return (ffelexHandler) ffeexpr_token_rhs_;
12828 }
12829
12830 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12831
12832    Return a pointer to this function to the lexer (ffelex), which will
12833    invoke it for the next token.
12834
12835    After a period and a string of digits, check next token for possible
12836    exponent designation (D, E, or Q as first/only character) and continue
12837    real-number handling accordingly.  Else form basic real constant, push
12838    onto expression stack, and enter binary state using current token (which,
12839    if it is a name not beginning with D, E, or Q, will certainly result
12840    in an error, but that's not for this routine to deal with).  */
12841
12842 static ffelexHandler
12843 ffeexpr_token_real_ (ffelexToken t)
12844 {
12845   char d;
12846   const char *p;
12847
12848   if (((ffelex_token_type (t) != FFELEX_typeNAME)
12849        && (ffelex_token_type (t) != FFELEX_typeNAMES))
12850       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12851                                      'D', 'd')
12852              || ffesrc_char_match_init (d, 'E', 'e')
12853              || ffesrc_char_match_init (d, 'Q', 'q')))
12854            && ffeexpr_isdigits_ (++p)))
12855     {
12856 #if 0
12857       /* This code has been removed because it seems inconsistent to
12858          produce a diagnostic in this case, but not all of the other
12859          ones that look for an exponent and cannot recognize one.  */
12860       if (((ffelex_token_type (t) == FFELEX_typeNAME)
12861            || (ffelex_token_type (t) == FFELEX_typeNAMES))
12862           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12863         {
12864           char bad[2];
12865
12866           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12867           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12868                        ffelex_token_where_column (ffeexpr_tokens_[0]));
12869           bad[0] = *(p - 1);
12870           bad[1] = '\0';
12871           ffebad_string (bad);
12872           ffebad_finish ();
12873         }
12874 #endif
12875       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12876                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12877                                  NULL, NULL, NULL);
12878
12879       ffelex_token_kill (ffeexpr_tokens_[0]);
12880       ffelex_token_kill (ffeexpr_tokens_[1]);
12881       return (ffelexHandler) ffeexpr_token_binary_ (t);
12882     }
12883
12884   /* Just exponent character by itself?  In which case, PLUS or MINUS must
12885      surely be next, followed by a NUMBER token. */
12886
12887   if (*p == '\0')
12888     {
12889       ffeexpr_tokens_[2] = ffelex_token_use (t);
12890       return (ffelexHandler) ffeexpr_token_real_exponent_;
12891     }
12892
12893   ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12894                              t, NULL, NULL);
12895
12896   ffelex_token_kill (ffeexpr_tokens_[0]);
12897   ffelex_token_kill (ffeexpr_tokens_[1]);
12898   return (ffelexHandler) ffeexpr_token_binary_;
12899 }
12900
12901 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12902
12903    Return a pointer to this function to the lexer (ffelex), which will
12904    invoke it for the next token.
12905
12906    Ensures this token is PLUS or MINUS, preserves it, goes to final state
12907    for real number (exponent digits).  Else issues diagnostic, assumes a
12908    zero exponent field for number, passes token on to binary state as if
12909    previous token had been "E0" instead of "E", for example.  */
12910
12911 static ffelexHandler
12912 ffeexpr_token_real_exponent_ (ffelexToken t)
12913 {
12914   if ((ffelex_token_type (t) != FFELEX_typePLUS)
12915       && (ffelex_token_type (t) != FFELEX_typeMINUS))
12916     {
12917       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12918         {
12919           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12920                        ffelex_token_where_column (ffeexpr_tokens_[2]));
12921           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12922           ffebad_finish ();
12923         }
12924
12925       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12926                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12927                                  NULL, NULL, NULL);
12928
12929       ffelex_token_kill (ffeexpr_tokens_[0]);
12930       ffelex_token_kill (ffeexpr_tokens_[1]);
12931       ffelex_token_kill (ffeexpr_tokens_[2]);
12932       return (ffelexHandler) ffeexpr_token_binary_ (t);
12933     }
12934
12935   ffeexpr_tokens_[3] = ffelex_token_use (t);
12936   return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12937 }
12938
12939 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12940
12941    Return a pointer to this function to the lexer (ffelex), which will
12942    invoke it for the next token.
12943
12944    Make sure token is a NUMBER, make a real constant out of all we have and
12945    push it onto the expression stack.  Else issue diagnostic and pretend
12946    exponent field was a zero.  */
12947
12948 static ffelexHandler
12949 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12950 {
12951   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12952     {
12953       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12954         {
12955           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12956                        ffelex_token_where_column (ffeexpr_tokens_[2]));
12957           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12958           ffebad_finish ();
12959         }
12960
12961       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12962                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12963                                  NULL, NULL, NULL);
12964
12965       ffelex_token_kill (ffeexpr_tokens_[0]);
12966       ffelex_token_kill (ffeexpr_tokens_[1]);
12967       ffelex_token_kill (ffeexpr_tokens_[2]);
12968       ffelex_token_kill (ffeexpr_tokens_[3]);
12969       return (ffelexHandler) ffeexpr_token_binary_ (t);
12970     }
12971
12972   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12973                  ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12974                              ffeexpr_tokens_[3], t);
12975
12976   ffelex_token_kill (ffeexpr_tokens_[0]);
12977   ffelex_token_kill (ffeexpr_tokens_[1]);
12978   ffelex_token_kill (ffeexpr_tokens_[2]);
12979   ffelex_token_kill (ffeexpr_tokens_[3]);
12980   return (ffelexHandler) ffeexpr_token_binary_;
12981 }
12982
12983 /* ffeexpr_token_number_ -- Rhs NUMBER
12984
12985    Return a pointer to this function to the lexer (ffelex), which will
12986    invoke it for the next token.
12987
12988    If the token is a period, we may have a floating-point number, or an
12989    integer followed by a dotdot binary operator.  If the token is a name
12990    beginning with D, E, or Q, we definitely have a floating-point number.
12991    If the token is a hollerith constant, that's what we've got, so push
12992    it onto the expression stack and continue with the binary state.
12993
12994    Otherwise, we have an integer followed by something the binary state
12995    should be able to swallow.  */
12996
12997 static ffelexHandler
12998 ffeexpr_token_number_ (ffelexToken t)
12999 {
13000   ffeexprExpr_ e;
13001   ffeinfo ni;
13002   char d;
13003   const char *p;
13004
13005   if (ffeexpr_hollerith_count_ > 0)
13006     ffelex_set_expecting_hollerith (0, '\0',
13007                                     ffewhere_line_unknown (),
13008                                     ffewhere_column_unknown ());
13009
13010   /* See if we've got a floating-point number here. */
13011
13012   switch (ffelex_token_type (t))
13013     {
13014     case FFELEX_typeNAME:
13015     case FFELEX_typeNAMES:
13016       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13017                                    'D', 'd')
13018            || ffesrc_char_match_init (d, 'E', 'e')
13019            || ffesrc_char_match_init (d, 'Q', 'q'))
13020           && ffeexpr_isdigits_ (++p))
13021         {
13022
13023           /* Just exponent character by itself?  In which case, PLUS or MINUS
13024              must surely be next, followed by a NUMBER token. */
13025
13026           if (*p == '\0')
13027             {
13028               ffeexpr_tokens_[1] = ffelex_token_use (t);
13029               return (ffelexHandler) ffeexpr_token_number_exponent_;
13030             }
13031           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13032                                      NULL, NULL);
13033
13034           ffelex_token_kill (ffeexpr_tokens_[0]);
13035           return (ffelexHandler) ffeexpr_token_binary_;
13036         }
13037       break;
13038
13039     case FFELEX_typePERIOD:
13040       ffeexpr_tokens_[1] = ffelex_token_use (t);
13041       return (ffelexHandler) ffeexpr_token_number_period_;
13042
13043     case FFELEX_typeHOLLERITH:
13044       e = ffeexpr_expr_new_ ();
13045       e->type = FFEEXPR_exprtypeOPERAND_;
13046       e->token = ffeexpr_tokens_[0];
13047       e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13048       ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13049                         0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13050                         ffelex_token_length (t));
13051       ffebld_set_info (e->u.operand, ni);
13052       ffeexpr_exprstack_push_operand_ (e);
13053       return (ffelexHandler) ffeexpr_token_binary_;
13054
13055     default:
13056       break;
13057     }
13058
13059   /* Nothing specific we were looking for, so make an integer and pass the
13060      current token to the binary state. */
13061
13062   ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13063                              NULL, NULL, NULL);
13064   return (ffelexHandler) ffeexpr_token_binary_ (t);
13065 }
13066
13067 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13068
13069    Return a pointer to this function to the lexer (ffelex), which will
13070    invoke it for the next token.
13071
13072    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13073    for real number (exponent digits).  Else treats number as integer, passes
13074    name to binary, passes current token to subsequent handler.  */
13075
13076 static ffelexHandler
13077 ffeexpr_token_number_exponent_ (ffelexToken t)
13078 {
13079   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13080       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13081     {
13082       ffeexprExpr_ e;
13083       ffelexHandler nexthandler;
13084
13085       e = ffeexpr_expr_new_ ();
13086       e->type = FFEEXPR_exprtypeOPERAND_;
13087       e->token = ffeexpr_tokens_[0];
13088       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13089                                         (ffeexpr_tokens_[0]));
13090       ffebld_set_info (e->u.operand,
13091       ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13092                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13093       ffeexpr_exprstack_push_operand_ (e);
13094       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13095       ffelex_token_kill (ffeexpr_tokens_[1]);
13096       return (ffelexHandler) (*nexthandler) (t);
13097     }
13098
13099   ffeexpr_tokens_[2] = ffelex_token_use (t);
13100   return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13101 }
13102
13103 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13104
13105    Return a pointer to this function to the lexer (ffelex), which will
13106    invoke it for the next token.
13107
13108    Make sure token is a NUMBER, make a real constant out of all we have and
13109    push it onto the expression stack.  Else issue diagnostic and pretend
13110    exponent field was a zero.  */
13111
13112 static ffelexHandler
13113 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13114 {
13115   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13116     {
13117       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13118         {
13119           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13120                        ffelex_token_where_column (ffeexpr_tokens_[1]));
13121           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13122           ffebad_finish ();
13123         }
13124
13125       ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13126                                  ffeexpr_tokens_[0], NULL, NULL,
13127                                  ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13128                                  NULL);
13129
13130       ffelex_token_kill (ffeexpr_tokens_[0]);
13131       ffelex_token_kill (ffeexpr_tokens_[1]);
13132       ffelex_token_kill (ffeexpr_tokens_[2]);
13133       return (ffelexHandler) ffeexpr_token_binary_ (t);
13134     }
13135
13136   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13137                              ffeexpr_tokens_[0], NULL, NULL,
13138                              ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13139
13140   ffelex_token_kill (ffeexpr_tokens_[0]);
13141   ffelex_token_kill (ffeexpr_tokens_[1]);
13142   ffelex_token_kill (ffeexpr_tokens_[2]);
13143   return (ffelexHandler) ffeexpr_token_binary_;
13144 }
13145
13146 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13147
13148    Return a pointer to this function to the lexer (ffelex), which will
13149    invoke it for the next token.
13150
13151    Handle a period detected following a number at rhs state.  Must begin a
13152    floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
13153
13154 static ffelexHandler
13155 ffeexpr_token_number_period_ (ffelexToken t)
13156 {
13157   ffeexprExpr_ e;
13158   ffelexHandler nexthandler;
13159   const char *p;
13160   char d;
13161
13162   switch (ffelex_token_type (t))
13163     {
13164     case FFELEX_typeNAME:
13165     case FFELEX_typeNAMES:
13166       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13167                                    'D', 'd')
13168            || ffesrc_char_match_init (d, 'E', 'e')
13169            || ffesrc_char_match_init (d, 'Q', 'q'))
13170           && ffeexpr_isdigits_ (++p))
13171         {
13172
13173           /* Just exponent character by itself?  In which case, PLUS or MINUS
13174              must surely be next, followed by a NUMBER token. */
13175
13176           if (*p == '\0')
13177             {
13178               ffeexpr_tokens_[2] = ffelex_token_use (t);
13179               return (ffelexHandler) ffeexpr_token_number_per_exp_;
13180             }
13181           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13182                                      ffeexpr_tokens_[1], NULL, t, NULL,
13183                                      NULL);
13184
13185           ffelex_token_kill (ffeexpr_tokens_[0]);
13186           ffelex_token_kill (ffeexpr_tokens_[1]);
13187           return (ffelexHandler) ffeexpr_token_binary_;
13188         }
13189       /* A name not representing an exponent, so assume it will be something
13190          like EQ, make an integer from the number, pass the period to binary
13191          state and the current token to the resulting state. */
13192
13193       e = ffeexpr_expr_new_ ();
13194       e->type = FFEEXPR_exprtypeOPERAND_;
13195       e->token = ffeexpr_tokens_[0];
13196       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13197                                         (ffeexpr_tokens_[0]));
13198       ffebld_set_info (e->u.operand,
13199                        ffeinfo_new (FFEINFO_basictypeINTEGER,
13200                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
13201                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13202                                     FFETARGET_charactersizeNONE));
13203       ffeexpr_exprstack_push_operand_ (e);
13204       nexthandler = (ffelexHandler) ffeexpr_token_binary_
13205         (ffeexpr_tokens_[1]);
13206       ffelex_token_kill (ffeexpr_tokens_[1]);
13207       return (ffelexHandler) (*nexthandler) (t);
13208
13209     case FFELEX_typeNUMBER:
13210       ffeexpr_tokens_[2] = ffelex_token_use (t);
13211       return (ffelexHandler) ffeexpr_token_number_real_;
13212
13213     default:
13214       break;
13215     }
13216
13217   /* Nothing specific we were looking for, so make a real number and pass the
13218      period and then the current token to the binary state. */
13219
13220   ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13221                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13222                              NULL, NULL, NULL, NULL);
13223
13224   ffelex_token_kill (ffeexpr_tokens_[0]);
13225   ffelex_token_kill (ffeexpr_tokens_[1]);
13226   return (ffelexHandler) ffeexpr_token_binary_ (t);
13227 }
13228
13229 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13230
13231    Return a pointer to this function to the lexer (ffelex), which will
13232    invoke it for the next token.
13233
13234    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13235    for real number (exponent digits).  Else treats number as real, passes
13236    name to binary, passes current token to subsequent handler.  */
13237
13238 static ffelexHandler
13239 ffeexpr_token_number_per_exp_ (ffelexToken t)
13240 {
13241   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13242       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13243     {
13244       ffelexHandler nexthandler;
13245
13246       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13247                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13248                                  NULL, NULL, NULL, NULL);
13249
13250       ffelex_token_kill (ffeexpr_tokens_[0]);
13251       ffelex_token_kill (ffeexpr_tokens_[1]);
13252       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13253       ffelex_token_kill (ffeexpr_tokens_[2]);
13254       return (ffelexHandler) (*nexthandler) (t);
13255     }
13256
13257   ffeexpr_tokens_[3] = ffelex_token_use (t);
13258   return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13259 }
13260
13261 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13262
13263    Return a pointer to this function to the lexer (ffelex), which will
13264    invoke it for the next token.
13265
13266    After a number, period, and number, check next token for possible
13267    exponent designation (D, E, or Q as first/only character) and continue
13268    real-number handling accordingly.  Else form basic real constant, push
13269    onto expression stack, and enter binary state using current token (which,
13270    if it is a name not beginning with D, E, or Q, will certainly result
13271    in an error, but that's not for this routine to deal with).  */
13272
13273 static ffelexHandler
13274 ffeexpr_token_number_real_ (ffelexToken t)
13275 {
13276   char d;
13277   const char *p;
13278
13279   if (((ffelex_token_type (t) != FFELEX_typeNAME)
13280        && (ffelex_token_type (t) != FFELEX_typeNAMES))
13281       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13282                                      'D', 'd')
13283              || ffesrc_char_match_init (d, 'E', 'e')
13284              || ffesrc_char_match_init (d, 'Q', 'q')))
13285            && ffeexpr_isdigits_ (++p)))
13286     {
13287 #if 0
13288       /* This code has been removed because it seems inconsistent to
13289          produce a diagnostic in this case, but not all of the other
13290          ones that look for an exponent and cannot recognize one.  */
13291       if (((ffelex_token_type (t) == FFELEX_typeNAME)
13292            || (ffelex_token_type (t) == FFELEX_typeNAMES))
13293           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13294         {
13295           char bad[2];
13296
13297           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13298           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13299                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13300           bad[0] = *(p - 1);
13301           bad[1] = '\0';
13302           ffebad_string (bad);
13303           ffebad_finish ();
13304         }
13305 #endif
13306       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13307                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13308                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
13309
13310       ffelex_token_kill (ffeexpr_tokens_[0]);
13311       ffelex_token_kill (ffeexpr_tokens_[1]);
13312       ffelex_token_kill (ffeexpr_tokens_[2]);
13313       return (ffelexHandler) ffeexpr_token_binary_ (t);
13314     }
13315
13316   /* Just exponent character by itself?  In which case, PLUS or MINUS must
13317      surely be next, followed by a NUMBER token. */
13318
13319   if (*p == '\0')
13320     {
13321       ffeexpr_tokens_[3] = ffelex_token_use (t);
13322       return (ffelexHandler) ffeexpr_token_number_real_exp_;
13323     }
13324
13325   ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13326                              ffeexpr_tokens_[2], t, NULL, NULL);
13327
13328   ffelex_token_kill (ffeexpr_tokens_[0]);
13329   ffelex_token_kill (ffeexpr_tokens_[1]);
13330   ffelex_token_kill (ffeexpr_tokens_[2]);
13331   return (ffelexHandler) ffeexpr_token_binary_;
13332 }
13333
13334 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13335
13336    Return a pointer to this function to the lexer (ffelex), which will
13337    invoke it for the next token.
13338
13339    Make sure token is a NUMBER, make a real constant out of all we have and
13340    push it onto the expression stack.  Else issue diagnostic and pretend
13341    exponent field was a zero.  */
13342
13343 static ffelexHandler
13344 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13345 {
13346   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13347     {
13348       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13349         {
13350           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13351                        ffelex_token_where_column (ffeexpr_tokens_[2]));
13352           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13353           ffebad_finish ();
13354         }
13355
13356       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13357                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13358                                  NULL, NULL, NULL, NULL);
13359
13360       ffelex_token_kill (ffeexpr_tokens_[0]);
13361       ffelex_token_kill (ffeexpr_tokens_[1]);
13362       ffelex_token_kill (ffeexpr_tokens_[2]);
13363       ffelex_token_kill (ffeexpr_tokens_[3]);
13364       return (ffelexHandler) ffeexpr_token_binary_ (t);
13365     }
13366
13367   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13368                              ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13369                              ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13370
13371   ffelex_token_kill (ffeexpr_tokens_[0]);
13372   ffelex_token_kill (ffeexpr_tokens_[1]);
13373   ffelex_token_kill (ffeexpr_tokens_[2]);
13374   ffelex_token_kill (ffeexpr_tokens_[3]);
13375   return (ffelexHandler) ffeexpr_token_binary_;
13376 }
13377
13378 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13379
13380    Return a pointer to this function to the lexer (ffelex), which will
13381    invoke it for the next token.
13382
13383    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13384    for real number (exponent digits).  Else issues diagnostic, assumes a
13385    zero exponent field for number, passes token on to binary state as if
13386    previous token had been "E0" instead of "E", for example.  */
13387
13388 static ffelexHandler
13389 ffeexpr_token_number_real_exp_ (ffelexToken t)
13390 {
13391   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13392       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13393     {
13394       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13395         {
13396           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13397                        ffelex_token_where_column (ffeexpr_tokens_[3]));
13398           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13399           ffebad_finish ();
13400         }
13401
13402       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13403                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13404                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
13405
13406       ffelex_token_kill (ffeexpr_tokens_[0]);
13407       ffelex_token_kill (ffeexpr_tokens_[1]);
13408       ffelex_token_kill (ffeexpr_tokens_[2]);
13409       ffelex_token_kill (ffeexpr_tokens_[3]);
13410       return (ffelexHandler) ffeexpr_token_binary_ (t);
13411     }
13412
13413   ffeexpr_tokens_[4] = ffelex_token_use (t);
13414   return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13415 }
13416
13417 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13418                                   PLUS/MINUS
13419
13420    Return a pointer to this function to the lexer (ffelex), which will
13421    invoke it for the next token.
13422
13423    Make sure token is a NUMBER, make a real constant out of all we have and
13424    push it onto the expression stack.  Else issue diagnostic and pretend
13425    exponent field was a zero.  */
13426
13427 static ffelexHandler
13428 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13429 {
13430   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13431     {
13432       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13433         {
13434           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13435                        ffelex_token_where_column (ffeexpr_tokens_[3]));
13436           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13437           ffebad_finish ();
13438         }
13439
13440       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13441                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13442                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
13443
13444       ffelex_token_kill (ffeexpr_tokens_[0]);
13445       ffelex_token_kill (ffeexpr_tokens_[1]);
13446       ffelex_token_kill (ffeexpr_tokens_[2]);
13447       ffelex_token_kill (ffeexpr_tokens_[3]);
13448       ffelex_token_kill (ffeexpr_tokens_[4]);
13449       return (ffelexHandler) ffeexpr_token_binary_ (t);
13450     }
13451
13452   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13453                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13454                              ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13455                              ffeexpr_tokens_[4], t);
13456
13457   ffelex_token_kill (ffeexpr_tokens_[0]);
13458   ffelex_token_kill (ffeexpr_tokens_[1]);
13459   ffelex_token_kill (ffeexpr_tokens_[2]);
13460   ffelex_token_kill (ffeexpr_tokens_[3]);
13461   ffelex_token_kill (ffeexpr_tokens_[4]);
13462   return (ffelexHandler) ffeexpr_token_binary_;
13463 }
13464
13465 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13466
13467    Return a pointer to this function to the lexer (ffelex), which will
13468    invoke it for the next token.
13469
13470    The possibility of a binary operator is handled here, meaning the previous
13471    token was an operand.  */
13472
13473 static ffelexHandler
13474 ffeexpr_token_binary_ (ffelexToken t)
13475 {
13476   ffeexprExpr_ e;
13477
13478   if (!ffeexpr_stack_->is_rhs)
13479     return (ffelexHandler) ffeexpr_finished_ (t);       /* For now. */
13480
13481   switch (ffelex_token_type (t))
13482     {
13483     case FFELEX_typePLUS:
13484       e = ffeexpr_expr_new_ ();
13485       e->type = FFEEXPR_exprtypeBINARY_;
13486       e->token = ffelex_token_use (t);
13487       e->u.operator.op = FFEEXPR_operatorADD_;
13488       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13489       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13490       ffeexpr_exprstack_push_binary_ (e);
13491       return (ffelexHandler) ffeexpr_token_rhs_;
13492
13493     case FFELEX_typeMINUS:
13494       e = ffeexpr_expr_new_ ();
13495       e->type = FFEEXPR_exprtypeBINARY_;
13496       e->token = ffelex_token_use (t);
13497       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13498       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13499       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13500       ffeexpr_exprstack_push_binary_ (e);
13501       return (ffelexHandler) ffeexpr_token_rhs_;
13502
13503     case FFELEX_typeASTERISK:
13504       switch (ffeexpr_stack_->context)
13505         {
13506         case FFEEXPR_contextDATA:
13507           return (ffelexHandler) ffeexpr_finished_ (t);
13508
13509         default:
13510           break;
13511         }
13512       e = ffeexpr_expr_new_ ();
13513       e->type = FFEEXPR_exprtypeBINARY_;
13514       e->token = ffelex_token_use (t);
13515       e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13516       e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13517       e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13518       ffeexpr_exprstack_push_binary_ (e);
13519       return (ffelexHandler) ffeexpr_token_rhs_;
13520
13521     case FFELEX_typeSLASH:
13522       switch (ffeexpr_stack_->context)
13523         {
13524         case FFEEXPR_contextDATA:
13525           return (ffelexHandler) ffeexpr_finished_ (t);
13526
13527         default:
13528           break;
13529         }
13530       e = ffeexpr_expr_new_ ();
13531       e->type = FFEEXPR_exprtypeBINARY_;
13532       e->token = ffelex_token_use (t);
13533       e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13534       e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13535       e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13536       ffeexpr_exprstack_push_binary_ (e);
13537       return (ffelexHandler) ffeexpr_token_rhs_;
13538
13539     case FFELEX_typePOWER:
13540       e = ffeexpr_expr_new_ ();
13541       e->type = FFEEXPR_exprtypeBINARY_;
13542       e->token = ffelex_token_use (t);
13543       e->u.operator.op = FFEEXPR_operatorPOWER_;
13544       e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13545       e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13546       ffeexpr_exprstack_push_binary_ (e);
13547       return (ffelexHandler) ffeexpr_token_rhs_;
13548
13549     case FFELEX_typeCONCAT:
13550       e = ffeexpr_expr_new_ ();
13551       e->type = FFEEXPR_exprtypeBINARY_;
13552       e->token = ffelex_token_use (t);
13553       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13554       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13555       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13556       ffeexpr_exprstack_push_binary_ (e);
13557       return (ffelexHandler) ffeexpr_token_rhs_;
13558
13559     case FFELEX_typeOPEN_ANGLE:
13560       switch (ffeexpr_stack_->context)
13561         {
13562         case FFEEXPR_contextFORMAT:
13563           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13564           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13565           ffebad_finish ();
13566           break;
13567
13568         default:
13569           break;
13570         }
13571       e = ffeexpr_expr_new_ ();
13572       e->type = FFEEXPR_exprtypeBINARY_;
13573       e->token = ffelex_token_use (t);
13574       e->u.operator.op = FFEEXPR_operatorLT_;
13575       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13576       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13577       ffeexpr_exprstack_push_binary_ (e);
13578       return (ffelexHandler) ffeexpr_token_rhs_;
13579
13580     case FFELEX_typeCLOSE_ANGLE:
13581       switch (ffeexpr_stack_->context)
13582         {
13583         case FFEEXPR_contextFORMAT:
13584           return ffeexpr_finished_ (t);
13585
13586         default:
13587           break;
13588         }
13589       e = ffeexpr_expr_new_ ();
13590       e->type = FFEEXPR_exprtypeBINARY_;
13591       e->token = ffelex_token_use (t);
13592       e->u.operator.op = FFEEXPR_operatorGT_;
13593       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13594       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13595       ffeexpr_exprstack_push_binary_ (e);
13596       return (ffelexHandler) ffeexpr_token_rhs_;
13597
13598     case FFELEX_typeREL_EQ:
13599       switch (ffeexpr_stack_->context)
13600         {
13601         case FFEEXPR_contextFORMAT:
13602           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13603           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13604           ffebad_finish ();
13605           break;
13606
13607         default:
13608           break;
13609         }
13610       e = ffeexpr_expr_new_ ();
13611       e->type = FFEEXPR_exprtypeBINARY_;
13612       e->token = ffelex_token_use (t);
13613       e->u.operator.op = FFEEXPR_operatorEQ_;
13614       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13615       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13616       ffeexpr_exprstack_push_binary_ (e);
13617       return (ffelexHandler) ffeexpr_token_rhs_;
13618
13619     case FFELEX_typeREL_NE:
13620       switch (ffeexpr_stack_->context)
13621         {
13622         case FFEEXPR_contextFORMAT:
13623           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13624           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13625           ffebad_finish ();
13626           break;
13627
13628         default:
13629           break;
13630         }
13631       e = ffeexpr_expr_new_ ();
13632       e->type = FFEEXPR_exprtypeBINARY_;
13633       e->token = ffelex_token_use (t);
13634       e->u.operator.op = FFEEXPR_operatorNE_;
13635       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13636       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13637       ffeexpr_exprstack_push_binary_ (e);
13638       return (ffelexHandler) ffeexpr_token_rhs_;
13639
13640     case FFELEX_typeREL_LE:
13641       switch (ffeexpr_stack_->context)
13642         {
13643         case FFEEXPR_contextFORMAT:
13644           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13645           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13646           ffebad_finish ();
13647           break;
13648
13649         default:
13650           break;
13651         }
13652       e = ffeexpr_expr_new_ ();
13653       e->type = FFEEXPR_exprtypeBINARY_;
13654       e->token = ffelex_token_use (t);
13655       e->u.operator.op = FFEEXPR_operatorLE_;
13656       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13657       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13658       ffeexpr_exprstack_push_binary_ (e);
13659       return (ffelexHandler) ffeexpr_token_rhs_;
13660
13661     case FFELEX_typeREL_GE:
13662       switch (ffeexpr_stack_->context)
13663         {
13664         case FFEEXPR_contextFORMAT:
13665           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13666           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13667           ffebad_finish ();
13668           break;
13669
13670         default:
13671           break;
13672         }
13673       e = ffeexpr_expr_new_ ();
13674       e->type = FFEEXPR_exprtypeBINARY_;
13675       e->token = ffelex_token_use (t);
13676       e->u.operator.op = FFEEXPR_operatorGE_;
13677       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13678       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13679       ffeexpr_exprstack_push_binary_ (e);
13680       return (ffelexHandler) ffeexpr_token_rhs_;
13681
13682     case FFELEX_typePERIOD:
13683       ffeexpr_tokens_[0] = ffelex_token_use (t);
13684       return (ffelexHandler) ffeexpr_token_binary_period_;
13685
13686 #if 0
13687     case FFELEX_typeOPEN_PAREN:
13688     case FFELEX_typeCLOSE_PAREN:
13689     case FFELEX_typeEQUALS:
13690     case FFELEX_typePOINTS:
13691     case FFELEX_typeCOMMA:
13692     case FFELEX_typeCOLON:
13693     case FFELEX_typeEOS:
13694     case FFELEX_typeSEMICOLON:
13695     case FFELEX_typeNAME:
13696     case FFELEX_typeNAMES:
13697 #endif
13698     default:
13699       return (ffelexHandler) ffeexpr_finished_ (t);
13700     }
13701 }
13702
13703 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13704
13705    Return a pointer to this function to the lexer (ffelex), which will
13706    invoke it for the next token.
13707
13708    Handle a period detected at binary (expecting binary op or end) state.
13709    Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13710    valid.  */
13711
13712 static ffelexHandler
13713 ffeexpr_token_binary_period_ (ffelexToken t)
13714 {
13715   ffeexprExpr_ operand;
13716
13717   switch (ffelex_token_type (t))
13718     {
13719     case FFELEX_typeNAME:
13720     case FFELEX_typeNAMES:
13721       ffeexpr_current_dotdot_ = ffestr_other (t);
13722       switch (ffeexpr_current_dotdot_)
13723         {
13724         case FFESTR_otherTRUE:
13725         case FFESTR_otherFALSE:
13726         case FFESTR_otherNOT:
13727           if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13728             {
13729               operand = ffeexpr_stack_->exprstack;
13730               assert (operand != NULL);
13731               assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13732               ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13733               ffebad_here (1, ffelex_token_where_line (t),
13734                            ffelex_token_where_column (t));
13735               ffebad_finish ();
13736             }
13737           ffelex_token_kill (ffeexpr_tokens_[0]);
13738           return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13739
13740         default:
13741           ffeexpr_tokens_[1] = ffelex_token_use (t);
13742           return (ffelexHandler) ffeexpr_token_binary_end_per_;
13743         }
13744       break;                    /* Nothing really reaches here. */
13745
13746     default:
13747       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13748         {
13749           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13750                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13751           ffebad_finish ();
13752         }
13753       ffelex_token_kill (ffeexpr_tokens_[0]);
13754       return (ffelexHandler) ffeexpr_token_binary_ (t);
13755     }
13756 }
13757
13758 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13759
13760    Return a pointer to this function to the lexer (ffelex), which will
13761    invoke it for the next token.
13762
13763    Expecting a period to close a dot-dot at binary (binary op
13764    or operator) state.  If period isn't found, issue a diagnostic but
13765    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
13766    dotdot representation of the name in between the two PERIOD tokens.  */
13767
13768 static ffelexHandler
13769 ffeexpr_token_binary_end_per_ (ffelexToken t)
13770 {
13771   ffeexprExpr_ e;
13772
13773   e = ffeexpr_expr_new_ ();
13774   e->type = FFEEXPR_exprtypeBINARY_;
13775   e->token = ffeexpr_tokens_[0];
13776
13777   switch (ffeexpr_current_dotdot_)
13778     {
13779     case FFESTR_otherAND:
13780       e->u.operator.op = FFEEXPR_operatorAND_;
13781       e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13782       e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13783       break;
13784
13785     case FFESTR_otherOR:
13786       e->u.operator.op = FFEEXPR_operatorOR_;
13787       e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13788       e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13789       break;
13790
13791     case FFESTR_otherXOR:
13792       e->u.operator.op = FFEEXPR_operatorXOR_;
13793       e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13794       e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13795       break;
13796
13797     case FFESTR_otherEQV:
13798       e->u.operator.op = FFEEXPR_operatorEQV_;
13799       e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13800       e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13801       break;
13802
13803     case FFESTR_otherNEQV:
13804       e->u.operator.op = FFEEXPR_operatorNEQV_;
13805       e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13806       e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13807       break;
13808
13809     case FFESTR_otherLT:
13810       e->u.operator.op = FFEEXPR_operatorLT_;
13811       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13812       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13813       break;
13814
13815     case FFESTR_otherLE:
13816       e->u.operator.op = FFEEXPR_operatorLE_;
13817       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13818       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13819       break;
13820
13821     case FFESTR_otherEQ:
13822       e->u.operator.op = FFEEXPR_operatorEQ_;
13823       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13824       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13825       break;
13826
13827     case FFESTR_otherNE:
13828       e->u.operator.op = FFEEXPR_operatorNE_;
13829       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13830       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13831       break;
13832
13833     case FFESTR_otherGT:
13834       e->u.operator.op = FFEEXPR_operatorGT_;
13835       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13836       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13837       break;
13838
13839     case FFESTR_otherGE:
13840       e->u.operator.op = FFEEXPR_operatorGE_;
13841       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13842       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13843       break;
13844
13845     default:
13846       if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13847         {
13848           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13849                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13850           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13851           ffebad_finish ();
13852         }
13853       e->u.operator.op = FFEEXPR_operatorEQ_;
13854       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13855       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13856       break;
13857     }
13858
13859   ffeexpr_exprstack_push_binary_ (e);
13860
13861   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13862     {
13863       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13864         {
13865           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13866                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13867           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13868           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13869           ffebad_finish ();
13870         }
13871       ffelex_token_kill (ffeexpr_tokens_[1]);   /* Kill dot-dot token. */
13872       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13873     }
13874
13875   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill dot-dot token. */
13876   return (ffelexHandler) ffeexpr_token_rhs_;
13877 }
13878
13879 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13880
13881    Return a pointer to this function to the lexer (ffelex), which will
13882    invoke it for the next token.
13883
13884    A diagnostic has already been issued; just swallow a period if there is
13885    one, then continue with ffeexpr_token_binary_.  */
13886
13887 static ffelexHandler
13888 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13889 {
13890   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13891     return (ffelexHandler) ffeexpr_token_binary_ (t);
13892
13893   return (ffelexHandler) ffeexpr_token_binary_;
13894 }
13895
13896 /* ffeexpr_token_quote_ -- Rhs QUOTE
13897
13898    Return a pointer to this function to the lexer (ffelex), which will
13899    invoke it for the next token.
13900
13901    Expecting a NUMBER that we'll treat as an octal integer.  */
13902
13903 static ffelexHandler
13904 ffeexpr_token_quote_ (ffelexToken t)
13905 {
13906   ffeexprExpr_ e;
13907   ffebld anyexpr;
13908
13909   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13910     {
13911       if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13912         {
13913           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13914                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13915           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13916           ffebad_finish ();
13917         }
13918       ffelex_token_kill (ffeexpr_tokens_[0]);
13919       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13920     }
13921
13922   /* This is kind of a kludge to prevent any whining about magical numbers
13923      that start out as these octal integers, so "20000000000 (on a 32-bit
13924      2's-complement machine) by itself won't produce an error. */
13925
13926   anyexpr = ffebld_new_any ();
13927   ffebld_set_info (anyexpr, ffeinfo_new_any ());
13928
13929   e = ffeexpr_expr_new_ ();
13930   e->type = FFEEXPR_exprtypeOPERAND_;
13931   e->token = ffeexpr_tokens_[0];
13932   e->u.operand = ffebld_new_conter_with_orig
13933     (ffebld_constant_new_integeroctal (t), anyexpr);
13934   ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13935                       FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13936                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13937   ffeexpr_exprstack_push_operand_ (e);
13938   return (ffelexHandler) ffeexpr_token_binary_;
13939 }
13940
13941 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13942
13943    Return a pointer to this function to the lexer (ffelex), which will
13944    invoke it for the next token.
13945
13946    Handle an open-apostrophe, which begins either a character ('char-const'),
13947    typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13948    'hex-const'X) constant.  */
13949
13950 static ffelexHandler
13951 ffeexpr_token_apostrophe_ (ffelexToken t)
13952 {
13953   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13954   if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13955     {
13956       ffebad_start (FFEBAD_NULL_CHAR_CONST);
13957       ffebad_here (0, ffelex_token_where_line (t),
13958                    ffelex_token_where_column (t));
13959       ffebad_finish ();
13960     }
13961   ffeexpr_tokens_[1] = ffelex_token_use (t);
13962   return (ffelexHandler) ffeexpr_token_apos_char_;
13963 }
13964
13965 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13966
13967    Return a pointer to this function to the lexer (ffelex), which will
13968    invoke it for the next token.
13969
13970    Close-apostrophe is implicit; if this token is NAME, it is a possible
13971    typeless-constant radix specifier.  */
13972
13973 static ffelexHandler
13974 ffeexpr_token_apos_char_ (ffelexToken t)
13975 {
13976   ffeexprExpr_ e;
13977   ffeinfo ni;
13978   char c;
13979   ffetargetCharacterSize size;
13980
13981   if ((ffelex_token_type (t) == FFELEX_typeNAME)
13982       || (ffelex_token_type (t) == FFELEX_typeNAMES))
13983     {
13984       if ((ffelex_token_length (t) == 1)
13985           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13986                                       'b')
13987               || ffesrc_char_match_init (c, 'O', 'o')
13988               || ffesrc_char_match_init (c, 'X', 'x')
13989               || ffesrc_char_match_init (c, 'Z', 'z')))
13990         {
13991           e = ffeexpr_expr_new_ ();
13992           e->type = FFEEXPR_exprtypeOPERAND_;
13993           e->token = ffeexpr_tokens_[0];
13994           switch (c)
13995             {
13996             case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13997               e->u.operand = ffebld_new_conter
13998                 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13999               size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14000               break;
14001
14002             case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14003               e->u.operand = ffebld_new_conter
14004                 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14005               size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14006               break;
14007
14008             case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14009               e->u.operand = ffebld_new_conter
14010                 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14011               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14012               break;
14013
14014             case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14015               e->u.operand = ffebld_new_conter
14016                 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14017               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14018               break;
14019
14020             default:
14021             no_match:           /* :::::::::::::::::::: */
14022               assert ("not BOXZ!" == NULL);
14023               size = 0;
14024               break;
14025             }
14026           ffebld_set_info (e->u.operand,
14027                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14028                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14029           ffeexpr_exprstack_push_operand_ (e);
14030           ffelex_token_kill (ffeexpr_tokens_[1]);
14031           return (ffelexHandler) ffeexpr_token_binary_;
14032         }
14033     }
14034   e = ffeexpr_expr_new_ ();
14035   e->type = FFEEXPR_exprtypeOPERAND_;
14036   e->token = ffeexpr_tokens_[0];
14037   e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14038                                     (ffeexpr_tokens_[1]));
14039   ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14040                     0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14041                     ffelex_token_length (ffeexpr_tokens_[1]));
14042   ffebld_set_info (e->u.operand, ni);
14043   ffelex_token_kill (ffeexpr_tokens_[1]);
14044   ffeexpr_exprstack_push_operand_ (e);
14045   if ((ffelex_token_type (t) == FFELEX_typeNAME)
14046       || (ffelex_token_type (t) == FFELEX_typeNAMES))
14047     {
14048       if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14049         {
14050           ffebad_string (ffelex_token_text (t));
14051           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14052           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14053                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14054           ffebad_finish ();
14055         }
14056       e = ffeexpr_expr_new_ ();
14057       e->type = FFEEXPR_exprtypeBINARY_;
14058       e->token = ffelex_token_use (t);
14059       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14060       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14061       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14062       ffeexpr_exprstack_push_binary_ (e);
14063       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14064     }
14065   ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();   /* Allow "'hello'(3:5)". */
14066   return (ffelexHandler) ffeexpr_token_substrp_ (t);
14067 }
14068
14069 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14070
14071    Return a pointer to this function to the lexer (ffelex), which will
14072    invoke it for the next token.
14073
14074    Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14075    (RECORD%MEMBER), or nothing at all.  */
14076
14077 static ffelexHandler
14078 ffeexpr_token_name_lhs_ (ffelexToken t)
14079 {
14080   ffeexprExpr_ e;
14081   ffeexprParenType_ paren_type;
14082   ffesymbol s;
14083   ffebld expr;
14084   ffeinfo info;
14085
14086   switch (ffelex_token_type (t))
14087     {
14088     case FFELEX_typeOPEN_PAREN:
14089       switch (ffeexpr_stack_->context)
14090         {
14091         case FFEEXPR_contextASSIGN:
14092         case FFEEXPR_contextAGOTO:
14093         case FFEEXPR_contextFILEUNIT_DF:
14094           goto just_name;       /* :::::::::::::::::::: */
14095
14096         default:
14097           break;
14098         }
14099       e = ffeexpr_expr_new_ ();
14100       e->type = FFEEXPR_exprtypeOPERAND_;
14101       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14102       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14103                                           &paren_type);
14104
14105       switch (ffesymbol_where (s))
14106         {
14107         case FFEINFO_whereLOCAL:
14108           if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14109             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Recursion. */
14110           break;
14111
14112         case FFEINFO_whereINTRINSIC:
14113         case FFEINFO_whereGLOBAL:
14114           if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14115             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Can call intrin. */
14116           break;
14117
14118         case FFEINFO_whereCOMMON:
14119         case FFEINFO_whereDUMMY:
14120         case FFEINFO_whereRESULT:
14121           break;
14122
14123         case FFEINFO_whereNONE:
14124         case FFEINFO_whereANY:
14125           break;
14126
14127         default:
14128           ffesymbol_error (s, ffeexpr_tokens_[0]);
14129           break;
14130         }
14131
14132       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14133         {
14134           e->u.operand = ffebld_new_any ();
14135           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14136         }
14137       else
14138         {
14139           e->u.operand = ffebld_new_symter (s,
14140                                             ffesymbol_generic (s),
14141                                             ffesymbol_specific (s),
14142                                             ffesymbol_implementation (s));
14143           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14144         }
14145       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
14146       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14147       switch (paren_type)
14148         {
14149         case FFEEXPR_parentypeSUBROUTINE_:
14150           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14151           return
14152             (ffelexHandler)
14153             ffeexpr_rhs (ffeexpr_stack_->pool,
14154                          FFEEXPR_contextACTUALARG_,
14155                          ffeexpr_token_arguments_);
14156
14157         case FFEEXPR_parentypeARRAY_:
14158           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14159           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14160           ffeexpr_stack_->rank = 0;
14161           ffeexpr_stack_->constant = TRUE;
14162           ffeexpr_stack_->immediate = TRUE;
14163           switch (ffeexpr_stack_->context)
14164             {
14165             case FFEEXPR_contextDATAIMPDOITEM_:
14166               return
14167                 (ffelexHandler)
14168                 ffeexpr_rhs (ffeexpr_stack_->pool,
14169                              FFEEXPR_contextDATAIMPDOINDEX_,
14170                              ffeexpr_token_elements_);
14171
14172             case FFEEXPR_contextEQUIVALENCE:
14173               return
14174                 (ffelexHandler)
14175                 ffeexpr_rhs (ffeexpr_stack_->pool,
14176                              FFEEXPR_contextEQVINDEX_,
14177                              ffeexpr_token_elements_);
14178
14179             default:
14180               return
14181                 (ffelexHandler)
14182                 ffeexpr_rhs (ffeexpr_stack_->pool,
14183                              FFEEXPR_contextINDEX_,
14184                              ffeexpr_token_elements_);
14185             }
14186
14187         case FFEEXPR_parentypeSUBSTRING_:
14188           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14189                                                   ffeexpr_tokens_[0]);
14190           return
14191             (ffelexHandler)
14192             ffeexpr_rhs (ffeexpr_stack_->pool,
14193                          FFEEXPR_contextINDEX_,
14194                          ffeexpr_token_substring_);
14195
14196         case FFEEXPR_parentypeEQUIVALENCE_:
14197           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14198           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14199           ffeexpr_stack_->rank = 0;
14200           ffeexpr_stack_->constant = TRUE;
14201           ffeexpr_stack_->immediate = TRUE;
14202           return
14203             (ffelexHandler)
14204             ffeexpr_rhs (ffeexpr_stack_->pool,
14205                          FFEEXPR_contextEQVINDEX_,
14206                          ffeexpr_token_equivalence_);
14207
14208         case FFEEXPR_parentypeFUNCTION_:        /* Invalid case. */
14209         case FFEEXPR_parentypeFUNSUBSTR_:       /* Invalid case. */
14210           ffesymbol_error (s, ffeexpr_tokens_[0]);
14211           /* Fall through. */
14212         case FFEEXPR_parentypeANY_:
14213           e->u.operand = ffebld_new_any ();
14214           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14215           return
14216             (ffelexHandler)
14217             ffeexpr_rhs (ffeexpr_stack_->pool,
14218                          FFEEXPR_contextACTUALARG_,
14219                          ffeexpr_token_anything_);
14220
14221         default:
14222           assert ("bad paren type" == NULL);
14223           break;
14224         }
14225
14226     case FFELEX_typeEQUALS:     /* As in "VAR=". */
14227       switch (ffeexpr_stack_->context)
14228         {
14229         case FFEEXPR_contextIMPDOITEM_: /* within
14230                                                    "(,VAR=start,end[,incr])". */
14231         case FFEEXPR_contextIMPDOITEMDF_:
14232           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14233           break;
14234
14235         case FFEEXPR_contextDATAIMPDOITEM_:
14236           ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14237           break;
14238
14239         default:
14240           break;
14241         }
14242       break;
14243
14244 #if 0
14245     case FFELEX_typePERIOD:
14246     case FFELEX_typePERCENT:
14247       assert ("FOO%, FOO. not yet supported!~~" == NULL);
14248       break;
14249 #endif
14250
14251     default:
14252       break;
14253     }
14254
14255 just_name:                      /* :::::::::::::::::::: */
14256   e = ffeexpr_expr_new_ ();
14257   e->type = FFEEXPR_exprtypeOPERAND_;
14258   e->token = ffeexpr_tokens_[0];
14259   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14260                                   (ffeexpr_stack_->context
14261                                    == FFEEXPR_contextSUBROUTINEREF));
14262
14263   switch (ffesymbol_where (s))
14264     {
14265     case FFEINFO_whereCONSTANT:
14266       if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14267           || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14268         ffesymbol_error (s, ffeexpr_tokens_[0]);
14269       break;
14270
14271     case FFEINFO_whereIMMEDIATE:
14272       if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14273           && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14274         ffesymbol_error (s, ffeexpr_tokens_[0]);
14275       break;
14276
14277     case FFEINFO_whereLOCAL:
14278       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14279         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Recurse!. */
14280       break;
14281
14282     case FFEINFO_whereINTRINSIC:
14283       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14284         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Can call intrin. */
14285       break;
14286
14287     default:
14288       break;
14289     }
14290
14291   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14292     {
14293       expr = ffebld_new_any ();
14294       info = ffeinfo_new_any ();
14295       ffebld_set_info (expr, info);
14296     }
14297   else
14298     {
14299       expr = ffebld_new_symter (s,
14300                                 ffesymbol_generic (s),
14301                                 ffesymbol_specific (s),
14302                                 ffesymbol_implementation (s));
14303       info = ffesymbol_info (s);
14304       ffebld_set_info (expr, info);
14305       if (ffesymbol_is_doiter (s))
14306         {
14307           ffebad_start (FFEBAD_DOITER);
14308           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14309                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14310           ffest_ffebad_here_doiter (1, s);
14311           ffebad_string (ffesymbol_text (s));
14312           ffebad_finish ();
14313         }
14314       expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14315     }
14316
14317   if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14318     {
14319       if (ffebld_op (expr) == FFEBLD_opANY)
14320         {
14321           expr = ffebld_new_any ();
14322           ffebld_set_info (expr, ffeinfo_new_any ());
14323         }
14324       else
14325         {
14326           expr = ffebld_new_subrref (expr, NULL);       /* No argument list. */
14327           if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14328             ffeintrin_fulfill_generic (&expr, &info, e->token);
14329           else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14330             ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14331           else
14332             ffeexpr_fulfill_call_ (&expr, e->token);
14333
14334           if (ffebld_op (expr) != FFEBLD_opANY)
14335             ffebld_set_info (expr,
14336                              ffeinfo_new (ffeinfo_basictype (info),
14337                                           ffeinfo_kindtype (info),
14338                                           0,
14339                                           FFEINFO_kindENTITY,
14340                                           FFEINFO_whereFLEETING,
14341                                           ffeinfo_size (info)));
14342           else
14343             ffebld_set_info (expr, ffeinfo_new_any ());
14344         }
14345     }
14346
14347   e->u.operand = expr;
14348   ffeexpr_exprstack_push_operand_ (e);
14349   return (ffelexHandler) ffeexpr_finished_ (t);
14350 }
14351
14352 /* ffeexpr_token_name_arg_ -- Rhs NAME
14353
14354    Return a pointer to this function to the lexer (ffelex), which will
14355    invoke it for the next token.
14356
14357    Handle first token in an actual-arg (or possible actual-arg) context
14358    being a NAME, and use second token to refine the context.  */
14359
14360 static ffelexHandler
14361 ffeexpr_token_name_arg_ (ffelexToken t)
14362 {
14363   switch (ffelex_token_type (t))
14364     {
14365     case FFELEX_typeCLOSE_PAREN:
14366     case FFELEX_typeCOMMA:
14367       switch (ffeexpr_stack_->context)
14368         {
14369         case FFEEXPR_contextINDEXORACTUALARG_:
14370           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14371           break;
14372
14373         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14374           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14375           break;
14376
14377         default:
14378           break;
14379         }
14380       break;
14381
14382     default:
14383       switch (ffeexpr_stack_->context)
14384         {
14385         case FFEEXPR_contextACTUALARG_:
14386           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14387           break;
14388
14389         case FFEEXPR_contextINDEXORACTUALARG_:
14390           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14391           break;
14392
14393         case FFEEXPR_contextSFUNCDEFACTUALARG_:
14394           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14395           break;
14396
14397         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14398           ffeexpr_stack_->context
14399             = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14400           break;
14401
14402         default:
14403           assert ("bad context in _name_arg_" == NULL);
14404           break;
14405         }
14406       break;
14407     }
14408
14409   return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14410 }
14411
14412 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14413
14414    Return a pointer to this function to the lexer (ffelex), which will
14415    invoke it for the next token.
14416
14417    Handle a name followed by open-paren, apostrophe (O'octal-const',
14418    Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14419
14420    26-Nov-91  JCB  1.2
14421       When followed by apostrophe or quote, set lex hexnum flag on so
14422       [0-9] as first char of next token seen as starting a potentially
14423       hex number (NAME).
14424    04-Oct-91  JCB  1.1
14425       In case of intrinsic, decorate its SYMTER with the type info for
14426       the specific intrinsic.  */
14427
14428 static ffelexHandler
14429 ffeexpr_token_name_rhs_ (ffelexToken t)
14430 {
14431   ffeexprExpr_ e;
14432   ffeexprParenType_ paren_type;
14433   ffesymbol s;
14434   bool sfdef;
14435
14436   switch (ffelex_token_type (t))
14437     {
14438     case FFELEX_typeQUOTE:
14439     case FFELEX_typeAPOSTROPHE:
14440       ffeexpr_tokens_[1] = ffelex_token_use (t);
14441       ffelex_set_hexnum (TRUE);
14442       return (ffelexHandler) ffeexpr_token_name_apos_;
14443
14444     case FFELEX_typeOPEN_PAREN:
14445       e = ffeexpr_expr_new_ ();
14446       e->type = FFEEXPR_exprtypeOPERAND_;
14447       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14448       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14449                                           &paren_type);
14450       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14451         e->u.operand = ffebld_new_any ();
14452       else
14453         e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14454                                           ffesymbol_specific (s),
14455                                           ffesymbol_implementation (s));
14456       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
14457       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14458       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14459         {
14460         case FFEEXPR_contextSFUNCDEF:
14461         case FFEEXPR_contextSFUNCDEFINDEX_:
14462         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14463         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14464           sfdef = TRUE;
14465           break;
14466
14467         case FFEEXPR_contextSFUNCDEFACTUALARG_:
14468         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14469           assert ("weird context!" == NULL);
14470           sfdef = FALSE;
14471           break;
14472
14473         default:
14474           sfdef = FALSE;
14475           break;
14476         }
14477       switch (paren_type)
14478         {
14479         case FFEEXPR_parentypeFUNCTION_:
14480           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14481           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14482           if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14483             {                   /* A statement function. */
14484               ffeexpr_stack_->num_args
14485                 = ffebld_list_length
14486                   (ffeexpr_stack_->next_dummy
14487                    = ffesymbol_dummyargs (s));
14488               ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
14489             }
14490           else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14491                    && !ffe_is_pedantic_not_90 ()
14492                    && ((ffesymbol_implementation (s)
14493                         == FFEINTRIN_impICHAR)
14494                        || (ffesymbol_implementation (s)
14495                            == FFEINTRIN_impIACHAR)
14496                        || (ffesymbol_implementation (s)
14497                            == FFEINTRIN_impLEN)))
14498             {                   /* Allow arbitrary concatenations. */
14499               return
14500                 (ffelexHandler)
14501                   ffeexpr_rhs (ffeexpr_stack_->pool,
14502                                sfdef
14503                                ? FFEEXPR_contextSFUNCDEF
14504                                : FFEEXPR_contextLET,
14505                                ffeexpr_token_arguments_);
14506             }
14507           return
14508             (ffelexHandler)
14509             ffeexpr_rhs (ffeexpr_stack_->pool,
14510                          sfdef
14511                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
14512                          : FFEEXPR_contextACTUALARG_,
14513                          ffeexpr_token_arguments_);
14514
14515         case FFEEXPR_parentypeARRAY_:
14516           ffebld_set_info (e->u.operand,
14517                            ffesymbol_info (ffebld_symter (e->u.operand)));
14518           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14519           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14520           ffeexpr_stack_->rank = 0;
14521           ffeexpr_stack_->constant = TRUE;
14522           ffeexpr_stack_->immediate = TRUE;
14523           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14524                                               sfdef
14525                                               ? FFEEXPR_contextSFUNCDEFINDEX_
14526                                               : FFEEXPR_contextINDEX_,
14527                                               ffeexpr_token_elements_);
14528
14529         case FFEEXPR_parentypeSUBSTRING_:
14530           ffebld_set_info (e->u.operand,
14531                            ffesymbol_info (ffebld_symter (e->u.operand)));
14532           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14533                                                   ffeexpr_tokens_[0]);
14534           return
14535             (ffelexHandler)
14536             ffeexpr_rhs (ffeexpr_stack_->pool,
14537                          sfdef
14538                          ? FFEEXPR_contextSFUNCDEFINDEX_
14539                          : FFEEXPR_contextINDEX_,
14540                          ffeexpr_token_substring_);
14541
14542         case FFEEXPR_parentypeFUNSUBSTR_:
14543           return
14544             (ffelexHandler)
14545             ffeexpr_rhs (ffeexpr_stack_->pool,
14546                          sfdef
14547                          ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14548                          : FFEEXPR_contextINDEXORACTUALARG_,
14549                          ffeexpr_token_funsubstr_);
14550
14551         case FFEEXPR_parentypeANY_:
14552           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14553           return
14554             (ffelexHandler)
14555             ffeexpr_rhs (ffeexpr_stack_->pool,
14556                          sfdef
14557                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
14558                          : FFEEXPR_contextACTUALARG_,
14559                          ffeexpr_token_anything_);
14560
14561         default:
14562           assert ("bad paren type" == NULL);
14563           break;
14564         }
14565
14566     case FFELEX_typeEQUALS:     /* As in "VAR=". */
14567       switch (ffeexpr_stack_->context)
14568         {
14569         case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
14570         case FFEEXPR_contextIMPDOITEMDF_:
14571           ffeexpr_stack_->is_rhs = FALSE;       /* Really an lhs construct. */
14572           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14573           break;
14574
14575         default:
14576           break;
14577         }
14578       break;
14579
14580 #if 0
14581     case FFELEX_typePERIOD:
14582     case FFELEX_typePERCENT:
14583       ~~Support these two someday, though not required
14584         assert ("FOO%, FOO. not yet supported!~~" == NULL);
14585       break;
14586 #endif
14587
14588     default:
14589       break;
14590     }
14591
14592   switch (ffeexpr_stack_->context)
14593     {
14594     case FFEEXPR_contextINDEXORACTUALARG_:
14595     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14596       assert ("strange context" == NULL);
14597       break;
14598
14599     default:
14600       break;
14601     }
14602
14603   e = ffeexpr_expr_new_ ();
14604   e->type = FFEEXPR_exprtypeOPERAND_;
14605   e->token = ffeexpr_tokens_[0];
14606   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14607   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14608     {
14609       e->u.operand = ffebld_new_any ();
14610       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14611     }
14612   else
14613     {
14614       e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14615                                         ffesymbol_specific (s),
14616                                         ffesymbol_implementation (s));
14617       if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14618         ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14619       else
14620         {                       /* Decorate the SYMTER with the actual type
14621                                    of the intrinsic. */
14622           ffebld_set_info (e->u.operand, ffeinfo_new
14623                         (ffeintrin_basictype (ffesymbol_specific (s)),
14624                          ffeintrin_kindtype (ffesymbol_specific (s)),
14625                          0,
14626                          ffesymbol_kind (s),
14627                          ffesymbol_where (s),
14628                          FFETARGET_charactersizeNONE));
14629         }
14630       if (ffesymbol_is_doiter (s))
14631         ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14632       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14633                                               ffeexpr_tokens_[0]);
14634     }
14635   ffeexpr_exprstack_push_operand_ (e);
14636   return (ffelexHandler) ffeexpr_token_binary_ (t);
14637 }
14638
14639 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14640
14641    Return a pointer to this function to the lexer (ffelex), which will
14642    invoke it for the next token.
14643
14644    Expecting a NAME token, analyze the previous NAME token to see what kind,
14645    if any, typeless constant we've got.
14646
14647    01-Sep-90  JCB  1.1
14648       Expect a NAME instead of CHARACTER in this situation.  */
14649
14650 static ffelexHandler
14651 ffeexpr_token_name_apos_ (ffelexToken t)
14652 {
14653   ffeexprExpr_ e;
14654
14655   ffelex_set_hexnum (FALSE);
14656
14657   switch (ffelex_token_type (t))
14658     {
14659     case FFELEX_typeNAME:
14660       ffeexpr_tokens_[2] = ffelex_token_use (t);
14661       return (ffelexHandler) ffeexpr_token_name_apos_name_;
14662
14663     default:
14664       break;
14665     }
14666
14667   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14668     {
14669       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14670       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14671                    ffelex_token_where_column (ffeexpr_tokens_[0]));
14672       ffebad_here (1, ffelex_token_where_line (t),
14673                    ffelex_token_where_column (t));
14674       ffebad_finish ();
14675     }
14676
14677   ffelex_token_kill (ffeexpr_tokens_[1]);
14678
14679   e = ffeexpr_expr_new_ ();
14680   e->type = FFEEXPR_exprtypeOPERAND_;
14681   e->u.operand = ffebld_new_any ();
14682   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14683   e->token = ffeexpr_tokens_[0];
14684   ffeexpr_exprstack_push_operand_ (e);
14685
14686   return (ffelexHandler) ffeexpr_token_binary_ (t);
14687 }
14688
14689 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14690
14691    Return a pointer to this function to the lexer (ffelex), which will
14692    invoke it for the next token.
14693
14694    Expecting an APOSTROPHE token, analyze the previous NAME token to see
14695    what kind, if any, typeless constant we've got.  */
14696
14697 static ffelexHandler
14698 ffeexpr_token_name_apos_name_ (ffelexToken t)
14699 {
14700   ffeexprExpr_ e;
14701   char c;
14702
14703   e = ffeexpr_expr_new_ ();
14704   e->type = FFEEXPR_exprtypeOPERAND_;
14705   e->token = ffeexpr_tokens_[0];
14706
14707   if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14708       && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14709       && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14710                                   'B', 'b')
14711           || ffesrc_char_match_init (c, 'O', 'o')
14712           || ffesrc_char_match_init (c, 'X', 'x')
14713           || ffesrc_char_match_init (c, 'Z', 'z')))
14714     {
14715       ffetargetCharacterSize size;
14716
14717       if (!ffe_is_typeless_boz ()) {
14718
14719       switch (c)
14720         {
14721         case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14722           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14723                                             (ffeexpr_tokens_[2]));
14724           break;
14725
14726         case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14727           e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14728                                             (ffeexpr_tokens_[2]));
14729           break;
14730
14731         case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14732           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14733                                             (ffeexpr_tokens_[2]));
14734           break;
14735
14736         case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14737           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14738                                             (ffeexpr_tokens_[2]));
14739           break;
14740
14741         default:
14742         no_imatch:              /* :::::::::::::::::::: */
14743           assert ("not BOXZ!" == NULL);
14744           abort ();
14745         }
14746
14747         ffebld_set_info (e->u.operand,
14748                          ffeinfo_new (FFEINFO_basictypeINTEGER,
14749                                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
14750                                       FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14751                                       FFETARGET_charactersizeNONE));
14752         ffeexpr_exprstack_push_operand_ (e);
14753         ffelex_token_kill (ffeexpr_tokens_[1]);
14754         ffelex_token_kill (ffeexpr_tokens_[2]);
14755         return (ffelexHandler) ffeexpr_token_binary_;
14756       }
14757
14758       switch (c)
14759         {
14760         case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14761           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14762                                             (ffeexpr_tokens_[2]));
14763           size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14764           break;
14765
14766         case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14767           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14768                                             (ffeexpr_tokens_[2]));
14769           size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14770           break;
14771
14772         case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14773           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14774                                             (ffeexpr_tokens_[2]));
14775           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14776           break;
14777
14778         case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14779           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14780                                             (ffeexpr_tokens_[2]));
14781           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14782           break;
14783
14784         default:
14785         no_match:               /* :::::::::::::::::::: */
14786           assert ("not BOXZ!" == NULL);
14787           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14788                                             (ffeexpr_tokens_[2]));
14789           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14790           break;
14791         }
14792       ffebld_set_info (e->u.operand,
14793                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14794                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14795       ffeexpr_exprstack_push_operand_ (e);
14796       ffelex_token_kill (ffeexpr_tokens_[1]);
14797       ffelex_token_kill (ffeexpr_tokens_[2]);
14798       return (ffelexHandler) ffeexpr_token_binary_;
14799     }
14800
14801   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14802     {
14803       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14804       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14805                    ffelex_token_where_column (ffeexpr_tokens_[0]));
14806       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14807       ffebad_finish ();
14808     }
14809
14810   ffelex_token_kill (ffeexpr_tokens_[1]);
14811   ffelex_token_kill (ffeexpr_tokens_[2]);
14812
14813   e->type = FFEEXPR_exprtypeOPERAND_;
14814   e->u.operand = ffebld_new_any ();
14815   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14816   e->token = ffeexpr_tokens_[0];
14817   ffeexpr_exprstack_push_operand_ (e);
14818
14819   switch (ffelex_token_type (t))
14820     {
14821     case FFELEX_typeAPOSTROPHE:
14822     case FFELEX_typeQUOTE:
14823       return (ffelexHandler) ffeexpr_token_binary_;
14824
14825     default:
14826       return (ffelexHandler) ffeexpr_token_binary_ (t);
14827     }
14828 }
14829
14830 /* ffeexpr_token_percent_ -- Rhs PERCENT
14831
14832    Handle a percent sign possibly followed by "LOC".  If followed instead
14833    by "VAL", "REF", or "DESCR", issue an error message and substitute
14834    "LOC".  If followed by something else, treat the percent sign as a
14835    spurious incorrect token and reprocess the token via _rhs_.  */
14836
14837 static ffelexHandler
14838 ffeexpr_token_percent_ (ffelexToken t)
14839 {
14840   switch (ffelex_token_type (t))
14841     {
14842     case FFELEX_typeNAME:
14843     case FFELEX_typeNAMES:
14844       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14845       ffeexpr_tokens_[1] = ffelex_token_use (t);
14846       return (ffelexHandler) ffeexpr_token_percent_name_;
14847
14848     default:
14849       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14850         {
14851           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14852                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14853           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14854                    ffelex_token_where_column (ffeexpr_stack_->first_token));
14855           ffebad_finish ();
14856         }
14857       ffelex_token_kill (ffeexpr_tokens_[0]);
14858       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14859     }
14860 }
14861
14862 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14863
14864    Make sure the token is OPEN_PAREN and prepare for the one-item list of
14865    LHS expressions.  Else display an error message.  */
14866
14867 static ffelexHandler
14868 ffeexpr_token_percent_name_ (ffelexToken t)
14869 {
14870   ffelexHandler nexthandler;
14871
14872   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14873     {
14874       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14875         {
14876           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14877                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14878           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14879                    ffelex_token_where_column (ffeexpr_stack_->first_token));
14880           ffebad_finish ();
14881         }
14882       ffelex_token_kill (ffeexpr_tokens_[0]);
14883       nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14884       ffelex_token_kill (ffeexpr_tokens_[1]);
14885       return (ffelexHandler) (*nexthandler) (t);
14886     }
14887
14888   switch (ffeexpr_stack_->percent)
14889     {
14890     default:
14891       if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14892         {
14893           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14894                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14895           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14896           ffebad_finish ();
14897         }
14898       ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14899       /* Fall through. */
14900     case FFEEXPR_percentLOC_:
14901       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14902       ffelex_token_kill (ffeexpr_tokens_[1]);
14903       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14904       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14905                                           FFEEXPR_contextLOC_,
14906                                           ffeexpr_cb_end_loc_);
14907     }
14908 }
14909
14910 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14911
14912    See prototype.
14913
14914    Pass 'E', 'D', or 'Q' for exponent letter.  */
14915
14916 static void
14917 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14918                            ffelexToken decimal, ffelexToken fraction,
14919                            ffelexToken exponent, ffelexToken exponent_sign,
14920                            ffelexToken exponent_digits)
14921 {
14922   ffeexprExpr_ e;
14923
14924   e = ffeexpr_expr_new_ ();
14925   e->type = FFEEXPR_exprtypeOPERAND_;
14926   if (integer != NULL)
14927     e->token = ffelex_token_use (integer);
14928   else
14929     {
14930       assert (decimal != NULL);
14931       e->token = ffelex_token_use (decimal);
14932     }
14933
14934   switch (exp_letter)
14935     {
14936 #if !FFETARGET_okREALQUAD
14937     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14938       if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14939         {
14940           ffebad_here (0, ffelex_token_where_line (e->token),
14941                        ffelex_token_where_column (e->token));
14942           ffebad_finish ();
14943         }
14944       goto match_d;             /* The FFESRC_CASE_* macros don't
14945                                    allow fall-through! */
14946 #endif
14947
14948     case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14949       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14950                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14951       ffebld_set_info (e->u.operand,
14952              ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14953                           0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14954       break;
14955
14956     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14957       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14958                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14959       ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14960                          FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14961                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14962       break;
14963
14964 #if FFETARGET_okREALQUAD
14965     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14966       e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14967                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14968       ffebld_set_info (e->u.operand,
14969                ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14970                             0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14971       break;
14972 #endif
14973
14974     case 'I':   /* Make an integer. */
14975       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14976                                         (ffeexpr_tokens_[0]));
14977       ffebld_set_info (e->u.operand,
14978                        ffeinfo_new (FFEINFO_basictypeINTEGER,
14979                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
14980                                     FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14981                                     FFETARGET_charactersizeNONE));
14982       break;
14983
14984     default:
14985     no_match:                   /* :::::::::::::::::::: */
14986       assert ("Lost the exponent letter!" == NULL);
14987     }
14988
14989   ffeexpr_exprstack_push_operand_ (e);
14990 }
14991
14992 /* Just like ffesymbol_declare_local, except performs any implicit info
14993    assignment necessary.  */
14994
14995 static ffesymbol
14996 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14997 {
14998   ffesymbol s;
14999   ffeinfoKind k;
15000   bool bad;
15001
15002   s = ffesymbol_declare_local (t, maybe_intrin);
15003
15004   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15005     /* Special-case these since they can involve a different concept
15006        of "state" (in the stmtfunc name space).  */
15007     {
15008     case FFEEXPR_contextDATAIMPDOINDEX_:
15009     case FFEEXPR_contextDATAIMPDOCTRL_:
15010       if (ffeexpr_context_outer_ (ffeexpr_stack_)
15011           == FFEEXPR_contextDATAIMPDOINDEX_)
15012         s = ffeexpr_sym_impdoitem_ (s, t);
15013       else
15014         if (ffeexpr_stack_->is_rhs)
15015           s = ffeexpr_sym_impdoitem_ (s, t);
15016         else
15017           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15018       bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15019         || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15020             && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15021       if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15022         ffesymbol_error (s, t);
15023       return s;
15024
15025     default:
15026       break;
15027     }
15028
15029   switch ((ffesymbol_sfdummyparent (s) == NULL)
15030           ? ffesymbol_state (s)
15031           : FFESYMBOL_stateUNDERSTOOD)
15032     {
15033     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
15034                                    context. */
15035       if (!ffest_seen_first_exec ())
15036         goto seen;              /* :::::::::::::::::::: */
15037       /* Fall through. */
15038     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
15039       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15040         {
15041         case FFEEXPR_contextSUBROUTINEREF:
15042           s = ffeexpr_sym_lhs_call_ (s, t);
15043           break;
15044
15045         case FFEEXPR_contextFILEEXTFUNC:
15046           s = ffeexpr_sym_lhs_extfunc_ (s, t);
15047           break;
15048
15049         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15050           s = ffecom_sym_exec_transition (s);
15051           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15052             goto understood;    /* :::::::::::::::::::: */
15053           /* Fall through. */
15054         case FFEEXPR_contextACTUALARG_:
15055           s = ffeexpr_sym_rhs_actualarg_ (s, t);
15056           break;
15057
15058         case FFEEXPR_contextDATA:
15059           if (ffeexpr_stack_->is_rhs)
15060             s = ffeexpr_sym_rhs_let_ (s, t);
15061           else
15062             s = ffeexpr_sym_lhs_data_ (s, t);
15063           break;
15064
15065         case FFEEXPR_contextDATAIMPDOITEM_:
15066           s = ffeexpr_sym_lhs_data_ (s, t);
15067           break;
15068
15069         case FFEEXPR_contextSFUNCDEF:
15070         case FFEEXPR_contextSFUNCDEFINDEX_:
15071         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15072         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15073           s = ffecom_sym_exec_transition (s);
15074           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15075             goto understood;    /* :::::::::::::::::::: */
15076           /* Fall through. */
15077         case FFEEXPR_contextLET:
15078         case FFEEXPR_contextPAREN_:
15079         case FFEEXPR_contextACTUALARGEXPR_:
15080         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15081         case FFEEXPR_contextASSIGN:
15082         case FFEEXPR_contextIOLIST:
15083         case FFEEXPR_contextIOLISTDF:
15084         case FFEEXPR_contextDO:
15085         case FFEEXPR_contextDOWHILE:
15086         case FFEEXPR_contextAGOTO:
15087         case FFEEXPR_contextCGOTO:
15088         case FFEEXPR_contextIF:
15089         case FFEEXPR_contextARITHIF:
15090         case FFEEXPR_contextFORMAT:
15091         case FFEEXPR_contextSTOP:
15092         case FFEEXPR_contextRETURN:
15093         case FFEEXPR_contextSELECTCASE:
15094         case FFEEXPR_contextCASE:
15095         case FFEEXPR_contextFILEASSOC:
15096         case FFEEXPR_contextFILEINT:
15097         case FFEEXPR_contextFILEDFINT:
15098         case FFEEXPR_contextFILELOG:
15099         case FFEEXPR_contextFILENUM:
15100         case FFEEXPR_contextFILENUMAMBIG:
15101         case FFEEXPR_contextFILECHAR:
15102         case FFEEXPR_contextFILENUMCHAR:
15103         case FFEEXPR_contextFILEDFCHAR:
15104         case FFEEXPR_contextFILEKEY:
15105         case FFEEXPR_contextFILEUNIT:
15106         case FFEEXPR_contextFILEUNIT_DF:
15107         case FFEEXPR_contextFILEUNITAMBIG:
15108         case FFEEXPR_contextFILEFORMAT:
15109         case FFEEXPR_contextFILENAMELIST:
15110         case FFEEXPR_contextFILEVXTCODE:
15111         case FFEEXPR_contextINDEX_:
15112         case FFEEXPR_contextIMPDOITEM_:
15113         case FFEEXPR_contextIMPDOITEMDF_:
15114         case FFEEXPR_contextIMPDOCTRL_:
15115         case FFEEXPR_contextLOC_:
15116           if (ffeexpr_stack_->is_rhs)
15117             s = ffeexpr_sym_rhs_let_ (s, t);
15118           else
15119             s = ffeexpr_sym_lhs_let_ (s, t);
15120           break;
15121
15122         case FFEEXPR_contextCHARACTERSIZE:
15123         case FFEEXPR_contextEQUIVALENCE:
15124         case FFEEXPR_contextINCLUDE:
15125         case FFEEXPR_contextPARAMETER:
15126         case FFEEXPR_contextDIMLIST:
15127         case FFEEXPR_contextDIMLISTCOMMON:
15128         case FFEEXPR_contextKINDTYPE:
15129         case FFEEXPR_contextINITVAL:
15130         case FFEEXPR_contextEQVINDEX_:
15131           break;                /* Will turn into errors below. */
15132
15133         default:
15134           ffesymbol_error (s, t);
15135           break;
15136         }
15137       /* Fall through. */
15138     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
15139     understood:         /* :::::::::::::::::::: */
15140       k = ffesymbol_kind (s);
15141       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15142         {
15143         case FFEEXPR_contextSUBROUTINEREF:
15144           bad = ((k != FFEINFO_kindSUBROUTINE)
15145                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15146                      || (k != FFEINFO_kindNONE)));
15147           break;
15148
15149         case FFEEXPR_contextFILEEXTFUNC:
15150           bad = (k != FFEINFO_kindFUNCTION)
15151             || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15152           break;
15153
15154         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15155         case FFEEXPR_contextACTUALARG_:
15156           switch (k)
15157             {
15158             case FFEINFO_kindENTITY:
15159               bad = FALSE;
15160               break;
15161
15162             case FFEINFO_kindFUNCTION:
15163             case FFEINFO_kindSUBROUTINE:
15164               bad
15165                 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15166                    && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15167                    && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15168                        || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15169               break;
15170
15171             case FFEINFO_kindNONE:
15172               if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15173                 {
15174                   bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15175                   break;
15176                 }
15177
15178               /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15179                  and in the former case, attrsTYPE is set, so we
15180                  see this as an error as we should, since CHAR*(*)
15181                  cannot be actually referenced in a main/block data
15182                  program unit.  */
15183
15184               if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15185                                           | FFESYMBOL_attrsEXTERNAL
15186                                           | FFESYMBOL_attrsTYPE))
15187                   == FFESYMBOL_attrsEXTERNAL)
15188                 bad = FALSE;
15189               else
15190                 bad = TRUE;
15191               break;
15192
15193             default:
15194               bad = TRUE;
15195               break;
15196             }
15197           break;
15198
15199         case FFEEXPR_contextDATA:
15200           if (ffeexpr_stack_->is_rhs)
15201             bad = (k != FFEINFO_kindENTITY)
15202               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15203           else
15204             bad = (k != FFEINFO_kindENTITY)
15205               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15206                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15207                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15208           break;
15209
15210         case FFEEXPR_contextDATAIMPDOITEM_:
15211           bad = TRUE;           /* Unadorned item never valid. */
15212           break;
15213
15214         case FFEEXPR_contextSFUNCDEF:
15215         case FFEEXPR_contextSFUNCDEFINDEX_:
15216         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15217         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15218         case FFEEXPR_contextLET:
15219         case FFEEXPR_contextPAREN_:
15220         case FFEEXPR_contextACTUALARGEXPR_:
15221         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15222         case FFEEXPR_contextASSIGN:
15223         case FFEEXPR_contextIOLIST:
15224         case FFEEXPR_contextIOLISTDF:
15225         case FFEEXPR_contextDO:
15226         case FFEEXPR_contextDOWHILE:
15227         case FFEEXPR_contextAGOTO:
15228         case FFEEXPR_contextCGOTO:
15229         case FFEEXPR_contextIF:
15230         case FFEEXPR_contextARITHIF:
15231         case FFEEXPR_contextFORMAT:
15232         case FFEEXPR_contextSTOP:
15233         case FFEEXPR_contextRETURN:
15234         case FFEEXPR_contextSELECTCASE:
15235         case FFEEXPR_contextCASE:
15236         case FFEEXPR_contextFILEASSOC:
15237         case FFEEXPR_contextFILEINT:
15238         case FFEEXPR_contextFILEDFINT:
15239         case FFEEXPR_contextFILELOG:
15240         case FFEEXPR_contextFILENUM:
15241         case FFEEXPR_contextFILENUMAMBIG:
15242         case FFEEXPR_contextFILECHAR:
15243         case FFEEXPR_contextFILENUMCHAR:
15244         case FFEEXPR_contextFILEDFCHAR:
15245         case FFEEXPR_contextFILEKEY:
15246         case FFEEXPR_contextFILEUNIT:
15247         case FFEEXPR_contextFILEUNIT_DF:
15248         case FFEEXPR_contextFILEUNITAMBIG:
15249         case FFEEXPR_contextFILEFORMAT:
15250         case FFEEXPR_contextFILENAMELIST:
15251         case FFEEXPR_contextFILEVXTCODE:
15252         case FFEEXPR_contextINDEX_:
15253         case FFEEXPR_contextIMPDOITEM_:
15254         case FFEEXPR_contextIMPDOITEMDF_:
15255         case FFEEXPR_contextIMPDOCTRL_:
15256         case FFEEXPR_contextLOC_:
15257           bad = (k != FFEINFO_kindENTITY);      /* This catches "SUBROUTINE
15258                                                    X(A);EXTERNAL A;CALL
15259                                                    Y(A);B=A", for example. */
15260           break;
15261
15262         case FFEEXPR_contextCHARACTERSIZE:
15263         case FFEEXPR_contextEQUIVALENCE:
15264         case FFEEXPR_contextPARAMETER:
15265         case FFEEXPR_contextDIMLIST:
15266         case FFEEXPR_contextDIMLISTCOMMON:
15267         case FFEEXPR_contextKINDTYPE:
15268         case FFEEXPR_contextINITVAL:
15269         case FFEEXPR_contextEQVINDEX_:
15270           bad = (k != FFEINFO_kindENTITY)
15271             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15272           break;
15273
15274         case FFEEXPR_contextINCLUDE:
15275           bad = TRUE;
15276           break;
15277
15278         default:
15279           bad = TRUE;
15280           break;
15281         }
15282       if (bad && (k != FFEINFO_kindANY))
15283         ffesymbol_error (s, t);
15284       return s;
15285
15286     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
15287     seen:                       /* :::::::::::::::::::: */
15288       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15289         {
15290         case FFEEXPR_contextPARAMETER:
15291           if (ffeexpr_stack_->is_rhs)
15292             ffesymbol_error (s, t);
15293           else
15294             s = ffeexpr_sym_lhs_parameter_ (s, t);
15295           break;
15296
15297         case FFEEXPR_contextDATA:
15298           s = ffecom_sym_exec_transition (s);
15299           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15300             goto understood;    /* :::::::::::::::::::: */
15301           if (ffeexpr_stack_->is_rhs)
15302             ffesymbol_error (s, t);
15303           else
15304             s = ffeexpr_sym_lhs_data_ (s, t);
15305           goto understood;      /* :::::::::::::::::::: */
15306
15307         case FFEEXPR_contextDATAIMPDOITEM_:
15308           s = ffecom_sym_exec_transition (s);
15309           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15310             goto understood;    /* :::::::::::::::::::: */
15311           s = ffeexpr_sym_lhs_data_ (s, t);
15312           goto understood;      /* :::::::::::::::::::: */
15313
15314         case FFEEXPR_contextEQUIVALENCE:
15315           s = ffeexpr_sym_lhs_equivalence_ (s, t);
15316           break;
15317
15318         case FFEEXPR_contextDIMLIST:
15319           s = ffeexpr_sym_rhs_dimlist_ (s, t);
15320           break;
15321
15322         case FFEEXPR_contextCHARACTERSIZE:
15323         case FFEEXPR_contextKINDTYPE:
15324         case FFEEXPR_contextDIMLISTCOMMON:
15325         case FFEEXPR_contextINITVAL:
15326         case FFEEXPR_contextEQVINDEX_:
15327           ffesymbol_error (s, t);
15328           break;
15329
15330         case FFEEXPR_contextINCLUDE:
15331           ffesymbol_error (s, t);
15332           break;
15333
15334         case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
15335         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15336           s = ffecom_sym_exec_transition (s);
15337           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15338             goto understood;    /* :::::::::::::::::::: */
15339           s = ffeexpr_sym_rhs_actualarg_ (s, t);
15340           goto understood;      /* :::::::::::::::::::: */
15341
15342         case FFEEXPR_contextINDEX_:
15343         case FFEEXPR_contextACTUALARGEXPR_:
15344         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15345         case FFEEXPR_contextSFUNCDEF:
15346         case FFEEXPR_contextSFUNCDEFINDEX_:
15347         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15348         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15349           assert (ffeexpr_stack_->is_rhs);
15350           s = ffecom_sym_exec_transition (s);
15351           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15352             goto understood;    /* :::::::::::::::::::: */
15353           s = ffeexpr_sym_rhs_let_ (s, t);
15354           goto understood;      /* :::::::::::::::::::: */
15355
15356         default:
15357           ffesymbol_error (s, t);
15358           break;
15359         }
15360       return s;
15361
15362     default:
15363       assert ("bad symbol state" == NULL);
15364       return NULL;
15365       break;
15366     }
15367 }
15368
15369 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15370    Could be found via the "statement-function" name space (in which case
15371    it should become an iterator) or the local name space (in which case
15372    it should be either a named constant, or a variable that will have an
15373    sfunc name space sibling that should become an iterator).  */
15374
15375 static ffesymbol
15376 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15377 {
15378   ffesymbol s;
15379   ffesymbolAttrs sa;
15380   ffesymbolAttrs na;
15381   ffesymbolState ss;
15382   ffesymbolState ns;
15383   ffeinfoKind kind;
15384   ffeinfoWhere where;
15385
15386   ss = ffesymbol_state (sp);
15387
15388   if (ffesymbol_sfdummyparent (sp) != NULL)
15389     {                           /* Have symbol in sfunc name space. */
15390       switch (ss)
15391         {
15392         case FFESYMBOL_stateNONE:       /* Used as iterator already. */
15393           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15394             ffesymbol_error (sp, t);    /* Can't use dead iterator. */
15395           else
15396             {                   /* Can use dead iterator because we're at at
15397                                    least an innermore (higher-numbered) level
15398                                    than the iterator's outermost
15399                                    (lowest-numbered) level. */
15400               ffesymbol_signal_change (sp);
15401               ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15402               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15403               ffesymbol_signal_unreported (sp);
15404             }
15405           break;
15406
15407         case FFESYMBOL_stateSEEN:       /* Seen already in this or other
15408                                            implied-DO.  Set symbol level
15409                                            number to outermost value, as that
15410                                            tells us we can see it as iterator
15411                                            at that level at the innermost. */
15412           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15413             {
15414               ffesymbol_signal_change (sp);
15415               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15416               ffesymbol_signal_unreported (sp);
15417             }
15418           break;
15419
15420         case FFESYMBOL_stateUNCERTAIN:  /* Iterator. */
15421           assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15422           ffesymbol_error (sp, t);      /* (,,,I=I,10). */
15423           break;
15424
15425         case FFESYMBOL_stateUNDERSTOOD:
15426           break;                /* ANY. */
15427
15428         default:
15429           assert ("Foo Bar!!" == NULL);
15430           break;
15431         }
15432
15433       return sp;
15434     }
15435
15436   /* Got symbol in local name space, so we haven't seen it in impdo yet.
15437      First, if it is brand-new and we're in executable statements, set the
15438      attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15439      Second, if it is now a constant (PARAMETER), then just return it, it
15440      can't be an implied-do iterator.  If it is understood, complain if it is
15441      not a valid variable, but make the inner name space iterator anyway and
15442      return that.  If it is not understood, improve understanding of the
15443      symbol accordingly, complain accordingly, in either case make the inner
15444      name space iterator and return that.  */
15445
15446   sa = ffesymbol_attrs (sp);
15447
15448   if (ffesymbol_state_is_specable (ss)
15449       && ffest_seen_first_exec ())
15450     {
15451       assert (sa == FFESYMBOL_attrsetNONE);
15452       ffesymbol_signal_change (sp);
15453       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15454       ffesymbol_resolve_intrin (sp);
15455       if (ffeimplic_establish_symbol (sp))
15456         ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15457       else
15458         ffesymbol_error (sp, t);
15459
15460       /* After the exec transition, the state will either be UNCERTAIN (could
15461          be a dummy or local var) or UNDERSTOOD (local var, because this is a
15462          PROGRAM/BLOCKDATA program unit).  */
15463
15464       sp = ffecom_sym_exec_transition (sp);
15465       sa = ffesymbol_attrs (sp);
15466       ss = ffesymbol_state (sp);
15467     }
15468
15469   ns = ss;
15470   kind = ffesymbol_kind (sp);
15471   where = ffesymbol_where (sp);
15472
15473   if (ss == FFESYMBOL_stateUNDERSTOOD)
15474     {
15475       if (kind != FFEINFO_kindENTITY)
15476         ffesymbol_error (sp, t);
15477       if (where == FFEINFO_whereCONSTANT)
15478         return sp;
15479     }
15480   else
15481     {
15482       /* Enhance understanding of local symbol.  This used to imply exec
15483          transition, but that doesn't seem necessary, since the local symbol
15484          doesn't actually get put into an ffebld tree here -- we just learn
15485          more about it, just like when we see a local symbol's name in the
15486          dummy-arg list of a statement function.  */
15487
15488       if (ss != FFESYMBOL_stateUNCERTAIN)
15489         {
15490           /* Figure out what kind of object we've got based on previous
15491              declarations of or references to the object. */
15492
15493           ns = FFESYMBOL_stateSEEN;
15494
15495           if (sa & FFESYMBOL_attrsANY)
15496             na = sa;
15497           else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15498                             | FFESYMBOL_attrsANY
15499                             | FFESYMBOL_attrsCOMMON
15500                             | FFESYMBOL_attrsDUMMY
15501                             | FFESYMBOL_attrsEQUIV
15502                             | FFESYMBOL_attrsINIT
15503                             | FFESYMBOL_attrsNAMELIST
15504                             | FFESYMBOL_attrsRESULT
15505                             | FFESYMBOL_attrsSAVE
15506                             | FFESYMBOL_attrsSFARG
15507                             | FFESYMBOL_attrsTYPE)))
15508             na = sa | FFESYMBOL_attrsSFARG;
15509           else
15510             na = FFESYMBOL_attrsetNONE;
15511         }
15512       else
15513         {                       /* stateUNCERTAIN. */
15514           na = sa | FFESYMBOL_attrsSFARG;
15515           ns = FFESYMBOL_stateUNDERSTOOD;
15516
15517           assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15518                            | FFESYMBOL_attrsADJUSTABLE
15519                            | FFESYMBOL_attrsANYLEN
15520                            | FFESYMBOL_attrsARRAY
15521                            | FFESYMBOL_attrsDUMMY
15522                            | FFESYMBOL_attrsEXTERNAL
15523                            | FFESYMBOL_attrsSFARG
15524                            | FFESYMBOL_attrsTYPE)));
15525
15526           if (sa & FFESYMBOL_attrsEXTERNAL)
15527             {
15528               assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15529                                | FFESYMBOL_attrsDUMMY
15530                                | FFESYMBOL_attrsEXTERNAL
15531                                | FFESYMBOL_attrsTYPE)));
15532
15533               na = FFESYMBOL_attrsetNONE;
15534             }
15535           else if (sa & FFESYMBOL_attrsDUMMY)
15536             {
15537               assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15538               assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15539                                | FFESYMBOL_attrsEXTERNAL
15540                                | FFESYMBOL_attrsTYPE)));
15541
15542               kind = FFEINFO_kindENTITY;
15543             }
15544           else if (sa & FFESYMBOL_attrsARRAY)
15545             {
15546               assert (!(sa & ~(FFESYMBOL_attrsARRAY
15547                                | FFESYMBOL_attrsADJUSTABLE
15548                                | FFESYMBOL_attrsTYPE)));
15549
15550               na = FFESYMBOL_attrsetNONE;
15551             }
15552           else if (sa & FFESYMBOL_attrsSFARG)
15553             {
15554               assert (!(sa & ~(FFESYMBOL_attrsSFARG
15555                                | FFESYMBOL_attrsTYPE)));
15556
15557               ns = FFESYMBOL_stateUNCERTAIN;
15558             }
15559           else if (sa & FFESYMBOL_attrsTYPE)
15560             {
15561               assert (!(sa & (FFESYMBOL_attrsARRAY
15562                               | FFESYMBOL_attrsDUMMY
15563                               | FFESYMBOL_attrsEXTERNAL
15564                               | FFESYMBOL_attrsSFARG)));        /* Handled above. */
15565               assert (!(sa & ~(FFESYMBOL_attrsTYPE
15566                                | FFESYMBOL_attrsADJUSTABLE
15567                                | FFESYMBOL_attrsANYLEN
15568                                | FFESYMBOL_attrsARRAY
15569                                | FFESYMBOL_attrsDUMMY
15570                                | FFESYMBOL_attrsEXTERNAL
15571                                | FFESYMBOL_attrsSFARG)));
15572
15573               kind = FFEINFO_kindENTITY;
15574
15575               if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15576                 na = FFESYMBOL_attrsetNONE;
15577               else if (ffest_is_entry_valid ())
15578                 ns = FFESYMBOL_stateUNCERTAIN;  /* Could be DUMMY or LOCAL. */
15579               else
15580                 where = FFEINFO_whereLOCAL;
15581             }
15582           else
15583             na = FFESYMBOL_attrsetNONE; /* Error. */
15584         }
15585
15586       /* Now see what we've got for a new object: NONE means a new error
15587          cropped up; ANY means an old error to be ignored; otherwise,
15588          everything's ok, update the object (symbol) and continue on. */
15589
15590       if (na == FFESYMBOL_attrsetNONE)
15591         ffesymbol_error (sp, t);
15592       else if (!(na & FFESYMBOL_attrsANY))
15593         {
15594           ffesymbol_signal_change (sp); /* May need to back up to previous
15595                                            version. */
15596           if (!ffeimplic_establish_symbol (sp))
15597             ffesymbol_error (sp, t);
15598           else
15599             {
15600               ffesymbol_set_info (sp,
15601                                   ffeinfo_new (ffesymbol_basictype (sp),
15602                                                ffesymbol_kindtype (sp),
15603                                                ffesymbol_rank (sp),
15604                                                kind,
15605                                                where,
15606                                                ffesymbol_size (sp)));
15607               ffesymbol_set_attrs (sp, na);
15608               ffesymbol_set_state (sp, ns);
15609               ffesymbol_resolve_intrin (sp);
15610               if (!ffesymbol_state_is_specable (ns))
15611                 sp = ffecom_sym_learned (sp);
15612               ffesymbol_signal_unreported (sp); /* For debugging purposes. */
15613             }
15614         }
15615     }
15616
15617   /* Here we create the sfunc-name-space symbol representing what should
15618      become an iterator in this name space at this or an outermore (lower-
15619      numbered) expression level, else the implied-DO construct is in error.  */
15620
15621   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
15622                                            also sets sfa_dummy_parent to
15623                                            parent symbol. */
15624   assert (sp == ffesymbol_sfdummyparent (s));
15625
15626   ffesymbol_signal_change (s);
15627   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15628   ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15629   ffesymbol_set_info (s,
15630                       ffeinfo_new (FFEINFO_basictypeINTEGER,
15631                                    FFEINFO_kindtypeINTEGERDEFAULT,
15632                                    0,
15633                                    FFEINFO_kindENTITY,
15634                                    FFEINFO_whereIMMEDIATE,
15635                                    FFETARGET_charactersizeNONE));
15636   ffesymbol_signal_unreported (s);
15637
15638   if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15639        && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15640     ffesymbol_error (s, t);
15641
15642   return s;
15643 }
15644
15645 /* Have FOO in CALL FOO.  Local name space, executable context only.  */
15646
15647 static ffesymbol
15648 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15649 {
15650   ffesymbolAttrs sa;
15651   ffesymbolAttrs na;
15652   ffeinfoKind kind;
15653   ffeinfoWhere where;
15654   ffeintrinGen gen;
15655   ffeintrinSpec spec;
15656   ffeintrinImp imp;
15657   bool error = FALSE;
15658
15659   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15660           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15661
15662   na = sa = ffesymbol_attrs (s);
15663
15664   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15665                    | FFESYMBOL_attrsADJUSTABLE
15666                    | FFESYMBOL_attrsANYLEN
15667                    | FFESYMBOL_attrsARRAY
15668                    | FFESYMBOL_attrsDUMMY
15669                    | FFESYMBOL_attrsEXTERNAL
15670                    | FFESYMBOL_attrsSFARG
15671                    | FFESYMBOL_attrsTYPE)));
15672
15673   kind = ffesymbol_kind (s);
15674   where = ffesymbol_where (s);
15675
15676   /* Figure out what kind of object we've got based on previous declarations
15677      of or references to the object. */
15678
15679   if (sa & FFESYMBOL_attrsEXTERNAL)
15680     {
15681       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15682                        | FFESYMBOL_attrsDUMMY
15683                        | FFESYMBOL_attrsEXTERNAL
15684                        | FFESYMBOL_attrsTYPE)));
15685
15686       if (sa & FFESYMBOL_attrsTYPE)
15687         error = TRUE;
15688       else
15689         /* Not TYPE. */
15690         {
15691           kind = FFEINFO_kindSUBROUTINE;
15692
15693           if (sa & FFESYMBOL_attrsDUMMY)
15694             ;                   /* Not TYPE. */
15695           else if (sa & FFESYMBOL_attrsACTUALARG)
15696             ;                   /* Not DUMMY or TYPE. */
15697           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
15698             where = FFEINFO_whereGLOBAL;
15699         }
15700     }
15701   else if (sa & FFESYMBOL_attrsDUMMY)
15702     {
15703       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15704       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15705                        | FFESYMBOL_attrsEXTERNAL
15706                        | FFESYMBOL_attrsTYPE)));
15707
15708       if (sa & FFESYMBOL_attrsTYPE)
15709         error = TRUE;
15710       else
15711         kind = FFEINFO_kindSUBROUTINE;
15712     }
15713   else if (sa & FFESYMBOL_attrsARRAY)
15714     {
15715       assert (!(sa & ~(FFESYMBOL_attrsARRAY
15716                        | FFESYMBOL_attrsADJUSTABLE
15717                        | FFESYMBOL_attrsTYPE)));
15718
15719       error = TRUE;
15720     }
15721   else if (sa & FFESYMBOL_attrsSFARG)
15722     {
15723       assert (!(sa & ~(FFESYMBOL_attrsSFARG
15724                        | FFESYMBOL_attrsTYPE)));
15725
15726       error = TRUE;
15727     }
15728   else if (sa & FFESYMBOL_attrsTYPE)
15729     {
15730       assert (!(sa & (FFESYMBOL_attrsARRAY
15731                       | FFESYMBOL_attrsDUMMY
15732                       | FFESYMBOL_attrsEXTERNAL
15733                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
15734       assert (!(sa & ~(FFESYMBOL_attrsTYPE
15735                        | FFESYMBOL_attrsADJUSTABLE
15736                        | FFESYMBOL_attrsANYLEN
15737                        | FFESYMBOL_attrsARRAY
15738                        | FFESYMBOL_attrsDUMMY
15739                        | FFESYMBOL_attrsEXTERNAL
15740                        | FFESYMBOL_attrsSFARG)));
15741
15742       error = TRUE;
15743     }
15744   else if (sa == FFESYMBOL_attrsetNONE)
15745     {
15746       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15747
15748       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15749                                   &gen, &spec, &imp))
15750         {
15751           ffesymbol_signal_change (s);  /* May need to back up to previous
15752                                            version. */
15753           ffesymbol_set_generic (s, gen);
15754           ffesymbol_set_specific (s, spec);
15755           ffesymbol_set_implementation (s, imp);
15756           ffesymbol_set_info (s,
15757                               ffeinfo_new (FFEINFO_basictypeNONE,
15758                                            FFEINFO_kindtypeNONE,
15759                                            0,
15760                                            FFEINFO_kindSUBROUTINE,
15761                                            FFEINFO_whereINTRINSIC,
15762                                            FFETARGET_charactersizeNONE));
15763           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15764           ffesymbol_resolve_intrin (s);
15765           ffesymbol_reference (s, t, FALSE);
15766           s = ffecom_sym_learned (s);
15767           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
15768
15769           return s;
15770         }
15771
15772       kind = FFEINFO_kindSUBROUTINE;
15773       where = FFEINFO_whereGLOBAL;
15774     }
15775   else
15776     error = TRUE;
15777
15778   /* Now see what we've got for a new object: NONE means a new error cropped
15779      up; ANY means an old error to be ignored; otherwise, everything's ok,
15780      update the object (symbol) and continue on. */
15781
15782   if (error)
15783     ffesymbol_error (s, t);
15784   else if (!(na & FFESYMBOL_attrsANY))
15785     {
15786       ffesymbol_signal_change (s);      /* May need to back up to previous
15787                                            version. */
15788       ffesymbol_set_info (s,
15789                           ffeinfo_new (ffesymbol_basictype (s),
15790                                        ffesymbol_kindtype (s),
15791                                        ffesymbol_rank (s),
15792                                        kind,    /* SUBROUTINE. */
15793                                        where,   /* GLOBAL or DUMMY. */
15794                                        ffesymbol_size (s)));
15795       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15796       ffesymbol_resolve_intrin (s);
15797       ffesymbol_reference (s, t, FALSE);
15798       s = ffecom_sym_learned (s);
15799       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
15800     }
15801
15802   return s;
15803 }
15804
15805 /* Have FOO in DATA FOO/.../.  Local name space and executable context
15806    only.  (This will change in the future when DATA FOO may be followed
15807    by COMMON FOO or even INTEGER FOO(10), etc.)  */
15808
15809 static ffesymbol
15810 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15811 {
15812   ffesymbolAttrs sa;
15813   ffesymbolAttrs na;
15814   ffeinfoKind kind;
15815   ffeinfoWhere where;
15816   bool error = FALSE;
15817
15818   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15819           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15820
15821   na = sa = ffesymbol_attrs (s);
15822
15823   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15824                    | FFESYMBOL_attrsADJUSTABLE
15825                    | FFESYMBOL_attrsANYLEN
15826                    | FFESYMBOL_attrsARRAY
15827                    | FFESYMBOL_attrsDUMMY
15828                    | FFESYMBOL_attrsEXTERNAL
15829                    | FFESYMBOL_attrsSFARG
15830                    | FFESYMBOL_attrsTYPE)));
15831
15832   kind = ffesymbol_kind (s);
15833   where = ffesymbol_where (s);
15834
15835   /* Figure out what kind of object we've got based on previous declarations
15836      of or references to the object. */
15837
15838   if (sa & FFESYMBOL_attrsEXTERNAL)
15839     {
15840       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15841                        | FFESYMBOL_attrsDUMMY
15842                        | FFESYMBOL_attrsEXTERNAL
15843                        | FFESYMBOL_attrsTYPE)));
15844
15845       error = TRUE;
15846     }
15847   else if (sa & FFESYMBOL_attrsDUMMY)
15848     {
15849       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15850       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15851                        | FFESYMBOL_attrsEXTERNAL
15852                        | FFESYMBOL_attrsTYPE)));
15853
15854       error = TRUE;
15855     }
15856   else if (sa & FFESYMBOL_attrsARRAY)
15857     {
15858       assert (!(sa & ~(FFESYMBOL_attrsARRAY
15859                        | FFESYMBOL_attrsADJUSTABLE
15860                        | FFESYMBOL_attrsTYPE)));
15861
15862       if (sa & FFESYMBOL_attrsADJUSTABLE)
15863         error = TRUE;
15864       where = FFEINFO_whereLOCAL;
15865     }
15866   else if (sa & FFESYMBOL_attrsSFARG)
15867     {
15868       assert (!(sa & ~(FFESYMBOL_attrsSFARG
15869                        | FFESYMBOL_attrsTYPE)));
15870
15871       where = FFEINFO_whereLOCAL;
15872     }
15873   else if (sa & FFESYMBOL_attrsTYPE)
15874     {
15875       assert (!(sa & (FFESYMBOL_attrsARRAY
15876                       | FFESYMBOL_attrsDUMMY
15877                       | FFESYMBOL_attrsEXTERNAL
15878                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
15879       assert (!(sa & ~(FFESYMBOL_attrsTYPE
15880                        | FFESYMBOL_attrsADJUSTABLE
15881                        | FFESYMBOL_attrsANYLEN
15882                        | FFESYMBOL_attrsARRAY
15883                        | FFESYMBOL_attrsDUMMY
15884                        | FFESYMBOL_attrsEXTERNAL
15885                        | FFESYMBOL_attrsSFARG)));
15886
15887       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15888         error = TRUE;
15889       else
15890         {
15891           kind = FFEINFO_kindENTITY;
15892           where = FFEINFO_whereLOCAL;
15893         }
15894     }
15895   else if (sa == FFESYMBOL_attrsetNONE)
15896     {
15897       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15898       kind = FFEINFO_kindENTITY;
15899       where = FFEINFO_whereLOCAL;
15900     }
15901   else
15902     error = TRUE;
15903
15904   /* Now see what we've got for a new object: NONE means a new error cropped
15905      up; ANY means an old error to be ignored; otherwise, everything's ok,
15906      update the object (symbol) and continue on. */
15907
15908   if (error)
15909     ffesymbol_error (s, t);
15910   else if (!(na & FFESYMBOL_attrsANY))
15911     {
15912       ffesymbol_signal_change (s);      /* May need to back up to previous
15913                                            version. */
15914       if (!ffeimplic_establish_symbol (s))
15915         {
15916           ffesymbol_error (s, t);
15917           return s;
15918         }
15919       ffesymbol_set_info (s,
15920                           ffeinfo_new (ffesymbol_basictype (s),
15921                                        ffesymbol_kindtype (s),
15922                                        ffesymbol_rank (s),
15923                                        kind,    /* ENTITY. */
15924                                        where,   /* LOCAL. */
15925                                        ffesymbol_size (s)));
15926       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15927       ffesymbol_resolve_intrin (s);
15928       s = ffecom_sym_learned (s);
15929       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
15930     }
15931
15932   return s;
15933 }
15934
15935 /* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
15936    EQUIVALENCE (...,BAR(FOO),...).  */
15937
15938 static ffesymbol
15939 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15940 {
15941   ffesymbolAttrs sa;
15942   ffesymbolAttrs na;
15943   ffeinfoKind kind;
15944   ffeinfoWhere where;
15945
15946   na = sa = ffesymbol_attrs (s);
15947   kind = FFEINFO_kindENTITY;
15948   where = ffesymbol_where (s);
15949
15950   /* Figure out what kind of object we've got based on previous declarations
15951      of or references to the object. */
15952
15953   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15954                | FFESYMBOL_attrsARRAY
15955                | FFESYMBOL_attrsCOMMON
15956                | FFESYMBOL_attrsEQUIV
15957                | FFESYMBOL_attrsINIT
15958                | FFESYMBOL_attrsNAMELIST
15959                | FFESYMBOL_attrsSAVE
15960                | FFESYMBOL_attrsSFARG
15961                | FFESYMBOL_attrsTYPE)))
15962     na = sa | FFESYMBOL_attrsEQUIV;
15963   else
15964     na = FFESYMBOL_attrsetNONE;
15965
15966   /* Don't know why we're bothering to set kind and where in this code, but
15967      added the following to make it complete, in case it's really important.
15968      Generally this is left up to symbol exec transition.  */
15969
15970   if (where == FFEINFO_whereNONE)
15971     {
15972       if (na & (FFESYMBOL_attrsADJUSTS
15973                 | FFESYMBOL_attrsCOMMON))
15974         where = FFEINFO_whereCOMMON;
15975       else if (na & FFESYMBOL_attrsSAVE)
15976         where = FFEINFO_whereLOCAL;
15977     }
15978
15979   /* Now see what we've got for a new object: NONE means a new error cropped
15980      up; ANY means an old error to be ignored; otherwise, everything's ok,
15981      update the object (symbol) and continue on. */
15982
15983   if (na == FFESYMBOL_attrsetNONE)
15984     ffesymbol_error (s, t);
15985   else if (!(na & FFESYMBOL_attrsANY))
15986     {
15987       ffesymbol_signal_change (s);      /* May need to back up to previous
15988                                            version. */
15989       ffesymbol_set_info (s,
15990                           ffeinfo_new (ffesymbol_basictype (s),
15991                                        ffesymbol_kindtype (s),
15992                                        ffesymbol_rank (s),
15993                                        kind,    /* Always ENTITY. */
15994                                        where,   /* NONE, COMMON, or LOCAL. */
15995                                        ffesymbol_size (s)));
15996       ffesymbol_set_attrs (s, na);
15997       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15998       ffesymbol_resolve_intrin (s);
15999       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16000     }
16001
16002   return s;
16003 }
16004
16005 /* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
16006
16007    Note that I think this should be considered semantically similar to
16008    doing CALL XYZ(FOO), in that it should be considered like an
16009    ACTUALARG context.  In particular, without EXTERNAL being specified,
16010    it should not be allowed.  */
16011
16012 static ffesymbol
16013 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16014 {
16015   ffesymbolAttrs sa;
16016   ffesymbolAttrs na;
16017   ffeinfoKind kind;
16018   ffeinfoWhere where;
16019   bool needs_type = FALSE;
16020   bool error = FALSE;
16021
16022   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16023           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16024
16025   na = sa = ffesymbol_attrs (s);
16026
16027   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16028                    | FFESYMBOL_attrsADJUSTABLE
16029                    | FFESYMBOL_attrsANYLEN
16030                    | FFESYMBOL_attrsARRAY
16031                    | FFESYMBOL_attrsDUMMY
16032                    | FFESYMBOL_attrsEXTERNAL
16033                    | FFESYMBOL_attrsSFARG
16034                    | FFESYMBOL_attrsTYPE)));
16035
16036   kind = ffesymbol_kind (s);
16037   where = ffesymbol_where (s);
16038
16039   /* Figure out what kind of object we've got based on previous declarations
16040      of or references to the object. */
16041
16042   if (sa & FFESYMBOL_attrsEXTERNAL)
16043     {
16044       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16045                        | FFESYMBOL_attrsDUMMY
16046                        | FFESYMBOL_attrsEXTERNAL
16047                        | FFESYMBOL_attrsTYPE)));
16048
16049       if (sa & FFESYMBOL_attrsTYPE)
16050         where = FFEINFO_whereGLOBAL;
16051       else
16052         /* Not TYPE. */
16053         {
16054           kind = FFEINFO_kindFUNCTION;
16055           needs_type = TRUE;
16056
16057           if (sa & FFESYMBOL_attrsDUMMY)
16058             ;                   /* Not TYPE. */
16059           else if (sa & FFESYMBOL_attrsACTUALARG)
16060             ;                   /* Not DUMMY or TYPE. */
16061           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
16062             where = FFEINFO_whereGLOBAL;
16063         }
16064     }
16065   else if (sa & FFESYMBOL_attrsDUMMY)
16066     {
16067       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16068       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16069                        | FFESYMBOL_attrsEXTERNAL
16070                        | FFESYMBOL_attrsTYPE)));
16071
16072       kind = FFEINFO_kindFUNCTION;
16073       if (!(sa & FFESYMBOL_attrsTYPE))
16074         needs_type = TRUE;
16075     }
16076   else if (sa & FFESYMBOL_attrsARRAY)
16077     {
16078       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16079                        | FFESYMBOL_attrsADJUSTABLE
16080                        | FFESYMBOL_attrsTYPE)));
16081
16082       error = TRUE;
16083     }
16084   else if (sa & FFESYMBOL_attrsSFARG)
16085     {
16086       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16087                        | FFESYMBOL_attrsTYPE)));
16088
16089       error = TRUE;
16090     }
16091   else if (sa & FFESYMBOL_attrsTYPE)
16092     {
16093       assert (!(sa & (FFESYMBOL_attrsARRAY
16094                       | FFESYMBOL_attrsDUMMY
16095                       | FFESYMBOL_attrsEXTERNAL
16096                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16097       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16098                        | FFESYMBOL_attrsADJUSTABLE
16099                        | FFESYMBOL_attrsANYLEN
16100                        | FFESYMBOL_attrsARRAY
16101                        | FFESYMBOL_attrsDUMMY
16102                        | FFESYMBOL_attrsEXTERNAL
16103                        | FFESYMBOL_attrsSFARG)));
16104
16105       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16106         error = TRUE;
16107       else
16108         {
16109           kind = FFEINFO_kindFUNCTION;
16110           where = FFEINFO_whereGLOBAL;
16111         }
16112     }
16113   else if (sa == FFESYMBOL_attrsetNONE)
16114     {
16115       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16116       kind = FFEINFO_kindFUNCTION;
16117       where = FFEINFO_whereGLOBAL;
16118       needs_type = TRUE;
16119     }
16120   else
16121     error = TRUE;
16122
16123   /* Now see what we've got for a new object: NONE means a new error cropped
16124      up; ANY means an old error to be ignored; otherwise, everything's ok,
16125      update the object (symbol) and continue on. */
16126
16127   if (error)
16128     ffesymbol_error (s, t);
16129   else if (!(na & FFESYMBOL_attrsANY))
16130     {
16131       ffesymbol_signal_change (s);      /* May need to back up to previous
16132                                            version. */
16133       if (needs_type && !ffeimplic_establish_symbol (s))
16134         {
16135           ffesymbol_error (s, t);
16136           return s;
16137         }
16138       if (!ffesymbol_explicitwhere (s))
16139         {
16140           ffebad_start (FFEBAD_NEED_EXTERNAL);
16141           ffebad_here (0, ffelex_token_where_line (t),
16142                        ffelex_token_where_column (t));
16143           ffebad_string (ffesymbol_text (s));
16144           ffebad_finish ();
16145           ffesymbol_set_explicitwhere (s, TRUE);
16146         }
16147       ffesymbol_set_info (s,
16148                           ffeinfo_new (ffesymbol_basictype (s),
16149                                        ffesymbol_kindtype (s),
16150                                        ffesymbol_rank (s),
16151                                        kind,    /* FUNCTION. */
16152                                        where,   /* GLOBAL or DUMMY. */
16153                                        ffesymbol_size (s)));
16154       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16155       ffesymbol_resolve_intrin (s);
16156       ffesymbol_reference (s, t, FALSE);
16157       s = ffecom_sym_learned (s);
16158       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16159     }
16160
16161   return s;
16162 }
16163
16164 /* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
16165
16166 static ffesymbol
16167 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16168 {
16169   ffesymbolState ss;
16170
16171   /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16172      reference to it already within the imp-DO construct at this level, so as
16173      to get a symbol that is in the sfunc name space. But this is an
16174      erroneous construct, and should be caught elsewhere.  */
16175
16176   if (ffesymbol_sfdummyparent (s) == NULL)
16177     {
16178       s = ffeexpr_sym_impdoitem_ (s, t);
16179       if (ffesymbol_sfdummyparent (s) == NULL)
16180         {                       /* PARAMETER FOO...DATA (A(I),FOO=...). */
16181           ffesymbol_error (s, t);
16182           return s;
16183         }
16184     }
16185
16186   ss = ffesymbol_state (s);
16187
16188   switch (ss)
16189     {
16190     case FFESYMBOL_stateNONE:   /* Used as iterator already. */
16191       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16192         ffesymbol_error (s, t); /* Can't reuse dead iterator.  F90 disallows
16193                                    this; F77 allows it but it is a stupid
16194                                    feature. */
16195       else
16196         {                       /* Can use dead iterator because we're at at
16197                                    least a innermore (higher-numbered) level
16198                                    than the iterator's outermost
16199                                    (lowest-numbered) level.  This should be
16200                                    diagnosed later, because it means an item
16201                                    in this list didn't reference this
16202                                    iterator. */
16203 #if 1
16204           ffesymbol_error (s, t);       /* For now, complain. */
16205 #else /* Someday will detect all cases where initializer doesn't reference
16206          all applicable iterators, in which case reenable this code. */
16207           ffesymbol_signal_change (s);
16208           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16209           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16210           ffesymbol_signal_unreported (s);
16211 #endif
16212         }
16213       break;
16214
16215     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
16216                                    If seen in outermore level, can't be an
16217                                    iterator here, so complain.  If not seen
16218                                    at current level, complain for now,
16219                                    because that indicates something F90
16220                                    rejects (though we currently don't detect
16221                                    all such cases for now). */
16222       if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16223         {
16224           ffesymbol_signal_change (s);
16225           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16226           ffesymbol_signal_unreported (s);
16227         }
16228       else
16229         ffesymbol_error (s, t);
16230       break;
16231
16232     case FFESYMBOL_stateUNCERTAIN:      /* Already iterator! */
16233       assert ("DATA implied-DO control var seen twice!!" == NULL);
16234       ffesymbol_error (s, t);
16235       break;
16236
16237     case FFESYMBOL_stateUNDERSTOOD:
16238       break;                    /* ANY. */
16239
16240     default:
16241       assert ("Foo Bletch!!" == NULL);
16242       break;
16243     }
16244
16245   return s;
16246 }
16247
16248 /* Have FOO in PARAMETER (FOO=...).  */
16249
16250 static ffesymbol
16251 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16252 {
16253   ffesymbolAttrs sa;
16254
16255   sa = ffesymbol_attrs (s);
16256
16257   /* Figure out what kind of object we've got based on previous declarations
16258      of or references to the object. */
16259
16260   if (sa & ~(FFESYMBOL_attrsANYLEN
16261              | FFESYMBOL_attrsTYPE))
16262     {
16263       if (!(sa & FFESYMBOL_attrsANY))
16264         ffesymbol_error (s, t);
16265     }
16266   else
16267     {
16268       ffesymbol_signal_change (s);      /* May need to back up to previous
16269                                            version. */
16270       if (!ffeimplic_establish_symbol (s))
16271         {
16272           ffesymbol_error (s, t);
16273           return s;
16274         }
16275       ffesymbol_set_info (s,
16276                           ffeinfo_new (ffesymbol_basictype (s),
16277                                        ffesymbol_kindtype (s),
16278                                        ffesymbol_rank (s),
16279                                        FFEINFO_kindENTITY,
16280                                        FFEINFO_whereCONSTANT,
16281                                        ffesymbol_size (s)));
16282       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16283       ffesymbol_resolve_intrin (s);
16284       s = ffecom_sym_learned (s);
16285       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16286     }
16287
16288   return s;
16289 }
16290
16291 /* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
16292    embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
16293
16294 static ffesymbol
16295 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16296 {
16297   ffesymbolAttrs sa;
16298   ffesymbolAttrs na;
16299   ffeinfoKind kind;
16300   ffeinfoWhere where;
16301   ffesymbolState ns;
16302   bool needs_type = FALSE;
16303
16304   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16305           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16306
16307   na = sa = ffesymbol_attrs (s);
16308
16309   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16310                    | FFESYMBOL_attrsADJUSTABLE
16311                    | FFESYMBOL_attrsANYLEN
16312                    | FFESYMBOL_attrsARRAY
16313                    | FFESYMBOL_attrsDUMMY
16314                    | FFESYMBOL_attrsEXTERNAL
16315                    | FFESYMBOL_attrsSFARG
16316                    | FFESYMBOL_attrsTYPE)));
16317
16318   kind = ffesymbol_kind (s);
16319   where = ffesymbol_where (s);
16320
16321   /* Figure out what kind of object we've got based on previous declarations
16322      of or references to the object. */
16323
16324   ns = FFESYMBOL_stateUNDERSTOOD;
16325
16326   if (sa & FFESYMBOL_attrsEXTERNAL)
16327     {
16328       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16329                        | FFESYMBOL_attrsDUMMY
16330                        | FFESYMBOL_attrsEXTERNAL
16331                        | FFESYMBOL_attrsTYPE)));
16332
16333       if (sa & FFESYMBOL_attrsTYPE)
16334         where = FFEINFO_whereGLOBAL;
16335       else
16336         /* Not TYPE. */
16337         {
16338           ns = FFESYMBOL_stateUNCERTAIN;
16339
16340           if (sa & FFESYMBOL_attrsDUMMY)
16341             assert (kind == FFEINFO_kindNONE);  /* FUNCTION, SUBROUTINE. */
16342           else if (sa & FFESYMBOL_attrsACTUALARG)
16343             ;                   /* Not DUMMY or TYPE. */
16344           else
16345             /* Not ACTUALARG, DUMMY, or TYPE. */
16346             {
16347               assert (kind == FFEINFO_kindNONE);        /* FUNCTION, SUBROUTINE. */
16348               na |= FFESYMBOL_attrsACTUALARG;
16349               where = FFEINFO_whereGLOBAL;
16350             }
16351         }
16352     }
16353   else if (sa & FFESYMBOL_attrsDUMMY)
16354     {
16355       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16356       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16357                        | FFESYMBOL_attrsEXTERNAL
16358                        | FFESYMBOL_attrsTYPE)));
16359
16360       kind = FFEINFO_kindENTITY;
16361       if (!(sa & FFESYMBOL_attrsTYPE))
16362         needs_type = TRUE;
16363     }
16364   else if (sa & FFESYMBOL_attrsARRAY)
16365     {
16366       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16367                        | FFESYMBOL_attrsADJUSTABLE
16368                        | FFESYMBOL_attrsTYPE)));
16369
16370       where = FFEINFO_whereLOCAL;
16371     }
16372   else if (sa & FFESYMBOL_attrsSFARG)
16373     {
16374       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16375                        | FFESYMBOL_attrsTYPE)));
16376
16377       where = FFEINFO_whereLOCAL;
16378     }
16379   else if (sa & FFESYMBOL_attrsTYPE)
16380     {
16381       assert (!(sa & (FFESYMBOL_attrsARRAY
16382                       | FFESYMBOL_attrsDUMMY
16383                       | FFESYMBOL_attrsEXTERNAL
16384                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16385       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16386                        | FFESYMBOL_attrsADJUSTABLE
16387                        | FFESYMBOL_attrsANYLEN
16388                        | FFESYMBOL_attrsARRAY
16389                        | FFESYMBOL_attrsDUMMY
16390                        | FFESYMBOL_attrsEXTERNAL
16391                        | FFESYMBOL_attrsSFARG)));
16392
16393       if (sa & FFESYMBOL_attrsANYLEN)
16394         ns = FFESYMBOL_stateNONE;
16395       else
16396         {
16397           kind = FFEINFO_kindENTITY;
16398           where = FFEINFO_whereLOCAL;
16399         }
16400     }
16401   else if (sa == FFESYMBOL_attrsetNONE)
16402     {
16403       /* New state is left empty because there isn't any state flag to
16404          set for this case, and it's UNDERSTOOD after all.  */
16405       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16406       kind = FFEINFO_kindENTITY;
16407       where = FFEINFO_whereLOCAL;
16408       needs_type = TRUE;
16409     }
16410   else
16411     ns = FFESYMBOL_stateNONE;   /* Error. */
16412
16413   /* Now see what we've got for a new object: NONE means a new error cropped
16414      up; ANY means an old error to be ignored; otherwise, everything's ok,
16415      update the object (symbol) and continue on. */
16416
16417   if (ns == FFESYMBOL_stateNONE)
16418     ffesymbol_error (s, t);
16419   else if (!(na & FFESYMBOL_attrsANY))
16420     {
16421       ffesymbol_signal_change (s);      /* May need to back up to previous
16422                                            version. */
16423       if (needs_type && !ffeimplic_establish_symbol (s))
16424         {
16425           ffesymbol_error (s, t);
16426           return s;
16427         }
16428       ffesymbol_set_info (s,
16429                           ffeinfo_new (ffesymbol_basictype (s),
16430                                        ffesymbol_kindtype (s),
16431                                        ffesymbol_rank (s),
16432                                        kind,
16433                                        where,
16434                                        ffesymbol_size (s)));
16435       ffesymbol_set_attrs (s, na);
16436       ffesymbol_set_state (s, ns);
16437       s = ffecom_sym_learned (s);
16438       ffesymbol_reference (s, t, FALSE);
16439       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16440     }
16441
16442   return s;
16443 }
16444
16445 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16446    a reference to FOO.  */
16447
16448 static ffesymbol
16449 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16450 {
16451   ffesymbolAttrs sa;
16452   ffesymbolAttrs na;
16453   ffeinfoKind kind;
16454   ffeinfoWhere where;
16455
16456   na = sa = ffesymbol_attrs (s);
16457   kind = FFEINFO_kindENTITY;
16458   where = ffesymbol_where (s);
16459
16460   /* Figure out what kind of object we've got based on previous declarations
16461      of or references to the object. */
16462
16463   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16464                | FFESYMBOL_attrsCOMMON
16465                | FFESYMBOL_attrsDUMMY
16466                | FFESYMBOL_attrsEQUIV
16467                | FFESYMBOL_attrsINIT
16468                | FFESYMBOL_attrsNAMELIST
16469                | FFESYMBOL_attrsSFARG
16470                | FFESYMBOL_attrsARRAY
16471                | FFESYMBOL_attrsTYPE)))
16472     na = sa | FFESYMBOL_attrsADJUSTS;
16473   else
16474     na = FFESYMBOL_attrsetNONE;
16475
16476   /* Since this symbol definitely is going into an expression (the
16477      dimension-list for some dummy array, presumably), figure out WHERE if
16478      possible.  */
16479
16480   if (where == FFEINFO_whereNONE)
16481     {
16482       if (na & (FFESYMBOL_attrsCOMMON
16483                 | FFESYMBOL_attrsEQUIV
16484                 | FFESYMBOL_attrsINIT
16485                 | FFESYMBOL_attrsNAMELIST))
16486         where = FFEINFO_whereCOMMON;
16487       else if (na & FFESYMBOL_attrsDUMMY)
16488         where = FFEINFO_whereDUMMY;
16489     }
16490
16491   /* Now see what we've got for a new object: NONE means a new error cropped
16492      up; ANY means an old error to be ignored; otherwise, everything's ok,
16493      update the object (symbol) and continue on. */
16494
16495   if (na == FFESYMBOL_attrsetNONE)
16496     ffesymbol_error (s, t);
16497   else if (!(na & FFESYMBOL_attrsANY))
16498     {
16499       ffesymbol_signal_change (s);      /* May need to back up to previous
16500                                            version. */
16501       if (!ffeimplic_establish_symbol (s))
16502         {
16503           ffesymbol_error (s, t);
16504           return s;
16505         }
16506       ffesymbol_set_info (s,
16507                           ffeinfo_new (ffesymbol_basictype (s),
16508                                        ffesymbol_kindtype (s),
16509                                        ffesymbol_rank (s),
16510                                        kind,    /* Always ENTITY. */
16511                                        where,   /* NONE, COMMON, or DUMMY. */
16512                                        ffesymbol_size (s)));
16513       ffesymbol_set_attrs (s, na);
16514       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16515       ffesymbol_resolve_intrin (s);
16516       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16517     }
16518
16519   return s;
16520 }
16521
16522 /* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
16523    XYZ = BAR(FOO), as such cases are handled elsewhere.  */
16524
16525 static ffesymbol
16526 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16527 {
16528   ffesymbolAttrs sa;
16529   ffesymbolAttrs na;
16530   ffeinfoKind kind;
16531   ffeinfoWhere where;
16532   bool error = FALSE;
16533
16534   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16535           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16536
16537   na = sa = ffesymbol_attrs (s);
16538
16539   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16540                    | FFESYMBOL_attrsADJUSTABLE
16541                    | FFESYMBOL_attrsANYLEN
16542                    | FFESYMBOL_attrsARRAY
16543                    | FFESYMBOL_attrsDUMMY
16544                    | FFESYMBOL_attrsEXTERNAL
16545                    | FFESYMBOL_attrsSFARG
16546                    | FFESYMBOL_attrsTYPE)));
16547
16548   kind = ffesymbol_kind (s);
16549   where = ffesymbol_where (s);
16550
16551   /* Figure out what kind of object we've got based on previous declarations
16552      of or references to the object. */
16553
16554   if (sa & FFESYMBOL_attrsEXTERNAL)
16555     {
16556       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16557                        | FFESYMBOL_attrsDUMMY
16558                        | FFESYMBOL_attrsEXTERNAL
16559                        | FFESYMBOL_attrsTYPE)));
16560
16561       error = TRUE;
16562     }
16563   else if (sa & FFESYMBOL_attrsDUMMY)
16564     {
16565       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16566       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16567                        | FFESYMBOL_attrsEXTERNAL
16568                        | FFESYMBOL_attrsTYPE)));
16569
16570       kind = FFEINFO_kindENTITY;
16571     }
16572   else if (sa & FFESYMBOL_attrsARRAY)
16573     {
16574       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16575                        | FFESYMBOL_attrsADJUSTABLE
16576                        | FFESYMBOL_attrsTYPE)));
16577
16578       where = FFEINFO_whereLOCAL;
16579     }
16580   else if (sa & FFESYMBOL_attrsSFARG)
16581     {
16582       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16583                        | FFESYMBOL_attrsTYPE)));
16584
16585       where = FFEINFO_whereLOCAL;
16586     }
16587   else if (sa & FFESYMBOL_attrsTYPE)
16588     {
16589       assert (!(sa & (FFESYMBOL_attrsARRAY
16590                       | FFESYMBOL_attrsDUMMY
16591                       | FFESYMBOL_attrsEXTERNAL
16592                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16593       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16594                        | FFESYMBOL_attrsADJUSTABLE
16595                        | FFESYMBOL_attrsANYLEN
16596                        | FFESYMBOL_attrsARRAY
16597                        | FFESYMBOL_attrsDUMMY
16598                        | FFESYMBOL_attrsEXTERNAL
16599                        | FFESYMBOL_attrsSFARG)));
16600
16601       if (sa & FFESYMBOL_attrsANYLEN)
16602         error = TRUE;
16603       else
16604         {
16605           kind = FFEINFO_kindENTITY;
16606           where = FFEINFO_whereLOCAL;
16607         }
16608     }
16609   else if (sa == FFESYMBOL_attrsetNONE)
16610     {
16611       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16612       kind = FFEINFO_kindENTITY;
16613       where = FFEINFO_whereLOCAL;
16614     }
16615   else
16616     error = TRUE;
16617
16618   /* Now see what we've got for a new object: NONE means a new error cropped
16619      up; ANY means an old error to be ignored; otherwise, everything's ok,
16620      update the object (symbol) and continue on. */
16621
16622   if (error)
16623     ffesymbol_error (s, t);
16624   else if (!(na & FFESYMBOL_attrsANY))
16625     {
16626       ffesymbol_signal_change (s);      /* May need to back up to previous
16627                                            version. */
16628       if (!ffeimplic_establish_symbol (s))
16629         {
16630           ffesymbol_error (s, t);
16631           return s;
16632         }
16633       ffesymbol_set_info (s,
16634                           ffeinfo_new (ffesymbol_basictype (s),
16635                                        ffesymbol_kindtype (s),
16636                                        ffesymbol_rank (s),
16637                                        kind,    /* ENTITY. */
16638                                        where,   /* LOCAL. */
16639                                        ffesymbol_size (s)));
16640       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16641       ffesymbol_resolve_intrin (s);
16642       s = ffecom_sym_learned (s);
16643       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16644     }
16645
16646   return s;
16647 }
16648
16649 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16650
16651    ffelexToken t;
16652    bool maybe_intrin;
16653    ffeexprParenType_ paren_type;
16654    ffesymbol s;
16655    s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16656
16657    Just like ffesymbol_declare_local, except performs any implicit info
16658    assignment necessary, and it returns the type of the parenthesized list
16659    (list of function args, list of array args, or substring spec).  */
16660
16661 static ffesymbol
16662 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16663                                 ffeexprParenType_ *paren_type)
16664 {
16665   ffesymbol s;
16666   ffesymbolState st;            /* Effective state. */
16667   ffeinfoKind k;
16668   bool bad;
16669
16670   if (maybe_intrin && ffesrc_check_symbol ())
16671     {                           /* Knock off some easy cases. */
16672       switch (ffeexpr_stack_->context)
16673         {
16674         case FFEEXPR_contextSUBROUTINEREF:
16675         case FFEEXPR_contextDATA:
16676         case FFEEXPR_contextDATAIMPDOINDEX_:
16677         case FFEEXPR_contextSFUNCDEF:
16678         case FFEEXPR_contextSFUNCDEFINDEX_:
16679         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16680         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16681         case FFEEXPR_contextLET:
16682         case FFEEXPR_contextPAREN_:
16683         case FFEEXPR_contextACTUALARGEXPR_:
16684         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16685         case FFEEXPR_contextIOLIST:
16686         case FFEEXPR_contextIOLISTDF:
16687         case FFEEXPR_contextDO:
16688         case FFEEXPR_contextDOWHILE:
16689         case FFEEXPR_contextACTUALARG_:
16690         case FFEEXPR_contextCGOTO:
16691         case FFEEXPR_contextIF:
16692         case FFEEXPR_contextARITHIF:
16693         case FFEEXPR_contextFORMAT:
16694         case FFEEXPR_contextSTOP:
16695         case FFEEXPR_contextRETURN:
16696         case FFEEXPR_contextSELECTCASE:
16697         case FFEEXPR_contextCASE:
16698         case FFEEXPR_contextFILEASSOC:
16699         case FFEEXPR_contextFILEINT:
16700         case FFEEXPR_contextFILEDFINT:
16701         case FFEEXPR_contextFILELOG:
16702         case FFEEXPR_contextFILENUM:
16703         case FFEEXPR_contextFILENUMAMBIG:
16704         case FFEEXPR_contextFILECHAR:
16705         case FFEEXPR_contextFILENUMCHAR:
16706         case FFEEXPR_contextFILEDFCHAR:
16707         case FFEEXPR_contextFILEKEY:
16708         case FFEEXPR_contextFILEUNIT:
16709         case FFEEXPR_contextFILEUNIT_DF:
16710         case FFEEXPR_contextFILEUNITAMBIG:
16711         case FFEEXPR_contextFILEFORMAT:
16712         case FFEEXPR_contextFILENAMELIST:
16713         case FFEEXPR_contextFILEVXTCODE:
16714         case FFEEXPR_contextINDEX_:
16715         case FFEEXPR_contextIMPDOITEM_:
16716         case FFEEXPR_contextIMPDOITEMDF_:
16717         case FFEEXPR_contextIMPDOCTRL_:
16718         case FFEEXPR_contextDATAIMPDOCTRL_:
16719         case FFEEXPR_contextCHARACTERSIZE:
16720         case FFEEXPR_contextPARAMETER:
16721         case FFEEXPR_contextDIMLIST:
16722         case FFEEXPR_contextDIMLISTCOMMON:
16723         case FFEEXPR_contextKINDTYPE:
16724         case FFEEXPR_contextINITVAL:
16725         case FFEEXPR_contextEQVINDEX_:
16726           break;                /* These could be intrinsic invocations. */
16727
16728         case FFEEXPR_contextAGOTO:
16729         case FFEEXPR_contextFILEFORMATNML:
16730         case FFEEXPR_contextALLOCATE:
16731         case FFEEXPR_contextDEALLOCATE:
16732         case FFEEXPR_contextHEAPSTAT:
16733         case FFEEXPR_contextNULLIFY:
16734         case FFEEXPR_contextINCLUDE:
16735         case FFEEXPR_contextDATAIMPDOITEM_:
16736         case FFEEXPR_contextLOC_:
16737         case FFEEXPR_contextINDEXORACTUALARG_:
16738         case FFEEXPR_contextSFUNCDEFACTUALARG_:
16739         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16740         case FFEEXPR_contextPARENFILENUM_:
16741         case FFEEXPR_contextPARENFILEUNIT_:
16742           maybe_intrin = FALSE;
16743           break;                /* Can't be intrinsic invocation. */
16744
16745         default:
16746           assert ("blah! blah! waaauuggh!" == NULL);
16747           break;
16748         }
16749     }
16750
16751   s = ffesymbol_declare_local (t, maybe_intrin);
16752
16753   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16754     /* Special-case these since they can involve a different concept
16755        of "state" (in the stmtfunc name space).  */
16756     {
16757     case FFEEXPR_contextDATAIMPDOINDEX_:
16758     case FFEEXPR_contextDATAIMPDOCTRL_:
16759       if (ffeexpr_context_outer_ (ffeexpr_stack_)
16760           == FFEEXPR_contextDATAIMPDOINDEX_)
16761         s = ffeexpr_sym_impdoitem_ (s, t);
16762       else
16763         if (ffeexpr_stack_->is_rhs)
16764           s = ffeexpr_sym_impdoitem_ (s, t);
16765         else
16766           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16767       if (ffesymbol_kind (s) != FFEINFO_kindANY)
16768         ffesymbol_error (s, t);
16769       return s;
16770
16771     default:
16772       break;
16773     }
16774
16775   switch ((ffesymbol_sfdummyparent (s) == NULL)
16776           ? ffesymbol_state (s)
16777           : FFESYMBOL_stateUNDERSTOOD)
16778     {
16779     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
16780                                    context. */
16781       if (!ffest_seen_first_exec ())
16782         goto seen;              /* :::::::::::::::::::: */
16783       /* Fall through. */
16784     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
16785       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16786         {
16787         case FFEEXPR_contextSUBROUTINEREF:
16788           s = ffeexpr_sym_lhs_call_ (s, t);     /* "CALL FOO"=="CALL
16789                                                    FOO(...)". */
16790           break;
16791
16792         case FFEEXPR_contextDATA:
16793           if (ffeexpr_stack_->is_rhs)
16794             s = ffeexpr_sym_rhs_let_ (s, t);
16795           else
16796             s = ffeexpr_sym_lhs_data_ (s, t);
16797           break;
16798
16799         case FFEEXPR_contextDATAIMPDOITEM_:
16800           s = ffeexpr_sym_lhs_data_ (s, t);
16801           break;
16802
16803         case FFEEXPR_contextSFUNCDEF:
16804         case FFEEXPR_contextSFUNCDEFINDEX_:
16805         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16806         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16807           s = ffecom_sym_exec_transition (s);
16808           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16809             goto understood;    /* :::::::::::::::::::: */
16810           /* Fall through. */
16811         case FFEEXPR_contextLET:
16812         case FFEEXPR_contextPAREN_:
16813         case FFEEXPR_contextACTUALARGEXPR_:
16814         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16815         case FFEEXPR_contextIOLIST:
16816         case FFEEXPR_contextIOLISTDF:
16817         case FFEEXPR_contextDO:
16818         case FFEEXPR_contextDOWHILE:
16819         case FFEEXPR_contextACTUALARG_:
16820         case FFEEXPR_contextCGOTO:
16821         case FFEEXPR_contextIF:
16822         case FFEEXPR_contextARITHIF:
16823         case FFEEXPR_contextFORMAT:
16824         case FFEEXPR_contextSTOP:
16825         case FFEEXPR_contextRETURN:
16826         case FFEEXPR_contextSELECTCASE:
16827         case FFEEXPR_contextCASE:
16828         case FFEEXPR_contextFILEASSOC:
16829         case FFEEXPR_contextFILEINT:
16830         case FFEEXPR_contextFILEDFINT:
16831         case FFEEXPR_contextFILELOG:
16832         case FFEEXPR_contextFILENUM:
16833         case FFEEXPR_contextFILENUMAMBIG:
16834         case FFEEXPR_contextFILECHAR:
16835         case FFEEXPR_contextFILENUMCHAR:
16836         case FFEEXPR_contextFILEDFCHAR:
16837         case FFEEXPR_contextFILEKEY:
16838         case FFEEXPR_contextFILEUNIT:
16839         case FFEEXPR_contextFILEUNIT_DF:
16840         case FFEEXPR_contextFILEUNITAMBIG:
16841         case FFEEXPR_contextFILEFORMAT:
16842         case FFEEXPR_contextFILENAMELIST:
16843         case FFEEXPR_contextFILEVXTCODE:
16844         case FFEEXPR_contextINDEX_:
16845         case FFEEXPR_contextIMPDOITEM_:
16846         case FFEEXPR_contextIMPDOITEMDF_:
16847         case FFEEXPR_contextIMPDOCTRL_:
16848         case FFEEXPR_contextLOC_:
16849           if (ffeexpr_stack_->is_rhs)
16850             s = ffeexpr_paren_rhs_let_ (s, t);
16851           else
16852             s = ffeexpr_paren_lhs_let_ (s, t);
16853           break;
16854
16855         case FFEEXPR_contextASSIGN:
16856         case FFEEXPR_contextAGOTO:
16857         case FFEEXPR_contextCHARACTERSIZE:
16858         case FFEEXPR_contextEQUIVALENCE:
16859         case FFEEXPR_contextINCLUDE:
16860         case FFEEXPR_contextPARAMETER:
16861         case FFEEXPR_contextDIMLIST:
16862         case FFEEXPR_contextDIMLISTCOMMON:
16863         case FFEEXPR_contextKINDTYPE:
16864         case FFEEXPR_contextINITVAL:
16865         case FFEEXPR_contextEQVINDEX_:
16866           break;                /* Will turn into errors below. */
16867
16868         default:
16869           ffesymbol_error (s, t);
16870           break;
16871         }
16872       /* Fall through. */
16873     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
16874     understood:         /* :::::::::::::::::::: */
16875
16876       /* State might have changed, update it.  */
16877       st = ((ffesymbol_sfdummyparent (s) == NULL)
16878             ? ffesymbol_state (s)
16879             : FFESYMBOL_stateUNDERSTOOD);
16880
16881       k = ffesymbol_kind (s);
16882       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16883         {
16884         case FFEEXPR_contextSUBROUTINEREF:
16885           bad = ((k != FFEINFO_kindSUBROUTINE)
16886                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16887                      || (k != FFEINFO_kindNONE)));
16888           break;
16889
16890         case FFEEXPR_contextDATA:
16891           if (ffeexpr_stack_->is_rhs)
16892             bad = (k != FFEINFO_kindENTITY)
16893               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16894           else
16895             bad = (k != FFEINFO_kindENTITY)
16896               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16897                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16898                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16899           break;
16900
16901         case FFEEXPR_contextDATAIMPDOITEM_:
16902           bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16903             || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16904                 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16905                 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16906           break;
16907
16908         case FFEEXPR_contextSFUNCDEF:
16909         case FFEEXPR_contextSFUNCDEFINDEX_:
16910         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16911         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16912         case FFEEXPR_contextLET:
16913         case FFEEXPR_contextPAREN_:
16914         case FFEEXPR_contextACTUALARGEXPR_:
16915         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16916         case FFEEXPR_contextIOLIST:
16917         case FFEEXPR_contextIOLISTDF:
16918         case FFEEXPR_contextDO:
16919         case FFEEXPR_contextDOWHILE:
16920         case FFEEXPR_contextACTUALARG_:
16921         case FFEEXPR_contextCGOTO:
16922         case FFEEXPR_contextIF:
16923         case FFEEXPR_contextARITHIF:
16924         case FFEEXPR_contextFORMAT:
16925         case FFEEXPR_contextSTOP:
16926         case FFEEXPR_contextRETURN:
16927         case FFEEXPR_contextSELECTCASE:
16928         case FFEEXPR_contextCASE:
16929         case FFEEXPR_contextFILEASSOC:
16930         case FFEEXPR_contextFILEINT:
16931         case FFEEXPR_contextFILEDFINT:
16932         case FFEEXPR_contextFILELOG:
16933         case FFEEXPR_contextFILENUM:
16934         case FFEEXPR_contextFILENUMAMBIG:
16935         case FFEEXPR_contextFILECHAR:
16936         case FFEEXPR_contextFILENUMCHAR:
16937         case FFEEXPR_contextFILEDFCHAR:
16938         case FFEEXPR_contextFILEKEY:
16939         case FFEEXPR_contextFILEUNIT:
16940         case FFEEXPR_contextFILEUNIT_DF:
16941         case FFEEXPR_contextFILEUNITAMBIG:
16942         case FFEEXPR_contextFILEFORMAT:
16943         case FFEEXPR_contextFILENAMELIST:
16944         case FFEEXPR_contextFILEVXTCODE:
16945         case FFEEXPR_contextINDEX_:
16946         case FFEEXPR_contextIMPDOITEM_:
16947         case FFEEXPR_contextIMPDOITEMDF_:
16948         case FFEEXPR_contextIMPDOCTRL_:
16949         case FFEEXPR_contextLOC_:
16950           bad = FALSE;          /* Let paren-switch handle the cases. */
16951           break;
16952
16953         case FFEEXPR_contextASSIGN:
16954         case FFEEXPR_contextAGOTO:
16955         case FFEEXPR_contextCHARACTERSIZE:
16956         case FFEEXPR_contextEQUIVALENCE:
16957         case FFEEXPR_contextPARAMETER:
16958         case FFEEXPR_contextDIMLIST:
16959         case FFEEXPR_contextDIMLISTCOMMON:
16960         case FFEEXPR_contextKINDTYPE:
16961         case FFEEXPR_contextINITVAL:
16962         case FFEEXPR_contextEQVINDEX_:
16963           bad = (k != FFEINFO_kindENTITY)
16964             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16965           break;
16966
16967         case FFEEXPR_contextINCLUDE:
16968           bad = TRUE;
16969           break;
16970
16971         default:
16972           bad = TRUE;
16973           break;
16974         }
16975
16976       switch (bad ? FFEINFO_kindANY : k)
16977         {
16978         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
16979           if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16980             {
16981               if (ffeexpr_context_outer_ (ffeexpr_stack_)
16982                   == FFEEXPR_contextSUBROUTINEREF)
16983                 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16984               else
16985                 *paren_type = FFEEXPR_parentypeFUNCTION_;
16986               break;
16987             }
16988           if (st == FFESYMBOL_stateUNDERSTOOD)
16989             {
16990               bad = TRUE;
16991               *paren_type = FFEEXPR_parentypeANY_;
16992             }
16993           else
16994             *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16995           break;
16996
16997         case FFEINFO_kindFUNCTION:
16998           *paren_type = FFEEXPR_parentypeFUNCTION_;
16999           switch (ffesymbol_where (s))
17000             {
17001             case FFEINFO_whereLOCAL:
17002               bad = TRUE;       /* Attempt to recurse! */
17003               break;
17004
17005             case FFEINFO_whereCONSTANT:
17006               bad = ((ffesymbol_sfexpr (s) == NULL)
17007                      || (ffebld_op (ffesymbol_sfexpr (s))
17008                          == FFEBLD_opANY));     /* Attempt to recurse! */
17009               break;
17010
17011             default:
17012               break;
17013             }
17014           break;
17015
17016         case FFEINFO_kindSUBROUTINE:
17017           if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17018               || (ffeexpr_stack_->previous != NULL))
17019             {
17020               bad = TRUE;
17021               *paren_type = FFEEXPR_parentypeANY_;
17022               break;
17023             }
17024
17025           *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17026           switch (ffesymbol_where (s))
17027             {
17028             case FFEINFO_whereLOCAL:
17029             case FFEINFO_whereCONSTANT:
17030               bad = TRUE;       /* Attempt to recurse! */
17031               break;
17032
17033             default:
17034               break;
17035             }
17036           break;
17037
17038         case FFEINFO_kindENTITY:
17039           if (ffesymbol_rank (s) == 0)
17040             {
17041               if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17042                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17043               else
17044                 {
17045                   bad = TRUE;
17046                   *paren_type = FFEEXPR_parentypeANY_;
17047                 }
17048             }
17049           else
17050             *paren_type = FFEEXPR_parentypeARRAY_;
17051           break;
17052
17053         default:
17054         case FFEINFO_kindANY:
17055           bad = TRUE;
17056           *paren_type = FFEEXPR_parentypeANY_;
17057           break;
17058         }
17059
17060       if (bad)
17061         {
17062           if (k == FFEINFO_kindANY)
17063             ffest_shutdown ();
17064           else
17065             ffesymbol_error (s, t);
17066         }
17067
17068       return s;
17069
17070     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
17071     seen:                       /* :::::::::::::::::::: */
17072       bad = TRUE;
17073       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17074         {
17075         case FFEEXPR_contextPARAMETER:
17076           if (ffeexpr_stack_->is_rhs)
17077             ffesymbol_error (s, t);
17078           else
17079             s = ffeexpr_sym_lhs_parameter_ (s, t);
17080           break;
17081
17082         case FFEEXPR_contextDATA:
17083           s = ffecom_sym_exec_transition (s);
17084           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17085             goto understood;    /* :::::::::::::::::::: */
17086           if (ffeexpr_stack_->is_rhs)
17087             ffesymbol_error (s, t);
17088           else
17089             s = ffeexpr_sym_lhs_data_ (s, t);
17090           goto understood;      /* :::::::::::::::::::: */
17091
17092         case FFEEXPR_contextDATAIMPDOITEM_:
17093           s = ffecom_sym_exec_transition (s);
17094           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17095             goto understood;    /* :::::::::::::::::::: */
17096           s = ffeexpr_sym_lhs_data_ (s, t);
17097           goto understood;      /* :::::::::::::::::::: */
17098
17099         case FFEEXPR_contextEQUIVALENCE:
17100           s = ffeexpr_sym_lhs_equivalence_ (s, t);
17101           bad = FALSE;
17102           break;
17103
17104         case FFEEXPR_contextDIMLIST:
17105           s = ffeexpr_sym_rhs_dimlist_ (s, t);
17106           bad = FALSE;
17107           break;
17108
17109         case FFEEXPR_contextCHARACTERSIZE:
17110         case FFEEXPR_contextKINDTYPE:
17111         case FFEEXPR_contextDIMLISTCOMMON:
17112         case FFEEXPR_contextINITVAL:
17113         case FFEEXPR_contextEQVINDEX_:
17114           break;
17115
17116         case FFEEXPR_contextINCLUDE:
17117           break;
17118
17119         case FFEEXPR_contextINDEX_:
17120         case FFEEXPR_contextACTUALARGEXPR_:
17121         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17122         case FFEEXPR_contextSFUNCDEF:
17123         case FFEEXPR_contextSFUNCDEFINDEX_:
17124         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17125         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17126           assert (ffeexpr_stack_->is_rhs);
17127           s = ffecom_sym_exec_transition (s);
17128           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17129             goto understood;    /* :::::::::::::::::::: */
17130           s = ffeexpr_paren_rhs_let_ (s, t);
17131           goto understood;      /* :::::::::::::::::::: */
17132
17133         default:
17134           break;
17135         }
17136       k = ffesymbol_kind (s);
17137       switch (bad ? FFEINFO_kindANY : k)
17138         {
17139         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
17140           *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17141           break;
17142
17143         case FFEINFO_kindFUNCTION:
17144           *paren_type = FFEEXPR_parentypeFUNCTION_;
17145           switch (ffesymbol_where (s))
17146             {
17147             case FFEINFO_whereLOCAL:
17148               bad = TRUE;       /* Attempt to recurse! */
17149               break;
17150
17151             case FFEINFO_whereCONSTANT:
17152               bad = ((ffesymbol_sfexpr (s) == NULL)
17153                      || (ffebld_op (ffesymbol_sfexpr (s))
17154                          == FFEBLD_opANY));     /* Attempt to recurse! */
17155               break;
17156
17157             default:
17158               break;
17159             }
17160           break;
17161
17162         case FFEINFO_kindSUBROUTINE:
17163           *paren_type = FFEEXPR_parentypeANY_;
17164           bad = TRUE;           /* Cannot possibly be in
17165                                    contextSUBROUTINEREF. */
17166           break;
17167
17168         case FFEINFO_kindENTITY:
17169           if (ffesymbol_rank (s) == 0)
17170             {
17171               if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17172                 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17173               else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17174                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17175               else
17176                 {
17177                   bad = TRUE;
17178                   *paren_type = FFEEXPR_parentypeANY_;
17179                 }
17180             }
17181           else
17182             *paren_type = FFEEXPR_parentypeARRAY_;
17183           break;
17184
17185         default:
17186         case FFEINFO_kindANY:
17187           bad = TRUE;
17188           *paren_type = FFEEXPR_parentypeANY_;
17189           break;
17190         }
17191
17192       if (bad)
17193         {
17194           if (k == FFEINFO_kindANY)
17195             ffest_shutdown ();
17196           else
17197             ffesymbol_error (s, t);
17198         }
17199
17200       return s;
17201
17202     default:
17203       assert ("bad symbol state" == NULL);
17204       return NULL;
17205     }
17206 }
17207
17208 /* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
17209
17210 static ffesymbol
17211 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17212 {
17213   ffesymbolAttrs sa;
17214   ffesymbolAttrs na;
17215   ffeinfoKind kind;
17216   ffeinfoWhere where;
17217   ffeintrinGen gen;
17218   ffeintrinSpec spec;
17219   ffeintrinImp imp;
17220   bool maybe_ambig = FALSE;
17221   bool error = FALSE;
17222
17223   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17224           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17225
17226   na = sa = ffesymbol_attrs (s);
17227
17228   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17229                    | FFESYMBOL_attrsADJUSTABLE
17230                    | FFESYMBOL_attrsANYLEN
17231                    | FFESYMBOL_attrsARRAY
17232                    | FFESYMBOL_attrsDUMMY
17233                    | FFESYMBOL_attrsEXTERNAL
17234                    | FFESYMBOL_attrsSFARG
17235                    | FFESYMBOL_attrsTYPE)));
17236
17237   kind = ffesymbol_kind (s);
17238   where = ffesymbol_where (s);
17239
17240   /* Figure out what kind of object we've got based on previous declarations
17241      of or references to the object. */
17242
17243   if (sa & FFESYMBOL_attrsEXTERNAL)
17244     {
17245       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17246                        | FFESYMBOL_attrsDUMMY
17247                        | FFESYMBOL_attrsEXTERNAL
17248                        | FFESYMBOL_attrsTYPE)));
17249
17250       if (sa & FFESYMBOL_attrsTYPE)
17251         where = FFEINFO_whereGLOBAL;
17252       else
17253         /* Not TYPE. */
17254         {
17255           kind = FFEINFO_kindFUNCTION;
17256
17257           if (sa & FFESYMBOL_attrsDUMMY)
17258             ;                   /* Not TYPE. */
17259           else if (sa & FFESYMBOL_attrsACTUALARG)
17260             ;                   /* Not DUMMY or TYPE. */
17261           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
17262             where = FFEINFO_whereGLOBAL;
17263         }
17264     }
17265   else if (sa & FFESYMBOL_attrsDUMMY)
17266     {
17267       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17268       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17269                        | FFESYMBOL_attrsEXTERNAL
17270                        | FFESYMBOL_attrsTYPE)));
17271
17272       kind = FFEINFO_kindFUNCTION;
17273       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure; kind
17274                                    could be ENTITY w/substring ref. */
17275     }
17276   else if (sa & FFESYMBOL_attrsARRAY)
17277     {
17278       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17279                        | FFESYMBOL_attrsADJUSTABLE
17280                        | FFESYMBOL_attrsTYPE)));
17281
17282       where = FFEINFO_whereLOCAL;
17283     }
17284   else if (sa & FFESYMBOL_attrsSFARG)
17285     {
17286       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17287                        | FFESYMBOL_attrsTYPE)));
17288
17289       where = FFEINFO_whereLOCAL;       /* Actually an error, but at least we
17290                                            know it's a local var. */
17291     }
17292   else if (sa & FFESYMBOL_attrsTYPE)
17293     {
17294       assert (!(sa & (FFESYMBOL_attrsARRAY
17295                       | FFESYMBOL_attrsDUMMY
17296                       | FFESYMBOL_attrsEXTERNAL
17297                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
17298       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17299                        | FFESYMBOL_attrsADJUSTABLE
17300                        | FFESYMBOL_attrsANYLEN
17301                        | FFESYMBOL_attrsARRAY
17302                        | FFESYMBOL_attrsDUMMY
17303                        | FFESYMBOL_attrsEXTERNAL
17304                        | FFESYMBOL_attrsSFARG)));
17305
17306       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17307                                   &gen, &spec, &imp))
17308         {
17309           if (!(sa & FFESYMBOL_attrsANYLEN)
17310               && (ffeimplic_peek_symbol_type (s, NULL)
17311                   == FFEINFO_basictypeCHARACTER))
17312             return s;           /* Haven't learned anything yet. */
17313
17314           ffesymbol_signal_change (s);  /* May need to back up to previous
17315                                            version. */
17316           ffesymbol_set_generic (s, gen);
17317           ffesymbol_set_specific (s, spec);
17318           ffesymbol_set_implementation (s, imp);
17319           ffesymbol_set_info (s,
17320                               ffeinfo_new (ffesymbol_basictype (s),
17321                                            ffesymbol_kindtype (s),
17322                                            0,
17323                                            FFEINFO_kindFUNCTION,
17324                                            FFEINFO_whereINTRINSIC,
17325                                            ffesymbol_size (s)));
17326           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17327           ffesymbol_resolve_intrin (s);
17328           ffesymbol_reference (s, t, FALSE);
17329           s = ffecom_sym_learned (s);
17330           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
17331
17332           return s;
17333         }
17334       if (sa & FFESYMBOL_attrsANYLEN)
17335         error = TRUE;           /* Error, since the only way we can,
17336                                    given CHARACTER*(*) FOO, accept
17337                                    FOO(...) is for FOO to be a dummy
17338                                    arg or constant, but it can't
17339                                    become either now. */
17340       else if (sa & FFESYMBOL_attrsADJUSTABLE)
17341         {
17342           kind = FFEINFO_kindENTITY;
17343           where = FFEINFO_whereLOCAL;
17344         }
17345       else
17346         {
17347           kind = FFEINFO_kindFUNCTION;
17348           where = FFEINFO_whereGLOBAL;
17349           maybe_ambig = TRUE;   /* If basictypeCHARACTER, can't be sure;
17350                                    could be ENTITY/LOCAL w/substring ref. */
17351         }
17352     }
17353   else if (sa == FFESYMBOL_attrsetNONE)
17354     {
17355       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17356
17357       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17358                                   &gen, &spec, &imp))
17359         {
17360           if (ffeimplic_peek_symbol_type (s, NULL)
17361               == FFEINFO_basictypeCHARACTER)
17362             return s;           /* Haven't learned anything yet. */
17363
17364           ffesymbol_signal_change (s);  /* May need to back up to previous
17365                                            version. */
17366           ffesymbol_set_generic (s, gen);
17367           ffesymbol_set_specific (s, spec);
17368           ffesymbol_set_implementation (s, imp);
17369           ffesymbol_set_info (s,
17370                               ffeinfo_new (ffesymbol_basictype (s),
17371                                            ffesymbol_kindtype (s),
17372                                            0,
17373                                            FFEINFO_kindFUNCTION,
17374                                            FFEINFO_whereINTRINSIC,
17375                                            ffesymbol_size (s)));
17376           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17377           ffesymbol_resolve_intrin (s);
17378           s = ffecom_sym_learned (s);
17379           ffesymbol_reference (s, t, FALSE);
17380           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
17381           return s;
17382         }
17383
17384       kind = FFEINFO_kindFUNCTION;
17385       where = FFEINFO_whereGLOBAL;
17386       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure;
17387                                    could be ENTITY/LOCAL w/substring ref. */
17388     }
17389   else
17390     error = TRUE;
17391
17392   /* Now see what we've got for a new object: NONE means a new error cropped
17393      up; ANY means an old error to be ignored; otherwise, everything's ok,
17394      update the object (symbol) and continue on. */
17395
17396   if (error)
17397     ffesymbol_error (s, t);
17398   else if (!(na & FFESYMBOL_attrsANY))
17399     {
17400       ffesymbol_signal_change (s);      /* May need to back up to previous
17401                                            version. */
17402       if (!ffeimplic_establish_symbol (s))
17403         {
17404           ffesymbol_error (s, t);
17405           return s;
17406         }
17407       if (maybe_ambig
17408           && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17409         return s;               /* Still not sure, let caller deal with it
17410                                    based on (...). */
17411
17412       ffesymbol_set_info (s,
17413                           ffeinfo_new (ffesymbol_basictype (s),
17414                                        ffesymbol_kindtype (s),
17415                                        ffesymbol_rank (s),
17416                                        kind,
17417                                        where,
17418                                        ffesymbol_size (s)));
17419       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17420       ffesymbol_resolve_intrin (s);
17421       s = ffecom_sym_learned (s);
17422       ffesymbol_reference (s, t, FALSE);
17423       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17424     }
17425
17426   return s;
17427 }
17428
17429 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17430
17431    Return a pointer to this function to the lexer (ffelex), which will
17432    invoke it for the next token.
17433
17434    Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
17435
17436 static ffelexHandler
17437 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17438 {
17439   ffeexprExpr_ procedure;
17440   ffebld reduced;
17441   ffeinfo info;
17442   ffeexprContext ctx;
17443   bool check_intrin = FALSE;    /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17444
17445   procedure = ffeexpr_stack_->exprstack;
17446   info = ffebld_info (procedure->u.operand);
17447
17448   /* Is there an expression to add?  If the expression is nil,
17449      it might still be an argument.  It is if:
17450
17451        -  The current token is comma, or
17452
17453        -  The -fugly-comma flag was specified *and* the procedure
17454           being invoked is external.
17455
17456      Otherwise, if neither of the above is the case, just
17457      ignore this (nil) expression.  */
17458
17459   if ((expr != NULL)
17460       || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17461       || (ffe_is_ugly_comma ()
17462           && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17463     {
17464       /* This expression, even if nil, is apparently intended as an argument.  */
17465
17466       /* Internal procedure (CONTAINS, or statement function)?  */
17467
17468       if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17469         {
17470           if ((expr == NULL)
17471               && ffebad_start (FFEBAD_NULL_ARGUMENT))
17472             {
17473               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17474                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17475               ffebad_here (1, ffelex_token_where_line (t),
17476                            ffelex_token_where_column (t));
17477               ffebad_finish ();
17478             }
17479
17480           if (expr == NULL)
17481             ;
17482           else
17483             {
17484               if (ffeexpr_stack_->next_dummy == NULL)
17485                 {                       /* Report later which was the first extra argument. */
17486                   if (ffeexpr_stack_->tokens[1] == NULL)
17487                     {
17488                       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17489                       ffeexpr_stack_->num_args = 0;
17490                     }
17491                   ++ffeexpr_stack_->num_args;   /* Count # of extra arguments. */
17492                 }
17493               else
17494                 {
17495                   if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17496                       && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17497                     {
17498                       ffebad_here (0,
17499                                    ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17500                                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17501                       ffebad_here (1, ffelex_token_where_line (ft),
17502                                    ffelex_token_where_column (ft));
17503                       ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17504                                                      (ffebld_symter (ffebld_head
17505                                                                      (ffeexpr_stack_->next_dummy)))));
17506                       ffebad_finish ();
17507                     }
17508                   else
17509                     {
17510                       expr = ffeexpr_convert_expr (expr, ft,
17511                                                    ffebld_head (ffeexpr_stack_->next_dummy),
17512                                                    ffeexpr_stack_->tokens[0],
17513                                                    FFEEXPR_contextLET);
17514                       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17515                     }
17516                   --ffeexpr_stack_->num_args;   /* Count down # of args. */
17517                   ffeexpr_stack_->next_dummy
17518                     = ffebld_trail (ffeexpr_stack_->next_dummy);
17519                 }
17520             }
17521         }
17522       else
17523         {
17524           if ((expr == NULL)
17525               && ffe_is_pedantic ()
17526               && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17527             {
17528               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17529                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17530               ffebad_here (1, ffelex_token_where_line (t),
17531                            ffelex_token_where_column (t));
17532               ffebad_finish ();
17533             }
17534           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17535         }
17536     }
17537
17538   switch (ffelex_token_type (t))
17539     {
17540     case FFELEX_typeCOMMA:
17541       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17542         {
17543         case FFEEXPR_contextSFUNCDEF:
17544         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17545         case FFEEXPR_contextSFUNCDEFINDEX_:
17546         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17547           ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17548           break;
17549
17550         case FFEEXPR_contextSFUNCDEFACTUALARG_:
17551         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17552           assert ("bad context" == NULL);
17553           ctx = FFEEXPR_context;
17554           break;
17555
17556         default:
17557           ctx = FFEEXPR_contextACTUALARG_;
17558           break;
17559         }
17560       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17561                                           ffeexpr_token_arguments_);
17562
17563     default:
17564       break;
17565     }
17566
17567   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17568       && (ffeexpr_stack_->next_dummy != NULL))
17569     {                           /* Too few arguments. */
17570       if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17571         {
17572           char num[10];
17573
17574           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17575
17576           ffebad_here (0, ffelex_token_where_line (t),
17577                        ffelex_token_where_column (t));
17578           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17579                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17580           ffebad_string (num);
17581           ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17582                               (ffebld_head (ffeexpr_stack_->next_dummy)))));
17583           ffebad_finish ();
17584         }
17585       for (;
17586            ffeexpr_stack_->next_dummy != NULL;
17587            ffeexpr_stack_->next_dummy
17588            = ffebld_trail (ffeexpr_stack_->next_dummy))
17589         {
17590           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17591           ffebld_set_info (expr, ffeinfo_new_any ());
17592           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17593         }
17594     }
17595
17596   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17597       && (ffeexpr_stack_->tokens[1] != NULL))
17598     {                           /* Too many arguments to statement function. */
17599       if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17600         {
17601           char num[10];
17602
17603           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17604
17605           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17606                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17607           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17608                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17609           ffebad_string (num);
17610           ffebad_finish ();
17611         }
17612       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17613     }
17614   ffebld_end_list (&ffeexpr_stack_->bottom);
17615
17616   if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17617     {
17618       reduced = ffebld_new_any ();
17619       ffebld_set_info (reduced, ffeinfo_new_any ());
17620     }
17621   else
17622     {
17623       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17624         reduced = ffebld_new_funcref (procedure->u.operand,
17625                                       ffeexpr_stack_->expr);
17626       else
17627         reduced = ffebld_new_subrref (procedure->u.operand,
17628                                       ffeexpr_stack_->expr);
17629       if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17630         ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17631       else if (ffebld_symter_specific (procedure->u.operand)
17632                != FFEINTRIN_specNONE)
17633         ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17634                                     ffeexpr_stack_->tokens[0]);
17635       else
17636         ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17637
17638       if (ffebld_op (reduced) != FFEBLD_opANY)
17639         ffebld_set_info (reduced,
17640                          ffeinfo_new (ffeinfo_basictype (info),
17641                                       ffeinfo_kindtype (info),
17642                                       0,
17643                                       FFEINFO_kindENTITY,
17644                                       FFEINFO_whereFLEETING,
17645                                       ffeinfo_size (info)));
17646       else
17647         ffebld_set_info (reduced, ffeinfo_new_any ());
17648     }
17649   if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17650     reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17651   ffeexpr_stack_->exprstack = procedure->previous;      /* Pops
17652                                                            not-quite-operand off
17653                                                            stack. */
17654   procedure->u.operand = reduced;       /* Save the line/column ffewhere
17655                                            info. */
17656   ffeexpr_exprstack_push_operand_ (procedure);  /* Push it back on stack. */
17657   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17658     {
17659       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17660       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FUNC(3)(1:1)".... */
17661
17662       /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17663          Z is DOUBLE COMPLEX), and a command-line option doesn't already
17664          establish interpretation, probably complain.  */
17665
17666       if (check_intrin
17667           && !ffe_is_90 ()
17668           && !ffe_is_ugly_complex ())
17669         {
17670           /* If the outer expression is REAL(me...), issue diagnostic
17671              only if next token isn't the close-paren for REAL(me).  */
17672
17673           if ((ffeexpr_stack_->previous != NULL)
17674               && (ffeexpr_stack_->previous->exprstack != NULL)
17675               && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17676               && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17677               && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17678               && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17679             return (ffelexHandler) ffeexpr_token_intrincheck_;
17680
17681           /* Diagnose the ambiguity now.  */
17682
17683           if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17684             {
17685               ffebad_string (ffeintrin_name_implementation
17686                              (ffebld_symter_implementation
17687                               (ffebld_left
17688                                (ffeexpr_stack_->exprstack->u.operand))));
17689               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17690                            ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17691               ffebad_finish ();
17692             }
17693         }
17694       return (ffelexHandler) ffeexpr_token_substrp_;
17695     }
17696
17697   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17698     {
17699       ffebad_here (0, ffelex_token_where_line (t),
17700                    ffelex_token_where_column (t));
17701       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17702                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17703       ffebad_finish ();
17704     }
17705   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17706   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17707   return
17708     (ffelexHandler) ffeexpr_find_close_paren_ (t,
17709                                                (ffelexHandler)
17710                                                ffeexpr_token_substrp_);
17711 }
17712
17713 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17714
17715    Return a pointer to this array to the lexer (ffelex), which will
17716    invoke it for the next token.
17717
17718    Handle expression and COMMA or CLOSE_PAREN.  */
17719
17720 static ffelexHandler
17721 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17722 {
17723   ffeexprExpr_ array;
17724   ffebld reduced;
17725   ffeinfo info;
17726   ffeinfoWhere where;
17727   ffetargetIntegerDefault val;
17728   ffetargetIntegerDefault lval = 0;
17729   ffetargetIntegerDefault uval = 0;
17730   ffebld lbound;
17731   ffebld ubound;
17732   bool lcheck;
17733   bool ucheck;
17734
17735   array = ffeexpr_stack_->exprstack;
17736   info = ffebld_info (array->u.operand);
17737
17738   if ((expr == NULL)            /* && ((ffeexpr_stack_->rank != 0) ||
17739                                    (ffelex_token_type(t) ==
17740          FFELEX_typeCOMMA)) */ )
17741     {
17742       if (ffebad_start (FFEBAD_NULL_ELEMENT))
17743         {
17744           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17745                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17746           ffebad_here (1, ffelex_token_where_line (t),
17747                        ffelex_token_where_column (t));
17748           ffebad_finish ();
17749         }
17750       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17751         {                       /* Don't bother if we're going to complain
17752                                    later! */
17753           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17754           ffebld_set_info (expr, ffeinfo_new_any ());
17755         }
17756     }
17757
17758   if (expr == NULL)
17759     ;
17760   else if (ffeinfo_rank (info) == 0)
17761     {                           /* In EQUIVALENCE context, ffeinfo_rank(info)
17762                                    may == 0. */
17763       ++ffeexpr_stack_->rank;   /* Track anyway, may need for new VXT
17764                                    feature. */
17765       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17766     }
17767   else
17768     {
17769       ++ffeexpr_stack_->rank;
17770       if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17771         {                       /* Report later which was the first extra
17772                                    element. */
17773           if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17774             ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17775         }
17776       else
17777         {
17778           switch (ffeinfo_where (ffebld_info (expr)))
17779             {
17780             case FFEINFO_whereCONSTANT:
17781               break;
17782
17783             case FFEINFO_whereIMMEDIATE:
17784               ffeexpr_stack_->constant = FALSE;
17785               break;
17786
17787             default:
17788               ffeexpr_stack_->constant = FALSE;
17789               ffeexpr_stack_->immediate = FALSE;
17790               break;
17791             }
17792           if (ffebld_op (expr) == FFEBLD_opCONTER
17793               && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17794             {
17795               val = ffebld_constant_integerdefault (ffebld_conter (expr));
17796
17797               lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17798               if (lbound == NULL)
17799                 {
17800                   lcheck = TRUE;
17801                   lval = 1;
17802                 }
17803               else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17804                 {
17805                   lcheck = TRUE;
17806                   lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17807                 }
17808               else
17809                 lcheck = FALSE;
17810
17811               ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17812               assert (ubound != NULL);
17813               if (ffebld_op (ubound) == FFEBLD_opCONTER)
17814                 {
17815                   ucheck = TRUE;
17816                   uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17817                 }
17818               else
17819                 ucheck = FALSE;
17820
17821               if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17822                 {
17823                   ffebad_start (FFEBAD_RANGE_ARRAY);
17824                   ffebad_here (0, ffelex_token_where_line (ft),
17825                                ffelex_token_where_column (ft));
17826                   ffebad_finish ();
17827                 }
17828             }
17829           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17830           ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17831         }
17832     }
17833
17834   switch (ffelex_token_type (t))
17835     {
17836     case FFELEX_typeCOMMA:
17837       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17838         {
17839         case FFEEXPR_contextDATAIMPDOITEM_:
17840           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17841                                               FFEEXPR_contextDATAIMPDOINDEX_,
17842                                               ffeexpr_token_elements_);
17843
17844         case FFEEXPR_contextEQUIVALENCE:
17845           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17846                                               FFEEXPR_contextEQVINDEX_,
17847                                               ffeexpr_token_elements_);
17848
17849         case FFEEXPR_contextSFUNCDEF:
17850         case FFEEXPR_contextSFUNCDEFINDEX_:
17851           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17852                                               FFEEXPR_contextSFUNCDEFINDEX_,
17853                                               ffeexpr_token_elements_);
17854
17855         case FFEEXPR_contextSFUNCDEFACTUALARG_:
17856         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17857           assert ("bad context" == NULL);
17858           break;
17859
17860         default:
17861           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17862                                               FFEEXPR_contextINDEX_,
17863                                               ffeexpr_token_elements_);
17864         }
17865
17866     default:
17867       break;
17868     }
17869
17870   if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17871       && (ffeinfo_rank (info) != 0))
17872     {
17873       char num[10];
17874
17875       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17876         {
17877           if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17878             {
17879               sprintf (num, "%d",
17880                        (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17881
17882               ffebad_here (0, ffelex_token_where_line (t),
17883                            ffelex_token_where_column (t));
17884               ffebad_here (1,
17885                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17886                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17887               ffebad_string (num);
17888               ffebad_finish ();
17889             }
17890         }
17891       else
17892         {
17893           if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17894             {
17895               sprintf (num, "%d",
17896                        (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17897
17898               ffebad_here (0,
17899                         ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17900                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17901               ffebad_here (1,
17902                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17903                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17904               ffebad_string (num);
17905               ffebad_finish ();
17906             }
17907           ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17908         }
17909       while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17910         {
17911           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17912           ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17913                                               FFEINFO_kindtypeINTEGERDEFAULT,
17914                                               0, FFEINFO_kindENTITY,
17915                                               FFEINFO_whereCONSTANT,
17916                                               FFETARGET_charactersizeNONE));
17917           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17918         }
17919     }
17920   ffebld_end_list (&ffeexpr_stack_->bottom);
17921
17922   if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17923     {
17924       reduced = ffebld_new_any ();
17925       ffebld_set_info (reduced, ffeinfo_new_any ());
17926     }
17927   else
17928     {
17929       reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17930       if (ffeexpr_stack_->constant)
17931         where = FFEINFO_whereFLEETING_CADDR;
17932       else if (ffeexpr_stack_->immediate)
17933         where = FFEINFO_whereFLEETING_IADDR;
17934       else
17935         where = FFEINFO_whereFLEETING;
17936       ffebld_set_info (reduced,
17937                        ffeinfo_new (ffeinfo_basictype (info),
17938                                     ffeinfo_kindtype (info),
17939                                     0,
17940                                     FFEINFO_kindENTITY,
17941                                     where,
17942                                     ffeinfo_size (info)));
17943       reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17944     }
17945
17946   ffeexpr_stack_->exprstack = array->previous;  /* Pops not-quite-operand off
17947                                                    stack. */
17948   array->u.operand = reduced;   /* Save the line/column ffewhere info. */
17949   ffeexpr_exprstack_push_operand_ (array);      /* Push it back on stack. */
17950
17951   switch (ffeinfo_basictype (info))
17952     {
17953     case FFEINFO_basictypeCHARACTER:
17954       ffeexpr_is_substr_ok_ = TRUE;     /* Everyone likes "FOO(3)(1:1)".... */
17955       break;
17956
17957     case FFEINFO_basictypeNONE:
17958       ffeexpr_is_substr_ok_ = TRUE;
17959       assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17960       break;
17961
17962     default:
17963       ffeexpr_is_substr_ok_ = FALSE;
17964       break;
17965     }
17966
17967   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17968     {
17969       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17970       return (ffelexHandler) ffeexpr_token_substrp_;
17971     }
17972
17973   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17974     {
17975       ffebad_here (0, ffelex_token_where_line (t),
17976                    ffelex_token_where_column (t));
17977       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17978                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17979       ffebad_finish ();
17980     }
17981   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17982   return
17983     (ffelexHandler) ffeexpr_find_close_paren_ (t,
17984                                                (ffelexHandler)
17985                                                ffeexpr_token_substrp_);
17986 }
17987
17988 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17989
17990    Return a pointer to this array to the lexer (ffelex), which will
17991    invoke it for the next token.
17992
17993    If token is COLON, pass off to _substr_, else init list and pass off
17994    to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
17995    ? marks the token, and where FOO's rank/type has not yet been established,
17996    meaning we could be in a list of indices or in a substring
17997    specification.  */
17998
17999 static ffelexHandler
18000 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18001 {
18002   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18003     return ffeexpr_token_substring_ (ft, expr, t);
18004
18005   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18006   return ffeexpr_token_elements_ (ft, expr, t);
18007 }
18008
18009 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18010
18011    Return a pointer to this function to the lexer (ffelex), which will
18012    invoke it for the next token.
18013
18014    Handle expression (which may be null) and COLON.  */
18015
18016 static ffelexHandler
18017 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18018 {
18019   ffeexprExpr_ string;
18020   ffeinfo info;
18021   ffetargetIntegerDefault i;
18022   ffeexprContext ctx;
18023   ffetargetCharacterSize size;
18024
18025   string = ffeexpr_stack_->exprstack;
18026   info = ffebld_info (string->u.operand);
18027   size = ffebld_size_max (string->u.operand);
18028
18029   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18030     {
18031       if ((expr != NULL)
18032           && (ffebld_op (expr) == FFEBLD_opCONTER)
18033           && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18034                < 1)
18035               || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18036         {
18037           ffebad_start (FFEBAD_RANGE_SUBSTR);
18038           ffebad_here (0, ffelex_token_where_line (ft),
18039                        ffelex_token_where_column (ft));
18040           ffebad_finish ();
18041         }
18042       ffeexpr_stack_->expr = expr;
18043
18044       switch (ffeexpr_stack_->context)
18045         {
18046         case FFEEXPR_contextSFUNCDEF:
18047         case FFEEXPR_contextSFUNCDEFINDEX_:
18048           ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18049           break;
18050
18051         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18052         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18053           assert ("bad context" == NULL);
18054           ctx = FFEEXPR_context;
18055           break;
18056
18057         default:
18058           ctx = FFEEXPR_contextINDEX_;
18059           break;
18060         }
18061
18062       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18063                                           ffeexpr_token_substring_1_);
18064     }
18065
18066   if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18067     {
18068       ffebad_here (0, ffelex_token_where_line (t),
18069                    ffelex_token_where_column (t));
18070       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18071                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18072       ffebad_finish ();
18073     }
18074
18075   ffeexpr_stack_->expr = NULL;
18076   return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18077 }
18078
18079 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18080
18081    Return a pointer to this function to the lexer (ffelex), which will
18082    invoke it for the next token.
18083
18084    Handle expression (which might be null) and CLOSE_PAREN.  */
18085
18086 static ffelexHandler
18087 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18088 {
18089   ffeexprExpr_ string;
18090   ffebld reduced;
18091   ffebld substrlist;
18092   ffebld first = ffeexpr_stack_->expr;
18093   ffebld strop;
18094   ffeinfo info;
18095   ffeinfoWhere lwh;
18096   ffeinfoWhere rwh;
18097   ffeinfoWhere where;
18098   ffeinfoKindtype first_kt;
18099   ffeinfoKindtype last_kt;
18100   ffetargetIntegerDefault first_val;
18101   ffetargetIntegerDefault last_val;
18102   ffetargetCharacterSize size;
18103   ffetargetCharacterSize strop_size_max;
18104   bool first_known;
18105
18106   string = ffeexpr_stack_->exprstack;
18107   strop = string->u.operand;
18108   info = ffebld_info (strop);
18109
18110   if (first == NULL
18111       || (ffebld_op (first) == FFEBLD_opCONTER
18112           && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18113     {                           /* The starting point is known. */
18114       first_val = (first == NULL) ? 1
18115         : ffebld_constant_integerdefault (ffebld_conter (first));
18116       first_known = TRUE;
18117     }
18118   else
18119     {                           /* Assume start of the entity. */
18120       first_val = 1;
18121       first_known = FALSE;
18122     }
18123
18124   if (last != NULL
18125       && (ffebld_op (last) == FFEBLD_opCONTER
18126           && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18127     {                           /* The ending point is known. */
18128       last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18129
18130       if (first_known)
18131         {                       /* The beginning point is a constant. */
18132           if (first_val <= last_val)
18133             size = last_val - first_val + 1;
18134           else
18135             {
18136               if (0 && ffe_is_90 ())
18137                 size = 0;
18138               else
18139                 {
18140                   size = 1;
18141                   ffebad_start (FFEBAD_ZERO_SIZE);
18142                   ffebad_here (0, ffelex_token_where_line (ft),
18143                                ffelex_token_where_column (ft));
18144                   ffebad_finish ();
18145                 }
18146             }
18147         }
18148       else
18149         size = FFETARGET_charactersizeNONE;
18150
18151       strop_size_max = ffebld_size_max (strop);
18152
18153       if ((strop_size_max != FFETARGET_charactersizeNONE)
18154           && (last_val > strop_size_max))
18155         {                       /* Beyond maximum possible end of string. */
18156           ffebad_start (FFEBAD_RANGE_SUBSTR);
18157           ffebad_here (0, ffelex_token_where_line (ft),
18158                        ffelex_token_where_column (ft));
18159           ffebad_finish ();
18160         }
18161     }
18162   else
18163     size = FFETARGET_charactersizeNONE; /* The size is not known. */
18164
18165 #if 0                           /* Don't do this, or "is size of target
18166                                    known?" would no longer be easily
18167                                    answerable.  To see if there is a max
18168                                    size, use ffebld_size_max; to get only the
18169                                    known size, else NONE, use
18170                                    ffebld_size_known; use ffebld_size if
18171                                    values are sure to be the same (not
18172                                    opSUBSTR or opCONCATENATE or known to have
18173                                    known length). By getting rid of this
18174                                    "useful info" stuff, we don't end up
18175                                    blank-padding the constant in the
18176                                    assignment "A(I:J)='XYZ'" to the known
18177                                    length of A. */
18178   if (size == FFETARGET_charactersizeNONE)
18179     size = strop_size_max;      /* Assume we use the entire string. */
18180 #endif
18181
18182   substrlist
18183     = ffebld_new_item
18184     (first,
18185      ffebld_new_item
18186      (last,
18187       NULL
18188      )
18189     )
18190     ;
18191
18192   if (first == NULL)
18193     lwh = FFEINFO_whereCONSTANT;
18194   else
18195     lwh = ffeinfo_where (ffebld_info (first));
18196   if (last == NULL)
18197     rwh = FFEINFO_whereCONSTANT;
18198   else
18199     rwh = ffeinfo_where (ffebld_info (last));
18200
18201   switch (lwh)
18202     {
18203     case FFEINFO_whereCONSTANT:
18204       switch (rwh)
18205         {
18206         case FFEINFO_whereCONSTANT:
18207           where = FFEINFO_whereCONSTANT;
18208           break;
18209
18210         case FFEINFO_whereIMMEDIATE:
18211           where = FFEINFO_whereIMMEDIATE;
18212           break;
18213
18214         default:
18215           where = FFEINFO_whereFLEETING;
18216           break;
18217         }
18218       break;
18219
18220     case FFEINFO_whereIMMEDIATE:
18221       switch (rwh)
18222         {
18223         case FFEINFO_whereCONSTANT:
18224         case FFEINFO_whereIMMEDIATE:
18225           where = FFEINFO_whereIMMEDIATE;
18226           break;
18227
18228         default:
18229           where = FFEINFO_whereFLEETING;
18230           break;
18231         }
18232       break;
18233
18234     default:
18235       where = FFEINFO_whereFLEETING;
18236       break;
18237     }
18238
18239   if (first == NULL)
18240     first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18241   else
18242     first_kt = ffeinfo_kindtype (ffebld_info (first));
18243   if (last == NULL)
18244     last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18245   else
18246     last_kt = ffeinfo_kindtype (ffebld_info (last));
18247
18248   switch (where)
18249     {
18250     case FFEINFO_whereCONSTANT:
18251       switch (ffeinfo_where (info))
18252         {
18253         case FFEINFO_whereCONSTANT:
18254           break;
18255
18256         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
18257           where = FFEINFO_whereIMMEDIATE;
18258           break;
18259
18260         default:
18261           where = FFEINFO_whereFLEETING_CADDR;
18262           break;
18263         }
18264       break;
18265
18266     case FFEINFO_whereIMMEDIATE:
18267       switch (ffeinfo_where (info))
18268         {
18269         case FFEINFO_whereCONSTANT:
18270         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
18271           break;
18272
18273         default:
18274           where = FFEINFO_whereFLEETING_IADDR;
18275           break;
18276         }
18277       break;
18278
18279     default:
18280       switch (ffeinfo_where (info))
18281         {
18282         case FFEINFO_whereCONSTANT:
18283           where = FFEINFO_whereCONSTANT_SUBOBJECT;      /* An F90 concept. */
18284           break;
18285
18286         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
18287         default:
18288           where = FFEINFO_whereFLEETING;
18289           break;
18290         }
18291       break;
18292     }
18293
18294   if (ffebld_op (strop) == FFEBLD_opANY)
18295     {
18296       reduced = ffebld_new_any ();
18297       ffebld_set_info (reduced, ffeinfo_new_any ());
18298     }
18299   else
18300     {
18301       reduced = ffebld_new_substr (strop, substrlist);
18302       ffebld_set_info (reduced, ffeinfo_new
18303                        (FFEINFO_basictypeCHARACTER,
18304                         ffeinfo_kindtype (info),
18305                         0,
18306                         FFEINFO_kindENTITY,
18307                         where,
18308                         size));
18309       reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18310     }
18311
18312   ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
18313                                                    stack. */
18314   string->u.operand = reduced;  /* Save the line/column ffewhere info. */
18315   ffeexpr_exprstack_push_operand_ (string);     /* Push it back on stack. */
18316
18317   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18318     {
18319       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18320       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FOO(3:5)(1:1)".... */
18321       return (ffelexHandler) ffeexpr_token_substrp_;
18322     }
18323
18324   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18325     {
18326       ffebad_here (0, ffelex_token_where_line (t),
18327                    ffelex_token_where_column (t));
18328       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18329                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18330       ffebad_finish ();
18331     }
18332
18333   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18334   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18335   return
18336     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18337                                                (ffelexHandler)
18338                                                ffeexpr_token_substrp_);
18339 }
18340
18341 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18342
18343    Return a pointer to this function to the lexer (ffelex), which will
18344    invoke it for the next token.
18345
18346    If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18347    issue error message if flag (serves as argument) is set.  Else, just
18348    forward token to binary_.  */
18349
18350 static ffelexHandler
18351 ffeexpr_token_substrp_ (ffelexToken t)
18352 {
18353   ffeexprContext ctx;
18354
18355   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18356     return (ffelexHandler) ffeexpr_token_binary_ (t);
18357
18358   ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18359
18360   switch (ffeexpr_stack_->context)
18361     {
18362     case FFEEXPR_contextSFUNCDEF:
18363     case FFEEXPR_contextSFUNCDEFINDEX_:
18364       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18365       break;
18366
18367     case FFEEXPR_contextSFUNCDEFACTUALARG_:
18368     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18369       assert ("bad context" == NULL);
18370       ctx = FFEEXPR_context;
18371       break;
18372
18373     default:
18374       ctx = FFEEXPR_contextINDEX_;
18375       break;
18376     }
18377
18378   if (!ffeexpr_is_substr_ok_)
18379     {
18380       if (ffebad_start (FFEBAD_BAD_SUBSTR))
18381         {
18382           ffebad_here (0, ffelex_token_where_line (t),
18383                        ffelex_token_where_column (t));
18384           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18385                        ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18386           ffebad_finish ();
18387         }
18388
18389       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18390                                           ffeexpr_token_anything_);
18391     }
18392
18393   return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18394                                       ffeexpr_token_substring_);
18395 }
18396
18397 static ffelexHandler
18398 ffeexpr_token_intrincheck_ (ffelexToken t)
18399 {
18400   if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18401       && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18402     {
18403       ffebad_string (ffeintrin_name_implementation
18404                      (ffebld_symter_implementation
18405                       (ffebld_left
18406                        (ffeexpr_stack_->exprstack->u.operand))));
18407       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18408                    ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18409       ffebad_finish ();
18410     }
18411
18412   return (ffelexHandler) ffeexpr_token_substrp_ (t);
18413 }
18414
18415 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18416
18417    Return a pointer to this function to the lexer (ffelex), which will
18418    invoke it for the next token.
18419
18420    If COLON, do everything we would have done since _parenthesized_ if
18421    we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18422    If not COLON, do likewise for kindFUNCTION instead.  */
18423
18424 static ffelexHandler
18425 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18426 {
18427   ffeinfoWhere where;
18428   ffesymbol s;
18429   ffesymbolAttrs sa;
18430   ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18431   bool needs_type;
18432   ffeintrinGen gen;
18433   ffeintrinSpec spec;
18434   ffeintrinImp imp;
18435
18436   s = ffebld_symter (symter);
18437   sa = ffesymbol_attrs (s);
18438   where = ffesymbol_where (s);
18439
18440   /* We get here only if we don't already know enough about FOO when seeing a
18441      FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
18442      "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18443      Else FOO is a function, either intrinsic or external.  If intrinsic, it
18444      wouldn't necessarily be CHARACTER type, so unless it has already been
18445      declared DUMMY, it hasn't had its type established yet.  It can't be
18446      CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
18447
18448   assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18449                    | FFESYMBOL_attrsTYPE)));
18450
18451   needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18452
18453   ffesymbol_signal_change (s);  /* Probably already done, but in case.... */
18454
18455   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18456     {                           /* Definitely an ENTITY (char substring). */
18457       if (needs_type && !ffeimplic_establish_symbol (s))
18458         {
18459           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18460           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18461         }
18462
18463       ffesymbol_set_info (s,
18464                           ffeinfo_new (ffesymbol_basictype (s),
18465                                        ffesymbol_kindtype (s),
18466                                        ffesymbol_rank (s),
18467                                        FFEINFO_kindENTITY,
18468                                        (where == FFEINFO_whereNONE)
18469                                        ? FFEINFO_whereLOCAL
18470                                        : where,
18471                                        ffesymbol_size (s)));
18472       ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18473
18474       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18475       ffesymbol_resolve_intrin (s);
18476       s = ffecom_sym_learned (s);
18477       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
18478
18479       ffeexpr_stack_->exprstack->u.operand
18480         = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18481
18482       return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18483     }
18484
18485   /* The "stuff" isn't a substring notation, so we now know the overall
18486      reference is to a function.  */
18487
18488   if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18489                               FALSE, &gen, &spec, &imp))
18490     {
18491       ffebld_symter_set_generic (symter, gen);
18492       ffebld_symter_set_specific (symter, spec);
18493       ffebld_symter_set_implementation (symter, imp);
18494       ffesymbol_set_generic (s, gen);
18495       ffesymbol_set_specific (s, spec);
18496       ffesymbol_set_implementation (s, imp);
18497       ffesymbol_set_info (s,
18498                           ffeinfo_new (ffesymbol_basictype (s),
18499                                        ffesymbol_kindtype (s),
18500                                        0,
18501                                        FFEINFO_kindFUNCTION,
18502                                        FFEINFO_whereINTRINSIC,
18503                                        ffesymbol_size (s)));
18504     }
18505   else
18506     {                           /* Not intrinsic, now needs CHAR type. */
18507       if (!ffeimplic_establish_symbol (s))
18508         {
18509           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18510           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18511         }
18512
18513       ffesymbol_set_info (s,
18514                           ffeinfo_new (ffesymbol_basictype (s),
18515                                        ffesymbol_kindtype (s),
18516                                        ffesymbol_rank (s),
18517                                        FFEINFO_kindFUNCTION,
18518                                        (where == FFEINFO_whereNONE)
18519                                        ? FFEINFO_whereGLOBAL
18520                                        : where,
18521                                        ffesymbol_size (s)));
18522     }
18523
18524   ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18525
18526   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18527   ffesymbol_resolve_intrin (s);
18528   s = ffecom_sym_learned (s);
18529   ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18530   ffesymbol_signal_unreported (s);      /* For debugging purposes. */
18531   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18532   return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18533 }
18534
18535 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18536
18537    Handle basically any expression, looking for CLOSE_PAREN.  */
18538
18539 static ffelexHandler
18540 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18541                          ffelexToken t)
18542 {
18543   ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18544
18545   switch (ffelex_token_type (t))
18546     {
18547     case FFELEX_typeCOMMA:
18548     case FFELEX_typeCOLON:
18549       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18550                                           FFEEXPR_contextACTUALARG_,
18551                                           ffeexpr_token_anything_);
18552
18553     default:
18554       e->u.operand = ffebld_new_any ();
18555       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18556       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18557       ffeexpr_is_substr_ok_ = FALSE;
18558       if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18559         return (ffelexHandler) ffeexpr_token_substrp_;
18560       return (ffelexHandler) ffeexpr_token_substrp_ (t);
18561     }
18562 }
18563
18564 /* Terminate module.  */
18565
18566 void
18567 ffeexpr_terminate_2 (void)
18568 {
18569   assert (ffeexpr_stack_ == NULL);
18570   assert (ffeexpr_level_ == 0);
18571 }