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 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
 314                                                 ffelexHandler after);
 315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
 316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
 317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
 318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
 319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
 320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
 321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
 322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
 323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
 324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
 325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
 326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
 327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
 328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
 329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
 330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
 331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
 332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
 333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
 334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
 335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
 336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
 337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
 338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
 339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
 340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
 341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
 342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
 343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
 344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
 345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
 346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
 347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
 348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
 349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
 350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
 351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
 352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
 353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
 354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
 355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
 356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
 357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
 358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
 359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
 360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
 361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
 362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
 363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
 364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
 365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
 366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
 367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
 368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
 369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
 370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
 371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
 372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
 373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
 374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
 375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
 376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
 377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
 378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
 379                                                ffelexToken t);
 380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
 381                                               ffelexToken t);
 382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
 383                                                  ffelexToken t);
 384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
 385                                                ffelexToken t);
 386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
 387                                                  ffelexToken t);
 388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
 389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
 390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
 391                                                ffelexToken t);
 392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
 393                                               ffelexToken t);
 394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
 395             ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
 396                     ffelexToken exponent_sign, ffelexToken exponent_digits);
 397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
 398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
 399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
 400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
 401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
 402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
 403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
 404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
 405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
 406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
 407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
 408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
 409                                                  bool maybe_intrin,
 410                                              ffeexprParenType_ *paren_type);
 411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
 412
 413 /* Internal macros. */
 414
 415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 417 \f
 418 /* ffeexpr_collapse_convert -- Collapse convert expr
 419
 420    ffebld expr;
 421    ffelexToken token;
 422    expr = ffeexpr_collapse_convert(expr,token);
 423
 424    If the result of the expr is a constant, replaces the expr with the
 425    computed constant.  */
 426
 427 ffebld
 428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
 429 {
 430   ffebad error = FFEBAD;
 431   ffebld l;
 432   ffebldConstantUnion u;
 433   ffeinfoBasictype bt;
 434   ffeinfoKindtype kt;
 435   ffetargetCharacterSize sz;
 436   ffetargetCharacterSize sz2;
 437
 438   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
 439     return expr;
 440
 441   l = ffebld_left (expr);
 442
 443   if (ffebld_op (l) != FFEBLD_opCONTER)
 444     return expr;
 445
 446   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
 447     {
 448     case FFEINFO_basictypeANY:
 449       return expr;
 450
 451     case FFEINFO_basictypeINTEGER:
 452       sz = FFETARGET_charactersizeNONE;
 453       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
 454         {
 455 #if FFETARGET_okINTEGER1
 456         case FFEINFO_kindtypeINTEGER1:
 457           switch (ffeinfo_basictype (ffebld_info (l)))
 458             {
 459             case FFEINFO_basictypeINTEGER:
 460               switch (ffeinfo_kindtype (ffebld_info (l)))
 461                 {
 462 #if FFETARGET_okINTEGER2
 463                 case FFEINFO_kindtypeINTEGER2:
 464                   error = ffetarget_convert_integer1_integer2
 465                     (ffebld_cu_ptr_integer1 (u),
 466                      ffebld_constant_integer2 (ffebld_conter (l)));
 467                   break;
 468 #endif
 469
 470 #if FFETARGET_okINTEGER3
 471                 case FFEINFO_kindtypeINTEGER3:
 472                   error = ffetarget_convert_integer1_integer3
 473                     (ffebld_cu_ptr_integer1 (u),
 474                      ffebld_constant_integer3 (ffebld_conter (l)));
 475                   break;
 476 #endif
 477
 478 #if FFETARGET_okINTEGER4
 479                 case FFEINFO_kindtypeINTEGER4:
 480                   error = ffetarget_convert_integer1_integer4
 481                     (ffebld_cu_ptr_integer1 (u),
 482                      ffebld_constant_integer4 (ffebld_conter (l)));
 483                   break;
 484 #endif
 485
 486                 default:
 487                   assert ("INTEGER1/INTEGER bad source kind type" == NULL);
 488                   break;
 489                 }
 490               break;
 491
 492             case FFEINFO_basictypeREAL:
 493               switch (ffeinfo_kindtype (ffebld_info (l)))
 494                 {
 495 #if FFETARGET_okREAL1
 496                 case FFEINFO_kindtypeREAL1:
 497                   error = ffetarget_convert_integer1_real1
 498                     (ffebld_cu_ptr_integer1 (u),
 499                      ffebld_constant_real1 (ffebld_conter (l)));
 500                   break;
 501 #endif
 502
 503 #if FFETARGET_okREAL2
 504                 case FFEINFO_kindtypeREAL2:
 505                   error = ffetarget_convert_integer1_real2
 506                     (ffebld_cu_ptr_integer1 (u),
 507                      ffebld_constant_real2 (ffebld_conter (l)));
 508                   break;
 509 #endif
 510
 511 #if FFETARGET_okREAL3
 512                 case FFEINFO_kindtypeREAL3:
 513                   error = ffetarget_convert_integer1_real3
 514                     (ffebld_cu_ptr_integer1 (u),
 515                      ffebld_constant_real3 (ffebld_conter (l)));
 516                   break;
 517 #endif
 518
 519                 default:
 520                   assert ("INTEGER1/REAL bad source kind type" == NULL);
 521                   break;
 522                 }
 523               break;
 524
 525             case FFEINFO_basictypeCOMPLEX:
 526               switch (ffeinfo_kindtype (ffebld_info (l)))
 527                 {
 528 #if FFETARGET_okCOMPLEX1
 529                 case FFEINFO_kindtypeREAL1:
 530                   error = ffetarget_convert_integer1_complex1
 531                     (ffebld_cu_ptr_integer1 (u),
 532                      ffebld_constant_complex1 (ffebld_conter (l)));
 533                   break;
 534 #endif
 535
 536 #if FFETARGET_okCOMPLEX2
 537                 case FFEINFO_kindtypeREAL2:
 538                   error = ffetarget_convert_integer1_complex2
 539                     (ffebld_cu_ptr_integer1 (u),
 540                      ffebld_constant_complex2 (ffebld_conter (l)));
 541                   break;
 542 #endif
 543
 544 #if FFETARGET_okCOMPLEX3
 545                 case FFEINFO_kindtypeREAL3:
 546                   error = ffetarget_convert_integer1_complex3
 547                     (ffebld_cu_ptr_integer1 (u),
 548                      ffebld_constant_complex3 (ffebld_conter (l)));
 549                   break;
 550 #endif
 551
 552                 default:
 553                   assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
 554                   break;
 555                 }
 556               break;
 557
 558             case FFEINFO_basictypeLOGICAL:
 559               switch (ffeinfo_kindtype (ffebld_info (l)))
 560                 {
 561 #if FFETARGET_okLOGICAL1
 562                 case FFEINFO_kindtypeLOGICAL1:
 563                   error = ffetarget_convert_integer1_logical1
 564                     (ffebld_cu_ptr_integer1 (u),
 565                      ffebld_constant_logical1 (ffebld_conter (l)));
 566                   break;
 567 #endif
 568
 569 #if FFETARGET_okLOGICAL2
 570                 case FFEINFO_kindtypeLOGICAL2:
 571                   error = ffetarget_convert_integer1_logical2
 572                     (ffebld_cu_ptr_integer1 (u),
 573                      ffebld_constant_logical2 (ffebld_conter (l)));
 574                   break;
 575 #endif
 576
 577 #if FFETARGET_okLOGICAL3
 578                 case FFEINFO_kindtypeLOGICAL3:
 579                   error = ffetarget_convert_integer1_logical3
 580                     (ffebld_cu_ptr_integer1 (u),
 581                      ffebld_constant_logical3 (ffebld_conter (l)));
 582                   break;
 583 #endif
 584
 585 #if FFETARGET_okLOGICAL4
 586                 case FFEINFO_kindtypeLOGICAL4:
 587                   error = ffetarget_convert_integer1_logical4
 588                     (ffebld_cu_ptr_integer1 (u),
 589                      ffebld_constant_logical4 (ffebld_conter (l)));
 590                   break;
 591 #endif
 592
 593                 default:
 594                   assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
 595                   break;
 596                 }
 597               break;
 598
 599             case FFEINFO_basictypeCHARACTER:
 600               error = ffetarget_convert_integer1_character1
 601                 (ffebld_cu_ptr_integer1 (u),
 602                  ffebld_constant_character1 (ffebld_conter (l)));
 603               break;
 604
 605             case FFEINFO_basictypeHOLLERITH:
 606               error = ffetarget_convert_integer1_hollerith
 607                 (ffebld_cu_ptr_integer1 (u),
 608                  ffebld_constant_hollerith (ffebld_conter (l)));
 609               break;
 610
 611             case FFEINFO_basictypeTYPELESS:
 612               error = ffetarget_convert_integer1_typeless
 613                 (ffebld_cu_ptr_integer1 (u),
 614                  ffebld_constant_typeless (ffebld_conter (l)));
 615               break;
 616
 617             default:
 618               assert ("INTEGER1 bad type" == NULL);
 619               break;
 620             }
 621
 622           /* If conversion operation is not implemented, return original expr.  */
 623           if (error == FFEBAD_NOCANDO)
 624             return expr;
 625
 626           expr = ffebld_new_conter_with_orig
 627             (ffebld_constant_new_integer1_val
 628              (ffebld_cu_val_integer1 (u)), expr);
 629           break;
 630 #endif
 631
 632 #if FFETARGET_okINTEGER2
 633         case FFEINFO_kindtypeINTEGER2:
 634           switch (ffeinfo_basictype (ffebld_info (l)))
 635             {
 636             case FFEINFO_basictypeINTEGER:
 637               switch (ffeinfo_kindtype (ffebld_info (l)))
 638                 {
 639 #if FFETARGET_okINTEGER1
 640                 case FFEINFO_kindtypeINTEGER1:
 641                   error = ffetarget_convert_integer2_integer1
 642                     (ffebld_cu_ptr_integer2 (u),
 643                      ffebld_constant_integer1 (ffebld_conter (l)));
 644                   break;
 645 #endif
 646
 647 #if FFETARGET_okINTEGER3
 648                 case FFEINFO_kindtypeINTEGER3:
 649                   error = ffetarget_convert_integer2_integer3
 650                     (ffebld_cu_ptr_integer2 (u),
 651                      ffebld_constant_integer3 (ffebld_conter (l)));
 652                   break;
 653 #endif
 654
 655 #if FFETARGET_okINTEGER4
 656                 case FFEINFO_kindtypeINTEGER4:
 657                   error = ffetarget_convert_integer2_integer4
 658                     (ffebld_cu_ptr_integer2 (u),
 659                      ffebld_constant_integer4 (ffebld_conter (l)));
 660                   break;
 661 #endif
 662
 663                 default:
 664                   assert ("INTEGER2/INTEGER bad source kind type" == NULL);
 665                   break;
 666                 }
 667               break;
 668
 669             case FFEINFO_basictypeREAL:
 670               switch (ffeinfo_kindtype (ffebld_info (l)))
 671                 {
 672 #if FFETARGET_okREAL1
 673                 case FFEINFO_kindtypeREAL1:
 674                   error = ffetarget_convert_integer2_real1
 675                     (ffebld_cu_ptr_integer2 (u),
 676                      ffebld_constant_real1 (ffebld_conter (l)));
 677                   break;
 678 #endif
 679
 680 #if FFETARGET_okREAL2
 681                 case FFEINFO_kindtypeREAL2:
 682                   error = ffetarget_convert_integer2_real2
 683                     (ffebld_cu_ptr_integer2 (u),
 684                      ffebld_constant_real2 (ffebld_conter (l)));
 685                   break;
 686 #endif
 687
 688 #if FFETARGET_okREAL3
 689                 case FFEINFO_kindtypeREAL3:
 690                   error = ffetarget_convert_integer2_real3
 691                     (ffebld_cu_ptr_integer2 (u),
 692                      ffebld_constant_real3 (ffebld_conter (l)));
 693                   break;
 694 #endif
 695
 696                 default:
 697                   assert ("INTEGER2/REAL bad source kind type" == NULL);
 698                   break;
 699                 }
 700               break;
 701
 702             case FFEINFO_basictypeCOMPLEX:
 703               switch (ffeinfo_kindtype (ffebld_info (l)))
 704                 {
 705 #if FFETARGET_okCOMPLEX1
 706                 case FFEINFO_kindtypeREAL1:
 707                   error = ffetarget_convert_integer2_complex1
 708                     (ffebld_cu_ptr_integer2 (u),
 709                      ffebld_constant_complex1 (ffebld_conter (l)));
 710                   break;
 711 #endif
 712
 713 #if FFETARGET_okCOMPLEX2
 714                 case FFEINFO_kindtypeREAL2:
 715                   error = ffetarget_convert_integer2_complex2
 716                     (ffebld_cu_ptr_integer2 (u),
 717                      ffebld_constant_complex2 (ffebld_conter (l)));
 718                   break;
 719 #endif
 720
 721 #if FFETARGET_okCOMPLEX3
 722                 case FFEINFO_kindtypeREAL3:
 723                   error = ffetarget_convert_integer2_complex3
 724                     (ffebld_cu_ptr_integer2 (u),
 725                      ffebld_constant_complex3 (ffebld_conter (l)));
 726                   break;
 727 #endif
 728
 729                 default:
 730                   assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
 731                   break;
 732                 }
 733               break;
 734
 735             case FFEINFO_basictypeLOGICAL:
 736               switch (ffeinfo_kindtype (ffebld_info (l)))
 737                 {
 738 #if FFETARGET_okLOGICAL1
 739                 case FFEINFO_kindtypeLOGICAL1:
 740                   error = ffetarget_convert_integer2_logical1
 741                     (ffebld_cu_ptr_integer2 (u),
 742                      ffebld_constant_logical1 (ffebld_conter (l)));
 743                   break;
 744 #endif
 745
 746 #if FFETARGET_okLOGICAL2
 747                 case FFEINFO_kindtypeLOGICAL2:
 748                   error = ffetarget_convert_integer2_logical2
 749                     (ffebld_cu_ptr_integer2 (u),
 750                      ffebld_constant_logical2 (ffebld_conter (l)));
 751                   break;
 752 #endif
 753
 754 #if FFETARGET_okLOGICAL3
 755                 case FFEINFO_kindtypeLOGICAL3:
 756                   error = ffetarget_convert_integer2_logical3
 757                     (ffebld_cu_ptr_integer2 (u),
 758                      ffebld_constant_logical3 (ffebld_conter (l)));
 759                   break;
 760 #endif
 761
 762 #if FFETARGET_okLOGICAL4
 763                 case FFEINFO_kindtypeLOGICAL4:
 764                   error = ffetarget_convert_integer2_logical4
 765                     (ffebld_cu_ptr_integer2 (u),
 766                      ffebld_constant_logical4 (ffebld_conter (l)));
 767                   break;
 768 #endif
 769
 770                 default:
 771                   assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
 772                   break;
 773                 }
 774               break;
 775
 776             case FFEINFO_basictypeCHARACTER:
 777               error = ffetarget_convert_integer2_character1
 778                 (ffebld_cu_ptr_integer2 (u),
 779                  ffebld_constant_character1 (ffebld_conter (l)));
 780               break;
 781
 782             case FFEINFO_basictypeHOLLERITH:
 783               error = ffetarget_convert_integer2_hollerith
 784                 (ffebld_cu_ptr_integer2 (u),
 785                  ffebld_constant_hollerith (ffebld_conter (l)));
 786               break;
 787
 788             case FFEINFO_basictypeTYPELESS:
 789               error = ffetarget_convert_integer2_typeless
 790                 (ffebld_cu_ptr_integer2 (u),
 791                  ffebld_constant_typeless (ffebld_conter (l)));
 792               break;
 793
 794             default:
 795               assert ("INTEGER2 bad type" == NULL);
 796               break;
 797             }
 798
 799           /* If conversion operation is not implemented, return original expr.  */
 800           if (error == FFEBAD_NOCANDO)
 801             return expr;
 802
 803           expr = ffebld_new_conter_with_orig
 804             (ffebld_constant_new_integer2_val
 805              (ffebld_cu_val_integer2 (u)), expr);
 806           break;
 807 #endif
 808
 809 #if FFETARGET_okINTEGER3
 810         case FFEINFO_kindtypeINTEGER3:
 811           switch (ffeinfo_basictype (ffebld_info (l)))
 812             {
 813             case FFEINFO_basictypeINTEGER:
 814               switch (ffeinfo_kindtype (ffebld_info (l)))
 815                 {
 816 #if FFETARGET_okINTEGER1
 817                 case FFEINFO_kindtypeINTEGER1:
 818                   error = ffetarget_convert_integer3_integer1
 819                     (ffebld_cu_ptr_integer3 (u),
 820                      ffebld_constant_integer1 (ffebld_conter (l)));
 821                   break;
 822 #endif
 823
 824 #if FFETARGET_okINTEGER2
 825                 case FFEINFO_kindtypeINTEGER2:
 826                   error = ffetarget_convert_integer3_integer2
 827                     (ffebld_cu_ptr_integer3 (u),
 828                      ffebld_constant_integer2 (ffebld_conter (l)));
 829                   break;
 830 #endif
 831
 832 #if FFETARGET_okINTEGER4
 833                 case FFEINFO_kindtypeINTEGER4:
 834                   error = ffetarget_convert_integer3_integer4
 835                     (ffebld_cu_ptr_integer3 (u),
 836                      ffebld_constant_integer4 (ffebld_conter (l)));
 837                   break;
 838 #endif
 839
 840                 default:
 841                   assert ("INTEGER3/INTEGER bad source kind type" == NULL);
 842                   break;
 843                 }
 844               break;
 845
 846             case FFEINFO_basictypeREAL:
 847               switch (ffeinfo_kindtype (ffebld_info (l)))
 848                 {
 849 #if FFETARGET_okREAL1
 850                 case FFEINFO_kindtypeREAL1:
 851                   error = ffetarget_convert_integer3_real1
 852                     (ffebld_cu_ptr_integer3 (u),
 853                      ffebld_constant_real1 (ffebld_conter (l)));
 854                   break;
 855 #endif
 856
 857 #if FFETARGET_okREAL2
 858                 case FFEINFO_kindtypeREAL2:
 859                   error = ffetarget_convert_integer3_real2
 860                     (ffebld_cu_ptr_integer3 (u),
 861                      ffebld_constant_real2 (ffebld_conter (l)));
 862                   break;
 863 #endif
 864
 865 #if FFETARGET_okREAL3
 866                 case FFEINFO_kindtypeREAL3:
 867                   error = ffetarget_convert_integer3_real3
 868                     (ffebld_cu_ptr_integer3 (u),
 869                      ffebld_constant_real3 (ffebld_conter (l)));
 870                   break;
 871 #endif
 872
 873                 default:
 874                   assert ("INTEGER3/REAL bad source kind type" == NULL);
 875                   break;
 876                 }
 877               break;
 878
 879             case FFEINFO_basictypeCOMPLEX:
 880               switch (ffeinfo_kindtype (ffebld_info (l)))
 881                 {
 882 #if FFETARGET_okCOMPLEX1
 883                 case FFEINFO_kindtypeREAL1:
 884                   error = ffetarget_convert_integer3_complex1
 885                     (ffebld_cu_ptr_integer3 (u),
 886                      ffebld_constant_complex1 (ffebld_conter (l)));
 887                   break;
 888 #endif
 889
 890 #if FFETARGET_okCOMPLEX2
 891                 case FFEINFO_kindtypeREAL2:
 892                   error = ffetarget_convert_integer3_complex2
 893                     (ffebld_cu_ptr_integer3 (u),
 894                      ffebld_constant_complex2 (ffebld_conter (l)));
 895                   break;
 896 #endif
 897
 898 #if FFETARGET_okCOMPLEX3
 899                 case FFEINFO_kindtypeREAL3:
 900                   error = ffetarget_convert_integer3_complex3
 901                     (ffebld_cu_ptr_integer3 (u),
 902                      ffebld_constant_complex3 (ffebld_conter (l)));
 903                   break;
 904 #endif
 905
 906                 default:
 907                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
 908                   break;
 909                 }
 910               break;
 911
 912             case FFEINFO_basictypeLOGICAL:
 913               switch (ffeinfo_kindtype (ffebld_info (l)))
 914                 {
 915 #if FFETARGET_okLOGICAL1
 916                 case FFEINFO_kindtypeLOGICAL1:
 917                   error = ffetarget_convert_integer3_logical1
 918                     (ffebld_cu_ptr_integer3 (u),
 919                      ffebld_constant_logical1 (ffebld_conter (l)));
 920                   break;
 921 #endif
 922
 923 #if FFETARGET_okLOGICAL2
 924                 case FFEINFO_kindtypeLOGICAL2:
 925                   error = ffetarget_convert_integer3_logical2
 926                     (ffebld_cu_ptr_integer3 (u),
 927                      ffebld_constant_logical2 (ffebld_conter (l)));
 928                   break;
 929 #endif
 930
 931 #if FFETARGET_okLOGICAL3
 932                 case FFEINFO_kindtypeLOGICAL3:
 933                   error = ffetarget_convert_integer3_logical3
 934                     (ffebld_cu_ptr_integer3 (u),
 935                      ffebld_constant_logical3 (ffebld_conter (l)));
 936                   break;
 937 #endif
 938
 939 #if FFETARGET_okLOGICAL4
 940                 case FFEINFO_kindtypeLOGICAL4:
 941                   error = ffetarget_convert_integer3_logical4
 942                     (ffebld_cu_ptr_integer3 (u),
 943                      ffebld_constant_logical4 (ffebld_conter (l)));
 944                   break;
 945 #endif
 946
 947                 default:
 948                   assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
 949                   break;
 950                 }
 951               break;
 952
 953             case FFEINFO_basictypeCHARACTER:
 954               error = ffetarget_convert_integer3_character1
 955                 (ffebld_cu_ptr_integer3 (u),
 956                  ffebld_constant_character1 (ffebld_conter (l)));
 957               break;
 958
 959             case FFEINFO_basictypeHOLLERITH:
 960               error = ffetarget_convert_integer3_hollerith
 961                 (ffebld_cu_ptr_integer3 (u),
 962                  ffebld_constant_hollerith (ffebld_conter (l)));
 963               break;
 964
 965             case FFEINFO_basictypeTYPELESS:
 966               error = ffetarget_convert_integer3_typeless
 967                 (ffebld_cu_ptr_integer3 (u),
 968                  ffebld_constant_typeless (ffebld_conter (l)));
 969               break;
 970
 971             default:
 972               assert ("INTEGER3 bad type" == NULL);
 973               break;
 974             }
 975
 976           /* If conversion operation is not implemented, return original expr.  */
 977           if (error == FFEBAD_NOCANDO)
 978             return expr;
 979
 980           expr = ffebld_new_conter_with_orig
 981             (ffebld_constant_new_integer3_val
 982              (ffebld_cu_val_integer3 (u)), expr);
 983           break;
 984 #endif
 985
 986 #if FFETARGET_okINTEGER4
 987         case FFEINFO_kindtypeINTEGER4:
 988           switch (ffeinfo_basictype (ffebld_info (l)))
 989             {
 990             case FFEINFO_basictypeINTEGER:
 991               switch (ffeinfo_kindtype (ffebld_info (l)))
 992                 {
 993 #if FFETARGET_okINTEGER1
 994                 case FFEINFO_kindtypeINTEGER1:
 995                   error = ffetarget_convert_integer4_integer1
 996                     (ffebld_cu_ptr_integer4 (u),
 997                      ffebld_constant_integer1 (ffebld_conter (l)));
 998                   break;
 999 #endif
1000
1001 #if FFETARGET_okINTEGER2
1002                 case FFEINFO_kindtypeINTEGER2:
1003                   error = ffetarget_convert_integer4_integer2
1004                     (ffebld_cu_ptr_integer4 (u),
1005                      ffebld_constant_integer2 (ffebld_conter (l)));
1006                   break;
1007 #endif
1008
1009 #if FFETARGET_okINTEGER3
1010                 case FFEINFO_kindtypeINTEGER3:
1011                   error = ffetarget_convert_integer4_integer3
1012                     (ffebld_cu_ptr_integer4 (u),
1013                      ffebld_constant_integer3 (ffebld_conter (l)));
1014                   break;
1015 #endif
1016
1017                 default:
1018                   assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1019                   break;
1020                 }
1021               break;
1022
1023             case FFEINFO_basictypeREAL:
1024               switch (ffeinfo_kindtype (ffebld_info (l)))
1025                 {
1026 #if FFETARGET_okREAL1
1027                 case FFEINFO_kindtypeREAL1:
1028                   error = ffetarget_convert_integer4_real1
1029                     (ffebld_cu_ptr_integer4 (u),
1030                      ffebld_constant_real1 (ffebld_conter (l)));
1031                   break;
1032 #endif
1033
1034 #if FFETARGET_okREAL2
1035                 case FFEINFO_kindtypeREAL2:
1036                   error = ffetarget_convert_integer4_real2
1037                     (ffebld_cu_ptr_integer4 (u),
1038                      ffebld_constant_real2 (ffebld_conter (l)));
1039                   break;
1040 #endif
1041
1042 #if FFETARGET_okREAL3
1043                 case FFEINFO_kindtypeREAL3:
1044                   error = ffetarget_convert_integer4_real3
1045                     (ffebld_cu_ptr_integer4 (u),
1046                      ffebld_constant_real3 (ffebld_conter (l)));
1047                   break;
1048 #endif
1049
1050                 default:
1051                   assert ("INTEGER4/REAL bad source kind type" == NULL);
1052                   break;
1053                 }
1054               break;
1055
1056             case FFEINFO_basictypeCOMPLEX:
1057               switch (ffeinfo_kindtype (ffebld_info (l)))
1058                 {
1059 #if FFETARGET_okCOMPLEX1
1060                 case FFEINFO_kindtypeREAL1:
1061                   error = ffetarget_convert_integer4_complex1
1062                     (ffebld_cu_ptr_integer4 (u),
1063                      ffebld_constant_complex1 (ffebld_conter (l)));
1064                   break;
1065 #endif
1066
1067 #if FFETARGET_okCOMPLEX2
1068                 case FFEINFO_kindtypeREAL2:
1069                   error = ffetarget_convert_integer4_complex2
1070                     (ffebld_cu_ptr_integer4 (u),
1071                      ffebld_constant_complex2 (ffebld_conter (l)));
1072                   break;
1073 #endif
1074
1075 #if FFETARGET_okCOMPLEX3
1076                 case FFEINFO_kindtypeREAL3:
1077                   error = ffetarget_convert_integer4_complex3
1078                     (ffebld_cu_ptr_integer4 (u),
1079                      ffebld_constant_complex3 (ffebld_conter (l)));
1080                   break;
1081 #endif
1082
1083                 default:
1084                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1085                   break;
1086                 }
1087               break;
1088
1089             case FFEINFO_basictypeLOGICAL:
1090               switch (ffeinfo_kindtype (ffebld_info (l)))
1091                 {
1092 #if FFETARGET_okLOGICAL1
1093                 case FFEINFO_kindtypeLOGICAL1:
1094                   error = ffetarget_convert_integer4_logical1
1095                     (ffebld_cu_ptr_integer4 (u),
1096                      ffebld_constant_logical1 (ffebld_conter (l)));
1097                   break;
1098 #endif
1099
1100 #if FFETARGET_okLOGICAL2
1101                 case FFEINFO_kindtypeLOGICAL2:
1102                   error = ffetarget_convert_integer4_logical2
1103                     (ffebld_cu_ptr_integer4 (u),
1104                      ffebld_constant_logical2 (ffebld_conter (l)));
1105                   break;
1106 #endif
1107
1108 #if FFETARGET_okLOGICAL3
1109                 case FFEINFO_kindtypeLOGICAL3:
1110                   error = ffetarget_convert_integer4_logical3
1111                     (ffebld_cu_ptr_integer4 (u),
1112                      ffebld_constant_logical3 (ffebld_conter (l)));
1113                   break;
1114 #endif
1115
1116 #if FFETARGET_okLOGICAL4
1117                 case FFEINFO_kindtypeLOGICAL4:
1118                   error = ffetarget_convert_integer4_logical4
1119                     (ffebld_cu_ptr_integer4 (u),
1120                      ffebld_constant_logical4 (ffebld_conter (l)));
1121                   break;
1122 #endif
1123
1124                 default:
1125                   assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1126                   break;
1127                 }
1128               break;
1129
1130             case FFEINFO_basictypeCHARACTER:
1131               error = ffetarget_convert_integer4_character1
1132                 (ffebld_cu_ptr_integer4 (u),
1133                  ffebld_constant_character1 (ffebld_conter (l)));
1134               break;
1135
1136             case FFEINFO_basictypeHOLLERITH:
1137               error = ffetarget_convert_integer4_hollerith
1138                 (ffebld_cu_ptr_integer4 (u),
1139                  ffebld_constant_hollerith (ffebld_conter (l)));
1140               break;
1141
1142             case FFEINFO_basictypeTYPELESS:
1143               error = ffetarget_convert_integer4_typeless
1144                 (ffebld_cu_ptr_integer4 (u),
1145                  ffebld_constant_typeless (ffebld_conter (l)));
1146               break;
1147
1148             default:
1149               assert ("INTEGER4 bad type" == NULL);
1150               break;
1151             }
1152
1153           /* If conversion operation is not implemented, return original expr.  */
1154           if (error == FFEBAD_NOCANDO)
1155             return expr;
1156
1157           expr = ffebld_new_conter_with_orig
1158             (ffebld_constant_new_integer4_val
1159              (ffebld_cu_val_integer4 (u)), expr);
1160           break;
1161 #endif
1162
1163         default:
1164           assert ("bad integer kind type" == NULL);
1165           break;
1166         }
1167       break;
1168
1169     case FFEINFO_basictypeLOGICAL:
1170       sz = FFETARGET_charactersizeNONE;
1171       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1172         {
1173 #if FFETARGET_okLOGICAL1
1174         case FFEINFO_kindtypeLOGICAL1:
1175           switch (ffeinfo_basictype (ffebld_info (l)))
1176             {
1177             case FFEINFO_basictypeLOGICAL:
1178               switch (ffeinfo_kindtype (ffebld_info (l)))
1179                 {
1180 #if FFETARGET_okLOGICAL2
1181                 case FFEINFO_kindtypeLOGICAL2:
1182                   error = ffetarget_convert_logical1_logical2
1183                     (ffebld_cu_ptr_logical1 (u),
1184                      ffebld_constant_logical2 (ffebld_conter (l)));
1185                   break;
1186 #endif
1187
1188 #if FFETARGET_okLOGICAL3
1189                 case FFEINFO_kindtypeLOGICAL3:
1190                   error = ffetarget_convert_logical1_logical3
1191                     (ffebld_cu_ptr_logical1 (u),
1192                      ffebld_constant_logical3 (ffebld_conter (l)));
1193                   break;
1194 #endif
1195
1196 #if FFETARGET_okLOGICAL4
1197                 case FFEINFO_kindtypeLOGICAL4:
1198                   error = ffetarget_convert_logical1_logical4
1199                     (ffebld_cu_ptr_logical1 (u),
1200                      ffebld_constant_logical4 (ffebld_conter (l)));
1201                   break;
1202 #endif
1203
1204                 default:
1205                   assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1206                   break;
1207                 }
1208               break;
1209
1210             case FFEINFO_basictypeINTEGER:
1211               switch (ffeinfo_kindtype (ffebld_info (l)))
1212                 {
1213 #if FFETARGET_okINTEGER1
1214                 case FFEINFO_kindtypeINTEGER1:
1215                   error = ffetarget_convert_logical1_integer1
1216                     (ffebld_cu_ptr_logical1 (u),
1217                      ffebld_constant_integer1 (ffebld_conter (l)));
1218                   break;
1219 #endif
1220
1221 #if FFETARGET_okINTEGER2
1222                 case FFEINFO_kindtypeINTEGER2:
1223                   error = ffetarget_convert_logical1_integer2
1224                     (ffebld_cu_ptr_logical1 (u),
1225                      ffebld_constant_integer2 (ffebld_conter (l)));
1226                   break;
1227 #endif
1228
1229 #if FFETARGET_okINTEGER3
1230                 case FFEINFO_kindtypeINTEGER3:
1231                   error = ffetarget_convert_logical1_integer3
1232                     (ffebld_cu_ptr_logical1 (u),
1233                      ffebld_constant_integer3 (ffebld_conter (l)));
1234                   break;
1235 #endif
1236
1237 #if FFETARGET_okINTEGER4
1238                 case FFEINFO_kindtypeINTEGER4:
1239                   error = ffetarget_convert_logical1_integer4
1240                     (ffebld_cu_ptr_logical1 (u),
1241                      ffebld_constant_integer4 (ffebld_conter (l)));
1242                   break;
1243 #endif
1244
1245                 default:
1246                   assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1247                   break;
1248                 }
1249               break;
1250
1251             case FFEINFO_basictypeCHARACTER:
1252               error = ffetarget_convert_logical1_character1
1253                 (ffebld_cu_ptr_logical1 (u),
1254                  ffebld_constant_character1 (ffebld_conter (l)));
1255               break;
1256
1257             case FFEINFO_basictypeHOLLERITH:
1258               error = ffetarget_convert_logical1_hollerith
1259                 (ffebld_cu_ptr_logical1 (u),
1260                  ffebld_constant_hollerith (ffebld_conter (l)));
1261               break;
1262
1263             case FFEINFO_basictypeTYPELESS:
1264               error = ffetarget_convert_logical1_typeless
1265                 (ffebld_cu_ptr_logical1 (u),
1266                  ffebld_constant_typeless (ffebld_conter (l)));
1267               break;
1268
1269             default:
1270               assert ("LOGICAL1 bad type" == NULL);
1271               break;
1272             }
1273
1274           /* If conversion operation is not implemented, return original expr.  */
1275           if (error == FFEBAD_NOCANDO)
1276             return expr;
1277
1278           expr = ffebld_new_conter_with_orig
1279             (ffebld_constant_new_logical1_val
1280              (ffebld_cu_val_logical1 (u)), expr);
1281           break;
1282 #endif
1283
1284 #if FFETARGET_okLOGICAL2
1285         case FFEINFO_kindtypeLOGICAL2:
1286           switch (ffeinfo_basictype (ffebld_info (l)))
1287             {
1288             case FFEINFO_basictypeLOGICAL:
1289               switch (ffeinfo_kindtype (ffebld_info (l)))
1290                 {
1291 #if FFETARGET_okLOGICAL1
1292                 case FFEINFO_kindtypeLOGICAL1:
1293                   error = ffetarget_convert_logical2_logical1
1294                     (ffebld_cu_ptr_logical2 (u),
1295                      ffebld_constant_logical1 (ffebld_conter (l)));
1296                   break;
1297 #endif
1298
1299 #if FFETARGET_okLOGICAL3
1300                 case FFEINFO_kindtypeLOGICAL3:
1301                   error = ffetarget_convert_logical2_logical3
1302                     (ffebld_cu_ptr_logical2 (u),
1303                      ffebld_constant_logical3 (ffebld_conter (l)));
1304                   break;
1305 #endif
1306
1307 #if FFETARGET_okLOGICAL4
1308                 case FFEINFO_kindtypeLOGICAL4:
1309                   error = ffetarget_convert_logical2_logical4
1310                     (ffebld_cu_ptr_logical2 (u),
1311                      ffebld_constant_logical4 (ffebld_conter (l)));
1312                   break;
1313 #endif
1314
1315                 default:
1316                   assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1317                   break;
1318                 }
1319               break;
1320
1321             case FFEINFO_basictypeINTEGER:
1322               switch (ffeinfo_kindtype (ffebld_info (l)))
1323                 {
1324 #if FFETARGET_okINTEGER1
1325                 case FFEINFO_kindtypeINTEGER1:
1326                   error = ffetarget_convert_logical2_integer1
1327                     (ffebld_cu_ptr_logical2 (u),
1328                      ffebld_constant_integer1 (ffebld_conter (l)));
1329                   break;
1330 #endif
1331
1332 #if FFETARGET_okINTEGER2
1333                 case FFEINFO_kindtypeINTEGER2:
1334                   error = ffetarget_convert_logical2_integer2
1335                     (ffebld_cu_ptr_logical2 (u),
1336                      ffebld_constant_integer2 (ffebld_conter (l)));
1337                   break;
1338 #endif
1339
1340 #if FFETARGET_okINTEGER3
1341                 case FFEINFO_kindtypeINTEGER3:
1342                   error = ffetarget_convert_logical2_integer3
1343                     (ffebld_cu_ptr_logical2 (u),
1344                      ffebld_constant_integer3 (ffebld_conter (l)));
1345                   break;
1346 #endif
1347
1348 #if FFETARGET_okINTEGER4
1349                 case FFEINFO_kindtypeINTEGER4:
1350                   error = ffetarget_convert_logical2_integer4
1351                     (ffebld_cu_ptr_logical2 (u),
1352                      ffebld_constant_integer4 (ffebld_conter (l)));
1353                   break;
1354 #endif
1355
1356                 default:
1357                   assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1358                   break;
1359                 }
1360               break;
1361
1362             case FFEINFO_basictypeCHARACTER:
1363               error = ffetarget_convert_logical2_character1
1364                 (ffebld_cu_ptr_logical2 (u),
1365                  ffebld_constant_character1 (ffebld_conter (l)));
1366               break;
1367
1368             case FFEINFO_basictypeHOLLERITH:
1369               error = ffetarget_convert_logical2_hollerith
1370                 (ffebld_cu_ptr_logical2 (u),
1371                  ffebld_constant_hollerith (ffebld_conter (l)));
1372               break;
1373
1374             case FFEINFO_basictypeTYPELESS:
1375               error = ffetarget_convert_logical2_typeless
1376                 (ffebld_cu_ptr_logical2 (u),
1377                  ffebld_constant_typeless (ffebld_conter (l)));
1378               break;
1379
1380             default:
1381               assert ("LOGICAL2 bad type" == NULL);
1382               break;
1383             }
1384
1385           /* If conversion operation is not implemented, return original expr.  */
1386           if (error == FFEBAD_NOCANDO)
1387             return expr;
1388
1389           expr = ffebld_new_conter_with_orig
1390             (ffebld_constant_new_logical2_val
1391              (ffebld_cu_val_logical2 (u)), expr);
1392           break;
1393 #endif
1394
1395 #if FFETARGET_okLOGICAL3
1396         case FFEINFO_kindtypeLOGICAL3:
1397           switch (ffeinfo_basictype (ffebld_info (l)))
1398             {
1399             case FFEINFO_basictypeLOGICAL:
1400               switch (ffeinfo_kindtype (ffebld_info (l)))
1401                 {
1402 #if FFETARGET_okLOGICAL1
1403                 case FFEINFO_kindtypeLOGICAL1:
1404                   error = ffetarget_convert_logical3_logical1
1405                     (ffebld_cu_ptr_logical3 (u),
1406                      ffebld_constant_logical1 (ffebld_conter (l)));
1407                   break;
1408 #endif
1409
1410 #if FFETARGET_okLOGICAL2
1411                 case FFEINFO_kindtypeLOGICAL2:
1412                   error = ffetarget_convert_logical3_logical2
1413                     (ffebld_cu_ptr_logical3 (u),
1414                      ffebld_constant_logical2 (ffebld_conter (l)));
1415                   break;
1416 #endif
1417
1418 #if FFETARGET_okLOGICAL4
1419                 case FFEINFO_kindtypeLOGICAL4:
1420                   error = ffetarget_convert_logical3_logical4
1421                     (ffebld_cu_ptr_logical3 (u),
1422                      ffebld_constant_logical4 (ffebld_conter (l)));
1423                   break;
1424 #endif
1425
1426                 default:
1427                   assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1428                   break;
1429                 }
1430               break;
1431
1432             case FFEINFO_basictypeINTEGER:
1433               switch (ffeinfo_kindtype (ffebld_info (l)))
1434                 {
1435 #if FFETARGET_okINTEGER1
1436                 case FFEINFO_kindtypeINTEGER1:
1437                   error = ffetarget_convert_logical3_integer1
1438                     (ffebld_cu_ptr_logical3 (u),
1439                      ffebld_constant_integer1 (ffebld_conter (l)));
1440                   break;
1441 #endif
1442
1443 #if FFETARGET_okINTEGER2
1444                 case FFEINFO_kindtypeINTEGER2:
1445                   error = ffetarget_convert_logical3_integer2
1446                     (ffebld_cu_ptr_logical3 (u),
1447                      ffebld_constant_integer2 (ffebld_conter (l)));
1448                   break;
1449 #endif
1450
1451 #if FFETARGET_okINTEGER3
1452                 case FFEINFO_kindtypeINTEGER3:
1453                   error = ffetarget_convert_logical3_integer3
1454                     (ffebld_cu_ptr_logical3 (u),
1455                      ffebld_constant_integer3 (ffebld_conter (l)));
1456                   break;
1457 #endif
1458
1459 #if FFETARGET_okINTEGER4
1460                 case FFEINFO_kindtypeINTEGER4:
1461                   error = ffetarget_convert_logical3_integer4
1462                     (ffebld_cu_ptr_logical3 (u),
1463                      ffebld_constant_integer4 (ffebld_conter (l)));
1464                   break;
1465 #endif
1466
1467                 default:
1468                   assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1469                   break;
1470                 }
1471               break;
1472
1473             case FFEINFO_basictypeCHARACTER:
1474               error = ffetarget_convert_logical3_character1
1475                 (ffebld_cu_ptr_logical3 (u),
1476                  ffebld_constant_character1 (ffebld_conter (l)));
1477               break;
1478
1479             case FFEINFO_basictypeHOLLERITH:
1480               error = ffetarget_convert_logical3_hollerith
1481                 (ffebld_cu_ptr_logical3 (u),
1482                  ffebld_constant_hollerith (ffebld_conter (l)));
1483               break;
1484
1485             case FFEINFO_basictypeTYPELESS:
1486               error = ffetarget_convert_logical3_typeless
1487                 (ffebld_cu_ptr_logical3 (u),
1488                  ffebld_constant_typeless (ffebld_conter (l)));
1489               break;
1490
1491             default:
1492               assert ("LOGICAL3 bad type" == NULL);
1493               break;
1494             }
1495
1496           /* If conversion operation is not implemented, return original expr.  */
1497           if (error == FFEBAD_NOCANDO)
1498             return expr;
1499
1500           expr = ffebld_new_conter_with_orig
1501             (ffebld_constant_new_logical3_val
1502              (ffebld_cu_val_logical3 (u)), expr);
1503           break;
1504 #endif
1505
1506 #if FFETARGET_okLOGICAL4
1507         case FFEINFO_kindtypeLOGICAL4:
1508           switch (ffeinfo_basictype (ffebld_info (l)))
1509             {
1510             case FFEINFO_basictypeLOGICAL:
1511               switch (ffeinfo_kindtype (ffebld_info (l)))
1512                 {
1513 #if FFETARGET_okLOGICAL1
1514                 case FFEINFO_kindtypeLOGICAL1:
1515                   error = ffetarget_convert_logical4_logical1
1516                     (ffebld_cu_ptr_logical4 (u),
1517                      ffebld_constant_logical1 (ffebld_conter (l)));
1518                   break;
1519 #endif
1520
1521 #if FFETARGET_okLOGICAL2
1522                 case FFEINFO_kindtypeLOGICAL2:
1523                   error = ffetarget_convert_logical4_logical2
1524                     (ffebld_cu_ptr_logical4 (u),
1525                      ffebld_constant_logical2 (ffebld_conter (l)));
1526                   break;
1527 #endif
1528
1529 #if FFETARGET_okLOGICAL3
1530                 case FFEINFO_kindtypeLOGICAL3:
1531                   error = ffetarget_convert_logical4_logical3
1532                     (ffebld_cu_ptr_logical4 (u),
1533                      ffebld_constant_logical3 (ffebld_conter (l)));
1534                   break;
1535 #endif
1536
1537                 default:
1538                   assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1539                   break;
1540                 }
1541               break;
1542
1543             case FFEINFO_basictypeINTEGER:
1544               switch (ffeinfo_kindtype (ffebld_info (l)))
1545                 {
1546 #if FFETARGET_okINTEGER1
1547                 case FFEINFO_kindtypeINTEGER1:
1548                   error = ffetarget_convert_logical4_integer1
1549                     (ffebld_cu_ptr_logical4 (u),
1550                      ffebld_constant_integer1 (ffebld_conter (l)));
1551                   break;
1552 #endif
1553
1554 #if FFETARGET_okINTEGER2
1555                 case FFEINFO_kindtypeINTEGER2:
1556                   error = ffetarget_convert_logical4_integer2
1557                     (ffebld_cu_ptr_logical4 (u),
1558                      ffebld_constant_integer2 (ffebld_conter (l)));
1559                   break;
1560 #endif
1561
1562 #if FFETARGET_okINTEGER3
1563                 case FFEINFO_kindtypeINTEGER3:
1564                   error = ffetarget_convert_logical4_integer3
1565                     (ffebld_cu_ptr_logical4 (u),
1566                      ffebld_constant_integer3 (ffebld_conter (l)));
1567                   break;
1568 #endif
1569
1570 #if FFETARGET_okINTEGER4
1571                 case FFEINFO_kindtypeINTEGER4:
1572                   error = ffetarget_convert_logical4_integer4
1573                     (ffebld_cu_ptr_logical4 (u),
1574                      ffebld_constant_integer4 (ffebld_conter (l)));
1575                   break;
1576 #endif
1577
1578                 default:
1579                   assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1580                   break;
1581                 }
1582               break;
1583
1584             case FFEINFO_basictypeCHARACTER:
1585               error = ffetarget_convert_logical4_character1
1586                 (ffebld_cu_ptr_logical4 (u),
1587                  ffebld_constant_character1 (ffebld_conter (l)));
1588               break;
1589
1590             case FFEINFO_basictypeHOLLERITH:
1591               error = ffetarget_convert_logical4_hollerith
1592                 (ffebld_cu_ptr_logical4 (u),
1593                  ffebld_constant_hollerith (ffebld_conter (l)));
1594               break;
1595
1596             case FFEINFO_basictypeTYPELESS:
1597               error = ffetarget_convert_logical4_typeless
1598                 (ffebld_cu_ptr_logical4 (u),
1599                  ffebld_constant_typeless (ffebld_conter (l)));
1600               break;
1601
1602             default:
1603               assert ("LOGICAL4 bad type" == NULL);
1604               break;
1605             }
1606
1607           /* If conversion operation is not implemented, return original expr.  */
1608           if (error == FFEBAD_NOCANDO)
1609             return expr;
1610
1611           expr = ffebld_new_conter_with_orig
1612             (ffebld_constant_new_logical4_val
1613              (ffebld_cu_val_logical4 (u)), expr);
1614           break;
1615 #endif
1616
1617         default:
1618           assert ("bad logical kind type" == NULL);
1619           break;
1620         }
1621       break;
1622
1623     case FFEINFO_basictypeREAL:
1624       sz = FFETARGET_charactersizeNONE;
1625       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1626         {
1627 #if FFETARGET_okREAL1
1628         case FFEINFO_kindtypeREAL1:
1629           switch (ffeinfo_basictype (ffebld_info (l)))
1630             {
1631             case FFEINFO_basictypeINTEGER:
1632               switch (ffeinfo_kindtype (ffebld_info (l)))
1633                 {
1634 #if FFETARGET_okINTEGER1
1635                 case FFEINFO_kindtypeINTEGER1:
1636                   error = ffetarget_convert_real1_integer1
1637                     (ffebld_cu_ptr_real1 (u),
1638                      ffebld_constant_integer1 (ffebld_conter (l)));
1639                   break;
1640 #endif
1641
1642 #if FFETARGET_okINTEGER2
1643                 case FFEINFO_kindtypeINTEGER2:
1644                   error = ffetarget_convert_real1_integer2
1645                     (ffebld_cu_ptr_real1 (u),
1646                      ffebld_constant_integer2 (ffebld_conter (l)));
1647                   break;
1648 #endif
1649
1650 #if FFETARGET_okINTEGER3
1651                 case FFEINFO_kindtypeINTEGER3:
1652                   error = ffetarget_convert_real1_integer3
1653                     (ffebld_cu_ptr_real1 (u),
1654                      ffebld_constant_integer3 (ffebld_conter (l)));
1655                   break;
1656 #endif
1657
1658 #if FFETARGET_okINTEGER4
1659                 case FFEINFO_kindtypeINTEGER4:
1660                   error = ffetarget_convert_real1_integer4
1661                     (ffebld_cu_ptr_real1 (u),
1662                      ffebld_constant_integer4 (ffebld_conter (l)));
1663                   break;
1664 #endif
1665
1666                 default:
1667                   assert ("REAL1/INTEGER bad source kind type" == NULL);
1668                   break;
1669                 }
1670               break;
1671
1672             case FFEINFO_basictypeREAL:
1673               switch (ffeinfo_kindtype (ffebld_info (l)))
1674                 {
1675 #if FFETARGET_okREAL2
1676                 case FFEINFO_kindtypeREAL2:
1677                   error = ffetarget_convert_real1_real2
1678                     (ffebld_cu_ptr_real1 (u),
1679                      ffebld_constant_real2 (ffebld_conter (l)));
1680                   break;
1681 #endif
1682
1683 #if FFETARGET_okREAL3
1684                 case FFEINFO_kindtypeREAL3:
1685                   error = ffetarget_convert_real1_real3
1686                     (ffebld_cu_ptr_real1 (u),
1687                      ffebld_constant_real3 (ffebld_conter (l)));
1688                   break;
1689 #endif
1690
1691                 default:
1692                   assert ("REAL1/REAL bad source kind type" == NULL);
1693                   break;
1694                 }
1695               break;
1696
1697             case FFEINFO_basictypeCOMPLEX:
1698               switch (ffeinfo_kindtype (ffebld_info (l)))
1699                 {
1700 #if FFETARGET_okCOMPLEX1
1701                 case FFEINFO_kindtypeREAL1:
1702                   error = ffetarget_convert_real1_complex1
1703                     (ffebld_cu_ptr_real1 (u),
1704                      ffebld_constant_complex1 (ffebld_conter (l)));
1705                   break;
1706 #endif
1707
1708 #if FFETARGET_okCOMPLEX2
1709                 case FFEINFO_kindtypeREAL2:
1710                   error = ffetarget_convert_real1_complex2
1711                     (ffebld_cu_ptr_real1 (u),
1712                      ffebld_constant_complex2 (ffebld_conter (l)));
1713                   break;
1714 #endif
1715
1716 #if FFETARGET_okCOMPLEX3
1717                 case FFEINFO_kindtypeREAL3:
1718                   error = ffetarget_convert_real1_complex3
1719                     (ffebld_cu_ptr_real1 (u),
1720                      ffebld_constant_complex3 (ffebld_conter (l)));
1721                   break;
1722 #endif
1723
1724                 default:
1725                   assert ("REAL1/COMPLEX bad source kind type" == NULL);
1726                   break;
1727                 }
1728               break;
1729
1730             case FFEINFO_basictypeCHARACTER:
1731               error = ffetarget_convert_real1_character1
1732                 (ffebld_cu_ptr_real1 (u),
1733                  ffebld_constant_character1 (ffebld_conter (l)));
1734               break;
1735
1736             case FFEINFO_basictypeHOLLERITH:
1737               error = ffetarget_convert_real1_hollerith
1738                 (ffebld_cu_ptr_real1 (u),
1739                  ffebld_constant_hollerith (ffebld_conter (l)));
1740               break;
1741
1742             case FFEINFO_basictypeTYPELESS:
1743               error = ffetarget_convert_real1_typeless
1744                 (ffebld_cu_ptr_real1 (u),
1745                  ffebld_constant_typeless (ffebld_conter (l)));
1746               break;
1747
1748             default:
1749               assert ("REAL1 bad type" == NULL);
1750               break;
1751             }
1752
1753           /* If conversion operation is not implemented, return original expr.  */
1754           if (error == FFEBAD_NOCANDO)
1755             return expr;
1756
1757           expr = ffebld_new_conter_with_orig
1758             (ffebld_constant_new_real1_val
1759              (ffebld_cu_val_real1 (u)), expr);
1760           break;
1761 #endif
1762
1763 #if FFETARGET_okREAL2
1764         case FFEINFO_kindtypeREAL2:
1765           switch (ffeinfo_basictype (ffebld_info (l)))
1766             {
1767             case FFEINFO_basictypeINTEGER:
1768               switch (ffeinfo_kindtype (ffebld_info (l)))
1769                 {
1770 #if FFETARGET_okINTEGER1
1771                 case FFEINFO_kindtypeINTEGER1:
1772                   error = ffetarget_convert_real2_integer1
1773                     (ffebld_cu_ptr_real2 (u),
1774                      ffebld_constant_integer1 (ffebld_conter (l)));
1775                   break;
1776 #endif
1777
1778 #if FFETARGET_okINTEGER2
1779                 case FFEINFO_kindtypeINTEGER2:
1780                   error = ffetarget_convert_real2_integer2
1781                     (ffebld_cu_ptr_real2 (u),
1782                      ffebld_constant_integer2 (ffebld_conter (l)));
1783                   break;
1784 #endif
1785
1786 #if FFETARGET_okINTEGER3
1787                 case FFEINFO_kindtypeINTEGER3:
1788                   error = ffetarget_convert_real2_integer3
1789                     (ffebld_cu_ptr_real2 (u),
1790                      ffebld_constant_integer3 (ffebld_conter (l)));
1791                   break;
1792 #endif
1793
1794 #if FFETARGET_okINTEGER4
1795                 case FFEINFO_kindtypeINTEGER4:
1796                   error = ffetarget_convert_real2_integer4
1797                     (ffebld_cu_ptr_real2 (u),
1798                      ffebld_constant_integer4 (ffebld_conter (l)));
1799                   break;
1800 #endif
1801
1802                 default:
1803                   assert ("REAL2/INTEGER bad source kind type" == NULL);
1804                   break;
1805                 }
1806               break;
1807
1808             case FFEINFO_basictypeREAL:
1809               switch (ffeinfo_kindtype (ffebld_info (l)))
1810                 {
1811 #if FFETARGET_okREAL1
1812                 case FFEINFO_kindtypeREAL1:
1813                   error = ffetarget_convert_real2_real1
1814                     (ffebld_cu_ptr_real2 (u),
1815                      ffebld_constant_real1 (ffebld_conter (l)));
1816                   break;
1817 #endif
1818
1819 #if FFETARGET_okREAL3
1820                 case FFEINFO_kindtypeREAL3:
1821                   error = ffetarget_convert_real2_real3
1822                     (ffebld_cu_ptr_real2 (u),
1823                      ffebld_constant_real3 (ffebld_conter (l)));
1824                   break;
1825 #endif
1826
1827                 default:
1828                   assert ("REAL2/REAL bad source kind type" == NULL);
1829                   break;
1830                 }
1831               break;
1832
1833             case FFEINFO_basictypeCOMPLEX:
1834               switch (ffeinfo_kindtype (ffebld_info (l)))
1835                 {
1836 #if FFETARGET_okCOMPLEX1
1837                 case FFEINFO_kindtypeREAL1:
1838                   error = ffetarget_convert_real2_complex1
1839                     (ffebld_cu_ptr_real2 (u),
1840                      ffebld_constant_complex1 (ffebld_conter (l)));
1841                   break;
1842 #endif
1843
1844 #if FFETARGET_okCOMPLEX2
1845                 case FFEINFO_kindtypeREAL2:
1846                   error = ffetarget_convert_real2_complex2
1847                     (ffebld_cu_ptr_real2 (u),
1848                      ffebld_constant_complex2 (ffebld_conter (l)));
1849                   break;
1850 #endif
1851
1852 #if FFETARGET_okCOMPLEX3
1853                 case FFEINFO_kindtypeREAL3:
1854                   error = ffetarget_convert_real2_complex3
1855                     (ffebld_cu_ptr_real2 (u),
1856                      ffebld_constant_complex3 (ffebld_conter (l)));
1857                   break;
1858 #endif
1859
1860                 default:
1861                   assert ("REAL2/COMPLEX bad source kind type" == NULL);
1862                   break;
1863                 }
1864               break;
1865
1866             case FFEINFO_basictypeCHARACTER:
1867               error = ffetarget_convert_real2_character1
1868                 (ffebld_cu_ptr_real2 (u),
1869                  ffebld_constant_character1 (ffebld_conter (l)));
1870               break;
1871
1872             case FFEINFO_basictypeHOLLERITH:
1873               error = ffetarget_convert_real2_hollerith
1874                 (ffebld_cu_ptr_real2 (u),
1875                  ffebld_constant_hollerith (ffebld_conter (l)));
1876               break;
1877
1878             case FFEINFO_basictypeTYPELESS:
1879               error = ffetarget_convert_real2_typeless
1880                 (ffebld_cu_ptr_real2 (u),
1881                  ffebld_constant_typeless (ffebld_conter (l)));
1882               break;
1883
1884             default:
1885               assert ("REAL2 bad type" == NULL);
1886               break;
1887             }
1888
1889           /* If conversion operation is not implemented, return original expr.  */
1890           if (error == FFEBAD_NOCANDO)
1891             return expr;
1892
1893           expr = ffebld_new_conter_with_orig
1894             (ffebld_constant_new_real2_val
1895              (ffebld_cu_val_real2 (u)), expr);
1896           break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900         case FFEINFO_kindtypeREAL3:
1901           switch (ffeinfo_basictype (ffebld_info (l)))
1902             {
1903             case FFEINFO_basictypeINTEGER:
1904               switch (ffeinfo_kindtype (ffebld_info (l)))
1905                 {
1906 #if FFETARGET_okINTEGER1
1907                 case FFEINFO_kindtypeINTEGER1:
1908                   error = ffetarget_convert_real3_integer1
1909                     (ffebld_cu_ptr_real3 (u),
1910                      ffebld_constant_integer1 (ffebld_conter (l)));
1911                   break;
1912 #endif
1913
1914 #if FFETARGET_okINTEGER2
1915                 case FFEINFO_kindtypeINTEGER2:
1916                   error = ffetarget_convert_real3_integer2
1917                     (ffebld_cu_ptr_real3 (u),
1918                      ffebld_constant_integer2 (ffebld_conter (l)));
1919                   break;
1920 #endif
1921
1922 #if FFETARGET_okINTEGER3
1923                 case FFEINFO_kindtypeINTEGER3:
1924                   error = ffetarget_convert_real3_integer3
1925                     (ffebld_cu_ptr_real3 (u),
1926                      ffebld_constant_integer3 (ffebld_conter (l)));
1927                   break;
1928 #endif
1929
1930 #if FFETARGET_okINTEGER4
1931                 case FFEINFO_kindtypeINTEGER4:
1932                   error = ffetarget_convert_real3_integer4
1933                     (ffebld_cu_ptr_real3 (u),
1934                      ffebld_constant_integer4 (ffebld_conter (l)));
1935                   break;
1936 #endif
1937
1938                 default:
1939                   assert ("REAL3/INTEGER bad source kind type" == NULL);
1940                   break;
1941                 }
1942               break;
1943
1944             case FFEINFO_basictypeREAL:
1945               switch (ffeinfo_kindtype (ffebld_info (l)))
1946                 {
1947 #if FFETARGET_okREAL1
1948                 case FFEINFO_kindtypeREAL1:
1949                   error = ffetarget_convert_real3_real1
1950                     (ffebld_cu_ptr_real3 (u),
1951                      ffebld_constant_real1 (ffebld_conter (l)));
1952                   break;
1953 #endif
1954
1955 #if FFETARGET_okREAL2
1956                 case FFEINFO_kindtypeREAL2:
1957                   error = ffetarget_convert_real3_real2
1958                     (ffebld_cu_ptr_real3 (u),
1959                      ffebld_constant_real2 (ffebld_conter (l)));
1960                   break;
1961 #endif
1962
1963                 default:
1964                   assert ("REAL3/REAL bad source kind type" == NULL);
1965                   break;
1966                 }
1967               break;
1968
1969             case FFEINFO_basictypeCOMPLEX:
1970               switch (ffeinfo_kindtype (ffebld_info (l)))
1971                 {
1972 #if FFETARGET_okCOMPLEX1
1973                 case FFEINFO_kindtypeREAL1:
1974                   error = ffetarget_convert_real3_complex1
1975                     (ffebld_cu_ptr_real3 (u),
1976                      ffebld_constant_complex1 (ffebld_conter (l)));
1977                   break;
1978 #endif
1979
1980 #if FFETARGET_okCOMPLEX2
1981                 case FFEINFO_kindtypeREAL2:
1982                   error = ffetarget_convert_real3_complex2
1983                     (ffebld_cu_ptr_real3 (u),
1984                      ffebld_constant_complex2 (ffebld_conter (l)));
1985                   break;
1986 #endif
1987
1988 #if FFETARGET_okCOMPLEX3
1989                 case FFEINFO_kindtypeREAL3:
1990                   error = ffetarget_convert_real3_complex3
1991                     (ffebld_cu_ptr_real3 (u),
1992                      ffebld_constant_complex3 (ffebld_conter (l)));
1993                   break;
1994 #endif
1995
1996                 default:
1997                   assert ("REAL3/COMPLEX bad source kind type" == NULL);
1998                   break;
1999                 }
2000               break;
2001
2002             case FFEINFO_basictypeCHARACTER:
2003               error = ffetarget_convert_real3_character1
2004                 (ffebld_cu_ptr_real3 (u),
2005                  ffebld_constant_character1 (ffebld_conter (l)));
2006               break;
2007
2008             case FFEINFO_basictypeHOLLERITH:
2009               error = ffetarget_convert_real3_hollerith
2010                 (ffebld_cu_ptr_real3 (u),
2011                  ffebld_constant_hollerith (ffebld_conter (l)));
2012               break;
2013
2014             case FFEINFO_basictypeTYPELESS:
2015               error = ffetarget_convert_real3_typeless
2016                 (ffebld_cu_ptr_real3 (u),
2017                  ffebld_constant_typeless (ffebld_conter (l)));
2018               break;
2019
2020             default:
2021               assert ("REAL3 bad type" == NULL);
2022               break;
2023             }
2024
2025           /* If conversion operation is not implemented, return original expr.  */
2026           if (error == FFEBAD_NOCANDO)
2027             return expr;
2028
2029           expr = ffebld_new_conter_with_orig
2030             (ffebld_constant_new_real3_val
2031              (ffebld_cu_val_real3 (u)), expr);
2032           break;
2033 #endif
2034
2035         default:
2036           assert ("bad real kind type" == NULL);
2037           break;
2038         }
2039       break;
2040
2041     case FFEINFO_basictypeCOMPLEX:
2042       sz = FFETARGET_charactersizeNONE;
2043       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2044         {
2045 #if FFETARGET_okCOMPLEX1
2046         case FFEINFO_kindtypeREAL1:
2047           switch (ffeinfo_basictype (ffebld_info (l)))
2048             {
2049             case FFEINFO_basictypeINTEGER:
2050               switch (ffeinfo_kindtype (ffebld_info (l)))
2051                 {
2052 #if FFETARGET_okINTEGER1
2053                 case FFEINFO_kindtypeINTEGER1:
2054                   error = ffetarget_convert_complex1_integer1
2055                     (ffebld_cu_ptr_complex1 (u),
2056                      ffebld_constant_integer1 (ffebld_conter (l)));
2057                   break;
2058 #endif
2059
2060 #if FFETARGET_okINTEGER2
2061                 case FFEINFO_kindtypeINTEGER2:
2062                   error = ffetarget_convert_complex1_integer2
2063                     (ffebld_cu_ptr_complex1 (u),
2064                      ffebld_constant_integer2 (ffebld_conter (l)));
2065                   break;
2066 #endif
2067
2068 #if FFETARGET_okINTEGER3
2069                 case FFEINFO_kindtypeINTEGER3:
2070                   error = ffetarget_convert_complex1_integer3
2071                     (ffebld_cu_ptr_complex1 (u),
2072                      ffebld_constant_integer3 (ffebld_conter (l)));
2073                   break;
2074 #endif
2075
2076 #if FFETARGET_okINTEGER4
2077                 case FFEINFO_kindtypeINTEGER4:
2078                   error = ffetarget_convert_complex1_integer4
2079                     (ffebld_cu_ptr_complex1 (u),
2080                      ffebld_constant_integer4 (ffebld_conter (l)));
2081                   break;
2082 #endif
2083
2084                 default:
2085                   assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2086                   break;
2087                 }
2088               break;
2089
2090             case FFEINFO_basictypeREAL:
2091               switch (ffeinfo_kindtype (ffebld_info (l)))
2092                 {
2093 #if FFETARGET_okREAL1
2094                 case FFEINFO_kindtypeREAL1:
2095                   error = ffetarget_convert_complex1_real1
2096                     (ffebld_cu_ptr_complex1 (u),
2097                      ffebld_constant_real1 (ffebld_conter (l)));
2098                   break;
2099 #endif
2100
2101 #if FFETARGET_okREAL2
2102                 case FFEINFO_kindtypeREAL2:
2103                   error = ffetarget_convert_complex1_real2
2104                     (ffebld_cu_ptr_complex1 (u),
2105                      ffebld_constant_real2 (ffebld_conter (l)));
2106                   break;
2107 #endif
2108
2109 #if FFETARGET_okREAL3
2110                 case FFEINFO_kindtypeREAL3:
2111                   error = ffetarget_convert_complex1_real3
2112                     (ffebld_cu_ptr_complex1 (u),
2113                      ffebld_constant_real3 (ffebld_conter (l)));
2114                   break;
2115 #endif
2116
2117                 default:
2118                   assert ("COMPLEX1/REAL bad source kind type" == NULL);
2119                   break;
2120                 }
2121               break;
2122
2123             case FFEINFO_basictypeCOMPLEX:
2124               switch (ffeinfo_kindtype (ffebld_info (l)))
2125                 {
2126 #if FFETARGET_okCOMPLEX2
2127                 case FFEINFO_kindtypeREAL2:
2128                   error = ffetarget_convert_complex1_complex2
2129                     (ffebld_cu_ptr_complex1 (u),
2130                      ffebld_constant_complex2 (ffebld_conter (l)));
2131                   break;
2132 #endif
2133
2134 #if FFETARGET_okCOMPLEX3
2135                 case FFEINFO_kindtypeREAL3:
2136                   error = ffetarget_convert_complex1_complex3
2137                     (ffebld_cu_ptr_complex1 (u),
2138                      ffebld_constant_complex3 (ffebld_conter (l)));
2139                   break;
2140 #endif
2141
2142                 default:
2143                   assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2144                   break;
2145                 }
2146               break;
2147
2148             case FFEINFO_basictypeCHARACTER:
2149               error = ffetarget_convert_complex1_character1
2150                 (ffebld_cu_ptr_complex1 (u),
2151                  ffebld_constant_character1 (ffebld_conter (l)));
2152               break;
2153
2154             case FFEINFO_basictypeHOLLERITH:
2155               error = ffetarget_convert_complex1_hollerith
2156                 (ffebld_cu_ptr_complex1 (u),
2157                  ffebld_constant_hollerith (ffebld_conter (l)));
2158               break;
2159
2160             case FFEINFO_basictypeTYPELESS:
2161               error = ffetarget_convert_complex1_typeless
2162                 (ffebld_cu_ptr_complex1 (u),
2163                  ffebld_constant_typeless (ffebld_conter (l)));
2164               break;
2165
2166             default:
2167               assert ("COMPLEX1 bad type" == NULL);
2168               break;
2169             }
2170
2171           /* If conversion operation is not implemented, return original expr.  */
2172           if (error == FFEBAD_NOCANDO)
2173             return expr;
2174
2175           expr = ffebld_new_conter_with_orig
2176             (ffebld_constant_new_complex1_val
2177              (ffebld_cu_val_complex1 (u)), expr);
2178           break;
2179 #endif
2180
2181 #if FFETARGET_okCOMPLEX2
2182         case FFEINFO_kindtypeREAL2:
2183           switch (ffeinfo_basictype (ffebld_info (l)))
2184             {
2185             case FFEINFO_basictypeINTEGER:
2186               switch (ffeinfo_kindtype (ffebld_info (l)))
2187                 {
2188 #if FFETARGET_okINTEGER1
2189                 case FFEINFO_kindtypeINTEGER1:
2190                   error = ffetarget_convert_complex2_integer1
2191                     (ffebld_cu_ptr_complex2 (u),
2192                      ffebld_constant_integer1 (ffebld_conter (l)));
2193                   break;
2194 #endif
2195
2196 #if FFETARGET_okINTEGER2
2197                 case FFEINFO_kindtypeINTEGER2:
2198                   error = ffetarget_convert_complex2_integer2
2199                     (ffebld_cu_ptr_complex2 (u),
2200                      ffebld_constant_integer2 (ffebld_conter (l)));
2201                   break;
2202 #endif
2203
2204 #if FFETARGET_okINTEGER3
2205                 case FFEINFO_kindtypeINTEGER3:
2206                   error = ffetarget_convert_complex2_integer3
2207                     (ffebld_cu_ptr_complex2 (u),
2208                      ffebld_constant_integer3 (ffebld_conter (l)));
2209                   break;
2210 #endif
2211
2212 #if FFETARGET_okINTEGER4
2213                 case FFEINFO_kindtypeINTEGER4:
2214                   error = ffetarget_convert_complex2_integer4
2215                     (ffebld_cu_ptr_complex2 (u),
2216                      ffebld_constant_integer4 (ffebld_conter (l)));
2217                   break;
2218 #endif
2219
2220                 default:
2221                   assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2222                   break;
2223                 }
2224               break;
2225
2226             case FFEINFO_basictypeREAL:
2227               switch (ffeinfo_kindtype (ffebld_info (l)))
2228                 {
2229 #if FFETARGET_okREAL1
2230                 case FFEINFO_kindtypeREAL1:
2231                   error = ffetarget_convert_complex2_real1
2232                     (ffebld_cu_ptr_complex2 (u),
2233                      ffebld_constant_real1 (ffebld_conter (l)));
2234                   break;
2235 #endif
2236
2237 #if FFETARGET_okREAL2
2238                 case FFEINFO_kindtypeREAL2:
2239                   error = ffetarget_convert_complex2_real2
2240                     (ffebld_cu_ptr_complex2 (u),
2241                      ffebld_constant_real2 (ffebld_conter (l)));
2242                   break;
2243 #endif
2244
2245 #if FFETARGET_okREAL3
2246                 case FFEINFO_kindtypeREAL3:
2247                   error = ffetarget_convert_complex2_real3
2248                     (ffebld_cu_ptr_complex2 (u),
2249                      ffebld_constant_real3 (ffebld_conter (l)));
2250                   break;
2251 #endif
2252
2253                 default:
2254                   assert ("COMPLEX2/REAL bad source kind type" == NULL);
2255                   break;
2256                 }
2257               break;
2258
2259             case FFEINFO_basictypeCOMPLEX:
2260               switch (ffeinfo_kindtype (ffebld_info (l)))
2261                 {
2262 #if FFETARGET_okCOMPLEX1
2263                 case FFEINFO_kindtypeREAL1:
2264                   error = ffetarget_convert_complex2_complex1
2265                     (ffebld_cu_ptr_complex2 (u),
2266                      ffebld_constant_complex1 (ffebld_conter (l)));
2267                   break;
2268 #endif
2269
2270 #if FFETARGET_okCOMPLEX3
2271                 case FFEINFO_kindtypeREAL3:
2272                   error = ffetarget_convert_complex2_complex3
2273                     (ffebld_cu_ptr_complex2 (u),
2274                      ffebld_constant_complex3 (ffebld_conter (l)));
2275                   break;
2276 #endif
2277
2278                 default:
2279                   assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2280                   break;
2281                 }
2282               break;
2283
2284             case FFEINFO_basictypeCHARACTER:
2285               error = ffetarget_convert_complex2_character1
2286                 (ffebld_cu_ptr_complex2 (u),
2287                  ffebld_constant_character1 (ffebld_conter (l)));
2288               break;
2289
2290             case FFEINFO_basictypeHOLLERITH:
2291               error = ffetarget_convert_complex2_hollerith
2292                 (ffebld_cu_ptr_complex2 (u),
2293                  ffebld_constant_hollerith (ffebld_conter (l)));
2294               break;
2295
2296             case FFEINFO_basictypeTYPELESS:
2297               error = ffetarget_convert_complex2_typeless
2298                 (ffebld_cu_ptr_complex2 (u),
2299                  ffebld_constant_typeless (ffebld_conter (l)));
2300               break;
2301
2302             default:
2303               assert ("COMPLEX2 bad type" == NULL);
2304               break;
2305             }
2306
2307           /* If conversion operation is not implemented, return original expr.  */
2308           if (error == FFEBAD_NOCANDO)
2309             return expr;
2310
2311           expr = ffebld_new_conter_with_orig
2312             (ffebld_constant_new_complex2_val
2313              (ffebld_cu_val_complex2 (u)), expr);
2314           break;
2315 #endif
2316
2317 #if FFETARGET_okCOMPLEX3
2318         case FFEINFO_kindtypeREAL3:
2319           switch (ffeinfo_basictype (ffebld_info (l)))
2320             {
2321             case FFEINFO_basictypeINTEGER:
2322               switch (ffeinfo_kindtype (ffebld_info (l)))
2323                 {
2324 #if FFETARGET_okINTEGER1
2325                 case FFEINFO_kindtypeINTEGER1:
2326                   error = ffetarget_convert_complex3_integer1
2327                     (ffebld_cu_ptr_complex3 (u),
2328                      ffebld_constant_integer1 (ffebld_conter (l)));
2329                   break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER2
2333                 case FFEINFO_kindtypeINTEGER2:
2334                   error = ffetarget_convert_complex3_integer2
2335                     (ffebld_cu_ptr_complex3 (u),
2336                      ffebld_constant_integer2 (ffebld_conter (l)));
2337                   break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER3
2341                 case FFEINFO_kindtypeINTEGER3:
2342                   error = ffetarget_convert_complex3_integer3
2343                     (ffebld_cu_ptr_complex3 (u),
2344                      ffebld_constant_integer3 (ffebld_conter (l)));
2345                   break;
2346 #endif
2347
2348 #if FFETARGET_okINTEGER4
2349                 case FFEINFO_kindtypeINTEGER4:
2350                   error = ffetarget_convert_complex3_integer4
2351                     (ffebld_cu_ptr_complex3 (u),
2352                      ffebld_constant_integer4 (ffebld_conter (l)));
2353                   break;
2354 #endif
2355
2356                 default:
2357                   assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2358                   break;
2359                 }
2360               break;
2361
2362             case FFEINFO_basictypeREAL:
2363               switch (ffeinfo_kindtype (ffebld_info (l)))
2364                 {
2365 #if FFETARGET_okREAL1
2366                 case FFEINFO_kindtypeREAL1:
2367                   error = ffetarget_convert_complex3_real1
2368                     (ffebld_cu_ptr_complex3 (u),
2369                      ffebld_constant_real1 (ffebld_conter (l)));
2370                   break;
2371 #endif
2372
2373 #if FFETARGET_okREAL2
2374                 case FFEINFO_kindtypeREAL2:
2375                   error = ffetarget_convert_complex3_real2
2376                     (ffebld_cu_ptr_complex3 (u),
2377                      ffebld_constant_real2 (ffebld_conter (l)));
2378                   break;
2379 #endif
2380
2381 #if FFETARGET_okREAL3
2382                 case FFEINFO_kindtypeREAL3:
2383                   error = ffetarget_convert_complex3_real3
2384                     (ffebld_cu_ptr_complex3 (u),
2385                      ffebld_constant_real3 (ffebld_conter (l)));
2386                   break;
2387 #endif
2388
2389                 default:
2390                   assert ("COMPLEX3/REAL bad source kind type" == NULL);
2391                   break;
2392                 }
2393               break;
2394
2395             case FFEINFO_basictypeCOMPLEX:
2396               switch (ffeinfo_kindtype (ffebld_info (l)))
2397                 {
2398 #if FFETARGET_okCOMPLEX1
2399                 case FFEINFO_kindtypeREAL1:
2400                   error = ffetarget_convert_complex3_complex1
2401                     (ffebld_cu_ptr_complex3 (u),
2402                      ffebld_constant_complex1 (ffebld_conter (l)));
2403                   break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX2
2407                 case FFEINFO_kindtypeREAL2:
2408                   error = ffetarget_convert_complex3_complex2
2409                     (ffebld_cu_ptr_complex3 (u),
2410                      ffebld_constant_complex2 (ffebld_conter (l)));
2411                   break;
2412 #endif
2413
2414                 default:
2415                   assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2416                   break;
2417                 }
2418               break;
2419
2420             case FFEINFO_basictypeCHARACTER:
2421               error = ffetarget_convert_complex3_character1
2422                 (ffebld_cu_ptr_complex3 (u),
2423                  ffebld_constant_character1 (ffebld_conter (l)));
2424               break;
2425
2426             case FFEINFO_basictypeHOLLERITH:
2427               error = ffetarget_convert_complex3_hollerith
2428                 (ffebld_cu_ptr_complex3 (u),
2429                  ffebld_constant_hollerith (ffebld_conter (l)));
2430               break;
2431
2432             case FFEINFO_basictypeTYPELESS:
2433               error = ffetarget_convert_complex3_typeless
2434                 (ffebld_cu_ptr_complex3 (u),
2435                  ffebld_constant_typeless (ffebld_conter (l)));
2436               break;
2437
2438             default:
2439               assert ("COMPLEX3 bad type" == NULL);
2440               break;
2441             }
2442
2443           /* If conversion operation is not implemented, return original expr.  */
2444           if (error == FFEBAD_NOCANDO)
2445             return expr;
2446
2447           expr = ffebld_new_conter_with_orig
2448             (ffebld_constant_new_complex3_val
2449              (ffebld_cu_val_complex3 (u)), expr);
2450           break;
2451 #endif
2452
2453         default:
2454           assert ("bad complex kind type" == NULL);
2455           break;
2456         }
2457       break;
2458
2459     case FFEINFO_basictypeCHARACTER:
2460       if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2461         return expr;
2462       kt = ffeinfo_kindtype (ffebld_info (expr));
2463       switch (kt)
2464         {
2465 #if FFETARGET_okCHARACTER1
2466         case FFEINFO_kindtypeCHARACTER1:
2467           switch (ffeinfo_basictype (ffebld_info (l)))
2468             {
2469             case FFEINFO_basictypeCHARACTER:
2470               if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2471                 return expr;
2472               assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2473               assert (sz2 == ffetarget_length_character1
2474                       (ffebld_constant_character1
2475                        (ffebld_conter (l))));
2476               error
2477                 = ffetarget_convert_character1_character1
2478                 (ffebld_cu_ptr_character1 (u), sz,
2479                  ffebld_constant_character1 (ffebld_conter (l)),
2480                  ffebld_constant_pool ());
2481               break;
2482
2483             case FFEINFO_basictypeINTEGER:
2484               switch (ffeinfo_kindtype (ffebld_info (l)))
2485                 {
2486 #if FFETARGET_okINTEGER1
2487                 case FFEINFO_kindtypeINTEGER1:
2488                   error
2489                     = ffetarget_convert_character1_integer1
2490                       (ffebld_cu_ptr_character1 (u),
2491                        sz,
2492                        ffebld_constant_integer1 (ffebld_conter (l)),
2493                        ffebld_constant_pool ());
2494                   break;
2495 #endif
2496
2497 #if FFETARGET_okINTEGER2
2498                 case FFEINFO_kindtypeINTEGER2:
2499                   error
2500                     = ffetarget_convert_character1_integer2
2501                       (ffebld_cu_ptr_character1 (u),
2502                        sz,
2503                        ffebld_constant_integer2 (ffebld_conter (l)),
2504                        ffebld_constant_pool ());
2505                   break;
2506 #endif
2507
2508 #if FFETARGET_okINTEGER3
2509                 case FFEINFO_kindtypeINTEGER3:
2510                   error
2511                     = ffetarget_convert_character1_integer3
2512                       (ffebld_cu_ptr_character1 (u),
2513                        sz,
2514                        ffebld_constant_integer3 (ffebld_conter (l)),
2515                        ffebld_constant_pool ());
2516                   break;
2517 #endif
2518
2519 #if FFETARGET_okINTEGER4
2520                 case FFEINFO_kindtypeINTEGER4:
2521                   error
2522                     = ffetarget_convert_character1_integer4
2523                       (ffebld_cu_ptr_character1 (u),
2524                        sz,
2525                        ffebld_constant_integer4 (ffebld_conter (l)),
2526                        ffebld_constant_pool ());
2527                   break;
2528 #endif
2529
2530                 default:
2531                   assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2532                   break;
2533                 }
2534               break;
2535
2536             case FFEINFO_basictypeLOGICAL:
2537               switch (ffeinfo_kindtype (ffebld_info (l)))
2538                 {
2539 #if FFETARGET_okLOGICAL1
2540                 case FFEINFO_kindtypeLOGICAL1:
2541                   error
2542                     = ffetarget_convert_character1_logical1
2543                       (ffebld_cu_ptr_character1 (u),
2544                        sz,
2545                        ffebld_constant_logical1 (ffebld_conter (l)),
2546                        ffebld_constant_pool ());
2547                   break;
2548 #endif
2549
2550 #if FFETARGET_okLOGICAL2
2551                 case FFEINFO_kindtypeLOGICAL2:
2552                   error
2553                     = ffetarget_convert_character1_logical2
2554                       (ffebld_cu_ptr_character1 (u),
2555                        sz,
2556                        ffebld_constant_logical2 (ffebld_conter (l)),
2557                        ffebld_constant_pool ());
2558                   break;
2559 #endif
2560
2561 #if FFETARGET_okLOGICAL3
2562                 case FFEINFO_kindtypeLOGICAL3:
2563                   error
2564                     = ffetarget_convert_character1_logical3
2565                       (ffebld_cu_ptr_character1 (u),
2566                        sz,
2567                        ffebld_constant_logical3 (ffebld_conter (l)),
2568                        ffebld_constant_pool ());
2569                   break;
2570 #endif
2571
2572 #if FFETARGET_okLOGICAL4
2573                 case FFEINFO_kindtypeLOGICAL4:
2574                   error
2575                     = ffetarget_convert_character1_logical4
2576                       (ffebld_cu_ptr_character1 (u),
2577                        sz,
2578                        ffebld_constant_logical4 (ffebld_conter (l)),
2579                        ffebld_constant_pool ());
2580                   break;
2581 #endif
2582
2583                 default:
2584                   assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2585                   break;
2586                 }
2587               break;
2588
2589             case FFEINFO_basictypeHOLLERITH:
2590               error
2591                 = ffetarget_convert_character1_hollerith
2592                 (ffebld_cu_ptr_character1 (u),
2593                  sz,
2594                  ffebld_constant_hollerith (ffebld_conter (l)),
2595                  ffebld_constant_pool ());
2596               break;
2597
2598             case FFEINFO_basictypeTYPELESS:
2599               error
2600                 = ffetarget_convert_character1_typeless
2601                 (ffebld_cu_ptr_character1 (u),
2602                  sz,
2603                  ffebld_constant_typeless (ffebld_conter (l)),
2604                  ffebld_constant_pool ());
2605               break;
2606
2607             default:
2608               assert ("CHARACTER1 bad type" == NULL);
2609             }
2610
2611           expr
2612             = ffebld_new_conter_with_orig
2613             (ffebld_constant_new_character1_val
2614              (ffebld_cu_val_character1 (u)),
2615              expr);
2616           break;
2617 #endif
2618
2619         default:
2620           assert ("bad character kind type" == NULL);
2621           break;
2622         }
2623       break;
2624
2625     default:
2626       assert ("bad type" == NULL);
2627       return expr;
2628     }
2629
2630   ffebld_set_info (expr, ffeinfo_new
2631                    (bt,
2632                     kt,
2633                     0,
2634                     FFEINFO_kindENTITY,
2635                     FFEINFO_whereCONSTANT,
2636                     sz));
2637
2638   if ((error != FFEBAD)
2639       && ffebad_start (error))
2640     {
2641       assert (t != NULL);
2642       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2643       ffebad_finish ();
2644     }
2645
2646   return expr;
2647 }
2648
2649 /* ffeexpr_collapse_paren -- Collapse paren expr
2650
2651    ffebld expr;
2652    ffelexToken token;
2653    expr = ffeexpr_collapse_paren(expr,token);
2654
2655    If the result of the expr is a constant, replaces the expr with the
2656    computed constant.  */
2657
2658 ffebld
2659 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2660 {
2661   ffebld r;
2662   ffeinfoBasictype bt;
2663   ffeinfoKindtype kt;
2664   ffetargetCharacterSize len;
2665
2666   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2667     return expr;
2668
2669   r = ffebld_left (expr);
2670
2671   if (ffebld_op (r) != FFEBLD_opCONTER)
2672     return expr;
2673
2674   bt = ffeinfo_basictype (ffebld_info (r));
2675   kt = ffeinfo_kindtype (ffebld_info (r));
2676   len = ffebld_size (r);
2677
2678   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2679                                       expr);
2680
2681   ffebld_set_info (expr, ffeinfo_new
2682                    (bt,
2683                     kt,
2684                     0,
2685                     FFEINFO_kindENTITY,
2686                     FFEINFO_whereCONSTANT,
2687                     len));
2688
2689   return expr;
2690 }
2691
2692 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2693
2694    ffebld expr;
2695    ffelexToken token;
2696    expr = ffeexpr_collapse_uplus(expr,token);
2697
2698    If the result of the expr is a constant, replaces the expr with the
2699    computed constant.  */
2700
2701 ffebld
2702 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2703 {
2704   ffebld r;
2705   ffeinfoBasictype bt;
2706   ffeinfoKindtype kt;
2707   ffetargetCharacterSize len;
2708
2709   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2710     return expr;
2711
2712   r = ffebld_left (expr);
2713
2714   if (ffebld_op (r) != FFEBLD_opCONTER)
2715     return expr;
2716
2717   bt = ffeinfo_basictype (ffebld_info (r));
2718   kt = ffeinfo_kindtype (ffebld_info (r));
2719   len = ffebld_size (r);
2720
2721   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2722                                       expr);
2723
2724   ffebld_set_info (expr, ffeinfo_new
2725                    (bt,
2726                     kt,
2727                     0,
2728                     FFEINFO_kindENTITY,
2729                     FFEINFO_whereCONSTANT,
2730                     len));
2731
2732   return expr;
2733 }
2734
2735 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2736
2737    ffebld expr;
2738    ffelexToken token;
2739    expr = ffeexpr_collapse_uminus(expr,token);
2740
2741    If the result of the expr is a constant, replaces the expr with the
2742    computed constant.  */
2743
2744 ffebld
2745 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2746 {
2747   ffebad error = FFEBAD;
2748   ffebld r;
2749   ffebldConstantUnion u;
2750   ffeinfoBasictype bt;
2751   ffeinfoKindtype kt;
2752
2753   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2754     return expr;
2755
2756   r = ffebld_left (expr);
2757
2758   if (ffebld_op (r) != FFEBLD_opCONTER)
2759     return expr;
2760
2761   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2762     {
2763     case FFEINFO_basictypeANY:
2764       return expr;
2765
2766     case FFEINFO_basictypeINTEGER:
2767       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2768         {
2769 #if FFETARGET_okINTEGER1
2770         case FFEINFO_kindtypeINTEGER1:
2771           error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2772                               ffebld_constant_integer1 (ffebld_conter (r)));
2773           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2774                                         (ffebld_cu_val_integer1 (u)), expr);
2775           break;
2776 #endif
2777
2778 #if FFETARGET_okINTEGER2
2779         case FFEINFO_kindtypeINTEGER2:
2780           error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2781                               ffebld_constant_integer2 (ffebld_conter (r)));
2782           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2783                                         (ffebld_cu_val_integer2 (u)), expr);
2784           break;
2785 #endif
2786
2787 #if FFETARGET_okINTEGER3
2788         case FFEINFO_kindtypeINTEGER3:
2789           error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2790                               ffebld_constant_integer3 (ffebld_conter (r)));
2791           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2792                                         (ffebld_cu_val_integer3 (u)), expr);
2793           break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797         case FFEINFO_kindtypeINTEGER4:
2798           error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2799                               ffebld_constant_integer4 (ffebld_conter (r)));
2800           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2801                                         (ffebld_cu_val_integer4 (u)), expr);
2802           break;
2803 #endif
2804
2805         default:
2806           assert ("bad integer kind type" == NULL);
2807           break;
2808         }
2809       break;
2810
2811     case FFEINFO_basictypeREAL:
2812       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2813         {
2814 #if FFETARGET_okREAL1
2815         case FFEINFO_kindtypeREAL1:
2816           error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2817                                  ffebld_constant_real1 (ffebld_conter (r)));
2818           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2819                                            (ffebld_cu_val_real1 (u)), expr);
2820           break;
2821 #endif
2822
2823 #if FFETARGET_okREAL2
2824         case FFEINFO_kindtypeREAL2:
2825           error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2826                                  ffebld_constant_real2 (ffebld_conter (r)));
2827           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2828                                            (ffebld_cu_val_real2 (u)), expr);
2829           break;
2830 #endif
2831
2832 #if FFETARGET_okREAL3
2833         case FFEINFO_kindtypeREAL3:
2834           error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2835                                  ffebld_constant_real3 (ffebld_conter (r)));
2836           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2837                                            (ffebld_cu_val_real3 (u)), expr);
2838           break;
2839 #endif
2840
2841         default:
2842           assert ("bad real kind type" == NULL);
2843           break;
2844         }
2845       break;
2846
2847     case FFEINFO_basictypeCOMPLEX:
2848       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2849         {
2850 #if FFETARGET_okCOMPLEX1
2851         case FFEINFO_kindtypeREAL1:
2852           error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2853                               ffebld_constant_complex1 (ffebld_conter (r)));
2854           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2855                                         (ffebld_cu_val_complex1 (u)), expr);
2856           break;
2857 #endif
2858
2859 #if FFETARGET_okCOMPLEX2
2860         case FFEINFO_kindtypeREAL2:
2861           error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2862                               ffebld_constant_complex2 (ffebld_conter (r)));
2863           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2864                                         (ffebld_cu_val_complex2 (u)), expr);
2865           break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX3
2869         case FFEINFO_kindtypeREAL3:
2870           error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2871                               ffebld_constant_complex3 (ffebld_conter (r)));
2872           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2873                                         (ffebld_cu_val_complex3 (u)), expr);
2874           break;
2875 #endif
2876
2877         default:
2878           assert ("bad complex kind type" == NULL);
2879           break;
2880         }
2881       break;
2882
2883     default:
2884       assert ("bad type" == NULL);
2885       return expr;
2886     }
2887
2888   ffebld_set_info (expr, ffeinfo_new
2889                    (bt,
2890                     kt,
2891                     0,
2892                     FFEINFO_kindENTITY,
2893                     FFEINFO_whereCONSTANT,
2894                     FFETARGET_charactersizeNONE));
2895
2896   if ((error != FFEBAD)
2897       && ffebad_start (error))
2898     {
2899       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2900       ffebad_finish ();
2901     }
2902
2903   return expr;
2904 }
2905
2906 /* ffeexpr_collapse_not -- Collapse not expr
2907
2908    ffebld expr;
2909    ffelexToken token;
2910    expr = ffeexpr_collapse_not(expr,token);
2911
2912    If the result of the expr is a constant, replaces the expr with the
2913    computed constant.  */
2914
2915 ffebld
2916 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2917 {
2918   ffebad error = FFEBAD;
2919   ffebld r;
2920   ffebldConstantUnion u;
2921   ffeinfoBasictype bt;
2922   ffeinfoKindtype kt;
2923
2924   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2925     return expr;
2926
2927   r = ffebld_left (expr);
2928
2929   if (ffebld_op (r) != FFEBLD_opCONTER)
2930     return expr;
2931
2932   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2933     {
2934     case FFEINFO_basictypeANY:
2935       return expr;
2936
2937     case FFEINFO_basictypeINTEGER:
2938       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2939         {
2940 #if FFETARGET_okINTEGER1
2941         case FFEINFO_kindtypeINTEGER1:
2942           error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2943                               ffebld_constant_integer1 (ffebld_conter (r)));
2944           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2945                                         (ffebld_cu_val_integer1 (u)), expr);
2946           break;
2947 #endif
2948
2949 #if FFETARGET_okINTEGER2
2950         case FFEINFO_kindtypeINTEGER2:
2951           error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2952                               ffebld_constant_integer2 (ffebld_conter (r)));
2953           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2954                                         (ffebld_cu_val_integer2 (u)), expr);
2955           break;
2956 #endif
2957
2958 #if FFETARGET_okINTEGER3
2959         case FFEINFO_kindtypeINTEGER3:
2960           error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2961                               ffebld_constant_integer3 (ffebld_conter (r)));
2962           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2963                                         (ffebld_cu_val_integer3 (u)), expr);
2964           break;
2965 #endif
2966
2967 #if FFETARGET_okINTEGER4
2968         case FFEINFO_kindtypeINTEGER4:
2969           error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2970                               ffebld_constant_integer4 (ffebld_conter (r)));
2971           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2972                                         (ffebld_cu_val_integer4 (u)), expr);
2973           break;
2974 #endif
2975
2976         default:
2977           assert ("bad integer kind type" == NULL);
2978           break;
2979         }
2980       break;
2981
2982     case FFEINFO_basictypeLOGICAL:
2983       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2984         {
2985 #if FFETARGET_okLOGICAL1
2986         case FFEINFO_kindtypeLOGICAL1:
2987           error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2988                               ffebld_constant_logical1 (ffebld_conter (r)));
2989           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2990                                         (ffebld_cu_val_logical1 (u)), expr);
2991           break;
2992 #endif
2993
2994 #if FFETARGET_okLOGICAL2
2995         case FFEINFO_kindtypeLOGICAL2:
2996           error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2997                               ffebld_constant_logical2 (ffebld_conter (r)));
2998           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
2999                                         (ffebld_cu_val_logical2 (u)), expr);
3000           break;
3001 #endif
3002
3003 #if FFETARGET_okLOGICAL3
3004         case FFEINFO_kindtypeLOGICAL3:
3005           error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3006                               ffebld_constant_logical3 (ffebld_conter (r)));
3007           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3008                                         (ffebld_cu_val_logical3 (u)), expr);
3009           break;
3010 #endif
3011
3012 #if FFETARGET_okLOGICAL4
3013         case FFEINFO_kindtypeLOGICAL4:
3014           error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3015                               ffebld_constant_logical4 (ffebld_conter (r)));
3016           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3017                                         (ffebld_cu_val_logical4 (u)), expr);
3018           break;
3019 #endif
3020
3021         default:
3022           assert ("bad logical kind type" == NULL);
3023           break;
3024         }
3025       break;
3026
3027     default:
3028       assert ("bad type" == NULL);
3029       return expr;
3030     }
3031
3032   ffebld_set_info (expr, ffeinfo_new
3033                    (bt,
3034                     kt,
3035                     0,
3036                     FFEINFO_kindENTITY,
3037                     FFEINFO_whereCONSTANT,
3038                     FFETARGET_charactersizeNONE));
3039
3040   if ((error != FFEBAD)
3041       && ffebad_start (error))
3042     {
3043       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3044       ffebad_finish ();
3045     }
3046
3047   return expr;
3048 }
3049
3050 /* ffeexpr_collapse_add -- Collapse add expr
3051
3052    ffebld expr;
3053    ffelexToken token;
3054    expr = ffeexpr_collapse_add(expr,token);
3055
3056    If the result of the expr is a constant, replaces the expr with the
3057    computed constant.  */
3058
3059 ffebld
3060 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3061 {
3062   ffebad error = FFEBAD;
3063   ffebld l;
3064   ffebld r;
3065   ffebldConstantUnion u;
3066   ffeinfoBasictype bt;
3067   ffeinfoKindtype kt;
3068
3069   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3070     return expr;
3071
3072   l = ffebld_left (expr);
3073   r = ffebld_right (expr);
3074
3075   if (ffebld_op (l) != FFEBLD_opCONTER)
3076     return expr;
3077   if (ffebld_op (r) != FFEBLD_opCONTER)
3078     return expr;
3079
3080   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3081     {
3082     case FFEINFO_basictypeANY:
3083       return expr;
3084
3085     case FFEINFO_basictypeINTEGER:
3086       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3087         {
3088 #if FFETARGET_okINTEGER1
3089         case FFEINFO_kindtypeINTEGER1:
3090           error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3091                                ffebld_constant_integer1 (ffebld_conter (l)),
3092                               ffebld_constant_integer1 (ffebld_conter (r)));
3093           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3094                                         (ffebld_cu_val_integer1 (u)), expr);
3095           break;
3096 #endif
3097
3098 #if FFETARGET_okINTEGER2
3099         case FFEINFO_kindtypeINTEGER2:
3100           error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3101                                ffebld_constant_integer2 (ffebld_conter (l)),
3102                               ffebld_constant_integer2 (ffebld_conter (r)));
3103           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3104                                         (ffebld_cu_val_integer2 (u)), expr);
3105           break;
3106 #endif
3107
3108 #if FFETARGET_okINTEGER3
3109         case FFEINFO_kindtypeINTEGER3:
3110           error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3111                                ffebld_constant_integer3 (ffebld_conter (l)),
3112                               ffebld_constant_integer3 (ffebld_conter (r)));
3113           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3114                                         (ffebld_cu_val_integer3 (u)), expr);
3115           break;
3116 #endif
3117
3118 #if FFETARGET_okINTEGER4
3119         case FFEINFO_kindtypeINTEGER4:
3120           error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3121                                ffebld_constant_integer4 (ffebld_conter (l)),
3122                               ffebld_constant_integer4 (ffebld_conter (r)));
3123           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3124                                         (ffebld_cu_val_integer4 (u)), expr);
3125           break;
3126 #endif
3127
3128         default:
3129           assert ("bad integer kind type" == NULL);
3130           break;
3131         }
3132       break;
3133
3134     case FFEINFO_basictypeREAL:
3135       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3136         {
3137 #if FFETARGET_okREAL1
3138         case FFEINFO_kindtypeREAL1:
3139           error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3140                                   ffebld_constant_real1 (ffebld_conter (l)),
3141                                  ffebld_constant_real1 (ffebld_conter (r)));
3142           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3143                                            (ffebld_cu_val_real1 (u)), expr);
3144           break;
3145 #endif
3146
3147 #if FFETARGET_okREAL2
3148         case FFEINFO_kindtypeREAL2:
3149           error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3150                                   ffebld_constant_real2 (ffebld_conter (l)),
3151                                  ffebld_constant_real2 (ffebld_conter (r)));
3152           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3153                                            (ffebld_cu_val_real2 (u)), expr);
3154           break;
3155 #endif
3156
3157 #if FFETARGET_okREAL3
3158         case FFEINFO_kindtypeREAL3:
3159           error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3160                                   ffebld_constant_real3 (ffebld_conter (l)),
3161                                  ffebld_constant_real3 (ffebld_conter (r)));
3162           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3163                                            (ffebld_cu_val_real3 (u)), expr);
3164           break;
3165 #endif
3166
3167         default:
3168           assert ("bad real kind type" == NULL);
3169           break;
3170         }
3171       break;
3172
3173     case FFEINFO_basictypeCOMPLEX:
3174       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3175         {
3176 #if FFETARGET_okCOMPLEX1
3177         case FFEINFO_kindtypeREAL1:
3178           error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3179                                ffebld_constant_complex1 (ffebld_conter (l)),
3180                               ffebld_constant_complex1 (ffebld_conter (r)));
3181           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3182                                         (ffebld_cu_val_complex1 (u)), expr);
3183           break;
3184 #endif
3185
3186 #if FFETARGET_okCOMPLEX2
3187         case FFEINFO_kindtypeREAL2:
3188           error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3189                                ffebld_constant_complex2 (ffebld_conter (l)),
3190                               ffebld_constant_complex2 (ffebld_conter (r)));
3191           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3192                                         (ffebld_cu_val_complex2 (u)), expr);
3193           break;
3194 #endif
3195
3196 #if FFETARGET_okCOMPLEX3
3197         case FFEINFO_kindtypeREAL3:
3198           error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3199                                ffebld_constant_complex3 (ffebld_conter (l)),
3200                               ffebld_constant_complex3 (ffebld_conter (r)));
3201           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3202                                         (ffebld_cu_val_complex3 (u)), expr);
3203           break;
3204 #endif
3205
3206         default:
3207           assert ("bad complex kind type" == NULL);
3208           break;
3209         }
3210       break;
3211
3212     default:
3213       assert ("bad type" == NULL);
3214       return expr;
3215     }
3216
3217   ffebld_set_info (expr, ffeinfo_new
3218                    (bt,
3219                     kt,
3220                     0,
3221                     FFEINFO_kindENTITY,
3222                     FFEINFO_whereCONSTANT,
3223                     FFETARGET_charactersizeNONE));
3224
3225   if ((error != FFEBAD)
3226       && ffebad_start (error))
3227     {
3228       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3229       ffebad_finish ();
3230     }
3231
3232   return expr;
3233 }
3234
3235 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3236
3237    ffebld expr;
3238    ffelexToken token;
3239    expr = ffeexpr_collapse_subtract(expr,token);
3240
3241    If the result of the expr is a constant, replaces the expr with the
3242    computed constant.  */
3243
3244 ffebld
3245 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3246 {
3247   ffebad error = FFEBAD;
3248   ffebld l;
3249   ffebld r;
3250   ffebldConstantUnion u;
3251   ffeinfoBasictype bt;
3252   ffeinfoKindtype kt;
3253
3254   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3255     return expr;
3256
3257   l = ffebld_left (expr);
3258   r = ffebld_right (expr);
3259
3260   if (ffebld_op (l) != FFEBLD_opCONTER)
3261     return expr;
3262   if (ffebld_op (r) != FFEBLD_opCONTER)
3263     return expr;
3264
3265   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3266     {
3267     case FFEINFO_basictypeANY:
3268       return expr;
3269
3270     case FFEINFO_basictypeINTEGER:
3271       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3272         {
3273 #if FFETARGET_okINTEGER1
3274         case FFEINFO_kindtypeINTEGER1:
3275           error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3276                                ffebld_constant_integer1 (ffebld_conter (l)),
3277                               ffebld_constant_integer1 (ffebld_conter (r)));
3278           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3279                                         (ffebld_cu_val_integer1 (u)), expr);
3280           break;
3281 #endif
3282
3283 #if FFETARGET_okINTEGER2
3284         case FFEINFO_kindtypeINTEGER2:
3285           error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3286                                ffebld_constant_integer2 (ffebld_conter (l)),
3287                               ffebld_constant_integer2 (ffebld_conter (r)));
3288           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3289                                         (ffebld_cu_val_integer2 (u)), expr);
3290           break;
3291 #endif
3292
3293 #if FFETARGET_okINTEGER3
3294         case FFEINFO_kindtypeINTEGER3:
3295           error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3296                                ffebld_constant_integer3 (ffebld_conter (l)),
3297                               ffebld_constant_integer3 (ffebld_conter (r)));
3298           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3299                                         (ffebld_cu_val_integer3 (u)), expr);
3300           break;
3301 #endif
3302
3303 #if FFETARGET_okINTEGER4
3304         case FFEINFO_kindtypeINTEGER4:
3305           error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3306                                ffebld_constant_integer4 (ffebld_conter (l)),
3307                               ffebld_constant_integer4 (ffebld_conter (r)));
3308           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3309                                         (ffebld_cu_val_integer4 (u)), expr);
3310           break;
3311 #endif
3312
3313         default:
3314           assert ("bad integer kind type" == NULL);
3315           break;
3316         }
3317       break;
3318
3319     case FFEINFO_basictypeREAL:
3320       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3321         {
3322 #if FFETARGET_okREAL1
3323         case FFEINFO_kindtypeREAL1:
3324           error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3325                                   ffebld_constant_real1 (ffebld_conter (l)),
3326                                  ffebld_constant_real1 (ffebld_conter (r)));
3327           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3328                                            (ffebld_cu_val_real1 (u)), expr);
3329           break;
3330 #endif
3331
3332 #if FFETARGET_okREAL2
3333         case FFEINFO_kindtypeREAL2:
3334           error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3335                                   ffebld_constant_real2 (ffebld_conter (l)),
3336                                  ffebld_constant_real2 (ffebld_conter (r)));
3337           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3338                                            (ffebld_cu_val_real2 (u)), expr);
3339           break;
3340 #endif
3341
3342 #if FFETARGET_okREAL3
3343         case FFEINFO_kindtypeREAL3:
3344           error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3345                                   ffebld_constant_real3 (ffebld_conter (l)),
3346                                  ffebld_constant_real3 (ffebld_conter (r)));
3347           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3348                                            (ffebld_cu_val_real3 (u)), expr);
3349           break;
3350 #endif
3351
3352         default:
3353           assert ("bad real kind type" == NULL);
3354           break;
3355         }
3356       break;
3357
3358     case FFEINFO_basictypeCOMPLEX:
3359       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3360         {
3361 #if FFETARGET_okCOMPLEX1
3362         case FFEINFO_kindtypeREAL1:
3363           error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3364                                ffebld_constant_complex1 (ffebld_conter (l)),
3365                               ffebld_constant_complex1 (ffebld_conter (r)));
3366           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3367                                         (ffebld_cu_val_complex1 (u)), expr);
3368           break;
3369 #endif
3370
3371 #if FFETARGET_okCOMPLEX2
3372         case FFEINFO_kindtypeREAL2:
3373           error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3374                                ffebld_constant_complex2 (ffebld_conter (l)),
3375                               ffebld_constant_complex2 (ffebld_conter (r)));
3376           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3377                                         (ffebld_cu_val_complex2 (u)), expr);
3378           break;
3379 #endif
3380
3381 #if FFETARGET_okCOMPLEX3
3382         case FFEINFO_kindtypeREAL3:
3383           error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3384                                ffebld_constant_complex3 (ffebld_conter (l)),
3385                               ffebld_constant_complex3 (ffebld_conter (r)));
3386           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3387                                         (ffebld_cu_val_complex3 (u)), expr);
3388           break;
3389 #endif
3390
3391         default:
3392           assert ("bad complex kind type" == NULL);
3393           break;
3394         }
3395       break;
3396
3397     default:
3398       assert ("bad type" == NULL);
3399       return expr;
3400     }
3401
3402   ffebld_set_info (expr, ffeinfo_new
3403                    (bt,
3404                     kt,
3405                     0,
3406                     FFEINFO_kindENTITY,
3407                     FFEINFO_whereCONSTANT,
3408                     FFETARGET_charactersizeNONE));
3409
3410   if ((error != FFEBAD)
3411       && ffebad_start (error))
3412     {
3413       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3414       ffebad_finish ();
3415     }
3416
3417   return expr;
3418 }
3419
3420 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3421
3422    ffebld expr;
3423    ffelexToken token;
3424    expr = ffeexpr_collapse_multiply(expr,token);
3425
3426    If the result of the expr is a constant, replaces the expr with the
3427    computed constant.  */
3428
3429 ffebld
3430 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3431 {
3432   ffebad error = FFEBAD;
3433   ffebld l;
3434   ffebld r;
3435   ffebldConstantUnion u;
3436   ffeinfoBasictype bt;
3437   ffeinfoKindtype kt;
3438
3439   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3440     return expr;
3441
3442   l = ffebld_left (expr);
3443   r = ffebld_right (expr);
3444
3445   if (ffebld_op (l) != FFEBLD_opCONTER)
3446     return expr;
3447   if (ffebld_op (r) != FFEBLD_opCONTER)
3448     return expr;
3449
3450   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3451     {
3452     case FFEINFO_basictypeANY:
3453       return expr;
3454
3455     case FFEINFO_basictypeINTEGER:
3456       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3457         {
3458 #if FFETARGET_okINTEGER1
3459         case FFEINFO_kindtypeINTEGER1:
3460           error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3461                                ffebld_constant_integer1 (ffebld_conter (l)),
3462                               ffebld_constant_integer1 (ffebld_conter (r)));
3463           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3464                                         (ffebld_cu_val_integer1 (u)), expr);
3465           break;
3466 #endif
3467
3468 #if FFETARGET_okINTEGER2
3469         case FFEINFO_kindtypeINTEGER2:
3470           error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3471                                ffebld_constant_integer2 (ffebld_conter (l)),
3472                               ffebld_constant_integer2 (ffebld_conter (r)));
3473           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3474                                         (ffebld_cu_val_integer2 (u)), expr);
3475           break;
3476 #endif
3477
3478 #if FFETARGET_okINTEGER3
3479         case FFEINFO_kindtypeINTEGER3:
3480           error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3481                                ffebld_constant_integer3 (ffebld_conter (l)),
3482                               ffebld_constant_integer3 (ffebld_conter (r)));
3483           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3484                                         (ffebld_cu_val_integer3 (u)), expr);
3485           break;
3486 #endif
3487
3488 #if FFETARGET_okINTEGER4
3489         case FFEINFO_kindtypeINTEGER4:
3490           error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3491                                ffebld_constant_integer4 (ffebld_conter (l)),
3492                               ffebld_constant_integer4 (ffebld_conter (r)));
3493           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3494                                         (ffebld_cu_val_integer4 (u)), expr);
3495           break;
3496 #endif
3497
3498         default:
3499           assert ("bad integer kind type" == NULL);
3500           break;
3501         }
3502       break;
3503
3504     case FFEINFO_basictypeREAL:
3505       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3506         {
3507 #if FFETARGET_okREAL1
3508         case FFEINFO_kindtypeREAL1:
3509           error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3510                                   ffebld_constant_real1 (ffebld_conter (l)),
3511                                  ffebld_constant_real1 (ffebld_conter (r)));
3512           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3513                                            (ffebld_cu_val_real1 (u)), expr);
3514           break;
3515 #endif
3516
3517 #if FFETARGET_okREAL2
3518         case FFEINFO_kindtypeREAL2:
3519           error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3520                                   ffebld_constant_real2 (ffebld_conter (l)),
3521                                  ffebld_constant_real2 (ffebld_conter (r)));
3522           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3523                                            (ffebld_cu_val_real2 (u)), expr);
3524           break;
3525 #endif
3526
3527 #if FFETARGET_okREAL3
3528         case FFEINFO_kindtypeREAL3:
3529           error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3530                                   ffebld_constant_real3 (ffebld_conter (l)),
3531                                  ffebld_constant_real3 (ffebld_conter (r)));
3532           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3533                                            (ffebld_cu_val_real3 (u)), expr);
3534           break;
3535 #endif
3536
3537         default:
3538           assert ("bad real kind type" == NULL);
3539           break;
3540         }
3541       break;
3542
3543     case FFEINFO_basictypeCOMPLEX:
3544       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3545         {
3546 #if FFETARGET_okCOMPLEX1
3547         case FFEINFO_kindtypeREAL1:
3548           error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3549                                ffebld_constant_complex1 (ffebld_conter (l)),
3550                               ffebld_constant_complex1 (ffebld_conter (r)));
3551           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3552                                         (ffebld_cu_val_complex1 (u)), expr);
3553           break;
3554 #endif
3555
3556 #if FFETARGET_okCOMPLEX2
3557         case FFEINFO_kindtypeREAL2:
3558           error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3559                                ffebld_constant_complex2 (ffebld_conter (l)),
3560                               ffebld_constant_complex2 (ffebld_conter (r)));
3561           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3562                                         (ffebld_cu_val_complex2 (u)), expr);
3563           break;
3564 #endif
3565
3566 #if FFETARGET_okCOMPLEX3
3567         case FFEINFO_kindtypeREAL3:
3568           error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3569                                ffebld_constant_complex3 (ffebld_conter (l)),
3570                               ffebld_constant_complex3 (ffebld_conter (r)));
3571           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3572                                         (ffebld_cu_val_complex3 (u)), expr);
3573           break;
3574 #endif
3575
3576         default:
3577           assert ("bad complex kind type" == NULL);
3578           break;
3579         }
3580       break;
3581
3582     default:
3583       assert ("bad type" == NULL);
3584       return expr;
3585     }
3586
3587   ffebld_set_info (expr, ffeinfo_new
3588                    (bt,
3589                     kt,
3590                     0,
3591                     FFEINFO_kindENTITY,
3592                     FFEINFO_whereCONSTANT,
3593                     FFETARGET_charactersizeNONE));
3594
3595   if ((error != FFEBAD)
3596       && ffebad_start (error))
3597     {
3598       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3599       ffebad_finish ();
3600     }
3601
3602   return expr;
3603 }
3604
3605 /* ffeexpr_collapse_divide -- Collapse divide expr
3606
3607    ffebld expr;
3608    ffelexToken token;
3609    expr = ffeexpr_collapse_divide(expr,token);
3610
3611    If the result of the expr is a constant, replaces the expr with the
3612    computed constant.  */
3613
3614 ffebld
3615 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3616 {
3617   ffebad error = FFEBAD;
3618   ffebld l;
3619   ffebld r;
3620   ffebldConstantUnion u;
3621   ffeinfoBasictype bt;
3622   ffeinfoKindtype kt;
3623
3624   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3625     return expr;
3626
3627   l = ffebld_left (expr);
3628   r = ffebld_right (expr);
3629
3630   if (ffebld_op (l) != FFEBLD_opCONTER)
3631     return expr;
3632   if (ffebld_op (r) != FFEBLD_opCONTER)
3633     return expr;
3634
3635   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3636     {
3637     case FFEINFO_basictypeANY:
3638       return expr;
3639
3640     case FFEINFO_basictypeINTEGER:
3641       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3642         {
3643 #if FFETARGET_okINTEGER1
3644         case FFEINFO_kindtypeINTEGER1:
3645           error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3646                                ffebld_constant_integer1 (ffebld_conter (l)),
3647                               ffebld_constant_integer1 (ffebld_conter (r)));
3648           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3649                                         (ffebld_cu_val_integer1 (u)), expr);
3650           break;
3651 #endif
3652
3653 #if FFETARGET_okINTEGER2
3654         case FFEINFO_kindtypeINTEGER2:
3655           error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3656                                ffebld_constant_integer2 (ffebld_conter (l)),
3657                               ffebld_constant_integer2 (ffebld_conter (r)));
3658           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3659                                         (ffebld_cu_val_integer2 (u)), expr);
3660           break;
3661 #endif
3662
3663 #if FFETARGET_okINTEGER3
3664         case FFEINFO_kindtypeINTEGER3:
3665           error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3666                                ffebld_constant_integer3 (ffebld_conter (l)),
3667                               ffebld_constant_integer3 (ffebld_conter (r)));
3668           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3669                                         (ffebld_cu_val_integer3 (u)), expr);
3670           break;
3671 #endif
3672
3673 #if FFETARGET_okINTEGER4
3674         case FFEINFO_kindtypeINTEGER4:
3675           error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3676                                ffebld_constant_integer4 (ffebld_conter (l)),
3677                               ffebld_constant_integer4 (ffebld_conter (r)));
3678           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3679                                         (ffebld_cu_val_integer4 (u)), expr);
3680           break;
3681 #endif
3682
3683         default:
3684           assert ("bad integer kind type" == NULL);
3685           break;
3686         }
3687       break;
3688
3689     case FFEINFO_basictypeREAL:
3690       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3691         {
3692 #if FFETARGET_okREAL1
3693         case FFEINFO_kindtypeREAL1:
3694           error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3695                                   ffebld_constant_real1 (ffebld_conter (l)),
3696                                  ffebld_constant_real1 (ffebld_conter (r)));
3697           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3698                                            (ffebld_cu_val_real1 (u)), expr);
3699           break;
3700 #endif
3701
3702 #if FFETARGET_okREAL2
3703         case FFEINFO_kindtypeREAL2:
3704           error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3705                                   ffebld_constant_real2 (ffebld_conter (l)),
3706                                  ffebld_constant_real2 (ffebld_conter (r)));
3707           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3708                                            (ffebld_cu_val_real2 (u)), expr);
3709           break;
3710 #endif
3711
3712 #if FFETARGET_okREAL3
3713         case FFEINFO_kindtypeREAL3:
3714           error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3715                                   ffebld_constant_real3 (ffebld_conter (l)),
3716                                  ffebld_constant_real3 (ffebld_conter (r)));
3717           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3718                                            (ffebld_cu_val_real3 (u)), expr);
3719           break;
3720 #endif
3721
3722         default:
3723           assert ("bad real kind type" == NULL);
3724           break;
3725         }
3726       break;
3727
3728     case FFEINFO_basictypeCOMPLEX:
3729       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3730         {
3731 #if FFETARGET_okCOMPLEX1
3732         case FFEINFO_kindtypeREAL1:
3733           error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3734                                ffebld_constant_complex1 (ffebld_conter (l)),
3735                               ffebld_constant_complex1 (ffebld_conter (r)));
3736           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3737                                         (ffebld_cu_val_complex1 (u)), expr);
3738           break;
3739 #endif
3740
3741 #if FFETARGET_okCOMPLEX2
3742         case FFEINFO_kindtypeREAL2:
3743           error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3744                                ffebld_constant_complex2 (ffebld_conter (l)),
3745                               ffebld_constant_complex2 (ffebld_conter (r)));
3746           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3747                                         (ffebld_cu_val_complex2 (u)), expr);
3748           break;
3749 #endif
3750
3751 #if FFETARGET_okCOMPLEX3
3752         case FFEINFO_kindtypeREAL3:
3753           error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3754                                ffebld_constant_complex3 (ffebld_conter (l)),
3755                               ffebld_constant_complex3 (ffebld_conter (r)));
3756           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3757                                         (ffebld_cu_val_complex3 (u)), expr);
3758           break;
3759 #endif
3760
3761         default:
3762           assert ("bad complex kind type" == NULL);
3763           break;
3764         }
3765       break;
3766
3767     default:
3768       assert ("bad type" == NULL);
3769       return expr;
3770     }
3771
3772   ffebld_set_info (expr, ffeinfo_new
3773                    (bt,
3774                     kt,
3775                     0,
3776                     FFEINFO_kindENTITY,
3777                     FFEINFO_whereCONSTANT,
3778                     FFETARGET_charactersizeNONE));
3779
3780   if ((error != FFEBAD)
3781       && ffebad_start (error))
3782     {
3783       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3784       ffebad_finish ();
3785     }
3786
3787   return expr;
3788 }
3789
3790 /* ffeexpr_collapse_power -- Collapse power expr
3791
3792    ffebld expr;
3793    ffelexToken token;
3794    expr = ffeexpr_collapse_power(expr,token);
3795
3796    If the result of the expr is a constant, replaces the expr with the
3797    computed constant.  */
3798
3799 ffebld
3800 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3801 {
3802   ffebad error = FFEBAD;
3803   ffebld l;
3804   ffebld r;
3805   ffebldConstantUnion u;
3806   ffeinfoBasictype bt;
3807   ffeinfoKindtype kt;
3808
3809   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3810     return expr;
3811
3812   l = ffebld_left (expr);
3813   r = ffebld_right (expr);
3814
3815   if (ffebld_op (l) != FFEBLD_opCONTER)
3816     return expr;
3817   if (ffebld_op (r) != FFEBLD_opCONTER)
3818     return expr;
3819
3820   if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3821   || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3822     return expr;
3823
3824   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3825     {
3826     case FFEINFO_basictypeANY:
3827       return expr;
3828
3829     case FFEINFO_basictypeINTEGER:
3830       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3831         {
3832         case FFEINFO_kindtypeINTEGERDEFAULT:
3833           error = ffetarget_power_integerdefault_integerdefault
3834             (ffebld_cu_ptr_integerdefault (u),
3835              ffebld_constant_integerdefault (ffebld_conter (l)),
3836              ffebld_constant_integerdefault (ffebld_conter (r)));
3837           expr = ffebld_new_conter_with_orig
3838             (ffebld_constant_new_integerdefault_val
3839              (ffebld_cu_val_integerdefault (u)), expr);
3840           break;
3841
3842         default:
3843           assert ("bad integer kind type" == NULL);
3844           break;
3845         }
3846       break;
3847
3848     case FFEINFO_basictypeREAL:
3849       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3850         {
3851         case FFEINFO_kindtypeREALDEFAULT:
3852           error = ffetarget_power_realdefault_integerdefault
3853             (ffebld_cu_ptr_realdefault (u),
3854              ffebld_constant_realdefault (ffebld_conter (l)),
3855              ffebld_constant_integerdefault (ffebld_conter (r)));
3856           expr = ffebld_new_conter_with_orig
3857             (ffebld_constant_new_realdefault_val
3858              (ffebld_cu_val_realdefault (u)), expr);
3859           break;
3860
3861         case FFEINFO_kindtypeREALDOUBLE:
3862           error = ffetarget_power_realdouble_integerdefault
3863             (ffebld_cu_ptr_realdouble (u),
3864              ffebld_constant_realdouble (ffebld_conter (l)),
3865              ffebld_constant_integerdefault (ffebld_conter (r)));
3866           expr = ffebld_new_conter_with_orig
3867             (ffebld_constant_new_realdouble_val
3868              (ffebld_cu_val_realdouble (u)), expr);
3869           break;
3870
3871 #if FFETARGET_okREALQUAD
3872         case FFEINFO_kindtypeREALQUAD:
3873           error = ffetarget_power_realquad_integerdefault
3874             (ffebld_cu_ptr_realquad (u),
3875              ffebld_constant_realquad (ffebld_conter (l)),
3876              ffebld_constant_integerdefault (ffebld_conter (r)));
3877           expr = ffebld_new_conter_with_orig
3878             (ffebld_constant_new_realquad_val
3879              (ffebld_cu_val_realquad (u)), expr);
3880           break;
3881 #endif
3882         default:
3883           assert ("bad real kind type" == NULL);
3884           break;
3885         }
3886       break;
3887
3888     case FFEINFO_basictypeCOMPLEX:
3889       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3890         {
3891         case FFEINFO_kindtypeREALDEFAULT:
3892           error = ffetarget_power_complexdefault_integerdefault
3893             (ffebld_cu_ptr_complexdefault (u),
3894              ffebld_constant_complexdefault (ffebld_conter (l)),
3895              ffebld_constant_integerdefault (ffebld_conter (r)));
3896           expr = ffebld_new_conter_with_orig
3897             (ffebld_constant_new_complexdefault_val
3898              (ffebld_cu_val_complexdefault (u)), expr);
3899           break;
3900
3901 #if FFETARGET_okCOMPLEXDOUBLE
3902         case FFEINFO_kindtypeREALDOUBLE:
3903           error = ffetarget_power_complexdouble_integerdefault
3904             (ffebld_cu_ptr_complexdouble (u),
3905              ffebld_constant_complexdouble (ffebld_conter (l)),
3906              ffebld_constant_integerdefault (ffebld_conter (r)));
3907           expr = ffebld_new_conter_with_orig
3908             (ffebld_constant_new_complexdouble_val
3909              (ffebld_cu_val_complexdouble (u)), expr);
3910           break;
3911 #endif
3912
3913 #if FFETARGET_okCOMPLEXQUAD
3914         case FFEINFO_kindtypeREALQUAD:
3915           error = ffetarget_power_complexquad_integerdefault
3916             (ffebld_cu_ptr_complexquad (u),
3917              ffebld_constant_complexquad (ffebld_conter (l)),
3918              ffebld_constant_integerdefault (ffebld_conter (r)));
3919           expr = ffebld_new_conter_with_orig
3920             (ffebld_constant_new_complexquad_val
3921              (ffebld_cu_val_complexquad (u)), expr);
3922           break;
3923 #endif
3924
3925         default:
3926           assert ("bad complex kind type" == NULL);
3927           break;
3928         }
3929       break;
3930
3931     default:
3932       assert ("bad type" == NULL);
3933       return expr;
3934     }
3935
3936   ffebld_set_info (expr, ffeinfo_new
3937                    (bt,
3938                     kt,
3939                     0,
3940                     FFEINFO_kindENTITY,
3941                     FFEINFO_whereCONSTANT,
3942                     FFETARGET_charactersizeNONE));
3943
3944   if ((error != FFEBAD)
3945       && ffebad_start (error))
3946     {
3947       ffebad_here (0, ffelex_token_where_line (t),
3948                    ffelex_token_where_column (t));
3949       ffebad_finish ();
3950     }
3951
3952   return expr;
3953 }
3954
3955 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3956
3957    ffebld expr;
3958    ffelexToken token;
3959    expr = ffeexpr_collapse_concatenate(expr,token);
3960
3961    If the result of the expr is a constant, replaces the expr with the
3962    computed constant.  */
3963
3964 ffebld
3965 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3966 {
3967   ffebad error = FFEBAD;
3968   ffebld l;
3969   ffebld r;
3970   ffebldConstantUnion u;
3971   ffeinfoKindtype kt;
3972   ffetargetCharacterSize len;
3973
3974   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3975     return expr;
3976
3977   l = ffebld_left (expr);
3978   r = ffebld_right (expr);
3979
3980   if (ffebld_op (l) != FFEBLD_opCONTER)
3981     return expr;
3982   if (ffebld_op (r) != FFEBLD_opCONTER)
3983     return expr;
3984
3985   switch (ffeinfo_basictype (ffebld_info (expr)))
3986     {
3987     case FFEINFO_basictypeANY:
3988       return expr;
3989
3990     case FFEINFO_basictypeCHARACTER:
3991       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3992         {
3993 #if FFETARGET_okCHARACTER1
3994         case FFEINFO_kindtypeCHARACTER1:
3995           error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3996                              ffebld_constant_character1 (ffebld_conter (l)),
3997                              ffebld_constant_character1 (ffebld_conter (r)),
3998                                    ffebld_constant_pool (), &len);
3999           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4000                                       (ffebld_cu_val_character1 (u)), expr);
4001           break;
4002 #endif
4003
4004         default:
4005           assert ("bad character kind type" == NULL);
4006           break;
4007         }
4008       break;
4009
4010     default:
4011       assert ("bad type" == NULL);
4012       return expr;
4013     }
4014
4015   ffebld_set_info (expr, ffeinfo_new
4016                    (FFEINFO_basictypeCHARACTER,
4017                     kt,
4018                     0,
4019                     FFEINFO_kindENTITY,
4020                     FFEINFO_whereCONSTANT,
4021                     len));
4022
4023   if ((error != FFEBAD)
4024       && ffebad_start (error))
4025     {
4026       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4027       ffebad_finish ();
4028     }
4029
4030   return expr;
4031 }
4032
4033 /* ffeexpr_collapse_eq -- Collapse eq expr
4034
4035    ffebld expr;
4036    ffelexToken token;
4037    expr = ffeexpr_collapse_eq(expr,token);
4038
4039    If the result of the expr is a constant, replaces the expr with the
4040    computed constant.  */
4041
4042 ffebld
4043 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4044 {
4045   ffebad error = FFEBAD;
4046   ffebld l;
4047   ffebld r;
4048   bool val;
4049
4050   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4051     return expr;
4052
4053   l = ffebld_left (expr);
4054   r = ffebld_right (expr);
4055
4056   if (ffebld_op (l) != FFEBLD_opCONTER)
4057     return expr;
4058   if (ffebld_op (r) != FFEBLD_opCONTER)
4059     return expr;
4060
4061   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4062     {
4063     case FFEINFO_basictypeANY:
4064       return expr;
4065
4066     case FFEINFO_basictypeINTEGER:
4067       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4068         {
4069 #if FFETARGET_okINTEGER1
4070         case FFEINFO_kindtypeINTEGER1:
4071           error = ffetarget_eq_integer1 (&val,
4072                                ffebld_constant_integer1 (ffebld_conter (l)),
4073                               ffebld_constant_integer1 (ffebld_conter (r)));
4074           expr = ffebld_new_conter_with_orig
4075             (ffebld_constant_new_logicaldefault (val), expr);
4076           break;
4077 #endif
4078
4079 #if FFETARGET_okINTEGER2
4080         case FFEINFO_kindtypeINTEGER2:
4081           error = ffetarget_eq_integer2 (&val,
4082                                ffebld_constant_integer2 (ffebld_conter (l)),
4083                               ffebld_constant_integer2 (ffebld_conter (r)));
4084           expr = ffebld_new_conter_with_orig
4085             (ffebld_constant_new_logicaldefault (val), expr);
4086           break;
4087 #endif
4088
4089 #if FFETARGET_okINTEGER3
4090         case FFEINFO_kindtypeINTEGER3:
4091           error = ffetarget_eq_integer3 (&val,
4092                                ffebld_constant_integer3 (ffebld_conter (l)),
4093                               ffebld_constant_integer3 (ffebld_conter (r)));
4094           expr = ffebld_new_conter_with_orig
4095             (ffebld_constant_new_logicaldefault (val), expr);
4096           break;
4097 #endif
4098
4099 #if FFETARGET_okINTEGER4
4100         case FFEINFO_kindtypeINTEGER4:
4101           error = ffetarget_eq_integer4 (&val,
4102                                ffebld_constant_integer4 (ffebld_conter (l)),
4103                               ffebld_constant_integer4 (ffebld_conter (r)));
4104           expr = ffebld_new_conter_with_orig
4105             (ffebld_constant_new_logicaldefault (val), expr);
4106           break;
4107 #endif
4108
4109         default:
4110           assert ("bad integer kind type" == NULL);
4111           break;
4112         }
4113       break;
4114
4115     case FFEINFO_basictypeREAL:
4116       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4117         {
4118 #if FFETARGET_okREAL1
4119         case FFEINFO_kindtypeREAL1:
4120           error = ffetarget_eq_real1 (&val,
4121                                   ffebld_constant_real1 (ffebld_conter (l)),
4122                                  ffebld_constant_real1 (ffebld_conter (r)));
4123           expr = ffebld_new_conter_with_orig
4124             (ffebld_constant_new_logicaldefault (val), expr);
4125           break;
4126 #endif
4127
4128 #if FFETARGET_okREAL2
4129         case FFEINFO_kindtypeREAL2:
4130           error = ffetarget_eq_real2 (&val,
4131                                   ffebld_constant_real2 (ffebld_conter (l)),
4132                                  ffebld_constant_real2 (ffebld_conter (r)));
4133           expr = ffebld_new_conter_with_orig
4134             (ffebld_constant_new_logicaldefault (val), expr);
4135           break;
4136 #endif
4137
4138 #if FFETARGET_okREAL3
4139         case FFEINFO_kindtypeREAL3:
4140           error = ffetarget_eq_real3 (&val,
4141                                   ffebld_constant_real3 (ffebld_conter (l)),
4142                                  ffebld_constant_real3 (ffebld_conter (r)));
4143           expr = ffebld_new_conter_with_orig
4144             (ffebld_constant_new_logicaldefault (val), expr);
4145           break;
4146 #endif
4147
4148         default:
4149           assert ("bad real kind type" == NULL);
4150           break;
4151         }
4152       break;
4153
4154     case FFEINFO_basictypeCOMPLEX:
4155       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4156         {
4157 #if FFETARGET_okCOMPLEX1
4158         case FFEINFO_kindtypeREAL1:
4159           error = ffetarget_eq_complex1 (&val,
4160                                ffebld_constant_complex1 (ffebld_conter (l)),
4161                               ffebld_constant_complex1 (ffebld_conter (r)));
4162           expr = ffebld_new_conter_with_orig
4163             (ffebld_constant_new_logicaldefault (val), expr);
4164           break;
4165 #endif
4166
4167 #if FFETARGET_okCOMPLEX2
4168         case FFEINFO_kindtypeREAL2:
4169           error = ffetarget_eq_complex2 (&val,
4170                                ffebld_constant_complex2 (ffebld_conter (l)),
4171                               ffebld_constant_complex2 (ffebld_conter (r)));
4172           expr = ffebld_new_conter_with_orig
4173             (ffebld_constant_new_logicaldefault (val), expr);
4174           break;
4175 #endif
4176
4177 #if FFETARGET_okCOMPLEX3
4178         case FFEINFO_kindtypeREAL3:
4179           error = ffetarget_eq_complex3 (&val,
4180                                ffebld_constant_complex3 (ffebld_conter (l)),
4181                               ffebld_constant_complex3 (ffebld_conter (r)));
4182           expr = ffebld_new_conter_with_orig
4183             (ffebld_constant_new_logicaldefault (val), expr);
4184           break;
4185 #endif
4186
4187         default:
4188           assert ("bad complex kind type" == NULL);
4189           break;
4190         }
4191       break;
4192
4193     case FFEINFO_basictypeCHARACTER:
4194       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4195         {
4196 #if FFETARGET_okCHARACTER1
4197         case FFEINFO_kindtypeCHARACTER1:
4198           error = ffetarget_eq_character1 (&val,
4199                              ffebld_constant_character1 (ffebld_conter (l)),
4200                             ffebld_constant_character1 (ffebld_conter (r)));
4201           expr = ffebld_new_conter_with_orig
4202             (ffebld_constant_new_logicaldefault (val), expr);
4203           break;
4204 #endif
4205
4206         default:
4207           assert ("bad character kind type" == NULL);
4208           break;
4209         }
4210       break;
4211
4212     default:
4213       assert ("bad type" == NULL);
4214       return expr;
4215     }
4216
4217   ffebld_set_info (expr, ffeinfo_new
4218                    (FFEINFO_basictypeLOGICAL,
4219                     FFEINFO_kindtypeLOGICALDEFAULT,
4220                     0,
4221                     FFEINFO_kindENTITY,
4222                     FFEINFO_whereCONSTANT,
4223                     FFETARGET_charactersizeNONE));
4224
4225   if ((error != FFEBAD)
4226       && ffebad_start (error))
4227     {
4228       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4229       ffebad_finish ();
4230     }
4231
4232   return expr;
4233 }
4234
4235 /* ffeexpr_collapse_ne -- Collapse ne expr
4236
4237    ffebld expr;
4238    ffelexToken token;
4239    expr = ffeexpr_collapse_ne(expr,token);
4240
4241    If the result of the expr is a constant, replaces the expr with the
4242    computed constant.  */
4243
4244 ffebld
4245 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4246 {
4247   ffebad error = FFEBAD;
4248   ffebld l;
4249   ffebld r;
4250   bool val;
4251
4252   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4253     return expr;
4254
4255   l = ffebld_left (expr);
4256   r = ffebld_right (expr);
4257
4258   if (ffebld_op (l) != FFEBLD_opCONTER)
4259     return expr;
4260   if (ffebld_op (r) != FFEBLD_opCONTER)
4261     return expr;
4262
4263   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4264     {
4265     case FFEINFO_basictypeANY:
4266       return expr;
4267
4268     case FFEINFO_basictypeINTEGER:
4269       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4270         {
4271 #if FFETARGET_okINTEGER1
4272         case FFEINFO_kindtypeINTEGER1:
4273           error = ffetarget_ne_integer1 (&val,
4274                                ffebld_constant_integer1 (ffebld_conter (l)),
4275                               ffebld_constant_integer1 (ffebld_conter (r)));
4276           expr = ffebld_new_conter_with_orig
4277             (ffebld_constant_new_logicaldefault (val), expr);
4278           break;
4279 #endif
4280
4281 #if FFETARGET_okINTEGER2
4282         case FFEINFO_kindtypeINTEGER2:
4283           error = ffetarget_ne_integer2 (&val,
4284                                ffebld_constant_integer2 (ffebld_conter (l)),
4285                               ffebld_constant_integer2 (ffebld_conter (r)));
4286           expr = ffebld_new_conter_with_orig
4287             (ffebld_constant_new_logicaldefault (val), expr);
4288           break;
4289 #endif
4290
4291 #if FFETARGET_okINTEGER3
4292         case FFEINFO_kindtypeINTEGER3:
4293           error = ffetarget_ne_integer3 (&val,
4294                                ffebld_constant_integer3 (ffebld_conter (l)),
4295                               ffebld_constant_integer3 (ffebld_conter (r)));
4296           expr = ffebld_new_conter_with_orig
4297             (ffebld_constant_new_logicaldefault (val), expr);
4298           break;
4299 #endif
4300
4301 #if FFETARGET_okINTEGER4
4302         case FFEINFO_kindtypeINTEGER4:
4303           error = ffetarget_ne_integer4 (&val,
4304                                ffebld_constant_integer4 (ffebld_conter (l)),
4305                               ffebld_constant_integer4 (ffebld_conter (r)));
4306           expr = ffebld_new_conter_with_orig
4307             (ffebld_constant_new_logicaldefault (val), expr);
4308           break;
4309 #endif
4310
4311         default:
4312           assert ("bad integer kind type" == NULL);
4313           break;
4314         }
4315       break;
4316
4317     case FFEINFO_basictypeREAL:
4318       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4319         {
4320 #if FFETARGET_okREAL1
4321         case FFEINFO_kindtypeREAL1:
4322           error = ffetarget_ne_real1 (&val,
4323                                   ffebld_constant_real1 (ffebld_conter (l)),
4324                                  ffebld_constant_real1 (ffebld_conter (r)));
4325           expr = ffebld_new_conter_with_orig
4326             (ffebld_constant_new_logicaldefault (val), expr);
4327           break;
4328 #endif
4329
4330 #if FFETARGET_okREAL2
4331         case FFEINFO_kindtypeREAL2:
4332           error = ffetarget_ne_real2 (&val,
4333                                   ffebld_constant_real2 (ffebld_conter (l)),
4334                                  ffebld_constant_real2 (ffebld_conter (r)));
4335           expr = ffebld_new_conter_with_orig
4336             (ffebld_constant_new_logicaldefault (val), expr);
4337           break;
4338 #endif
4339
4340 #if FFETARGET_okREAL3
4341         case FFEINFO_kindtypeREAL3:
4342           error = ffetarget_ne_real3 (&val,
4343                                   ffebld_constant_real3 (ffebld_conter (l)),
4344                                  ffebld_constant_real3 (ffebld_conter (r)));
4345           expr = ffebld_new_conter_with_orig
4346             (ffebld_constant_new_logicaldefault (val), expr);
4347           break;
4348 #endif
4349
4350         default:
4351           assert ("bad real kind type" == NULL);
4352           break;
4353         }
4354       break;
4355
4356     case FFEINFO_basictypeCOMPLEX:
4357       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4358         {
4359 #if FFETARGET_okCOMPLEX1
4360         case FFEINFO_kindtypeREAL1:
4361           error = ffetarget_ne_complex1 (&val,
4362                                ffebld_constant_complex1 (ffebld_conter (l)),
4363                               ffebld_constant_complex1 (ffebld_conter (r)));
4364           expr = ffebld_new_conter_with_orig
4365             (ffebld_constant_new_logicaldefault (val), expr);
4366           break;
4367 #endif
4368
4369 #if FFETARGET_okCOMPLEX2
4370         case FFEINFO_kindtypeREAL2:
4371           error = ffetarget_ne_complex2 (&val,
4372                                ffebld_constant_complex2 (ffebld_conter (l)),
4373                               ffebld_constant_complex2 (ffebld_conter (r)));
4374           expr = ffebld_new_conter_with_orig
4375             (ffebld_constant_new_logicaldefault (val), expr);
4376           break;
4377 #endif
4378
4379 #if FFETARGET_okCOMPLEX3
4380         case FFEINFO_kindtypeREAL3:
4381           error = ffetarget_ne_complex3 (&val,
4382                                ffebld_constant_complex3 (ffebld_conter (l)),
4383                               ffebld_constant_complex3 (ffebld_conter (r)));
4384           expr = ffebld_new_conter_with_orig
4385             (ffebld_constant_new_logicaldefault (val), expr);
4386           break;
4387 #endif
4388
4389         default:
4390           assert ("bad complex kind type" == NULL);
4391           break;
4392         }
4393       break;
4394
4395     case FFEINFO_basictypeCHARACTER:
4396       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4397         {
4398 #if FFETARGET_okCHARACTER1
4399         case FFEINFO_kindtypeCHARACTER1:
4400           error = ffetarget_ne_character1 (&val,
4401                              ffebld_constant_character1 (ffebld_conter (l)),
4402                             ffebld_constant_character1 (ffebld_conter (r)));
4403           expr = ffebld_new_conter_with_orig
4404             (ffebld_constant_new_logicaldefault (val), expr);
4405           break;
4406 #endif
4407
4408         default:
4409           assert ("bad character kind type" == NULL);
4410           break;
4411         }
4412       break;
4413
4414     default:
4415       assert ("bad type" == NULL);
4416       return expr;
4417     }
4418
4419   ffebld_set_info (expr, ffeinfo_new
4420                    (FFEINFO_basictypeLOGICAL,
4421                     FFEINFO_kindtypeLOGICALDEFAULT,
4422                     0,
4423                     FFEINFO_kindENTITY,
4424                     FFEINFO_whereCONSTANT,
4425                     FFETARGET_charactersizeNONE));
4426
4427   if ((error != FFEBAD)
4428       && ffebad_start (error))
4429     {
4430       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4431       ffebad_finish ();
4432     }
4433
4434   return expr;
4435 }
4436
4437 /* ffeexpr_collapse_ge -- Collapse ge expr
4438
4439    ffebld expr;
4440    ffelexToken token;
4441    expr = ffeexpr_collapse_ge(expr,token);
4442
4443    If the result of the expr is a constant, replaces the expr with the
4444    computed constant.  */
4445
4446 ffebld
4447 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4448 {
4449   ffebad error = FFEBAD;
4450   ffebld l;
4451   ffebld r;
4452   bool val;
4453
4454   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4455     return expr;
4456
4457   l = ffebld_left (expr);
4458   r = ffebld_right (expr);
4459
4460   if (ffebld_op (l) != FFEBLD_opCONTER)
4461     return expr;
4462   if (ffebld_op (r) != FFEBLD_opCONTER)
4463     return expr;
4464
4465   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4466     {
4467     case FFEINFO_basictypeANY:
4468       return expr;
4469
4470     case FFEINFO_basictypeINTEGER:
4471       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4472         {
4473 #if FFETARGET_okINTEGER1
4474         case FFEINFO_kindtypeINTEGER1:
4475           error = ffetarget_ge_integer1 (&val,
4476                                ffebld_constant_integer1 (ffebld_conter (l)),
4477                               ffebld_constant_integer1 (ffebld_conter (r)));
4478           expr = ffebld_new_conter_with_orig
4479             (ffebld_constant_new_logicaldefault (val), expr);
4480           break;
4481 #endif
4482
4483 #if FFETARGET_okINTEGER2
4484         case FFEINFO_kindtypeINTEGER2:
4485           error = ffetarget_ge_integer2 (&val,
4486                                ffebld_constant_integer2 (ffebld_conter (l)),
4487                               ffebld_constant_integer2 (ffebld_conter (r)));
4488           expr = ffebld_new_conter_with_orig
4489             (ffebld_constant_new_logicaldefault (val), expr);
4490           break;
4491 #endif
4492
4493 #if FFETARGET_okINTEGER3
4494         case FFEINFO_kindtypeINTEGER3:
4495           error = ffetarget_ge_integer3 (&val,
4496                                ffebld_constant_integer3 (ffebld_conter (l)),
4497                               ffebld_constant_integer3 (ffebld_conter (r)));
4498           expr = ffebld_new_conter_with_orig
4499             (ffebld_constant_new_logicaldefault (val), expr);
4500           break;
4501 #endif
4502
4503 #if FFETARGET_okINTEGER4
4504         case FFEINFO_kindtypeINTEGER4:
4505           error = ffetarget_ge_integer4 (&val,
4506                                ffebld_constant_integer4 (ffebld_conter (l)),
4507                               ffebld_constant_integer4 (ffebld_conter (r)));
4508           expr = ffebld_new_conter_with_orig
4509             (ffebld_constant_new_logicaldefault (val), expr);
4510           break;
4511 #endif
4512
4513         default:
4514           assert ("bad integer kind type" == NULL);
4515           break;
4516         }
4517       break;
4518
4519     case FFEINFO_basictypeREAL:
4520       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4521         {
4522 #if FFETARGET_okREAL1
4523         case FFEINFO_kindtypeREAL1:
4524           error = ffetarget_ge_real1 (&val,
4525                                   ffebld_constant_real1 (ffebld_conter (l)),
4526                                  ffebld_constant_real1 (ffebld_conter (r)));
4527           expr = ffebld_new_conter_with_orig
4528             (ffebld_constant_new_logicaldefault (val), expr);
4529           break;
4530 #endif
4531
4532 #if FFETARGET_okREAL2
4533         case FFEINFO_kindtypeREAL2:
4534           error = ffetarget_ge_real2 (&val,
4535                                   ffebld_constant_real2 (ffebld_conter (l)),
4536                                  ffebld_constant_real2 (ffebld_conter (r)));
4537           expr = ffebld_new_conter_with_orig
4538             (ffebld_constant_new_logicaldefault (val), expr);
4539           break;
4540 #endif
4541
4542 #if FFETARGET_okREAL3
4543         case FFEINFO_kindtypeREAL3:
4544           error = ffetarget_ge_real3 (&val,
4545                                   ffebld_constant_real3 (ffebld_conter (l)),
4546                                  ffebld_constant_real3 (ffebld_conter (r)));
4547           expr = ffebld_new_conter_with_orig
4548             (ffebld_constant_new_logicaldefault (val), expr);
4549           break;
4550 #endif
4551
4552         default:
4553           assert ("bad real kind type" == NULL);
4554           break;
4555         }
4556       break;
4557
4558     case FFEINFO_basictypeCHARACTER:
4559       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4560         {
4561 #if FFETARGET_okCHARACTER1
4562         case FFEINFO_kindtypeCHARACTER1:
4563           error = ffetarget_ge_character1 (&val,
4564                              ffebld_constant_character1 (ffebld_conter (l)),
4565                             ffebld_constant_character1 (ffebld_conter (r)));
4566           expr = ffebld_new_conter_with_orig
4567             (ffebld_constant_new_logicaldefault (val), expr);
4568           break;
4569 #endif
4570
4571         default:
4572           assert ("bad character kind type" == NULL);
4573           break;
4574         }
4575       break;
4576
4577     default:
4578       assert ("bad type" == NULL);
4579       return expr;
4580     }
4581
4582   ffebld_set_info (expr, ffeinfo_new
4583                    (FFEINFO_basictypeLOGICAL,
4584                     FFEINFO_kindtypeLOGICALDEFAULT,
4585                     0,
4586                     FFEINFO_kindENTITY,
4587                     FFEINFO_whereCONSTANT,
4588                     FFETARGET_charactersizeNONE));
4589
4590   if ((error != FFEBAD)
4591       && ffebad_start (error))
4592     {
4593       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4594       ffebad_finish ();
4595     }
4596
4597   return expr;
4598 }
4599
4600 /* ffeexpr_collapse_gt -- Collapse gt expr
4601
4602    ffebld expr;
4603    ffelexToken token;
4604    expr = ffeexpr_collapse_gt(expr,token);
4605
4606    If the result of the expr is a constant, replaces the expr with the
4607    computed constant.  */
4608
4609 ffebld
4610 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4611 {
4612   ffebad error = FFEBAD;
4613   ffebld l;
4614   ffebld r;
4615   bool val;
4616
4617   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4618     return expr;
4619
4620   l = ffebld_left (expr);
4621   r = ffebld_right (expr);
4622
4623   if (ffebld_op (l) != FFEBLD_opCONTER)
4624     return expr;
4625   if (ffebld_op (r) != FFEBLD_opCONTER)
4626     return expr;
4627
4628   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4629     {
4630     case FFEINFO_basictypeANY:
4631       return expr;
4632
4633     case FFEINFO_basictypeINTEGER:
4634       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4635         {
4636 #if FFETARGET_okINTEGER1
4637         case FFEINFO_kindtypeINTEGER1:
4638           error = ffetarget_gt_integer1 (&val,
4639                                ffebld_constant_integer1 (ffebld_conter (l)),
4640                               ffebld_constant_integer1 (ffebld_conter (r)));
4641           expr = ffebld_new_conter_with_orig
4642             (ffebld_constant_new_logicaldefault (val), expr);
4643           break;
4644 #endif
4645
4646 #if FFETARGET_okINTEGER2
4647         case FFEINFO_kindtypeINTEGER2:
4648           error = ffetarget_gt_integer2 (&val,
4649                                ffebld_constant_integer2 (ffebld_conter (l)),
4650                               ffebld_constant_integer2 (ffebld_conter (r)));
4651           expr = ffebld_new_conter_with_orig
4652             (ffebld_constant_new_logicaldefault (val), expr);
4653           break;
4654 #endif
4655
4656 #if FFETARGET_okINTEGER3
4657         case FFEINFO_kindtypeINTEGER3:
4658           error = ffetarget_gt_integer3 (&val,
4659                                ffebld_constant_integer3 (ffebld_conter (l)),
4660                               ffebld_constant_integer3 (ffebld_conter (r)));
4661           expr = ffebld_new_conter_with_orig
4662             (ffebld_constant_new_logicaldefault (val), expr);
4663           break;
4664 #endif
4665
4666 #if FFETARGET_okINTEGER4
4667         case FFEINFO_kindtypeINTEGER4:
4668           error = ffetarget_gt_integer4 (&val,
4669                                ffebld_constant_integer4 (ffebld_conter (l)),
4670                               ffebld_constant_integer4 (ffebld_conter (r)));
4671           expr = ffebld_new_conter_with_orig
4672             (ffebld_constant_new_logicaldefault (val), expr);
4673           break;
4674 #endif
4675
4676         default:
4677           assert ("bad integer kind type" == NULL);
4678           break;
4679         }
4680       break;
4681
4682     case FFEINFO_basictypeREAL:
4683       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4684         {
4685 #if FFETARGET_okREAL1
4686         case FFEINFO_kindtypeREAL1:
4687           error = ffetarget_gt_real1 (&val,
4688                                   ffebld_constant_real1 (ffebld_conter (l)),
4689                                  ffebld_constant_real1 (ffebld_conter (r)));
4690           expr = ffebld_new_conter_with_orig
4691             (ffebld_constant_new_logicaldefault (val), expr);
4692           break;
4693 #endif
4694
4695 #if FFETARGET_okREAL2
4696         case FFEINFO_kindtypeREAL2:
4697           error = ffetarget_gt_real2 (&val,
4698                                   ffebld_constant_real2 (ffebld_conter (l)),
4699                                  ffebld_constant_real2 (ffebld_conter (r)));
4700           expr = ffebld_new_conter_with_orig
4701             (ffebld_constant_new_logicaldefault (val), expr);
4702           break;
4703 #endif
4704
4705 #if FFETARGET_okREAL3
4706         case FFEINFO_kindtypeREAL3:
4707           error = ffetarget_gt_real3 (&val,
4708                                   ffebld_constant_real3 (ffebld_conter (l)),
4709                                  ffebld_constant_real3 (ffebld_conter (r)));
4710           expr = ffebld_new_conter_with_orig
4711             (ffebld_constant_new_logicaldefault (val), expr);
4712           break;
4713 #endif
4714
4715         default:
4716           assert ("bad real kind type" == NULL);
4717           break;
4718         }
4719       break;
4720
4721     case FFEINFO_basictypeCHARACTER:
4722       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4723         {
4724 #if FFETARGET_okCHARACTER1
4725         case FFEINFO_kindtypeCHARACTER1:
4726           error = ffetarget_gt_character1 (&val,
4727                              ffebld_constant_character1 (ffebld_conter (l)),
4728                             ffebld_constant_character1 (ffebld_conter (r)));
4729           expr = ffebld_new_conter_with_orig
4730             (ffebld_constant_new_logicaldefault (val), expr);
4731           break;
4732 #endif
4733
4734         default:
4735           assert ("bad character kind type" == NULL);
4736           break;
4737         }
4738       break;
4739
4740     default:
4741       assert ("bad type" == NULL);
4742       return expr;
4743     }
4744
4745   ffebld_set_info (expr, ffeinfo_new
4746                    (FFEINFO_basictypeLOGICAL,
4747                     FFEINFO_kindtypeLOGICALDEFAULT,
4748                     0,
4749                     FFEINFO_kindENTITY,
4750                     FFEINFO_whereCONSTANT,
4751                     FFETARGET_charactersizeNONE));
4752
4753   if ((error != FFEBAD)
4754       && ffebad_start (error))
4755     {
4756       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4757       ffebad_finish ();
4758     }
4759
4760   return expr;
4761 }
4762
4763 /* ffeexpr_collapse_le -- Collapse le expr
4764
4765    ffebld expr;
4766    ffelexToken token;
4767    expr = ffeexpr_collapse_le(expr,token);
4768
4769    If the result of the expr is a constant, replaces the expr with the
4770    computed constant.  */
4771
4772 ffebld
4773 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4774 {
4775   ffebad error = FFEBAD;
4776   ffebld l;
4777   ffebld r;
4778   bool val;
4779
4780   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4781     return expr;
4782
4783   l = ffebld_left (expr);
4784   r = ffebld_right (expr);
4785
4786   if (ffebld_op (l) != FFEBLD_opCONTER)
4787     return expr;
4788   if (ffebld_op (r) != FFEBLD_opCONTER)
4789     return expr;
4790
4791   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4792     {
4793     case FFEINFO_basictypeANY:
4794       return expr;
4795
4796     case FFEINFO_basictypeINTEGER:
4797       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4798         {
4799 #if FFETARGET_okINTEGER1
4800         case FFEINFO_kindtypeINTEGER1:
4801           error = ffetarget_le_integer1 (&val,
4802                                ffebld_constant_integer1 (ffebld_conter (l)),
4803                               ffebld_constant_integer1 (ffebld_conter (r)));
4804           expr = ffebld_new_conter_with_orig
4805             (ffebld_constant_new_logicaldefault (val), expr);
4806           break;
4807 #endif
4808
4809 #if FFETARGET_okINTEGER2
4810         case FFEINFO_kindtypeINTEGER2:
4811           error = ffetarget_le_integer2 (&val,
4812                                ffebld_constant_integer2 (ffebld_conter (l)),
4813                               ffebld_constant_integer2 (ffebld_conter (r)));
4814           expr = ffebld_new_conter_with_orig
4815             (ffebld_constant_new_logicaldefault (val), expr);
4816           break;
4817 #endif
4818
4819 #if FFETARGET_okINTEGER3
4820         case FFEINFO_kindtypeINTEGER3:
4821           error = ffetarget_le_integer3 (&val,
4822                                ffebld_constant_integer3 (ffebld_conter (l)),
4823                               ffebld_constant_integer3 (ffebld_conter (r)));
4824           expr = ffebld_new_conter_with_orig
4825             (ffebld_constant_new_logicaldefault (val), expr);
4826           break;
4827 #endif
4828
4829 #if FFETARGET_okINTEGER4
4830         case FFEINFO_kindtypeINTEGER4:
4831           error = ffetarget_le_integer4 (&val,
4832                                ffebld_constant_integer4 (ffebld_conter (l)),
4833                               ffebld_constant_integer4 (ffebld_conter (r)));
4834           expr = ffebld_new_conter_with_orig
4835             (ffebld_constant_new_logicaldefault (val), expr);
4836           break;
4837 #endif
4838
4839         default:
4840           assert ("bad integer kind type" == NULL);
4841           break;
4842         }
4843       break;
4844
4845     case FFEINFO_basictypeREAL:
4846       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4847         {
4848 #if FFETARGET_okREAL1
4849         case FFEINFO_kindtypeREAL1:
4850           error = ffetarget_le_real1 (&val,
4851                                   ffebld_constant_real1 (ffebld_conter (l)),
4852                                  ffebld_constant_real1 (ffebld_conter (r)));
4853           expr = ffebld_new_conter_with_orig
4854             (ffebld_constant_new_logicaldefault (val), expr);
4855           break;
4856 #endif
4857
4858 #if FFETARGET_okREAL2
4859         case FFEINFO_kindtypeREAL2:
4860           error = ffetarget_le_real2 (&val,
4861                                   ffebld_constant_real2 (ffebld_conter (l)),
4862                                  ffebld_constant_real2 (ffebld_conter (r)));
4863           expr = ffebld_new_conter_with_orig
4864             (ffebld_constant_new_logicaldefault (val), expr);
4865           break;
4866 #endif
4867
4868 #if FFETARGET_okREAL3
4869         case FFEINFO_kindtypeREAL3:
4870           error = ffetarget_le_real3 (&val,
4871                                   ffebld_constant_real3 (ffebld_conter (l)),
4872                                  ffebld_constant_real3 (ffebld_conter (r)));
4873           expr = ffebld_new_conter_with_orig
4874             (ffebld_constant_new_logicaldefault (val), expr);
4875           break;
4876 #endif
4877
4878         default:
4879           assert ("bad real kind type" == NULL);
4880           break;
4881         }
4882       break;
4883
4884     case FFEINFO_basictypeCHARACTER:
4885       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4886         {
4887 #if FFETARGET_okCHARACTER1
4888         case FFEINFO_kindtypeCHARACTER1:
4889           error = ffetarget_le_character1 (&val,
4890                              ffebld_constant_character1 (ffebld_conter (l)),
4891                             ffebld_constant_character1 (ffebld_conter (r)));
4892           expr = ffebld_new_conter_with_orig
4893             (ffebld_constant_new_logicaldefault (val), expr);
4894           break;
4895 #endif
4896
4897         default:
4898           assert ("bad character kind type" == NULL);
4899           break;
4900         }
4901       break;
4902
4903     default:
4904       assert ("bad type" == NULL);
4905       return expr;
4906     }
4907
4908   ffebld_set_info (expr, ffeinfo_new
4909                    (FFEINFO_basictypeLOGICAL,
4910                     FFEINFO_kindtypeLOGICALDEFAULT,
4911                     0,
4912                     FFEINFO_kindENTITY,
4913                     FFEINFO_whereCONSTANT,
4914                     FFETARGET_charactersizeNONE));
4915
4916   if ((error != FFEBAD)
4917       && ffebad_start (error))
4918     {
4919       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4920       ffebad_finish ();
4921     }
4922
4923   return expr;
4924 }
4925
4926 /* ffeexpr_collapse_lt -- Collapse lt expr
4927
4928    ffebld expr;
4929    ffelexToken token;
4930    expr = ffeexpr_collapse_lt(expr,token);
4931
4932    If the result of the expr is a constant, replaces the expr with the
4933    computed constant.  */
4934
4935 ffebld
4936 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4937 {
4938   ffebad error = FFEBAD;
4939   ffebld l;
4940   ffebld r;
4941   bool val;
4942
4943   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4944     return expr;
4945
4946   l = ffebld_left (expr);
4947   r = ffebld_right (expr);
4948
4949   if (ffebld_op (l) != FFEBLD_opCONTER)
4950     return expr;
4951   if (ffebld_op (r) != FFEBLD_opCONTER)
4952     return expr;
4953
4954   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4955     {
4956     case FFEINFO_basictypeANY:
4957       return expr;
4958
4959     case FFEINFO_basictypeINTEGER:
4960       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4961         {
4962 #if FFETARGET_okINTEGER1
4963         case FFEINFO_kindtypeINTEGER1:
4964           error = ffetarget_lt_integer1 (&val,
4965                                ffebld_constant_integer1 (ffebld_conter (l)),
4966                               ffebld_constant_integer1 (ffebld_conter (r)));
4967           expr = ffebld_new_conter_with_orig
4968             (ffebld_constant_new_logicaldefault (val), expr);
4969           break;
4970 #endif
4971
4972 #if FFETARGET_okINTEGER2
4973         case FFEINFO_kindtypeINTEGER2:
4974           error = ffetarget_lt_integer2 (&val,
4975                                ffebld_constant_integer2 (ffebld_conter (l)),
4976                               ffebld_constant_integer2 (ffebld_conter (r)));
4977           expr = ffebld_new_conter_with_orig
4978             (ffebld_constant_new_logicaldefault (val), expr);
4979           break;
4980 #endif
4981
4982 #if FFETARGET_okINTEGER3
4983         case FFEINFO_kindtypeINTEGER3:
4984           error = ffetarget_lt_integer3 (&val,
4985                                ffebld_constant_integer3 (ffebld_conter (l)),
4986                               ffebld_constant_integer3 (ffebld_conter (r)));
4987           expr = ffebld_new_conter_with_orig
4988             (ffebld_constant_new_logicaldefault (val), expr);
4989           break;
4990 #endif
4991
4992 #if FFETARGET_okINTEGER4
4993         case FFEINFO_kindtypeINTEGER4:
4994           error = ffetarget_lt_integer4 (&val,
4995                                ffebld_constant_integer4 (ffebld_conter (l)),
4996                               ffebld_constant_integer4 (ffebld_conter (r)));
4997           expr = ffebld_new_conter_with_orig
4998             (ffebld_constant_new_logicaldefault (val), expr);
4999           break;
5000 #endif
5001
5002         default:
5003           assert ("bad integer kind type" == NULL);
5004           break;
5005         }
5006       break;
5007
5008     case FFEINFO_basictypeREAL:
5009       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5010         {
5011 #if FFETARGET_okREAL1
5012         case FFEINFO_kindtypeREAL1:
5013           error = ffetarget_lt_real1 (&val,
5014                                   ffebld_constant_real1 (ffebld_conter (l)),
5015                                  ffebld_constant_real1 (ffebld_conter (r)));
5016           expr = ffebld_new_conter_with_orig
5017             (ffebld_constant_new_logicaldefault (val), expr);
5018           break;
5019 #endif
5020
5021 #if FFETARGET_okREAL2
5022         case FFEINFO_kindtypeREAL2:
5023           error = ffetarget_lt_real2 (&val,
5024                                   ffebld_constant_real2 (ffebld_conter (l)),
5025                                  ffebld_constant_real2 (ffebld_conter (r)));
5026           expr = ffebld_new_conter_with_orig
5027             (ffebld_constant_new_logicaldefault (val), expr);
5028           break;
5029 #endif
5030
5031 #if FFETARGET_okREAL3
5032         case FFEINFO_kindtypeREAL3:
5033           error = ffetarget_lt_real3 (&val,
5034                                   ffebld_constant_real3 (ffebld_conter (l)),
5035                                  ffebld_constant_real3 (ffebld_conter (r)));
5036           expr = ffebld_new_conter_with_orig
5037             (ffebld_constant_new_logicaldefault (val), expr);
5038           break;
5039 #endif
5040
5041         default:
5042           assert ("bad real kind type" == NULL);
5043           break;
5044         }
5045       break;
5046
5047     case FFEINFO_basictypeCHARACTER:
5048       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5049         {
5050 #if FFETARGET_okCHARACTER1
5051         case FFEINFO_kindtypeCHARACTER1:
5052           error = ffetarget_lt_character1 (&val,
5053                              ffebld_constant_character1 (ffebld_conter (l)),
5054                             ffebld_constant_character1 (ffebld_conter (r)));
5055           expr = ffebld_new_conter_with_orig
5056             (ffebld_constant_new_logicaldefault (val), expr);
5057           break;
5058 #endif
5059
5060         default:
5061           assert ("bad character kind type" == NULL);
5062           break;
5063         }
5064       break;
5065
5066     default:
5067       assert ("bad type" == NULL);
5068       return expr;
5069     }
5070
5071   ffebld_set_info (expr, ffeinfo_new
5072                    (FFEINFO_basictypeLOGICAL,
5073                     FFEINFO_kindtypeLOGICALDEFAULT,
5074                     0,
5075                     FFEINFO_kindENTITY,
5076                     FFEINFO_whereCONSTANT,
5077                     FFETARGET_charactersizeNONE));
5078
5079   if ((error != FFEBAD)
5080       && ffebad_start (error))
5081     {
5082       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5083       ffebad_finish ();
5084     }
5085
5086   return expr;
5087 }
5088
5089 /* ffeexpr_collapse_and -- Collapse and expr
5090
5091    ffebld expr;
5092    ffelexToken token;
5093    expr = ffeexpr_collapse_and(expr,token);
5094
5095    If the result of the expr is a constant, replaces the expr with the
5096    computed constant.  */
5097
5098 ffebld
5099 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5100 {
5101   ffebad error = FFEBAD;
5102   ffebld l;
5103   ffebld r;
5104   ffebldConstantUnion u;
5105   ffeinfoBasictype bt;
5106   ffeinfoKindtype kt;
5107
5108   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5109     return expr;
5110
5111   l = ffebld_left (expr);
5112   r = ffebld_right (expr);
5113
5114   if (ffebld_op (l) != FFEBLD_opCONTER)
5115     return expr;
5116   if (ffebld_op (r) != FFEBLD_opCONTER)
5117     return expr;
5118
5119   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5120     {
5121     case FFEINFO_basictypeANY:
5122       return expr;
5123
5124     case FFEINFO_basictypeINTEGER:
5125       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5126         {
5127 #if FFETARGET_okINTEGER1
5128         case FFEINFO_kindtypeINTEGER1:
5129           error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5130                                ffebld_constant_integer1 (ffebld_conter (l)),
5131                               ffebld_constant_integer1 (ffebld_conter (r)));
5132           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5133                                         (ffebld_cu_val_integer1 (u)), expr);
5134           break;
5135 #endif
5136
5137 #if FFETARGET_okINTEGER2
5138         case FFEINFO_kindtypeINTEGER2:
5139           error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5140                                ffebld_constant_integer2 (ffebld_conter (l)),
5141                               ffebld_constant_integer2 (ffebld_conter (r)));
5142           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5143                                         (ffebld_cu_val_integer2 (u)), expr);
5144           break;
5145 #endif
5146
5147 #if FFETARGET_okINTEGER3
5148         case FFEINFO_kindtypeINTEGER3:
5149           error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5150                                ffebld_constant_integer3 (ffebld_conter (l)),
5151                               ffebld_constant_integer3 (ffebld_conter (r)));
5152           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5153                                         (ffebld_cu_val_integer3 (u)), expr);
5154           break;
5155 #endif
5156
5157 #if FFETARGET_okINTEGER4
5158         case FFEINFO_kindtypeINTEGER4:
5159           error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5160                                ffebld_constant_integer4 (ffebld_conter (l)),
5161                               ffebld_constant_integer4 (ffebld_conter (r)));
5162           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5163                                         (ffebld_cu_val_integer4 (u)), expr);
5164           break;
5165 #endif
5166
5167         default:
5168           assert ("bad integer kind type" == NULL);
5169           break;
5170         }
5171       break;
5172
5173     case FFEINFO_basictypeLOGICAL:
5174       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5175         {
5176 #if FFETARGET_okLOGICAL1
5177         case FFEINFO_kindtypeLOGICAL1:
5178           error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5179                                ffebld_constant_logical1 (ffebld_conter (l)),
5180                               ffebld_constant_logical1 (ffebld_conter (r)));
5181           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5182                                         (ffebld_cu_val_logical1 (u)), expr);
5183           break;
5184 #endif
5185
5186 #if FFETARGET_okLOGICAL2
5187         case FFEINFO_kindtypeLOGICAL2:
5188           error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5189                                ffebld_constant_logical2 (ffebld_conter (l)),
5190                               ffebld_constant_logical2 (ffebld_conter (r)));
5191           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5192                                         (ffebld_cu_val_logical2 (u)), expr);
5193           break;
5194 #endif
5195
5196 #if FFETARGET_okLOGICAL3
5197         case FFEINFO_kindtypeLOGICAL3:
5198           error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5199                                ffebld_constant_logical3 (ffebld_conter (l)),
5200                               ffebld_constant_logical3 (ffebld_conter (r)));
5201           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5202                                         (ffebld_cu_val_logical3 (u)), expr);
5203           break;
5204 #endif
5205
5206 #if FFETARGET_okLOGICAL4
5207         case FFEINFO_kindtypeLOGICAL4:
5208           error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5209                                ffebld_constant_logical4 (ffebld_conter (l)),
5210                               ffebld_constant_logical4 (ffebld_conter (r)));
5211           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5212                                         (ffebld_cu_val_logical4 (u)), expr);
5213           break;
5214 #endif
5215
5216         default:
5217           assert ("bad logical kind type" == NULL);
5218           break;
5219         }
5220       break;
5221
5222     default:
5223       assert ("bad type" == NULL);
5224       return expr;
5225     }
5226
5227   ffebld_set_info (expr, ffeinfo_new
5228                    (bt,
5229                     kt,
5230                     0,
5231                     FFEINFO_kindENTITY,
5232                     FFEINFO_whereCONSTANT,
5233                     FFETARGET_charactersizeNONE));
5234
5235   if ((error != FFEBAD)
5236       && ffebad_start (error))
5237     {
5238       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5239       ffebad_finish ();
5240     }
5241
5242   return expr;
5243 }
5244
5245 /* ffeexpr_collapse_or -- Collapse or expr
5246
5247    ffebld expr;
5248    ffelexToken token;
5249    expr = ffeexpr_collapse_or(expr,token);
5250
5251    If the result of the expr is a constant, replaces the expr with the
5252    computed constant.  */
5253
5254 ffebld
5255 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5256 {
5257   ffebad error = FFEBAD;
5258   ffebld l;
5259   ffebld r;
5260   ffebldConstantUnion u;
5261   ffeinfoBasictype bt;
5262   ffeinfoKindtype kt;
5263
5264   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5265     return expr;
5266
5267   l = ffebld_left (expr);
5268   r = ffebld_right (expr);
5269
5270   if (ffebld_op (l) != FFEBLD_opCONTER)
5271     return expr;
5272   if (ffebld_op (r) != FFEBLD_opCONTER)
5273     return expr;
5274
5275   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5276     {
5277     case FFEINFO_basictypeANY:
5278       return expr;
5279
5280     case FFEINFO_basictypeINTEGER:
5281       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5282         {
5283 #if FFETARGET_okINTEGER1
5284         case FFEINFO_kindtypeINTEGER1:
5285           error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5286                                ffebld_constant_integer1 (ffebld_conter (l)),
5287                               ffebld_constant_integer1 (ffebld_conter (r)));
5288           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5289                                         (ffebld_cu_val_integer1 (u)), expr);
5290           break;
5291 #endif
5292
5293 #if FFETARGET_okINTEGER2
5294         case FFEINFO_kindtypeINTEGER2:
5295           error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5296                                ffebld_constant_integer2 (ffebld_conter (l)),
5297                               ffebld_constant_integer2 (ffebld_conter (r)));
5298           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5299                                         (ffebld_cu_val_integer2 (u)), expr);
5300           break;
5301 #endif
5302
5303 #if FFETARGET_okINTEGER3
5304         case FFEINFO_kindtypeINTEGER3:
5305           error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5306                                ffebld_constant_integer3 (ffebld_conter (l)),
5307                               ffebld_constant_integer3 (ffebld_conter (r)));
5308           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5309                                         (ffebld_cu_val_integer3 (u)), expr);
5310           break;
5311 #endif
5312
5313 #if FFETARGET_okINTEGER4
5314         case FFEINFO_kindtypeINTEGER4:
5315           error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5316                                ffebld_constant_integer4 (ffebld_conter (l)),
5317                               ffebld_constant_integer4 (ffebld_conter (r)));
5318           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5319                                         (ffebld_cu_val_integer4 (u)), expr);
5320           break;
5321 #endif
5322
5323         default:
5324           assert ("bad integer kind type" == NULL);
5325           break;
5326         }
5327       break;
5328
5329     case FFEINFO_basictypeLOGICAL:
5330       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5331         {
5332 #if FFETARGET_okLOGICAL1
5333         case FFEINFO_kindtypeLOGICAL1:
5334           error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5335                                ffebld_constant_logical1 (ffebld_conter (l)),
5336                               ffebld_constant_logical1 (ffebld_conter (r)));
5337           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5338                                         (ffebld_cu_val_logical1 (u)), expr);
5339           break;
5340 #endif
5341
5342 #if FFETARGET_okLOGICAL2
5343         case FFEINFO_kindtypeLOGICAL2:
5344           error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5345                                ffebld_constant_logical2 (ffebld_conter (l)),
5346                               ffebld_constant_logical2 (ffebld_conter (r)));
5347           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5348                                         (ffebld_cu_val_logical2 (u)), expr);
5349           break;
5350 #endif
5351
5352 #if FFETARGET_okLOGICAL3
5353         case FFEINFO_kindtypeLOGICAL3:
5354           error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5355                                ffebld_constant_logical3 (ffebld_conter (l)),
5356                               ffebld_constant_logical3 (ffebld_conter (r)));
5357           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5358                                         (ffebld_cu_val_logical3 (u)), expr);
5359           break;
5360 #endif
5361
5362 #if FFETARGET_okLOGICAL4
5363         case FFEINFO_kindtypeLOGICAL4:
5364           error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5365                                ffebld_constant_logical4 (ffebld_conter (l)),
5366                               ffebld_constant_logical4 (ffebld_conter (r)));
5367           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5368                                         (ffebld_cu_val_logical4 (u)), expr);
5369           break;
5370 #endif
5371
5372         default:
5373           assert ("bad logical kind type" == NULL);
5374           break;
5375         }
5376       break;
5377
5378     default:
5379       assert ("bad type" == NULL);
5380       return expr;
5381     }
5382
5383   ffebld_set_info (expr, ffeinfo_new
5384                    (bt,
5385                     kt,
5386                     0,
5387                     FFEINFO_kindENTITY,
5388                     FFEINFO_whereCONSTANT,
5389                     FFETARGET_charactersizeNONE));
5390
5391   if ((error != FFEBAD)
5392       && ffebad_start (error))
5393     {
5394       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5395       ffebad_finish ();
5396     }
5397
5398   return expr;
5399 }
5400
5401 /* ffeexpr_collapse_xor -- Collapse xor expr
5402
5403    ffebld expr;
5404    ffelexToken token;
5405    expr = ffeexpr_collapse_xor(expr,token);
5406
5407    If the result of the expr is a constant, replaces the expr with the
5408    computed constant.  */
5409
5410 ffebld
5411 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5412 {
5413   ffebad error = FFEBAD;
5414   ffebld l;
5415   ffebld r;
5416   ffebldConstantUnion u;
5417   ffeinfoBasictype bt;
5418   ffeinfoKindtype kt;
5419
5420   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5421     return expr;
5422
5423   l = ffebld_left (expr);
5424   r = ffebld_right (expr);
5425
5426   if (ffebld_op (l) != FFEBLD_opCONTER)
5427     return expr;
5428   if (ffebld_op (r) != FFEBLD_opCONTER)
5429     return expr;
5430
5431   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5432     {
5433     case FFEINFO_basictypeANY:
5434       return expr;
5435
5436     case FFEINFO_basictypeINTEGER:
5437       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5438         {
5439 #if FFETARGET_okINTEGER1
5440         case FFEINFO_kindtypeINTEGER1:
5441           error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5442                                ffebld_constant_integer1 (ffebld_conter (l)),
5443                               ffebld_constant_integer1 (ffebld_conter (r)));
5444           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5445                                         (ffebld_cu_val_integer1 (u)), expr);
5446           break;
5447 #endif
5448
5449 #if FFETARGET_okINTEGER2
5450         case FFEINFO_kindtypeINTEGER2:
5451           error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5452                                ffebld_constant_integer2 (ffebld_conter (l)),
5453                               ffebld_constant_integer2 (ffebld_conter (r)));
5454           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5455                                         (ffebld_cu_val_integer2 (u)), expr);
5456           break;
5457 #endif
5458
5459 #if FFETARGET_okINTEGER3
5460         case FFEINFO_kindtypeINTEGER3:
5461           error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5462                                ffebld_constant_integer3 (ffebld_conter (l)),
5463                               ffebld_constant_integer3 (ffebld_conter (r)));
5464           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5465                                         (ffebld_cu_val_integer3 (u)), expr);
5466           break;
5467 #endif
5468
5469 #if FFETARGET_okINTEGER4
5470         case FFEINFO_kindtypeINTEGER4:
5471           error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5472                                ffebld_constant_integer4 (ffebld_conter (l)),
5473                               ffebld_constant_integer4 (ffebld_conter (r)));
5474           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5475                                         (ffebld_cu_val_integer4 (u)), expr);
5476           break;
5477 #endif
5478
5479         default:
5480           assert ("bad integer kind type" == NULL);
5481           break;
5482         }
5483       break;
5484
5485     case FFEINFO_basictypeLOGICAL:
5486       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5487         {
5488 #if FFETARGET_okLOGICAL1
5489         case FFEINFO_kindtypeLOGICAL1:
5490           error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5491                                ffebld_constant_logical1 (ffebld_conter (l)),
5492                               ffebld_constant_logical1 (ffebld_conter (r)));
5493           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5494                                         (ffebld_cu_val_logical1 (u)), expr);
5495           break;
5496 #endif
5497
5498 #if FFETARGET_okLOGICAL2
5499         case FFEINFO_kindtypeLOGICAL2:
5500           error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5501                                ffebld_constant_logical2 (ffebld_conter (l)),
5502                               ffebld_constant_logical2 (ffebld_conter (r)));
5503           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5504                                         (ffebld_cu_val_logical2 (u)), expr);
5505           break;
5506 #endif
5507
5508 #if FFETARGET_okLOGICAL3
5509         case FFEINFO_kindtypeLOGICAL3:
5510           error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5511                                ffebld_constant_logical3 (ffebld_conter (l)),
5512                               ffebld_constant_logical3 (ffebld_conter (r)));
5513           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5514                                         (ffebld_cu_val_logical3 (u)), expr);
5515           break;
5516 #endif
5517
5518 #if FFETARGET_okLOGICAL4
5519         case FFEINFO_kindtypeLOGICAL4:
5520           error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5521                                ffebld_constant_logical4 (ffebld_conter (l)),
5522                               ffebld_constant_logical4 (ffebld_conter (r)));
5523           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5524                                         (ffebld_cu_val_logical4 (u)), expr);
5525           break;
5526 #endif
5527
5528         default:
5529           assert ("bad logical kind type" == NULL);
5530           break;
5531         }
5532       break;
5533
5534     default:
5535       assert ("bad type" == NULL);
5536       return expr;
5537     }
5538
5539   ffebld_set_info (expr, ffeinfo_new
5540                    (bt,
5541                     kt,
5542                     0,
5543                     FFEINFO_kindENTITY,
5544                     FFEINFO_whereCONSTANT,
5545                     FFETARGET_charactersizeNONE));
5546
5547   if ((error != FFEBAD)
5548       && ffebad_start (error))
5549     {
5550       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5551       ffebad_finish ();
5552     }
5553
5554   return expr;
5555 }
5556
5557 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5558
5559    ffebld expr;
5560    ffelexToken token;
5561    expr = ffeexpr_collapse_eqv(expr,token);
5562
5563    If the result of the expr is a constant, replaces the expr with the
5564    computed constant.  */
5565
5566 ffebld
5567 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5568 {
5569   ffebad error = FFEBAD;
5570   ffebld l;
5571   ffebld r;
5572   ffebldConstantUnion u;
5573   ffeinfoBasictype bt;
5574   ffeinfoKindtype kt;
5575
5576   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5577     return expr;
5578
5579   l = ffebld_left (expr);
5580   r = ffebld_right (expr);
5581
5582   if (ffebld_op (l) != FFEBLD_opCONTER)
5583     return expr;
5584   if (ffebld_op (r) != FFEBLD_opCONTER)
5585     return expr;
5586
5587   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5588     {
5589     case FFEINFO_basictypeANY:
5590       return expr;
5591
5592     case FFEINFO_basictypeINTEGER:
5593       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5594         {
5595 #if FFETARGET_okINTEGER1
5596         case FFEINFO_kindtypeINTEGER1:
5597           error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5598                                ffebld_constant_integer1 (ffebld_conter (l)),
5599                               ffebld_constant_integer1 (ffebld_conter (r)));
5600           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5601                                         (ffebld_cu_val_integer1 (u)), expr);
5602           break;
5603 #endif
5604
5605 #if FFETARGET_okINTEGER2
5606         case FFEINFO_kindtypeINTEGER2:
5607           error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5608                                ffebld_constant_integer2 (ffebld_conter (l)),
5609                               ffebld_constant_integer2 (ffebld_conter (r)));
5610           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5611                                         (ffebld_cu_val_integer2 (u)), expr);
5612           break;
5613 #endif
5614
5615 #if FFETARGET_okINTEGER3
5616         case FFEINFO_kindtypeINTEGER3:
5617           error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5618                                ffebld_constant_integer3 (ffebld_conter (l)),
5619                               ffebld_constant_integer3 (ffebld_conter (r)));
5620           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5621                                         (ffebld_cu_val_integer3 (u)), expr);
5622           break;
5623 #endif
5624
5625 #if FFETARGET_okINTEGER4
5626         case FFEINFO_kindtypeINTEGER4:
5627           error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5628                                ffebld_constant_integer4 (ffebld_conter (l)),
5629                               ffebld_constant_integer4 (ffebld_conter (r)));
5630           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5631                                         (ffebld_cu_val_integer4 (u)), expr);
5632           break;
5633 #endif
5634
5635         default:
5636           assert ("bad integer kind type" == NULL);
5637           break;
5638         }
5639       break;
5640
5641     case FFEINFO_basictypeLOGICAL:
5642       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5643         {
5644 #if FFETARGET_okLOGICAL1
5645         case FFEINFO_kindtypeLOGICAL1:
5646           error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5647                                ffebld_constant_logical1 (ffebld_conter (l)),
5648                               ffebld_constant_logical1 (ffebld_conter (r)));
5649           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5650                                         (ffebld_cu_val_logical1 (u)), expr);
5651           break;
5652 #endif
5653
5654 #if FFETARGET_okLOGICAL2
5655         case FFEINFO_kindtypeLOGICAL2:
5656           error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5657                                ffebld_constant_logical2 (ffebld_conter (l)),
5658                               ffebld_constant_logical2 (ffebld_conter (r)));
5659           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5660                                         (ffebld_cu_val_logical2 (u)), expr);
5661           break;
5662 #endif
5663
5664 #if FFETARGET_okLOGICAL3
5665         case FFEINFO_kindtypeLOGICAL3:
5666           error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5667                                ffebld_constant_logical3 (ffebld_conter (l)),
5668                               ffebld_constant_logical3 (ffebld_conter (r)));
5669           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5670                                         (ffebld_cu_val_logical3 (u)), expr);
5671           break;
5672 #endif
5673
5674 #if FFETARGET_okLOGICAL4
5675         case FFEINFO_kindtypeLOGICAL4:
5676           error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5677                                ffebld_constant_logical4 (ffebld_conter (l)),
5678                               ffebld_constant_logical4 (ffebld_conter (r)));
5679           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5680                                         (ffebld_cu_val_logical4 (u)), expr);
5681           break;
5682 #endif
5683
5684         default:
5685           assert ("bad logical kind type" == NULL);
5686           break;
5687         }
5688       break;
5689
5690     default:
5691       assert ("bad type" == NULL);
5692       return expr;
5693     }
5694
5695   ffebld_set_info (expr, ffeinfo_new
5696                    (bt,
5697                     kt,
5698                     0,
5699                     FFEINFO_kindENTITY,
5700                     FFEINFO_whereCONSTANT,
5701                     FFETARGET_charactersizeNONE));
5702
5703   if ((error != FFEBAD)
5704       && ffebad_start (error))
5705     {
5706       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5707       ffebad_finish ();
5708     }
5709
5710   return expr;
5711 }
5712
5713 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5714
5715    ffebld expr;
5716    ffelexToken token;
5717    expr = ffeexpr_collapse_neqv(expr,token);
5718
5719    If the result of the expr is a constant, replaces the expr with the
5720    computed constant.  */
5721
5722 ffebld
5723 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5724 {
5725   ffebad error = FFEBAD;
5726   ffebld l;
5727   ffebld r;
5728   ffebldConstantUnion u;
5729   ffeinfoBasictype bt;
5730   ffeinfoKindtype kt;
5731
5732   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5733     return expr;
5734
5735   l = ffebld_left (expr);
5736   r = ffebld_right (expr);
5737
5738   if (ffebld_op (l) != FFEBLD_opCONTER)
5739     return expr;
5740   if (ffebld_op (r) != FFEBLD_opCONTER)
5741     return expr;
5742
5743   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5744     {
5745     case FFEINFO_basictypeANY:
5746       return expr;
5747
5748     case FFEINFO_basictypeINTEGER:
5749       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5750         {
5751 #if FFETARGET_okINTEGER1
5752         case FFEINFO_kindtypeINTEGER1:
5753           error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5754                                ffebld_constant_integer1 (ffebld_conter (l)),
5755                               ffebld_constant_integer1 (ffebld_conter (r)));
5756           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5757                                         (ffebld_cu_val_integer1 (u)), expr);
5758           break;
5759 #endif
5760
5761 #if FFETARGET_okINTEGER2
5762         case FFEINFO_kindtypeINTEGER2:
5763           error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5764                                ffebld_constant_integer2 (ffebld_conter (l)),
5765                               ffebld_constant_integer2 (ffebld_conter (r)));
5766           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5767                                         (ffebld_cu_val_integer2 (u)), expr);
5768           break;
5769 #endif
5770
5771 #if FFETARGET_okINTEGER3
5772         case FFEINFO_kindtypeINTEGER3:
5773           error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5774                                ffebld_constant_integer3 (ffebld_conter (l)),
5775                               ffebld_constant_integer3 (ffebld_conter (r)));
5776           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5777                                         (ffebld_cu_val_integer3 (u)), expr);
5778           break;
5779 #endif
5780
5781 #if FFETARGET_okINTEGER4
5782         case FFEINFO_kindtypeINTEGER4:
5783           error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5784                                ffebld_constant_integer4 (ffebld_conter (l)),
5785                               ffebld_constant_integer4 (ffebld_conter (r)));
5786           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5787                                         (ffebld_cu_val_integer4 (u)), expr);
5788           break;
5789 #endif
5790
5791         default:
5792           assert ("bad integer kind type" == NULL);
5793           break;
5794         }
5795       break;
5796
5797     case FFEINFO_basictypeLOGICAL:
5798       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5799         {
5800 #if FFETARGET_okLOGICAL1
5801         case FFEINFO_kindtypeLOGICAL1:
5802           error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5803                                ffebld_constant_logical1 (ffebld_conter (l)),
5804                               ffebld_constant_logical1 (ffebld_conter (r)));
5805           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5806                                         (ffebld_cu_val_logical1 (u)), expr);
5807           break;
5808 #endif
5809
5810 #if FFETARGET_okLOGICAL2
5811         case FFEINFO_kindtypeLOGICAL2:
5812           error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5813                                ffebld_constant_logical2 (ffebld_conter (l)),
5814                               ffebld_constant_logical2 (ffebld_conter (r)));
5815           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5816                                         (ffebld_cu_val_logical2 (u)), expr);
5817           break;
5818 #endif
5819
5820 #if FFETARGET_okLOGICAL3
5821         case FFEINFO_kindtypeLOGICAL3:
5822           error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5823                                ffebld_constant_logical3 (ffebld_conter (l)),
5824                               ffebld_constant_logical3 (ffebld_conter (r)));
5825           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5826                                         (ffebld_cu_val_logical3 (u)), expr);
5827           break;
5828 #endif
5829
5830 #if FFETARGET_okLOGICAL4
5831         case FFEINFO_kindtypeLOGICAL4:
5832           error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5833                                ffebld_constant_logical4 (ffebld_conter (l)),
5834                               ffebld_constant_logical4 (ffebld_conter (r)));
5835           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5836                                         (ffebld_cu_val_logical4 (u)), expr);
5837           break;
5838 #endif
5839
5840         default:
5841           assert ("bad logical kind type" == NULL);
5842           break;
5843         }
5844       break;
5845
5846     default:
5847       assert ("bad type" == NULL);
5848       return expr;
5849     }
5850
5851   ffebld_set_info (expr, ffeinfo_new
5852                    (bt,
5853                     kt,
5854                     0,
5855                     FFEINFO_kindENTITY,
5856                     FFEINFO_whereCONSTANT,
5857                     FFETARGET_charactersizeNONE));
5858
5859   if ((error != FFEBAD)
5860       && ffebad_start (error))
5861     {
5862       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5863       ffebad_finish ();
5864     }
5865
5866   return expr;
5867 }
5868
5869 /* ffeexpr_collapse_symter -- Collapse symter expr
5870
5871    ffebld expr;
5872    ffelexToken token;
5873    expr = ffeexpr_collapse_symter(expr,token);
5874
5875    If the result of the expr is a constant, replaces the expr with the
5876    computed constant.  */
5877
5878 ffebld
5879 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5880 {
5881   ffebld r;
5882   ffeinfoBasictype bt;
5883   ffeinfoKindtype kt;
5884   ffetargetCharacterSize len;
5885
5886   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5887     return expr;
5888
5889   if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5890     return expr;                /* A PARAMETER lhs in progress. */
5891
5892   switch (ffebld_op (r))
5893     {
5894     case FFEBLD_opCONTER:
5895       break;
5896
5897     case FFEBLD_opANY:
5898       return r;
5899
5900     default:
5901       return expr;
5902     }
5903
5904   bt = ffeinfo_basictype (ffebld_info (r));
5905   kt = ffeinfo_kindtype (ffebld_info (r));
5906   len = ffebld_size (r);
5907
5908   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5909                                       expr);
5910
5911   ffebld_set_info (expr, ffeinfo_new
5912                    (bt,
5913                     kt,
5914                     0,
5915                     FFEINFO_kindENTITY,
5916                     FFEINFO_whereCONSTANT,
5917                     len));
5918
5919   return expr;
5920 }
5921
5922 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5923
5924    ffebld expr;
5925    ffelexToken token;
5926    expr = ffeexpr_collapse_funcref(expr,token);
5927
5928    If the result of the expr is a constant, replaces the expr with the
5929    computed constant.  */
5930
5931 ffebld
5932 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5933 {
5934   return expr;                  /* ~~someday go ahead and collapse these,
5935                                    though not required */
5936 }
5937
5938 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5939
5940    ffebld expr;
5941    ffelexToken token;
5942    expr = ffeexpr_collapse_arrayref(expr,token);
5943
5944    If the result of the expr is a constant, replaces the expr with the
5945    computed constant.  */
5946
5947 ffebld
5948 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5949 {
5950   return expr;
5951 }
5952
5953 /* ffeexpr_collapse_substr -- Collapse substr expr
5954
5955    ffebld expr;
5956    ffelexToken token;
5957    expr = ffeexpr_collapse_substr(expr,token);
5958
5959    If the result of the expr is a constant, replaces the expr with the
5960    computed constant.  */
5961
5962 ffebld
5963 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5964 {
5965   ffebad error = FFEBAD;
5966   ffebld l;
5967   ffebld r;
5968   ffebld start;
5969   ffebld stop;
5970   ffebldConstantUnion u;
5971   ffeinfoKindtype kt;
5972   ffetargetCharacterSize len;
5973   ffetargetIntegerDefault first;
5974   ffetargetIntegerDefault last;
5975
5976   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5977     return expr;
5978
5979   l = ffebld_left (expr);
5980   r = ffebld_right (expr);      /* opITEM. */
5981
5982   if (ffebld_op (l) != FFEBLD_opCONTER)
5983     return expr;
5984
5985   kt = ffeinfo_kindtype (ffebld_info (l));
5986   len = ffebld_size (l);
5987
5988   start = ffebld_head (r);
5989   stop = ffebld_head (ffebld_trail (r));
5990   if (start == NULL)
5991     first = 1;
5992   else
5993     {
5994       if ((ffebld_op (start) != FFEBLD_opCONTER)
5995           || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5996           || (ffeinfo_kindtype (ffebld_info (start))
5997               != FFEINFO_kindtypeINTEGERDEFAULT))
5998         return expr;
5999       first = ffebld_constant_integerdefault (ffebld_conter (start));
6000     }
6001   if (stop == NULL)
6002     last = len;
6003   else
6004     {
6005       if ((ffebld_op (stop) != FFEBLD_opCONTER)
6006       || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6007           || (ffeinfo_kindtype (ffebld_info (stop))
6008               != FFEINFO_kindtypeINTEGERDEFAULT))
6009         return expr;
6010       last = ffebld_constant_integerdefault (ffebld_conter (stop));
6011     }
6012
6013   /* Handle problems that should have already been diagnosed, but
6014      left in the expression tree.  */
6015
6016   if (first <= 0)
6017     first = 1;
6018   if (last < first)
6019     last = first + len - 1;
6020
6021   if ((first == 1) && (last == len))
6022     {                           /* Same as original. */
6023       expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6024                                           (ffebld_conter (l)), expr);
6025       ffebld_set_info (expr, ffeinfo_new
6026                        (FFEINFO_basictypeCHARACTER,
6027                         kt,
6028                         0,
6029                         FFEINFO_kindENTITY,
6030                         FFEINFO_whereCONSTANT,
6031                         len));
6032
6033       return expr;
6034     }
6035
6036   switch (ffeinfo_basictype (ffebld_info (expr)))
6037     {
6038     case FFEINFO_basictypeANY:
6039       return expr;
6040
6041     case FFEINFO_basictypeCHARACTER:
6042       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6043         {
6044 #if FFETARGET_okCHARACTER1
6045         case FFEINFO_kindtypeCHARACTER1:
6046           error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6047                 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6048                                    ffebld_constant_pool (), &len);
6049           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6050                                       (ffebld_cu_val_character1 (u)), expr);
6051           break;
6052 #endif
6053
6054         default:
6055           assert ("bad character kind type" == NULL);
6056           break;
6057         }
6058       break;
6059
6060     default:
6061       assert ("bad type" == NULL);
6062       return expr;
6063     }
6064
6065   ffebld_set_info (expr, ffeinfo_new
6066                    (FFEINFO_basictypeCHARACTER,
6067                     kt,
6068                     0,
6069                     FFEINFO_kindENTITY,
6070                     FFEINFO_whereCONSTANT,
6071                     len));
6072
6073   if ((error != FFEBAD)
6074       && ffebad_start (error))
6075     {
6076       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6077       ffebad_finish ();
6078     }
6079
6080   return expr;
6081 }
6082
6083 /* ffeexpr_convert -- Convert source expression to given type
6084
6085    ffebld source;
6086    ffelexToken source_token;
6087    ffelexToken dest_token;  // Any appropriate token for "destination".
6088    ffeinfoBasictype bt;
6089    ffeinfoKindtype kt;
6090    ffetargetCharactersize sz;
6091    ffeexprContext context;  // Mainly LET or DATA.
6092    source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6093
6094    If the expression conforms, returns the source expression.  Otherwise
6095    returns source wrapped in a convert node doing the conversion, or
6096    ANY wrapped in convert if there is a conversion error (and issues an
6097    error message).  Be sensitive to the context for certain aspects of
6098    the conversion.  */
6099
6100 ffebld
6101 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6102                  ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6103                  ffetargetCharacterSize sz, ffeexprContext context)
6104 {
6105   bool bad;
6106   ffeinfo info;
6107   ffeinfoWhere wh;
6108
6109   info = ffebld_info (source);
6110   if ((bt != ffeinfo_basictype (info))
6111       || (kt != ffeinfo_kindtype (info))
6112       || (rk != 0)              /* Can't convert from or to arrays yet. */
6113       || (ffeinfo_rank (info) != 0)
6114       || (sz != ffebld_size_known (source)))
6115 #if 0   /* Nobody seems to need this spurious CONVERT node. */
6116       || ((context != FFEEXPR_contextLET)
6117           && (bt == FFEINFO_basictypeCHARACTER)
6118           && (sz == FFETARGET_charactersizeNONE)))
6119 #endif
6120     {
6121       switch (ffeinfo_basictype (info))
6122         {
6123         case FFEINFO_basictypeLOGICAL:
6124           switch (bt)
6125             {
6126             case FFEINFO_basictypeLOGICAL:
6127               bad = FALSE;
6128               break;
6129
6130             case FFEINFO_basictypeINTEGER:
6131               bad = !ffe_is_ugly_logint ();
6132               break;
6133
6134             case FFEINFO_basictypeCHARACTER:
6135               bad = ffe_is_pedantic ()
6136                 || !(ffe_is_ugly_init ()
6137                      && (context == FFEEXPR_contextDATA));
6138               break;
6139
6140             default:
6141               bad = TRUE;
6142               break;
6143             }
6144           break;
6145
6146         case FFEINFO_basictypeINTEGER:
6147           switch (bt)
6148             {
6149             case FFEINFO_basictypeINTEGER:
6150             case FFEINFO_basictypeREAL:
6151             case FFEINFO_basictypeCOMPLEX:
6152               bad = FALSE;
6153               break;
6154
6155             case FFEINFO_basictypeLOGICAL:
6156               bad = !ffe_is_ugly_logint ();
6157               break;
6158
6159             case FFEINFO_basictypeCHARACTER:
6160               bad = ffe_is_pedantic ()
6161                 || !(ffe_is_ugly_init ()
6162                      && (context == FFEEXPR_contextDATA));
6163               break;
6164
6165             default:
6166               bad = TRUE;
6167               break;
6168             }
6169           break;
6170
6171         case FFEINFO_basictypeREAL:
6172         case FFEINFO_basictypeCOMPLEX:
6173           switch (bt)
6174             {
6175             case FFEINFO_basictypeINTEGER:
6176             case FFEINFO_basictypeREAL:
6177             case FFEINFO_basictypeCOMPLEX:
6178               bad = FALSE;
6179               break;
6180
6181             case FFEINFO_basictypeCHARACTER:
6182               bad = TRUE;
6183               break;
6184
6185             default:
6186               bad = TRUE;
6187               break;
6188             }
6189           break;
6190
6191         case FFEINFO_basictypeCHARACTER:
6192           bad = (bt != FFEINFO_basictypeCHARACTER)
6193             && (ffe_is_pedantic ()
6194                 || (bt != FFEINFO_basictypeINTEGER)
6195                 || !(ffe_is_ugly_init ()
6196                      && (context == FFEEXPR_contextDATA)));
6197           break;
6198
6199         case FFEINFO_basictypeTYPELESS:
6200         case FFEINFO_basictypeHOLLERITH:
6201           bad = ffe_is_pedantic ()
6202             || !(ffe_is_ugly_init ()
6203                  && ((context == FFEEXPR_contextDATA)
6204                      || (context == FFEEXPR_contextLET)));
6205           break;
6206
6207         default:
6208           bad = TRUE;
6209           break;
6210         }
6211
6212       if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6213         bad = TRUE;
6214
6215       if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6216           && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6217           && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6218           && (ffeinfo_where (info) != FFEINFO_whereANY))
6219         {
6220           if (ffebad_start (FFEBAD_BAD_TYPES))
6221             {
6222               if (dest_token == NULL)
6223                 ffebad_here (0, ffewhere_line_unknown (),
6224                              ffewhere_column_unknown ());
6225               else
6226                 ffebad_here (0, ffelex_token_where_line (dest_token),
6227                              ffelex_token_where_column (dest_token));
6228               assert (source_token != NULL);
6229               ffebad_here (1, ffelex_token_where_line (source_token),
6230                            ffelex_token_where_column (source_token));
6231               ffebad_finish ();
6232             }
6233
6234           source = ffebld_new_any ();
6235           ffebld_set_info (source, ffeinfo_new_any ());
6236         }
6237       else
6238         {
6239           switch (ffeinfo_where (info))
6240             {
6241             case FFEINFO_whereCONSTANT:
6242               wh = FFEINFO_whereCONSTANT;
6243               break;
6244
6245             case FFEINFO_whereIMMEDIATE:
6246               wh = FFEINFO_whereIMMEDIATE;
6247               break;
6248
6249             default:
6250               wh = FFEINFO_whereFLEETING;
6251               break;
6252             }
6253           source = ffebld_new_convert (source);
6254           ffebld_set_info (source, ffeinfo_new
6255                            (bt,
6256                             kt,
6257                             0,
6258                             FFEINFO_kindENTITY,
6259                             wh,
6260                             sz));
6261           source = ffeexpr_collapse_convert (source, source_token);
6262         }
6263     }
6264
6265   return source;
6266 }
6267
6268 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6269
6270    ffebld source;
6271    ffebld dest;
6272    ffelexToken source_token;
6273    ffelexToken dest_token;
6274    ffeexprContext context;
6275    source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6276
6277    If the expressions conform, returns the source expression.  Otherwise
6278    returns source wrapped in a convert node doing the conversion, or
6279    ANY wrapped in convert if there is a conversion error (and issues an
6280    error message).  Be sensitive to the context, such as LET or DATA.  */
6281
6282 ffebld
6283 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6284                       ffelexToken dest_token, ffeexprContext context)
6285 {
6286   ffeinfo info;
6287
6288   info = ffebld_info (dest);
6289   return ffeexpr_convert (source, source_token, dest_token,
6290                           ffeinfo_basictype (info),
6291                           ffeinfo_kindtype (info),
6292                           ffeinfo_rank (info),
6293                           ffebld_size_known (dest),
6294                           context);
6295 }
6296
6297 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6298
6299    ffebld source;
6300    ffesymbol dest;
6301    ffelexToken source_token;
6302    ffelexToken dest_token;
6303    source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6304
6305    If the expressions conform, returns the source expression.  Otherwise
6306    returns source wrapped in a convert node doing the conversion, or
6307    ANY wrapped in convert if there is a conversion error (and issues an
6308    error message).  */
6309
6310 ffebld
6311 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6312                         ffesymbol dest, ffelexToken dest_token)
6313 {
6314   return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6315     ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6316                           FFEEXPR_contextLET);
6317 }
6318
6319 /* Initializes the module.  */
6320
6321 void
6322 ffeexpr_init_2 (void)
6323 {
6324   ffeexpr_stack_ = NULL;
6325   ffeexpr_level_ = 0;
6326 }
6327
6328 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6329
6330    Prepares cluster for delivery of lexer tokens representing an expression
6331    in a left-hand-side context (A in A=B, for example).  ffebld is used
6332    to build expressions in the given pool.  The appropriate lexer-token
6333    handling routine within ffeexpr is returned.  When the end of the
6334    expression is detected, mycallbackroutine is called with the resulting
6335    single ffebld object specifying the entire expression and the first
6336    lexer token that is not considered part of the expression.  This caller-
6337    supplied routine itself returns a lexer-token handling routine.  Thus,
6338    if necessary, ffeexpr can return several tokens as end-of-expression
6339    tokens if it needs to scan forward more than one in any instance.  */
6340
6341 ffelexHandler
6342 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6343 {
6344   ffeexprStack_ s;
6345
6346   ffebld_pool_push (pool);
6347   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6348   s->previous = ffeexpr_stack_;
6349   s->pool = pool;
6350   s->context = context;
6351   s->callback = callback;
6352   s->first_token = NULL;
6353   s->exprstack = NULL;
6354   s->is_rhs = FALSE;
6355   ffeexpr_stack_ = s;
6356   return (ffelexHandler) ffeexpr_token_first_lhs_;
6357 }
6358
6359 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6360
6361    return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
6362
6363    Prepares cluster for delivery of lexer tokens representing an expression
6364    in a right-hand-side context (B in A=B, for example).  ffebld is used
6365    to build expressions in the given pool.  The appropriate lexer-token
6366    handling routine within ffeexpr is returned.  When the end of the
6367    expression is detected, mycallbackroutine is called with the resulting
6368    single ffebld object specifying the entire expression and the first
6369    lexer token that is not considered part of the expression.  This caller-
6370    supplied routine itself returns a lexer-token handling routine.  Thus,
6371    if necessary, ffeexpr can return several tokens as end-of-expression
6372    tokens if it needs to scan forward more than one in any instance.  */
6373
6374 ffelexHandler
6375 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6376 {
6377   ffeexprStack_ s;
6378
6379   ffebld_pool_push (pool);
6380   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6381   s->previous = ffeexpr_stack_;
6382   s->pool = pool;
6383   s->context = context;
6384   s->callback = callback;
6385   s->first_token = NULL;
6386   s->exprstack = NULL;
6387   s->is_rhs = TRUE;
6388   ffeexpr_stack_ = s;
6389   return (ffelexHandler) ffeexpr_token_first_rhs_;
6390 }
6391
6392 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6393
6394    Pass it to ffeexpr_rhs as the callback routine.
6395
6396    Makes sure the end token is close-paren and swallows it, else issues
6397    an error message and doesn't swallow the token (passing it along instead).
6398    In either case wraps up subexpression construction by enclosing the
6399    ffebld expression in a paren.  */
6400
6401 static ffelexHandler
6402 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6403 {
6404   ffeexprExpr_ e;
6405
6406   if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6407     {
6408       /* Oops, naughty user didn't specify the close paren! */
6409
6410       if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6411         {
6412           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6413           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6414                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6415           ffebad_finish ();
6416         }
6417
6418       e = ffeexpr_expr_new_ ();
6419       e->type = FFEEXPR_exprtypeOPERAND_;
6420       e->u.operand = ffebld_new_any ();
6421       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6422       ffeexpr_exprstack_push_operand_ (e);
6423
6424       return
6425         (ffelexHandler) ffeexpr_find_close_paren_ (t,
6426                                                    (ffelexHandler)
6427                                                    ffeexpr_token_binary_);
6428     }
6429
6430   if (expr->op == FFEBLD_opIMPDO)
6431     {
6432       if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6433         {
6434           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6435                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6436           ffebad_finish ();
6437         }
6438     }
6439   else
6440     {
6441       expr = ffebld_new_paren (expr);
6442       ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6443     }
6444
6445   /* Now push the (parenthesized) expression as an operand onto the
6446      expression stack. */
6447
6448   e = ffeexpr_expr_new_ ();
6449   e->type = FFEEXPR_exprtypeOPERAND_;
6450   e->u.operand = expr;
6451   e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6452   e->token = ffeexpr_stack_->tokens[0];
6453   ffeexpr_exprstack_push_operand_ (e);
6454
6455   return (ffelexHandler) ffeexpr_token_binary_;
6456 }
6457
6458 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6459
6460    Pass it to ffeexpr_rhs as the callback routine.
6461
6462    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6463    with the next token in t.  If the next token is possibly a binary
6464    operator, continue processing the outer expression.  If the next
6465    token is COMMA, then the expression is a unit specifier, and
6466    parentheses should not be added to it because it surrounds the
6467    I/O control list that starts with the unit specifier (and continues
6468    on from here -- we haven't seen the CLOSE_PAREN that matches the
6469    OPEN_PAREN, it is up to the callback function to expect to see it
6470    at some point).  In this case, we notify the callback function that
6471    the COMMA is inside, not outside, the parens by wrapping the expression
6472    in an opITEM (with a NULL trail) -- the callback function presumably
6473    unwraps it after seeing this kludgey indicator.
6474
6475    If the next token is CLOSE_PAREN, then we go to the _1_ state to
6476    decide what to do with the token after that.
6477
6478    15-Feb-91  JCB  1.1
6479       Use an extra state for the CLOSE_PAREN case to make READ &co really
6480       work right.  */
6481
6482 static ffelexHandler
6483 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6484 {
6485   ffeexprCallback callback;
6486   ffeexprStack_ s;
6487
6488   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6489     {                           /* Need to see the next token before we
6490                                    decide anything. */
6491       ffeexpr_stack_->expr = expr;
6492       ffeexpr_tokens_[0] = ffelex_token_use (ft);
6493       ffeexpr_tokens_[1] = ffelex_token_use (t);
6494       return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6495     }
6496
6497   expr = ffeexpr_finished_ambig_ (ft, expr);
6498
6499   /* Let the callback function handle the case where t isn't COMMA. */
6500
6501   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6502      that preceded the expression starts a list of expressions, and the expr
6503      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6504      node.  The callback function should extract the real expr from the head
6505      of this opITEM node after testing it. */
6506
6507   expr = ffebld_new_item (expr, NULL);
6508
6509   ffebld_pool_pop ();
6510   callback = ffeexpr_stack_->callback;
6511   ffelex_token_kill (ffeexpr_stack_->first_token);
6512   s = ffeexpr_stack_->previous;
6513   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6514   ffeexpr_stack_ = s;
6515   return (ffelexHandler) (*callback) (ft, expr, t);
6516 }
6517
6518 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6519
6520    See ffeexpr_cb_close_paren_ambig_.
6521
6522    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6523    with the next token in t.  If the next token is possibly a binary
6524    operator, continue processing the outer expression.  If the next
6525    token is COMMA, the expression is a parenthesized format specifier.
6526    If the next token is not EOS or SEMICOLON, then because it is not a
6527    binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6528    a unit specifier, and parentheses should not be added to it because
6529    they surround the I/O control list that consists of only the unit
6530    specifier.  If the next token is EOS or SEMICOLON, the statement
6531    must be disambiguated by looking at the type of the expression -- a
6532    character expression is a parenthesized format specifier, while a
6533    non-character expression is a unit specifier.
6534
6535    Another issue is how to do the callback so the recipient of the
6536    next token knows how to handle it if it is a COMMA.  In all other
6537    cases, disambiguation is straightforward: the same approach as the
6538    above is used.
6539
6540    EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6541    as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6542    and apparently other compilers do, as well, and some code out there
6543    uses this "feature".
6544
6545    19-Feb-91  JCB  1.1
6546       Extend to allow COMMA as nondisambiguating by itself.  Remember
6547       to not try and check info field for opSTAR, since that expr doesn't
6548       have a valid info field.  */
6549
6550 static ffelexHandler
6551 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6552 {
6553   ffeexprCallback callback;
6554   ffeexprStack_ s;
6555   ffelexHandler next;
6556   ffelexToken orig_ft = ffeexpr_tokens_[0];     /* In case callback clobbers
6557                                                    these. */
6558   ffelexToken orig_t = ffeexpr_tokens_[1];
6559   ffebld expr = ffeexpr_stack_->expr;
6560
6561   switch (ffelex_token_type (t))
6562     {
6563     case FFELEX_typeCOMMA:      /* Subexpr is parenthesized format specifier. */
6564       if (ffe_is_pedantic ())
6565         goto pedantic_comma;    /* :::::::::::::::::::: */
6566       /* Fall through. */
6567     case FFELEX_typeEOS:        /* Ambiguous; use type of expr to
6568                                    disambiguate. */
6569     case FFELEX_typeSEMICOLON:
6570       if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6571           || (ffebld_op (expr) == FFEBLD_opSTAR)
6572           || (ffeinfo_basictype (ffebld_info (expr))
6573               != FFEINFO_basictypeCHARACTER))
6574         break;                  /* Not a valid CHARACTER entity, can't be a
6575                                    format spec. */
6576       /* Fall through. */
6577     default:                    /* Binary op (we assume; error otherwise);
6578                                    format specifier. */
6579
6580     pedantic_comma:             /* :::::::::::::::::::: */
6581
6582       switch (ffeexpr_stack_->context)
6583         {
6584         case FFEEXPR_contextFILENUMAMBIG:
6585           ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6586           break;
6587
6588         case FFEEXPR_contextFILEUNITAMBIG:
6589           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6590           break;
6591
6592         default:
6593           assert ("bad context" == NULL);
6594           break;
6595         }
6596
6597       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6598       next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6599       ffelex_token_kill (orig_ft);
6600       ffelex_token_kill (orig_t);
6601       return (ffelexHandler) (*next) (t);
6602
6603     case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6604     case FFELEX_typeNAME:
6605       break;
6606     }
6607
6608   expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6609
6610   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6611      that preceded the expression starts a list of expressions, and the expr
6612      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6613      node.  The callback function should extract the real expr from the head
6614      of this opITEM node after testing it. */
6615
6616   expr = ffebld_new_item (expr, NULL);
6617
6618   ffebld_pool_pop ();
6619   callback = ffeexpr_stack_->callback;
6620   ffelex_token_kill (ffeexpr_stack_->first_token);
6621   s = ffeexpr_stack_->previous;
6622   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6623   ffeexpr_stack_ = s;
6624   next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6625   ffelex_token_kill (orig_ft);
6626   ffelex_token_kill (orig_t);
6627   return (ffelexHandler) (*next) (t);
6628 }
6629
6630 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6631
6632    Pass it to ffeexpr_rhs as the callback routine.
6633
6634    Makes sure the end token is close-paren and swallows it, or a comma
6635    and handles complex/implied-do possibilities, else issues
6636    an error message and doesn't swallow the token (passing it along instead).  */
6637
6638 static ffelexHandler
6639 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6640 {
6641   /* First check to see if this is a possible complex entity.  It is if the
6642      token is a comma. */
6643
6644   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6645     {
6646       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6647       ffeexpr_stack_->expr = expr;
6648       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6649                                 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6650     }
6651
6652   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6653 }
6654
6655 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6656
6657    Pass it to ffeexpr_rhs as the callback routine.
6658
6659    If this token is not a comma, we have a complex constant (or an attempt
6660    at one), so handle it accordingly, displaying error messages if the token
6661    is not a close-paren.  */
6662
6663 static ffelexHandler
6664 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6665 {
6666   ffeexprExpr_ e;
6667   ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6668     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6669   ffeinfoBasictype rty = (expr == NULL)
6670     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6671   ffeinfoKindtype lkt;
6672   ffeinfoKindtype rkt;
6673   ffeinfoKindtype nkt;
6674   bool ok = TRUE;
6675   ffebld orig;
6676
6677   if ((ffeexpr_stack_->expr == NULL)
6678       || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6679       || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6680           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6681                && (ffebld_op (orig) != FFEBLD_opUPLUS))
6682               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6683       || ((lty != FFEINFO_basictypeINTEGER)
6684           && (lty != FFEINFO_basictypeREAL)))
6685     {
6686       if ((lty != FFEINFO_basictypeANY)
6687           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6688         {
6689           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6690                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6691           ffebad_string ("Real");
6692           ffebad_finish ();
6693         }
6694       ok = FALSE;
6695     }
6696   if ((expr == NULL)
6697       || (ffebld_op (expr) != FFEBLD_opCONTER)
6698       || (((orig = ffebld_conter_orig (expr)) != NULL)
6699           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6700                && (ffebld_op (orig) != FFEBLD_opUPLUS))
6701               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6702       || ((rty != FFEINFO_basictypeINTEGER)
6703           && (rty != FFEINFO_basictypeREAL)))
6704     {
6705       if ((rty != FFEINFO_basictypeANY)
6706           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6707         {
6708           ffebad_here (0, ffelex_token_where_line (ft),
6709                        ffelex_token_where_column (ft));
6710           ffebad_string ("Imaginary");
6711           ffebad_finish ();
6712         }
6713       ok = FALSE;
6714     }
6715
6716   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6717
6718   /* Push the (parenthesized) expression as an operand onto the expression
6719      stack. */
6720
6721   e = ffeexpr_expr_new_ ();
6722   e->type = FFEEXPR_exprtypeOPERAND_;
6723   e->token = ffeexpr_stack_->tokens[0];
6724
6725   if (ok)
6726     {
6727       if (lty == FFEINFO_basictypeINTEGER)
6728         lkt = FFEINFO_kindtypeREALDEFAULT;
6729       else
6730         lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6731       if (rty == FFEINFO_basictypeINTEGER)
6732         rkt = FFEINFO_kindtypeREALDEFAULT;
6733       else
6734         rkt = ffeinfo_kindtype (ffebld_info (expr));
6735
6736       nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6737       ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6738                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6739                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6740                                               FFEEXPR_contextLET);
6741       expr = ffeexpr_convert (expr,
6742                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6743                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6744                               FFEEXPR_contextLET);
6745     }
6746   else
6747     nkt = FFEINFO_kindtypeANY;
6748
6749   switch (nkt)
6750     {
6751 #if FFETARGET_okCOMPLEX1
6752     case FFEINFO_kindtypeREAL1:
6753       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6754               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6755       ffebld_set_info (e->u.operand,
6756                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6757                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6758                                     FFETARGET_charactersizeNONE));
6759       break;
6760 #endif
6761
6762 #if FFETARGET_okCOMPLEX2
6763     case FFEINFO_kindtypeREAL2:
6764       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6765               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6766       ffebld_set_info (e->u.operand,
6767                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6768                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6769                                     FFETARGET_charactersizeNONE));
6770       break;
6771 #endif
6772
6773 #if FFETARGET_okCOMPLEX3
6774     case FFEINFO_kindtypeREAL3:
6775       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6776               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6777       ffebld_set_info (e->u.operand,
6778                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6779                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6780                                     FFETARGET_charactersizeNONE));
6781       break;
6782 #endif
6783
6784     default:
6785       if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6786                         ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6787         {
6788           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6789                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6790           ffebad_finish ();
6791         }
6792       /* Fall through. */
6793     case FFEINFO_kindtypeANY:
6794       e->u.operand = ffebld_new_any ();
6795       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6796       break;
6797     }
6798   ffeexpr_exprstack_push_operand_ (e);
6799
6800   /* Now, if the token is a close parenthese, we're in great shape so return
6801      the next handler. */
6802
6803   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6804     return (ffelexHandler) ffeexpr_token_binary_;
6805
6806   /* Oops, naughty user didn't specify the close paren! */
6807
6808   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6809     {
6810       ffebad_here (0, ffelex_token_where_line (t),
6811                    ffelex_token_where_column (t));
6812       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6813                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6814       ffebad_finish ();
6815     }
6816
6817   return
6818     (ffelexHandler) ffeexpr_find_close_paren_ (t,
6819                                                (ffelexHandler)
6820                                                ffeexpr_token_binary_);
6821 }
6822
6823 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6824                                     implied-DO construct)
6825
6826    Pass it to ffeexpr_rhs as the callback routine.
6827
6828    Makes sure the end token is close-paren and swallows it, or a comma
6829    and handles complex/implied-do possibilities, else issues
6830    an error message and doesn't swallow the token (passing it along instead).  */
6831
6832 static ffelexHandler
6833 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6834 {
6835   ffeexprContext ctx;
6836
6837   /* First check to see if this is a possible complex or implied-DO entity.
6838      It is if the token is a comma. */
6839
6840   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6841     {
6842       switch (ffeexpr_stack_->context)
6843         {
6844         case FFEEXPR_contextIOLIST:
6845         case FFEEXPR_contextIMPDOITEM_:
6846           ctx = FFEEXPR_contextIMPDOITEM_;
6847           break;
6848
6849         case FFEEXPR_contextIOLISTDF:
6850         case FFEEXPR_contextIMPDOITEMDF_:
6851           ctx = FFEEXPR_contextIMPDOITEMDF_;
6852           break;
6853
6854         default:
6855           assert ("bad context" == NULL);
6856           ctx = FFEEXPR_contextIMPDOITEM_;
6857           break;
6858         }
6859
6860       ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6861       ffeexpr_stack_->expr = expr;
6862       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6863                                           ctx, ffeexpr_cb_comma_ci_);
6864     }
6865
6866   ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6867   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6868 }
6869
6870 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6871
6872    Pass it to ffeexpr_rhs as the callback routine.
6873
6874    If this token is not a comma, we have a complex constant (or an attempt
6875    at one), so handle it accordingly, displaying error messages if the token
6876    is not a close-paren.  If we have a comma here, it is an attempt at an
6877    implied-DO, so start making a list accordingly.  Oh, it might be an
6878    equal sign also, meaning an implied-DO with only one item in its list.  */
6879
6880 static ffelexHandler
6881 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6882 {
6883   ffebld fexpr;
6884
6885   /* First check to see if this is a possible complex constant.  It is if the
6886      token is not a comma or an equals sign, in which case it should be a
6887      close-paren. */
6888
6889   if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6890       && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6891     {
6892       ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6893       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6894       return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6895     }
6896
6897   /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6898      construct.  Make a list and handle accordingly. */
6899
6900   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6901   fexpr = ffeexpr_stack_->expr;
6902   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6903   ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6904   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6905 }
6906
6907 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6908
6909    Pass it to ffeexpr_rhs as the callback routine.
6910
6911    Handle first item in an implied-DO construct.  */
6912
6913 static ffelexHandler
6914 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6915 {
6916   if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6917     {
6918       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6919         {
6920           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6921           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6922                    ffelex_token_where_column (ffeexpr_stack_->first_token));
6923           ffebad_finish ();
6924         }
6925       ffebld_end_list (&ffeexpr_stack_->bottom);
6926       ffeexpr_stack_->expr = ffebld_new_any ();
6927       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6928       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6929         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6930       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6931     }
6932
6933   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6934 }
6935
6936 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6937
6938    Pass it to ffeexpr_rhs as the callback routine.
6939
6940    Handle first item in an implied-DO construct.  */
6941
6942 static ffelexHandler
6943 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6944 {
6945   ffeexprContext ctxi;
6946   ffeexprContext ctxc;
6947
6948   switch (ffeexpr_stack_->context)
6949     {
6950     case FFEEXPR_contextDATA:
6951     case FFEEXPR_contextDATAIMPDOITEM_:
6952       ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6953       ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6954       break;
6955
6956     case FFEEXPR_contextIOLIST:
6957     case FFEEXPR_contextIMPDOITEM_:
6958       ctxi = FFEEXPR_contextIMPDOITEM_;
6959       ctxc = FFEEXPR_contextIMPDOCTRL_;
6960       break;
6961
6962     case FFEEXPR_contextIOLISTDF:
6963     case FFEEXPR_contextIMPDOITEMDF_:
6964       ctxi = FFEEXPR_contextIMPDOITEMDF_;
6965       ctxc = FFEEXPR_contextIMPDOCTRL_;
6966       break;
6967
6968     default:
6969       assert ("bad context" == NULL);
6970       ctxi = FFEEXPR_context;
6971       ctxc = FFEEXPR_context;
6972       break;
6973     }
6974
6975   switch (ffelex_token_type (t))
6976     {
6977     case FFELEX_typeCOMMA:
6978       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6979       if (ffeexpr_stack_->is_rhs)
6980         return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6981                                             ctxi, ffeexpr_cb_comma_i_1_);
6982       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6983                                           ctxi, ffeexpr_cb_comma_i_1_);
6984
6985     case FFELEX_typeEQUALS:
6986       ffebld_end_list (&ffeexpr_stack_->bottom);
6987
6988       /* Complain if implied-DO variable in list of items to be read.  */
6989
6990       if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6991         ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6992                               ffeexpr_stack_->first_token, expr, ft);
6993
6994       /* Set doiter flag for all appropriate SYMTERs.  */
6995
6996       ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6997
6998       ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
6999       ffebld_set_info (ffeexpr_stack_->expr,
7000                        ffeinfo_new (FFEINFO_basictypeNONE,
7001                                     FFEINFO_kindtypeNONE,
7002                                     0,
7003                                     FFEINFO_kindNONE,
7004                                     FFEINFO_whereNONE,
7005                                     FFETARGET_charactersizeNONE));
7006       ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7007                         &ffeexpr_stack_->bottom);
7008       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7009       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7010                                           ctxc, ffeexpr_cb_comma_i_2_);
7011
7012     default:
7013       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7014         {
7015           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7016           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7017                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7018           ffebad_finish ();
7019         }
7020       ffebld_end_list (&ffeexpr_stack_->bottom);
7021       ffeexpr_stack_->expr = ffebld_new_any ();
7022       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7023       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7024         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7025       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7026     }
7027 }
7028
7029 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7030
7031    Pass it to ffeexpr_rhs as the callback routine.
7032
7033    Handle start-value in an implied-DO construct.  */
7034
7035 static ffelexHandler
7036 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7037 {
7038   ffeexprContext ctx;
7039
7040   switch (ffeexpr_stack_->context)
7041     {
7042     case FFEEXPR_contextDATA:
7043     case FFEEXPR_contextDATAIMPDOITEM_:
7044       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7045       break;
7046
7047     case FFEEXPR_contextIOLIST:
7048     case FFEEXPR_contextIOLISTDF:
7049     case FFEEXPR_contextIMPDOITEM_:
7050     case FFEEXPR_contextIMPDOITEMDF_:
7051       ctx = FFEEXPR_contextIMPDOCTRL_;
7052       break;
7053
7054     default:
7055       assert ("bad context" == NULL);
7056       ctx = FFEEXPR_context;
7057       break;
7058     }
7059
7060   switch (ffelex_token_type (t))
7061     {
7062     case FFELEX_typeCOMMA:
7063       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7064       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7065                                           ctx, ffeexpr_cb_comma_i_3_);
7066       break;
7067
7068     default:
7069       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7070         {
7071           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7072           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7073                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7074           ffebad_finish ();
7075         }
7076       ffebld_end_list (&ffeexpr_stack_->bottom);
7077       ffeexpr_stack_->expr = ffebld_new_any ();
7078       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7079       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7080         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7081       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7082     }
7083 }
7084
7085 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7086
7087    Pass it to ffeexpr_rhs as the callback routine.
7088
7089    Handle end-value in an implied-DO construct.  */
7090
7091 static ffelexHandler
7092 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7093 {
7094   ffeexprContext ctx;
7095
7096   switch (ffeexpr_stack_->context)
7097     {
7098     case FFEEXPR_contextDATA:
7099     case FFEEXPR_contextDATAIMPDOITEM_:
7100       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7101       break;
7102
7103     case FFEEXPR_contextIOLIST:
7104     case FFEEXPR_contextIOLISTDF:
7105     case FFEEXPR_contextIMPDOITEM_:
7106     case FFEEXPR_contextIMPDOITEMDF_:
7107       ctx = FFEEXPR_contextIMPDOCTRL_;
7108       break;
7109
7110     default:
7111       assert ("bad context" == NULL);
7112       ctx = FFEEXPR_context;
7113       break;
7114     }
7115
7116   switch (ffelex_token_type (t))
7117     {
7118     case FFELEX_typeCOMMA:
7119       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7120       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7121                                           ctx, ffeexpr_cb_comma_i_4_);
7122       break;
7123
7124     case FFELEX_typeCLOSE_PAREN:
7125       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7126       return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7127       break;
7128
7129     default:
7130       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7131         {
7132           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7133           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7134                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7135           ffebad_finish ();
7136         }
7137       ffebld_end_list (&ffeexpr_stack_->bottom);
7138       ffeexpr_stack_->expr = ffebld_new_any ();
7139       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7140       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7141         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7142       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7143     }
7144 }
7145
7146 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7147                                [COMMA expr]
7148
7149    Pass it to ffeexpr_rhs as the callback routine.
7150
7151    Handle incr-value in an implied-DO construct.  */
7152
7153 static ffelexHandler
7154 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7155 {
7156   switch (ffelex_token_type (t))
7157     {
7158     case FFELEX_typeCLOSE_PAREN:
7159       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7160       ffebld_end_list (&ffeexpr_stack_->bottom);
7161       {
7162         ffebld item;
7163
7164         for (item = ffebld_left (ffeexpr_stack_->expr);
7165              item != NULL;
7166              item = ffebld_trail (item))
7167           if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7168             goto replace_with_any;      /* :::::::::::::::::::: */
7169
7170         for (item = ffebld_right (ffeexpr_stack_->expr);
7171              item != NULL;
7172              item = ffebld_trail (item))
7173           if ((ffebld_head (item) != NULL)      /* Increment may be NULL. */
7174               && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7175             goto replace_with_any;      /* :::::::::::::::::::: */
7176       }
7177       break;
7178
7179     default:
7180       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7181         {
7182           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7183           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7184                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7185           ffebad_finish ();
7186         }
7187       ffebld_end_list (&ffeexpr_stack_->bottom);
7188
7189     replace_with_any:           /* :::::::::::::::::::: */
7190
7191       ffeexpr_stack_->expr = ffebld_new_any ();
7192       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7193       break;
7194     }
7195
7196   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7197     return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7198   return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7199 }
7200
7201 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7202                                [COMMA expr] CLOSE_PAREN
7203
7204    Pass it to ffeexpr_rhs as the callback routine.
7205
7206    Collects token following implied-DO construct for callback function.  */
7207
7208 static ffelexHandler
7209 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7210 {
7211   ffeexprCallback callback;
7212   ffeexprStack_ s;
7213   ffelexHandler next;
7214   ffelexToken ft;
7215   ffebld expr;
7216   bool terminate;
7217
7218   switch (ffeexpr_stack_->context)
7219     {
7220     case FFEEXPR_contextDATA:
7221     case FFEEXPR_contextDATAIMPDOITEM_:
7222       terminate = TRUE;
7223       break;
7224
7225     case FFEEXPR_contextIOLIST:
7226     case FFEEXPR_contextIOLISTDF:
7227     case FFEEXPR_contextIMPDOITEM_:
7228     case FFEEXPR_contextIMPDOITEMDF_:
7229       terminate = FALSE;
7230       break;
7231
7232     default:
7233       assert ("bad context" == NULL);
7234       terminate = FALSE;
7235       break;
7236     }
7237
7238   ffebld_pool_pop ();
7239   callback = ffeexpr_stack_->callback;
7240   ft = ffeexpr_stack_->first_token;
7241   expr = ffeexpr_stack_->expr;
7242   s = ffeexpr_stack_->previous;
7243   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7244                   sizeof (*ffeexpr_stack_));
7245   ffeexpr_stack_ = s;
7246   next = (ffelexHandler) (*callback) (ft, expr, t);
7247   ffelex_token_kill (ft);
7248   if (terminate)
7249     {
7250       ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7251       --ffeexpr_level_;
7252       if (ffeexpr_level_ == 0)
7253         ffe_terminate_4 ();
7254     }
7255   return (ffelexHandler) next;
7256 }
7257
7258 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7259
7260    Makes sure the end token is close-paren and swallows it, else issues
7261    an error message and doesn't swallow the token (passing it along instead).
7262    In either case wraps up subexpression construction by enclosing the
7263    ffebld expression in a %LOC.  */
7264
7265 static ffelexHandler
7266 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7267 {
7268   ffeexprExpr_ e;
7269
7270   /* First push the (%LOC) expression as an operand onto the expression
7271      stack. */
7272
7273   e = ffeexpr_expr_new_ ();
7274   e->type = FFEEXPR_exprtypeOPERAND_;
7275   e->token = ffeexpr_stack_->tokens[0];
7276   e->u.operand = ffebld_new_percent_loc (expr);
7277   ffebld_set_info (e->u.operand,
7278                    ffeinfo_new (FFEINFO_basictypeINTEGER,
7279                                 ffecom_pointer_kind (),
7280                                 0,
7281                                 FFEINFO_kindENTITY,
7282                                 FFEINFO_whereFLEETING,
7283                                 FFETARGET_charactersizeNONE));
7284 #if 0                           /* ~~ */
7285   e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7286 #endif
7287   ffeexpr_exprstack_push_operand_ (e);
7288
7289   /* Now, if the token is a close parenthese, we're in great shape so return
7290      the next handler. */
7291
7292   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7293     {
7294       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7295       return (ffelexHandler) ffeexpr_token_binary_;
7296     }
7297
7298   /* Oops, naughty user didn't specify the close paren! */
7299
7300   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7301     {
7302       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7303       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7304                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7305       ffebad_finish ();
7306     }
7307
7308   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7309   return
7310     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311                                                (ffelexHandler)
7312                                                ffeexpr_token_binary_);
7313 }
7314
7315 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7316
7317    Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
7318
7319 static ffelexHandler
7320 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7321 {
7322   ffeexprExpr_ e;
7323   ffebldOp op;
7324
7325   /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7326      such things until the lowest-level expression is reached.  */
7327
7328   op = ffebld_op (expr);
7329   if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7330       || (op == FFEBLD_opPERCENT_DESCR))
7331     {
7332       if (ffebad_start (FFEBAD_NESTED_PERCENT))
7333         {
7334           ffebad_here (0, ffelex_token_where_line (ft),
7335                        ffelex_token_where_column (ft));
7336           ffebad_finish ();
7337         }
7338
7339       do
7340         {
7341           expr = ffebld_left (expr);
7342           op = ffebld_op (expr);
7343         }
7344       while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7345              || (op == FFEBLD_opPERCENT_DESCR));
7346     }
7347
7348   /* Push the expression as an operand onto the expression stack. */
7349
7350   e = ffeexpr_expr_new_ ();
7351   e->type = FFEEXPR_exprtypeOPERAND_;
7352   e->token = ffeexpr_stack_->tokens[0];
7353   switch (ffeexpr_stack_->percent)
7354     {
7355     case FFEEXPR_percentVAL_:
7356       e->u.operand = ffebld_new_percent_val (expr);
7357       break;
7358
7359     case FFEEXPR_percentREF_:
7360       e->u.operand = ffebld_new_percent_ref (expr);
7361       break;
7362
7363     case FFEEXPR_percentDESCR_:
7364       e->u.operand = ffebld_new_percent_descr (expr);
7365       break;
7366
7367     default:
7368       assert ("%lossage" == NULL);
7369       e->u.operand = expr;
7370       break;
7371     }
7372   ffebld_set_info (e->u.operand, ffebld_info (expr));
7373 #if 0                           /* ~~ */
7374   e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7375 #endif
7376   ffeexpr_exprstack_push_operand_ (e);
7377
7378   /* Now, if the token is a close parenthese, we're in great shape so return
7379      the next handler. */
7380
7381   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7382     return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7383
7384   /* Oops, naughty user didn't specify the close paren! */
7385
7386   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7387     {
7388       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7389       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7390                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7391       ffebad_finish ();
7392     }
7393
7394   ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7395
7396   switch (ffeexpr_stack_->context)
7397     {
7398     case FFEEXPR_contextACTUALARG_:
7399       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7400       break;
7401
7402     case FFEEXPR_contextINDEXORACTUALARG_:
7403       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7404       break;
7405
7406     case FFEEXPR_contextSFUNCDEFACTUALARG_:
7407       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7408       break;
7409
7410     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7411       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7412       break;
7413
7414     default:
7415       assert ("bad context?!?!" == NULL);
7416       break;
7417     }
7418
7419   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7420   return
7421     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7422                                                (ffelexHandler)
7423                                                ffeexpr_cb_end_notloc_1_);
7424 }
7425
7426 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7427    CLOSE_PAREN
7428
7429    Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
7430
7431 static ffelexHandler
7432 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7433 {
7434   switch (ffelex_token_type (t))
7435     {
7436     case FFELEX_typeCOMMA:
7437     case FFELEX_typeCLOSE_PAREN:
7438       switch (ffeexpr_stack_->context)
7439         {
7440         case FFEEXPR_contextACTUALARG_:
7441         case FFEEXPR_contextSFUNCDEFACTUALARG_:
7442           break;
7443
7444         case FFEEXPR_contextINDEXORACTUALARG_:
7445           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7446           break;
7447
7448         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7449           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7450           break;
7451
7452         default:
7453           assert ("bad context?!?!" == NULL);
7454           break;
7455         }
7456       break;
7457
7458     default:
7459       if (ffebad_start (FFEBAD_INVALID_PERCENT))
7460         {
7461           ffebad_here (0,
7462                        ffelex_token_where_line (ffeexpr_stack_->first_token),
7463                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7464           ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7465           ffebad_finish ();
7466         }
7467
7468       ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7469                      FFEBLD_opPERCENT_LOC);
7470
7471       switch (ffeexpr_stack_->context)
7472         {
7473         case FFEEXPR_contextACTUALARG_:
7474           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7475           break;
7476
7477         case FFEEXPR_contextINDEXORACTUALARG_:
7478           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7479           break;
7480
7481         case FFEEXPR_contextSFUNCDEFACTUALARG_:
7482           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7483           break;
7484
7485         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7486           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7487           break;
7488
7489         default:
7490           assert ("bad context?!?!" == NULL);
7491           break;
7492         }
7493     }
7494
7495   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7496   return
7497     (ffelexHandler) ffeexpr_token_binary_ (t);
7498 }
7499
7500 /* Process DATA implied-DO iterator variables as this implied-DO level
7501    terminates.  At this point, ffeexpr_level_ == 1 when we see the
7502    last right-paren in "DATA (A(I),I=1,10)/.../".  */
7503
7504 static ffesymbol
7505 ffeexpr_check_impctrl_ (ffesymbol s)
7506 {
7507   assert (s != NULL);
7508   assert (ffesymbol_sfdummyparent (s) != NULL);
7509
7510   switch (ffesymbol_state (s))
7511     {
7512     case FFESYMBOL_stateNONE:   /* Used as iterator already. Now let symbol
7513                                    be used as iterator at any level at or
7514                                    innermore than the outermost of the
7515                                    current level and the symbol's current
7516                                    level. */
7517       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7518         {
7519           ffesymbol_signal_change (s);
7520           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7521           ffesymbol_signal_unreported (s);
7522         }
7523       break;
7524
7525     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
7526                                    Error if at outermost level, else it can
7527                                    still become an iterator. */
7528       if ((ffeexpr_level_ == 1)
7529           && ffebad_start (FFEBAD_BAD_IMPDCL))
7530         {
7531           ffebad_string (ffesymbol_text (s));
7532           ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7533           ffebad_finish ();
7534         }
7535       break;
7536
7537     case FFESYMBOL_stateUNCERTAIN:      /* Iterator. */
7538       assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7539       ffesymbol_signal_change (s);
7540       ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7541       ffesymbol_signal_unreported (s);
7542       break;
7543
7544     case FFESYMBOL_stateUNDERSTOOD:
7545       break;                    /* ANY. */
7546
7547     default:
7548       assert ("Sasha Foo!!" == NULL);
7549       break;
7550     }
7551
7552   return s;
7553 }
7554
7555 /* Issue diagnostic if implied-DO variable appears in list of lhs
7556    expressions (as in "READ *, (I,I=1,10)").  */
7557
7558 static void
7559 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7560                       ffebld dovar, ffelexToken dovar_t)
7561 {
7562   ffebld item;
7563   ffesymbol dovar_sym;
7564   int itemnum;
7565
7566   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7567     return;                     /* Presumably opANY. */
7568
7569   dovar_sym = ffebld_symter (dovar);
7570
7571   for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7572     {
7573       if (((item = ffebld_head (list)) != NULL)
7574           && (ffebld_op (item) == FFEBLD_opSYMTER)
7575           && (ffebld_symter (item) == dovar_sym))
7576         {
7577           char itemno[20];
7578
7579           sprintf (&itemno[0], "%d", itemnum);
7580           if (ffebad_start (FFEBAD_DOITER_IMPDO))
7581             {
7582               ffebad_here (0, ffelex_token_where_line (list_t),
7583                            ffelex_token_where_column (list_t));
7584               ffebad_here (1, ffelex_token_where_line (dovar_t),
7585                            ffelex_token_where_column (dovar_t));
7586               ffebad_string (ffesymbol_text (dovar_sym));
7587               ffebad_string (itemno);
7588               ffebad_finish ();
7589             }
7590         }
7591     }
7592 }
7593
7594 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7595    flag.  */
7596
7597 static void
7598 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7599 {
7600   ffesymbol dovar_sym;
7601
7602   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7603     return;                     /* Presumably opANY. */
7604
7605   dovar_sym = ffebld_symter (dovar);
7606
7607   ffeexpr_update_impdo_sym_ (list, dovar_sym);  /* Recurse! */
7608 }
7609
7610 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7611    if they refer to the given variable.  */
7612
7613 static void
7614 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7615 {
7616   tail_recurse:                 /* :::::::::::::::::::: */
7617
7618   if (expr == NULL)
7619     return;
7620
7621   switch (ffebld_op (expr))
7622     {
7623     case FFEBLD_opSYMTER:
7624       if (ffebld_symter (expr) == dovar)
7625         ffebld_symter_set_is_doiter (expr, TRUE);
7626       break;
7627
7628     case FFEBLD_opITEM:
7629       ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7630       expr = ffebld_trail (expr);
7631       goto tail_recurse;        /* :::::::::::::::::::: */
7632
7633     default:
7634       break;
7635     }
7636
7637   switch (ffebld_arity (expr))
7638     {
7639     case 2:
7640       ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7641       expr = ffebld_right (expr);
7642       goto tail_recurse;        /* :::::::::::::::::::: */
7643
7644     case 1:
7645       expr = ffebld_left (expr);
7646       goto tail_recurse;        /* :::::::::::::::::::: */
7647
7648     default:
7649       break;
7650     }
7651
7652   return;
7653 }
7654
7655 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7656
7657    if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7658        // After zero or more PAREN_ contexts, an IF context exists  */
7659
7660 static ffeexprContext
7661 ffeexpr_context_outer_ (ffeexprStack_ s)
7662 {
7663   assert (s != NULL);
7664
7665   for (;;)
7666     {
7667       switch (s->context)
7668         {
7669         case FFEEXPR_contextPAREN_:
7670         case FFEEXPR_contextPARENFILENUM_:
7671         case FFEEXPR_contextPARENFILEUNIT_:
7672           break;
7673
7674         default:
7675           return s->context;
7676         }
7677       s = s->previous;
7678       assert (s != NULL);
7679     }
7680 }
7681
7682 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7683
7684    ffeexprPercent_ p;
7685    ffelexToken t;
7686    p = ffeexpr_percent_(t);
7687
7688    Returns the identifier for the name, or the NONE identifier.  */
7689
7690 static ffeexprPercent_
7691 ffeexpr_percent_ (ffelexToken t)
7692 {
7693   const char *p;
7694
7695   switch (ffelex_token_length (t))
7696     {
7697     case 3:
7698       switch (*(p = ffelex_token_text (t)))
7699         {
7700         case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7701           if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7702               && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7703             return FFEEXPR_percentLOC_;
7704           return FFEEXPR_percentNONE_;
7705
7706         case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7707           if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7708               && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7709             return FFEEXPR_percentREF_;
7710           return FFEEXPR_percentNONE_;
7711
7712         case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7713           if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7714               && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7715             return FFEEXPR_percentVAL_;
7716           return FFEEXPR_percentNONE_;
7717
7718         default:
7719         no_match_3:             /* :::::::::::::::::::: */
7720           return FFEEXPR_percentNONE_;
7721         }
7722
7723     case 5:
7724       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7725                             "descr", "Descr") == 0)
7726         return FFEEXPR_percentDESCR_;
7727       return FFEEXPR_percentNONE_;
7728
7729     default:
7730       return FFEEXPR_percentNONE_;
7731     }
7732 }
7733
7734 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7735
7736    See prototype.
7737
7738    If combining the two basictype/kindtype pairs produces a COMPLEX with an
7739    unsupported kind type, complain and use the default kind type for
7740    COMPLEX.  */
7741
7742 void
7743 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7744                       ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7745                       ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7746                       ffelexToken t)
7747 {
7748   ffeinfoBasictype nbt;
7749   ffeinfoKindtype nkt;
7750
7751   nbt = ffeinfo_basictype_combine (lbt, rbt);
7752   if ((nbt == FFEINFO_basictypeCOMPLEX)
7753       && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7754       && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7755     {
7756       nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7757       if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7758         nkt = FFEINFO_kindtypeNONE;     /* Force error. */
7759       switch (nkt)
7760         {
7761 #if FFETARGET_okCOMPLEX1
7762         case FFEINFO_kindtypeREAL1:
7763 #endif
7764 #if FFETARGET_okCOMPLEX2
7765         case FFEINFO_kindtypeREAL2:
7766 #endif
7767 #if FFETARGET_okCOMPLEX3
7768         case FFEINFO_kindtypeREAL3:
7769 #endif
7770           break;                /* Fine and dandy. */
7771
7772         default:
7773           if (t != NULL)
7774             {
7775               ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7776                             ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7777               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7778               ffebad_finish ();
7779             }
7780           nbt = FFEINFO_basictypeNONE;
7781           nkt = FFEINFO_kindtypeNONE;
7782           break;
7783
7784         case FFEINFO_kindtypeANY:
7785           nkt = FFEINFO_kindtypeREALDEFAULT;
7786           break;
7787         }
7788     }
7789   else
7790     {                           /* The normal stuff. */
7791       if (nbt == lbt)
7792         {
7793           if (nbt == rbt)
7794             nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7795           else
7796             nkt = lkt;
7797         }
7798       else if (nbt == rbt)
7799         nkt = rkt;
7800       else
7801         {                       /* Let the caller do the complaining. */
7802           nbt = FFEINFO_basictypeNONE;
7803           nkt = FFEINFO_kindtypeNONE;
7804         }
7805     }
7806
7807   /* Always a good idea to avoid aliasing problems.  */
7808
7809   *xnbt = nbt;
7810   *xnkt = nkt;
7811 }
7812
7813 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7814
7815    Return a pointer to this function to the lexer (ffelex), which will
7816    invoke it for the next token.
7817
7818    Record line and column of first token in expression, then invoke the
7819    initial-state lhs handler.  */
7820
7821 static ffelexHandler
7822 ffeexpr_token_first_lhs_ (ffelexToken t)
7823 {
7824   ffeexpr_stack_->first_token = ffelex_token_use (t);
7825
7826   /* When changing the list of valid initial lhs tokens, check whether to
7827      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7828      READ (expr) <token> case -- it assumes it knows which tokens <token> can
7829      be to indicate an lhs (or implied DO), which right now is the set
7830      {NAME,OPEN_PAREN}.
7831
7832      This comment also appears in ffeexpr_token_lhs_. */
7833
7834   switch (ffelex_token_type (t))
7835     {
7836     case FFELEX_typeOPEN_PAREN:
7837       switch (ffeexpr_stack_->context)
7838         {
7839         case FFEEXPR_contextDATA:
7840           ffe_init_4 ();
7841           ffeexpr_level_ = 1;   /* Level of DATA implied-DO construct. */
7842           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7843           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7844                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7845
7846         case FFEEXPR_contextDATAIMPDOITEM_:
7847           ++ffeexpr_level_;     /* Level of DATA implied-DO construct. */
7848           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7849           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7850                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7851
7852         case FFEEXPR_contextIOLIST:
7853         case FFEEXPR_contextIMPDOITEM_:
7854           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7855           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7856                             FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7857
7858         case FFEEXPR_contextIOLISTDF:
7859         case FFEEXPR_contextIMPDOITEMDF_:
7860           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7861           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7862                           FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7863
7864         case FFEEXPR_contextFILEEXTFUNC:
7865           assert (ffeexpr_stack_->exprstack == NULL);
7866           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7867
7868         default:
7869           break;
7870         }
7871       break;
7872
7873     case FFELEX_typeNAME:
7874       switch (ffeexpr_stack_->context)
7875         {
7876         case FFEEXPR_contextFILENAMELIST:
7877           assert (ffeexpr_stack_->exprstack == NULL);
7878           return (ffelexHandler) ffeexpr_token_namelist_;
7879
7880         case FFEEXPR_contextFILEEXTFUNC:
7881           assert (ffeexpr_stack_->exprstack == NULL);
7882           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7883
7884         default:
7885           break;
7886         }
7887       break;
7888
7889     default:
7890       switch (ffeexpr_stack_->context)
7891         {
7892         case FFEEXPR_contextFILEEXTFUNC:
7893           assert (ffeexpr_stack_->exprstack == NULL);
7894           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7895
7896         default:
7897           break;
7898         }
7899       break;
7900     }
7901
7902   return (ffelexHandler) ffeexpr_token_lhs_ (t);
7903 }
7904
7905 /* ffeexpr_token_first_lhs_1_ -- NAME
7906
7907    return ffeexpr_token_first_lhs_1_;  // to lexer
7908
7909    Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7910    statement).  */
7911
7912 static ffelexHandler
7913 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7914 {
7915   ffeexprCallback callback;
7916   ffeexprStack_ s;
7917   ffelexHandler next;
7918   ffelexToken ft;
7919   ffesymbol sy = NULL;
7920   ffebld expr;
7921
7922   ffebld_pool_pop ();
7923   callback = ffeexpr_stack_->callback;
7924   ft = ffeexpr_stack_->first_token;
7925   s = ffeexpr_stack_->previous;
7926
7927   if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7928       || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7929           & FFESYMBOL_attrANY))
7930     {
7931       if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7932           || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7933         {
7934           ffebad_start (FFEBAD_EXPR_WRONG);
7935           ffebad_here (0, ffelex_token_where_line (ft),
7936                        ffelex_token_where_column (ft));
7937           ffebad_finish ();
7938         }
7939       expr = ffebld_new_any ();
7940       ffebld_set_info (expr, ffeinfo_new_any ());
7941     }
7942   else
7943     {
7944       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7945                                 FFEINTRIN_impNONE);
7946       ffebld_set_info (expr, ffesymbol_info (sy));
7947     }
7948
7949   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7950                   sizeof (*ffeexpr_stack_));
7951   ffeexpr_stack_ = s;
7952
7953   next = (ffelexHandler) (*callback) (ft, expr, t);
7954   ffelex_token_kill (ft);
7955   return (ffelexHandler) next;
7956 }
7957
7958 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7959
7960    Record line and column of first token in expression, then invoke the
7961    initial-state rhs handler.
7962
7963    19-Feb-91  JCB  1.1
7964       Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7965       (i.e. only as in READ(*), not READ((*))).  */
7966
7967 static ffelexHandler
7968 ffeexpr_token_first_rhs_ (ffelexToken t)
7969 {
7970   ffesymbol s;
7971
7972   ffeexpr_stack_->first_token = ffelex_token_use (t);
7973
7974   switch (ffelex_token_type (t))
7975     {
7976     case FFELEX_typeASTERISK:
7977       switch (ffeexpr_stack_->context)
7978         {
7979         case FFEEXPR_contextFILEFORMATNML:
7980           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7981           /* Fall through.  */
7982         case FFEEXPR_contextFILEUNIT:
7983         case FFEEXPR_contextDIMLIST:
7984         case FFEEXPR_contextFILEFORMAT:
7985         case FFEEXPR_contextCHARACTERSIZE:
7986           if (ffeexpr_stack_->previous != NULL)
7987             break;              /* Valid only on first level. */
7988           assert (ffeexpr_stack_->exprstack == NULL);
7989           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7990
7991         case FFEEXPR_contextPARENFILEUNIT_:
7992           if (ffeexpr_stack_->previous->previous != NULL)
7993             break;              /* Valid only on second level. */
7994           assert (ffeexpr_stack_->exprstack == NULL);
7995           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7996
7997         case FFEEXPR_contextACTUALARG_:
7998           if (ffeexpr_stack_->previous->context
7999               != FFEEXPR_contextSUBROUTINEREF)
8000             {
8001               ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8002               break;
8003             }
8004           assert (ffeexpr_stack_->exprstack == NULL);
8005           return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8006
8007         case FFEEXPR_contextINDEXORACTUALARG_:
8008           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8009           break;
8010
8011         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8012           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8013           break;
8014
8015         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8016           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8017           break;
8018
8019         default:
8020           break;
8021         }
8022       break;
8023
8024     case FFELEX_typeOPEN_PAREN:
8025       switch (ffeexpr_stack_->context)
8026         {
8027         case FFEEXPR_contextFILENUMAMBIG:
8028           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8029                                               FFEEXPR_contextPARENFILENUM_,
8030                                               ffeexpr_cb_close_paren_ambig_);
8031
8032         case FFEEXPR_contextFILEUNITAMBIG:
8033           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8034                                               FFEEXPR_contextPARENFILEUNIT_,
8035                                               ffeexpr_cb_close_paren_ambig_);
8036
8037         case FFEEXPR_contextIOLIST:
8038         case FFEEXPR_contextIMPDOITEM_:
8039           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8040                                               FFEEXPR_contextIMPDOITEM_,
8041                                               ffeexpr_cb_close_paren_ci_);
8042
8043         case FFEEXPR_contextIOLISTDF:
8044         case FFEEXPR_contextIMPDOITEMDF_:
8045           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8046                                               FFEEXPR_contextIMPDOITEMDF_,
8047                                               ffeexpr_cb_close_paren_ci_);
8048
8049         case FFEEXPR_contextFILEFORMATNML:
8050           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8051           break;
8052
8053         case FFEEXPR_contextACTUALARG_:
8054           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8055           break;
8056
8057         case FFEEXPR_contextINDEXORACTUALARG_:
8058           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8059           break;
8060
8061         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8062           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8063           break;
8064
8065         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8066           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8067           break;
8068
8069         default:
8070           break;
8071         }
8072       break;
8073
8074     case FFELEX_typeNUMBER:
8075       switch (ffeexpr_stack_->context)
8076         {
8077         case FFEEXPR_contextFILEFORMATNML:
8078           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8079           /* Fall through.  */
8080         case FFEEXPR_contextFILEFORMAT:
8081           if (ffeexpr_stack_->previous != NULL)
8082             break;              /* Valid only on first level. */
8083           assert (ffeexpr_stack_->exprstack == NULL);
8084           return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8085
8086         case FFEEXPR_contextACTUALARG_:
8087           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8088           break;
8089
8090         case FFEEXPR_contextINDEXORACTUALARG_:
8091           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8092           break;
8093
8094         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8095           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8096           break;
8097
8098         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8099           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8100           break;
8101
8102         default:
8103           break;
8104         }
8105       break;
8106
8107     case FFELEX_typeNAME:
8108       switch (ffeexpr_stack_->context)
8109         {
8110         case FFEEXPR_contextFILEFORMATNML:
8111           assert (ffeexpr_stack_->exprstack == NULL);
8112           s = ffesymbol_lookup_local (t);
8113           if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8114             return (ffelexHandler) ffeexpr_token_namelist_;
8115           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8116           break;
8117
8118         default:
8119           break;
8120         }
8121       break;
8122
8123     case FFELEX_typePERCENT:
8124       switch (ffeexpr_stack_->context)
8125         {
8126         case FFEEXPR_contextACTUALARG_:
8127         case FFEEXPR_contextINDEXORACTUALARG_:
8128         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8129         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8130           return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8131
8132         case FFEEXPR_contextFILEFORMATNML:
8133           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8134           break;
8135
8136         default:
8137           break;
8138         }
8139
8140     default:
8141       switch (ffeexpr_stack_->context)
8142         {
8143         case FFEEXPR_contextACTUALARG_:
8144           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8145           break;
8146
8147         case FFEEXPR_contextINDEXORACTUALARG_:
8148           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8149           break;
8150
8151         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8152           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8153           break;
8154
8155         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8156           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8157           break;
8158
8159         case FFEEXPR_contextFILEFORMATNML:
8160           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8161           break;
8162
8163         default:
8164           break;
8165         }
8166       break;
8167     }
8168
8169   return (ffelexHandler) ffeexpr_token_rhs_ (t);
8170 }
8171
8172 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8173
8174    return ffeexpr_token_first_rhs_1_;  // to lexer
8175
8176    Return STAR as expression.  */
8177
8178 static ffelexHandler
8179 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8180 {
8181   ffebld expr;
8182   ffeexprCallback callback;
8183   ffeexprStack_ s;
8184   ffelexHandler next;
8185   ffelexToken ft;
8186
8187   expr = ffebld_new_star ();
8188   ffebld_pool_pop ();
8189   callback = ffeexpr_stack_->callback;
8190   ft = ffeexpr_stack_->first_token;
8191   s = ffeexpr_stack_->previous;
8192   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8193   ffeexpr_stack_ = s;
8194   next = (ffelexHandler) (*callback) (ft, expr, t);
8195   ffelex_token_kill (ft);
8196   return (ffelexHandler) next;
8197 }
8198
8199 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8200
8201    return ffeexpr_token_first_rhs_2_;  // to lexer
8202
8203    Return NULL as expression; NUMBER as first (and only) token, unless the
8204    current token is not a terminating token, in which case run normal
8205    expression handling.  */
8206
8207 static ffelexHandler
8208 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8209 {
8210   ffeexprCallback callback;
8211   ffeexprStack_ s;
8212   ffelexHandler next;
8213   ffelexToken ft;
8214
8215   switch (ffelex_token_type (t))
8216     {
8217     case FFELEX_typeCLOSE_PAREN:
8218     case FFELEX_typeCOMMA:
8219     case FFELEX_typeEOS:
8220     case FFELEX_typeSEMICOLON:
8221       break;
8222
8223     default:
8224       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8225       return (ffelexHandler) (*next) (t);
8226     }
8227
8228   ffebld_pool_pop ();
8229   callback = ffeexpr_stack_->callback;
8230   ft = ffeexpr_stack_->first_token;
8231   s = ffeexpr_stack_->previous;
8232   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8233                   sizeof (*ffeexpr_stack_));
8234   ffeexpr_stack_ = s;
8235   next = (ffelexHandler) (*callback) (ft, NULL, t);
8236   ffelex_token_kill (ft);
8237   return (ffelexHandler) next;
8238 }
8239
8240 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8241
8242    return ffeexpr_token_first_rhs_3_;  // to lexer
8243
8244    Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8245    confirming, else NULL).  */
8246
8247 static ffelexHandler
8248 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8249 {
8250   ffelexHandler next;
8251
8252   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8253     {                           /* An error, but let normal processing handle
8254                                    it. */
8255       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8256       return (ffelexHandler) (*next) (t);
8257     }
8258
8259   /* Special case: when we see "*10" as an argument to a subroutine
8260      reference, we confirm the current statement and, if not inhibited at
8261      this point, put a copy of the token into a LABTOK node.  We do this
8262      instead of just resolving the label directly via ffelab and putting it
8263      into a LABTER simply to improve error reporting and consistency in
8264      ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
8265      doesn't have to worry about killing off any tokens when retracting. */
8266
8267   ffest_confirmed ();
8268   if (ffest_is_inhibited ())
8269     ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8270   else
8271     ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8272   ffebld_set_info (ffeexpr_stack_->expr,
8273                    ffeinfo_new (FFEINFO_basictypeNONE,
8274                                 FFEINFO_kindtypeNONE,
8275                                 0,
8276                                 FFEINFO_kindNONE,
8277                                 FFEINFO_whereNONE,
8278                                 FFETARGET_charactersizeNONE));
8279
8280   return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8281 }
8282
8283 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8284
8285    return ffeexpr_token_first_rhs_4_;  // to lexer
8286
8287    Collect/flush appropriate stuff, send token to callback function.  */
8288
8289 static ffelexHandler
8290 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8291 {
8292   ffebld expr;
8293   ffeexprCallback callback;
8294   ffeexprStack_ s;
8295   ffelexHandler next;
8296   ffelexToken ft;
8297
8298   expr = ffeexpr_stack_->expr;
8299   ffebld_pool_pop ();
8300   callback = ffeexpr_stack_->callback;
8301   ft = ffeexpr_stack_->first_token;
8302   s = ffeexpr_stack_->previous;
8303   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8304   ffeexpr_stack_ = s;
8305   next = (ffelexHandler) (*callback) (ft, expr, t);
8306   ffelex_token_kill (ft);
8307   return (ffelexHandler) next;
8308 }
8309
8310 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8311
8312    Should be NAME, or pass through original mechanism.  If NAME is LOC,
8313    pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8314    in which case handle the argument (in parentheses), etc.  */
8315
8316 static ffelexHandler
8317 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8318 {
8319   ffelexHandler next;
8320
8321   if (ffelex_token_type (t) == FFELEX_typeNAME)
8322     {
8323       ffeexprPercent_ p = ffeexpr_percent_ (t);
8324
8325       switch (p)
8326         {
8327         case FFEEXPR_percentNONE_:
8328         case FFEEXPR_percentLOC_:
8329           break;                /* Treat %LOC as any other expression. */
8330
8331         case FFEEXPR_percentVAL_:
8332         case FFEEXPR_percentREF_:
8333         case FFEEXPR_percentDESCR_:
8334           ffeexpr_stack_->percent = p;
8335           ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8336           return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8337
8338         default:
8339           assert ("bad percent?!?" == NULL);
8340           break;
8341         }
8342     }
8343
8344   switch (ffeexpr_stack_->context)
8345     {
8346     case FFEEXPR_contextACTUALARG_:
8347       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8348       break;
8349
8350     case FFEEXPR_contextINDEXORACTUALARG_:
8351       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8352       break;
8353
8354     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8355       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8356       break;
8357
8358     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8359       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8360       break;
8361
8362     default:
8363       assert ("bad context?!?!" == NULL);
8364       break;
8365     }
8366
8367   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8368   return (ffelexHandler) (*next) (t);
8369 }
8370
8371 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8372
8373    Should be OPEN_PAREN, or pass through original mechanism.  */
8374
8375 static ffelexHandler
8376 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8377 {
8378   ffelexHandler next;
8379   ffelexToken ft;
8380
8381   if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8382     {
8383       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8384       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8385                                           ffeexpr_stack_->context,
8386                                           ffeexpr_cb_end_notloc_);
8387     }
8388
8389   switch (ffeexpr_stack_->context)
8390     {
8391     case FFEEXPR_contextACTUALARG_:
8392       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8393       break;
8394
8395     case FFEEXPR_contextINDEXORACTUALARG_:
8396       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8397       break;
8398
8399     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8400       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8401       break;
8402
8403     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8404       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8405       break;
8406
8407     default:
8408       assert ("bad context?!?!" == NULL);
8409       break;
8410     }
8411
8412   ft = ffeexpr_stack_->tokens[0];
8413   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8414   next = (ffelexHandler) (*next) (ft);
8415   ffelex_token_kill (ft);
8416   return (ffelexHandler) (*next) (t);
8417 }
8418
8419 /* ffeexpr_token_namelist_ -- NAME
8420
8421    return ffeexpr_token_namelist_;  // to lexer
8422
8423    Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8424    return.  */
8425
8426 static ffelexHandler
8427 ffeexpr_token_namelist_ (ffelexToken t)
8428 {
8429   ffeexprCallback callback;
8430   ffeexprStack_ s;
8431   ffelexHandler next;
8432   ffelexToken ft;
8433   ffesymbol sy;
8434   ffebld expr;
8435
8436   ffebld_pool_pop ();
8437   callback = ffeexpr_stack_->callback;
8438   ft = ffeexpr_stack_->first_token;
8439   s = ffeexpr_stack_->previous;
8440   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8441   ffeexpr_stack_ = s;
8442
8443   sy = ffesymbol_lookup_local (ft);
8444   if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8445     {
8446       ffebad_start (FFEBAD_EXPR_WRONG);
8447       ffebad_here (0, ffelex_token_where_line (ft),
8448                    ffelex_token_where_column (ft));
8449       ffebad_finish ();
8450       expr = ffebld_new_any ();
8451       ffebld_set_info (expr, ffeinfo_new_any ());
8452     }
8453   else
8454     {
8455       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8456                                 FFEINTRIN_impNONE);
8457       ffebld_set_info (expr, ffesymbol_info (sy));
8458     }
8459   next = (ffelexHandler) (*callback) (ft, expr, t);
8460   ffelex_token_kill (ft);
8461   return (ffelexHandler) next;
8462 }
8463
8464 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8465
8466    ffeexprExpr_ e;
8467    ffeexpr_expr_kill_(e);
8468
8469    Kills the ffewhere info, if necessary, then kills the object.  */
8470
8471 static void
8472 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8473 {
8474   if (e->token != NULL)
8475     ffelex_token_kill (e->token);
8476   malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8477 }
8478
8479 /* ffeexpr_expr_new_ -- Make a new internal expression object
8480
8481    ffeexprExpr_ e;
8482    e = ffeexpr_expr_new_();
8483
8484    Allocates and initializes a new expression object, returns it.  */
8485
8486 static ffeexprExpr_
8487 ffeexpr_expr_new_ (void)
8488 {
8489   ffeexprExpr_ e;
8490
8491   e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
8492   e->previous = NULL;
8493   e->type = FFEEXPR_exprtypeUNKNOWN_;
8494   e->token = NULL;
8495   return e;
8496 }
8497
8498 /* Verify that call to global is valid, and register whatever
8499    new information about a global might be discoverable by looking
8500    at the call.  */
8501
8502 static void
8503 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
8504 {
8505   int n_args;
8506   ffebld list;
8507   ffebld item;
8508   ffesymbol s;
8509
8510   assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
8511           || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
8512
8513   if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
8514     return;
8515
8516   if (ffesymbol_retractable ())
8517     return;
8518
8519   s = ffebld_symter (ffebld_left (*expr));
8520   if (ffesymbol_global (s) == NULL)
8521     return;
8522
8523   for (n_args = 0, list = ffebld_right (*expr);
8524        list != NULL;
8525        list = ffebld_trail (list), ++n_args)
8526     ;
8527
8528   if (ffeglobal_proc_ref_nargs (s, n_args, t))
8529     {
8530       ffeglobalArgSummary as;
8531       ffeinfoBasictype bt;
8532       ffeinfoKindtype kt;
8533       bool array;
8534       bool fail = FALSE;
8535
8536       for (n_args = 0, list = ffebld_right (*expr);
8537            list != NULL;
8538            list = ffebld_trail (list), ++n_args)
8539         {
8540           item = ffebld_head (list);
8541           if (item != NULL)
8542             {
8543               bt = ffeinfo_basictype (ffebld_info (item));
8544               kt = ffeinfo_kindtype (ffebld_info (item));
8545               array = (ffeinfo_rank (ffebld_info (item)) > 0);
8546               switch (ffebld_op (item))
8547                 {
8548                 case FFEBLD_opLABTOK:
8549                 case FFEBLD_opLABTER:
8550                   as = FFEGLOBAL_argsummaryALTRTN;
8551                   break;
8552
8553 #if 0
8554                   /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8555                      expression, so don't treat it specially.  */
8556                 case FFEBLD_opPERCENT_LOC:
8557                   as = FFEGLOBAL_argsummaryPTR;
8558                   break;
8559 #endif
8560
8561                 case FFEBLD_opPERCENT_VAL:
8562                   as = FFEGLOBAL_argsummaryVAL;
8563                   break;
8564
8565                 case FFEBLD_opPERCENT_REF:
8566                   as = FFEGLOBAL_argsummaryREF;
8567                   break;
8568
8569                 case FFEBLD_opPERCENT_DESCR:
8570                   as = FFEGLOBAL_argsummaryDESCR;
8571                   break;
8572
8573                 case FFEBLD_opFUNCREF:
8574 #if 0
8575                   /* No, LOC(foo) is just like any INTEGER(KIND=7)
8576                      expression, so don't treat it specially.  */
8577                   if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
8578                       && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
8579                           == FFEINTRIN_specLOC))
8580                     {
8581                       as = FFEGLOBAL_argsummaryPTR;
8582                       break;
8583                     }
8584 #endif
8585                   /* Fall through.  */
8586                 default:
8587                   if (ffebld_op (item) == FFEBLD_opSYMTER)
8588                     {
8589                       as = FFEGLOBAL_argsummaryNONE;
8590
8591                       switch (ffeinfo_kind (ffebld_info (item)))
8592                         {
8593                         case FFEINFO_kindFUNCTION:
8594                           as = FFEGLOBAL_argsummaryFUNC;
8595                           break;
8596
8597                         case FFEINFO_kindSUBROUTINE:
8598                           as = FFEGLOBAL_argsummarySUBR;
8599                           break;
8600
8601                         case FFEINFO_kindNONE:
8602                           as = FFEGLOBAL_argsummaryPROC;
8603                           break;
8604
8605                         default:
8606                           break;
8607                         }
8608
8609                       if (as != FFEGLOBAL_argsummaryNONE)
8610                         break;
8611                     }
8612
8613                   if (bt == FFEINFO_basictypeCHARACTER)
8614                     as = FFEGLOBAL_argsummaryDESCR;
8615                   else
8616                     as = FFEGLOBAL_argsummaryREF;
8617                   break;
8618                 }
8619             }
8620           else
8621             {
8622               array = FALSE;
8623               as = FFEGLOBAL_argsummaryNONE;
8624               bt = FFEINFO_basictypeNONE;
8625               kt = FFEINFO_kindtypeNONE;
8626             }
8627
8628           if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
8629             fail = TRUE;
8630         }
8631       if (! fail)
8632         return;
8633     }
8634
8635   *expr = ffebld_new_any ();
8636   ffebld_set_info (*expr, ffeinfo_new_any ());
8637 }
8638
8639 /* Check whether rest of string is all decimal digits.  */
8640
8641 static bool
8642 ffeexpr_isdigits_ (const char *p)
8643 {
8644   for (; *p != '\0'; ++p)
8645     if (! ISDIGIT (*p))
8646       return FALSE;
8647   return TRUE;
8648 }
8649
8650 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8651
8652    ffeexprExpr_ e;
8653    ffeexpr_exprstack_push_(e);
8654
8655    Pushes the expression onto the stack without any analysis of the existing
8656    contents of the stack.  */
8657
8658 static void
8659 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
8660 {
8661   e->previous = ffeexpr_stack_->exprstack;
8662   ffeexpr_stack_->exprstack = e;
8663 }
8664
8665 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8666
8667    ffeexprExpr_ e;
8668    ffeexpr_exprstack_push_operand_(e);
8669
8670    Pushes the expression already containing an operand (a constant, variable,
8671    or more complicated expression that has already been fully resolved) after
8672    analyzing the stack and checking for possible reduction (which will never
8673    happen here since the highest precedence operator is ** and it has right-
8674    to-left associativity).  */
8675
8676 static void
8677 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
8678 {
8679   ffeexpr_exprstack_push_ (e);
8680 }
8681
8682 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8683
8684    ffeexprExpr_ e;
8685    ffeexpr_exprstack_push_unary_(e);
8686
8687    Pushes the expression already containing a unary operator.  Reduction can
8688    never happen since unary operators are themselves always R-L; that is, the
8689    top of the expression stack is not an operand, in that it is either empty,
8690    has a binary operator at the top, or a unary operator at the top.  In any
8691    of these cases, reduction is impossible.  */
8692
8693 static void
8694 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
8695 {
8696   if ((ffe_is_pedantic ()
8697        || ffe_is_warn_surprising ())
8698       && (ffeexpr_stack_->exprstack != NULL)
8699       && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
8700       && (ffeexpr_stack_->exprstack->u.operator.prec
8701           <= FFEEXPR_operatorprecedenceLOWARITH_)
8702       && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
8703     {
8704       /* xgettext:no-c-format */
8705       ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8706                         ffe_is_pedantic ()
8707                         ? FFEBAD_severityPEDANTIC
8708                         : FFEBAD_severityWARNING);
8709       ffebad_here (0,
8710                   ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
8711                ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
8712       ffebad_here (1,
8713                    ffelex_token_where_line (e->token),
8714                    ffelex_token_where_column (e->token));
8715       ffebad_finish ();
8716     }
8717
8718   ffeexpr_exprstack_push_ (e);
8719 }
8720
8721 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8722
8723    ffeexprExpr_ e;
8724    ffeexpr_exprstack_push_binary_(e);
8725
8726    Pushes the expression already containing a binary operator after checking
8727    whether reduction is possible.  If the stack is not empty, the top of the
8728    stack must be an operand or syntactic analysis has failed somehow.  If
8729    the operand is preceded by a unary operator of higher (or equal and L-R
8730    associativity) precedence than the new binary operator, then reduce that
8731    preceding operator and its operand(s) before pushing the new binary
8732    operator.  */
8733
8734 static void
8735 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
8736 {
8737   ffeexprExpr_ ce;
8738
8739   if (ffe_is_warn_surprising ()
8740       /* These next two are always true (see assertions below).  */
8741       && (ffeexpr_stack_->exprstack != NULL)
8742       && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
8743       /* If the previous operator is a unary minus, and the binary op
8744          is of higher precedence, might not do what user expects,
8745          e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8746          yield "4".  */
8747       && (ffeexpr_stack_->exprstack->previous != NULL)
8748       && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
8749       && (ffeexpr_stack_->exprstack->previous->u.operator.op
8750           == FFEEXPR_operatorSUBTRACT_)
8751       && (e->u.operator.prec
8752           < ffeexpr_stack_->exprstack->previous->u.operator.prec))
8753     {
8754       /* xgettext:no-c-format */
8755       ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
8756       ffebad_here (0,
8757          ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
8758       ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
8759       ffebad_here (1,
8760                    ffelex_token_where_line (e->token),
8761                    ffelex_token_where_column (e->token));
8762       ffebad_finish ();
8763     }
8764
8765 again:
8766   assert (ffeexpr_stack_->exprstack != NULL);
8767   assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
8768   if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
8769     {
8770       assert (ce->type != FFEEXPR_exprtypeOPERAND_);
8771       if ((ce->u.operator.prec < e->u.operator.prec)
8772           || ((ce->u.operator.prec == e->u.operator.prec)
8773               && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
8774         {
8775           ffeexpr_reduce_ ();
8776           goto again;   /* :::::::::::::::::::: */
8777         }
8778     }
8779
8780   ffeexpr_exprstack_push_ (e);
8781 }
8782
8783 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8784
8785    ffeexpr_reduce_();
8786
8787    Converts operand binop operand or unop operand at top of stack to a
8788    single operand having the appropriate ffebld expression, and makes
8789    sure that the expression is proper (like not trying to add two character
8790    variables, not trying to concatenate two numbers).  Also does the
8791    requisite type-assignment.  */
8792
8793 static void
8794 ffeexpr_reduce_ (void)
8795 {
8796   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
8797   ffeexprExpr_ left_operand;    /* When operator is binary, this is A in A+B. */
8798   ffeexprExpr_ operator;        /* This is + in A+B. */
8799   ffebld reduced;               /* This is +(A,B) in A+B or u-(B) in -B. */
8800   ffebldConstant constnode;     /* For checking magical numbers (where mag ==
8801                                    -mag). */
8802   ffebld expr;
8803   ffebld left_expr;
8804   bool submag = FALSE;
8805
8806   operand = ffeexpr_stack_->exprstack;
8807   assert (operand != NULL);
8808   assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8809   operator = operand->previous;
8810   assert (operator != NULL);
8811   assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8812   if (operator->type == FFEEXPR_exprtypeUNARY_)
8813     {
8814       expr = operand->u.operand;
8815       switch (operator->u.operator.op)
8816         {
8817         case FFEEXPR_operatorADD_:
8818           reduced = ffebld_new_uplus (expr);
8819           if (ffe_is_ugly_logint ())
8820             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8821           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8822           reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8823           break;
8824
8825         case FFEEXPR_operatorSUBTRACT_:
8826           submag = TRUE;        /* Ok to negate a magic number. */
8827           reduced = ffebld_new_uminus (expr);
8828           if (ffe_is_ugly_logint ())
8829             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8830           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8831           reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8832           break;
8833
8834         case FFEEXPR_operatorNOT_:
8835           reduced = ffebld_new_not (expr);
8836           if (ffe_is_ugly_logint ())
8837             reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8838           reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8839           reduced = ffeexpr_collapse_not (reduced, operator->token);
8840           break;
8841
8842         default:
8843           assert ("unexpected unary op" != NULL);
8844           reduced = NULL;
8845           break;
8846         }
8847       if (!submag
8848           && (ffebld_op (expr) == FFEBLD_opCONTER)
8849           && (ffebld_conter_orig (expr) == NULL)
8850           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8851         {
8852           ffetarget_integer_bad_magical (operand->token);
8853         }
8854       ffeexpr_stack_->exprstack = operator->previous;   /* Pops unary-op operand
8855                                                            off stack. */
8856       ffeexpr_expr_kill_ (operand);
8857       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
8858                                                            save */
8859       operator->u.operand = reduced;    /* the line/column ffewhere info. */
8860       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
8861                                                            stack. */
8862     }
8863   else
8864     {
8865       assert (operator->type == FFEEXPR_exprtypeBINARY_);
8866       left_operand = operator->previous;
8867       assert (left_operand != NULL);
8868       assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8869       expr = operand->u.operand;
8870       left_expr = left_operand->u.operand;
8871       switch (operator->u.operator.op)
8872         {
8873         case FFEEXPR_operatorADD_:
8874           reduced = ffebld_new_add (left_expr, expr);
8875           if (ffe_is_ugly_logint ())
8876             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8877                                               operand);
8878           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8879                                             operand);
8880           reduced = ffeexpr_collapse_add (reduced, operator->token);
8881           break;
8882
8883         case FFEEXPR_operatorSUBTRACT_:
8884           submag = TRUE;        /* Just to pick the right error if magic
8885                                    number. */
8886           reduced = ffebld_new_subtract (left_expr, expr);
8887           if (ffe_is_ugly_logint ())
8888             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8889                                               operand);
8890           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8891                                             operand);
8892           reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8893           break;
8894
8895         case FFEEXPR_operatorMULTIPLY_:
8896           reduced = ffebld_new_multiply (left_expr, expr);
8897           if (ffe_is_ugly_logint ())
8898             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8899                                               operand);
8900           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8901                                             operand);
8902           reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8903           break;
8904
8905         case FFEEXPR_operatorDIVIDE_:
8906           reduced = ffebld_new_divide (left_expr, expr);
8907           if (ffe_is_ugly_logint ())
8908             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8909                                               operand);
8910           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8911                                             operand);
8912           reduced = ffeexpr_collapse_divide (reduced, operator->token);
8913           break;
8914
8915         case FFEEXPR_operatorPOWER_:
8916           reduced = ffebld_new_power (left_expr, expr);
8917           if (ffe_is_ugly_logint ())
8918             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8919                                               operand);
8920           reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8921                                             operand);
8922           reduced = ffeexpr_collapse_power (reduced, operator->token);
8923           break;
8924
8925         case FFEEXPR_operatorCONCATENATE_:
8926           reduced = ffebld_new_concatenate (left_expr, expr);
8927           reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8928                                                   operand);
8929           reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8930           break;
8931
8932         case FFEEXPR_operatorLT_:
8933           reduced = ffebld_new_lt (left_expr, expr);
8934           if (ffe_is_ugly_logint ())
8935             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8936                                               operand);
8937           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8938                                              operand);
8939           reduced = ffeexpr_collapse_lt (reduced, operator->token);
8940           break;
8941
8942         case FFEEXPR_operatorLE_:
8943           reduced = ffebld_new_le (left_expr, expr);
8944           if (ffe_is_ugly_logint ())
8945             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8946                                               operand);
8947           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8948                                              operand);
8949           reduced = ffeexpr_collapse_le (reduced, operator->token);
8950           break;
8951
8952         case FFEEXPR_operatorEQ_:
8953           reduced = ffebld_new_eq (left_expr, expr);
8954           if (ffe_is_ugly_logint ())
8955             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8956                                               operand);
8957           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8958                                             operand);
8959           reduced = ffeexpr_collapse_eq (reduced, operator->token);
8960           break;
8961
8962         case FFEEXPR_operatorNE_:
8963           reduced = ffebld_new_ne (left_expr, expr);
8964           if (ffe_is_ugly_logint ())
8965             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8966                                               operand);
8967           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8968                                             operand);
8969           reduced = ffeexpr_collapse_ne (reduced, operator->token);
8970           break;
8971
8972         case FFEEXPR_operatorGT_:
8973           reduced = ffebld_new_gt (left_expr, expr);
8974           if (ffe_is_ugly_logint ())
8975             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8976                                               operand);
8977           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8978                                              operand);
8979           reduced = ffeexpr_collapse_gt (reduced, operator->token);
8980           break;
8981
8982         case FFEEXPR_operatorGE_:
8983           reduced = ffebld_new_ge (left_expr, expr);
8984           if (ffe_is_ugly_logint ())
8985             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8986                                               operand);
8987           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8988                                              operand);
8989           reduced = ffeexpr_collapse_ge (reduced, operator->token);
8990           break;
8991
8992         case FFEEXPR_operatorAND_:
8993           reduced = ffebld_new_and (left_expr, expr);
8994           if (ffe_is_ugly_logint ())
8995             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8996                                                  operand);
8997           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
8998                                             operand);
8999           reduced = ffeexpr_collapse_and (reduced, operator->token);
9000           break;
9001
9002         case FFEEXPR_operatorOR_:
9003           reduced = ffebld_new_or (left_expr, expr);
9004           if (ffe_is_ugly_logint ())
9005             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9006                                                  operand);
9007           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9008                                             operand);
9009           reduced = ffeexpr_collapse_or (reduced, operator->token);
9010           break;
9011
9012         case FFEEXPR_operatorXOR_:
9013           reduced = ffebld_new_xor (left_expr, expr);
9014           if (ffe_is_ugly_logint ())
9015             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9016                                                  operand);
9017           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9018                                             operand);
9019           reduced = ffeexpr_collapse_xor (reduced, operator->token);
9020           break;
9021
9022         case FFEEXPR_operatorEQV_:
9023           reduced = ffebld_new_eqv (left_expr, expr);
9024           if (ffe_is_ugly_logint ())
9025             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9026                                                  operand);
9027           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9028                                             operand);
9029           reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9030           break;
9031
9032         case FFEEXPR_operatorNEQV_:
9033           reduced = ffebld_new_neqv (left_expr, expr);
9034           if (ffe_is_ugly_logint ())
9035             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9036                                                  operand);
9037           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9038                                             operand);
9039           reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9040           break;
9041
9042         default:
9043           assert ("bad bin op" == NULL);
9044           reduced = expr;
9045           break;
9046         }
9047       if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9048           && (ffebld_conter_orig (expr) == NULL)
9049       && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9050         {
9051           if ((left_operand->previous != NULL)
9052               && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9053               && (left_operand->previous->u.operator.op
9054                   == FFEEXPR_operatorSUBTRACT_))
9055             {
9056               if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9057                 ffetarget_integer_bad_magical_precedence (left_operand->token,
9058                                                           left_operand->previous->token,
9059                                                           operator->token);
9060               else
9061                 ffetarget_integer_bad_magical_precedence_binary
9062                   (left_operand->token,
9063                    left_operand->previous->token,
9064                    operator->token);
9065             }
9066           else
9067             ffetarget_integer_bad_magical (left_operand->token);
9068         }
9069       if ((ffebld_op (expr) == FFEBLD_opCONTER)
9070           && (ffebld_conter_orig (expr) == NULL)
9071           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9072         {
9073           if (submag)
9074             ffetarget_integer_bad_magical_binary (operand->token,
9075                                                   operator->token);
9076           else
9077             ffetarget_integer_bad_magical (operand->token);
9078         }
9079       ffeexpr_stack_->exprstack = left_operand->previous;       /* Pops binary-op
9080                                                                    operands off stack. */
9081       ffeexpr_expr_kill_ (left_operand);
9082       ffeexpr_expr_kill_ (operand);
9083       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
9084                                                            save */
9085       operator->u.operand = reduced;    /* the line/column ffewhere info. */
9086       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
9087                                                            stack. */
9088     }
9089 }
9090
9091 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9092
9093    reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9094
9095    Makes sure the argument for reduced has basictype of
9096    LOGICAL or (ugly) INTEGER.  If
9097    argument has where of CONSTANT, assign where CONSTANT to
9098    reduced, else assign where FLEETING.
9099
9100    If these requirements cannot be met, generate error message.  */
9101
9102 static ffebld
9103 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9104 {
9105   ffeinfo rinfo, ninfo;
9106   ffeinfoBasictype rbt;
9107   ffeinfoKindtype rkt;
9108   ffeinfoRank rrk;
9109   ffeinfoKind rkd;
9110   ffeinfoWhere rwh, nwh;
9111
9112   rinfo = ffebld_info (ffebld_left (reduced));
9113   rbt = ffeinfo_basictype (rinfo);
9114   rkt = ffeinfo_kindtype (rinfo);
9115   rrk = ffeinfo_rank (rinfo);
9116   rkd = ffeinfo_kind (rinfo);
9117   rwh = ffeinfo_where (rinfo);
9118
9119   if (((rbt == FFEINFO_basictypeLOGICAL)
9120        || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9121       && (rrk == 0))
9122     {
9123       switch (rwh)
9124         {
9125         case FFEINFO_whereCONSTANT:
9126           nwh = FFEINFO_whereCONSTANT;
9127           break;
9128
9129         case FFEINFO_whereIMMEDIATE:
9130           nwh = FFEINFO_whereIMMEDIATE;
9131           break;
9132
9133         default:
9134           nwh = FFEINFO_whereFLEETING;
9135           break;
9136         }
9137
9138       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9139                            FFETARGET_charactersizeNONE);
9140       ffebld_set_info (reduced, ninfo);
9141       return reduced;
9142     }
9143
9144   if ((rbt != FFEINFO_basictypeLOGICAL)
9145       && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9146     {
9147       if ((rbt != FFEINFO_basictypeANY)
9148           && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9149         {
9150           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9151           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9152           ffebad_finish ();
9153         }
9154     }
9155   else
9156     {
9157       if ((rkd != FFEINFO_kindANY)
9158           && ffebad_start (FFEBAD_NOT_ARG_KIND))
9159         {
9160           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9161           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9162           ffebad_string ("an array");
9163           ffebad_finish ();
9164         }
9165     }
9166
9167   reduced = ffebld_new_any ();
9168   ffebld_set_info (reduced, ffeinfo_new_any ());
9169   return reduced;
9170 }
9171
9172 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9173
9174    reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9175
9176    Makes sure the left and right arguments for reduced have basictype of
9177    LOGICAL or (ugly) INTEGER.  Determine common basictype and
9178    size for reduction (flag expression for combined hollerith/typeless
9179    situations for later determination of effective basictype).  If both left
9180    and right arguments have where of CONSTANT, assign where CONSTANT to
9181    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9182    needed.  Convert typeless
9183    constants to the desired type/size explicitly.
9184
9185    If these requirements cannot be met, generate error message.  */
9186
9187 static ffebld
9188 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9189                         ffeexprExpr_ r)
9190 {
9191   ffeinfo linfo, rinfo, ninfo;
9192   ffeinfoBasictype lbt, rbt, nbt;
9193   ffeinfoKindtype lkt, rkt, nkt;
9194   ffeinfoRank lrk, rrk;
9195   ffeinfoKind lkd, rkd;
9196   ffeinfoWhere lwh, rwh, nwh;
9197
9198   linfo = ffebld_info (ffebld_left (reduced));
9199   lbt = ffeinfo_basictype (linfo);
9200   lkt = ffeinfo_kindtype (linfo);
9201   lrk = ffeinfo_rank (linfo);
9202   lkd = ffeinfo_kind (linfo);
9203   lwh = ffeinfo_where (linfo);
9204
9205   rinfo = ffebld_info (ffebld_right (reduced));
9206   rbt = ffeinfo_basictype (rinfo);
9207   rkt = ffeinfo_kindtype (rinfo);
9208   rrk = ffeinfo_rank (rinfo);
9209   rkd = ffeinfo_kind (rinfo);
9210   rwh = ffeinfo_where (rinfo);
9211
9212   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9213
9214   if (((nbt == FFEINFO_basictypeLOGICAL)
9215        || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9216       && (lrk == 0) && (rrk == 0))
9217     {
9218       switch (lwh)
9219         {
9220         case FFEINFO_whereCONSTANT:
9221           switch (rwh)
9222             {
9223             case FFEINFO_whereCONSTANT:
9224               nwh = FFEINFO_whereCONSTANT;
9225               break;
9226
9227             case FFEINFO_whereIMMEDIATE:
9228               nwh = FFEINFO_whereIMMEDIATE;
9229               break;
9230
9231             default:
9232               nwh = FFEINFO_whereFLEETING;
9233               break;
9234             }
9235           break;
9236
9237         case FFEINFO_whereIMMEDIATE:
9238           switch (rwh)
9239             {
9240             case FFEINFO_whereCONSTANT:
9241             case FFEINFO_whereIMMEDIATE:
9242               nwh = FFEINFO_whereIMMEDIATE;
9243               break;
9244
9245             default:
9246               nwh = FFEINFO_whereFLEETING;
9247               break;
9248             }
9249           break;
9250
9251         default:
9252           nwh = FFEINFO_whereFLEETING;
9253           break;
9254         }
9255
9256       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9257                            FFETARGET_charactersizeNONE);
9258       ffebld_set_info (reduced, ninfo);
9259       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9260               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9261                                                  FFEEXPR_contextLET));
9262       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9263               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9264                                                   FFEEXPR_contextLET));
9265       return reduced;
9266     }
9267
9268   if ((lbt != FFEINFO_basictypeLOGICAL)
9269       && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9270     {
9271       if ((rbt != FFEINFO_basictypeLOGICAL)
9272           && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9273         {
9274           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9275               && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9276             {
9277               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9278               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9279               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9280               ffebad_finish ();
9281             }
9282         }
9283       else
9284         {
9285           if ((lbt != FFEINFO_basictypeANY)
9286               && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9287             {
9288               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9289               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9290               ffebad_finish ();
9291             }
9292         }
9293     }
9294   else if ((rbt != FFEINFO_basictypeLOGICAL)
9295            && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9296     {
9297       if ((rbt != FFEINFO_basictypeANY)
9298           && ffebad_start (FFEBAD_BOOL_ARG_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 (r->token), ffelex_token_where_column (r->token));
9302           ffebad_finish ();
9303         }
9304     }
9305   else if (lrk != 0)
9306     {
9307       if ((lkd != FFEINFO_kindANY)
9308           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9309         {
9310           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9311           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9312           ffebad_string ("an array");
9313           ffebad_finish ();
9314         }
9315     }
9316   else
9317     {
9318       if ((rkd != FFEINFO_kindANY)
9319           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9320         {
9321           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9322           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9323           ffebad_string ("an array");
9324           ffebad_finish ();
9325         }
9326     }
9327
9328   reduced = ffebld_new_any ();
9329   ffebld_set_info (reduced, ffeinfo_new_any ());
9330   return reduced;
9331 }
9332
9333 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9334
9335    reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9336
9337    Makes sure the left and right arguments for reduced have basictype of
9338    CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
9339    basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
9340    size of concatenation and assign that size to reduced.  If both left and
9341    right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9342    else assign where FLEETING.
9343
9344    If these requirements cannot be met, generate error message using the
9345    info in l, op, and r arguments and assign basictype, size, kind, and where
9346    of ANY.  */
9347
9348 static ffebld
9349 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9350                               ffeexprExpr_ r)
9351 {
9352   ffeinfo linfo, rinfo, ninfo;
9353   ffeinfoBasictype lbt, rbt, nbt;
9354   ffeinfoKindtype lkt, rkt, nkt;
9355   ffeinfoRank lrk, rrk;
9356   ffeinfoKind lkd, rkd, nkd;
9357   ffeinfoWhere lwh, rwh, nwh;
9358   ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9359
9360   linfo = ffebld_info (ffebld_left (reduced));
9361   lbt = ffeinfo_basictype (linfo);
9362   lkt = ffeinfo_kindtype (linfo);
9363   lrk = ffeinfo_rank (linfo);
9364   lkd = ffeinfo_kind (linfo);
9365   lwh = ffeinfo_where (linfo);
9366   lszk = ffeinfo_size (linfo);  /* Known size. */
9367   lszm = ffebld_size_max (ffebld_left (reduced));
9368
9369   rinfo = ffebld_info (ffebld_right (reduced));
9370   rbt = ffeinfo_basictype (rinfo);
9371   rkt = ffeinfo_kindtype (rinfo);
9372   rrk = ffeinfo_rank (rinfo);
9373   rkd = ffeinfo_kind (rinfo);
9374   rwh = ffeinfo_where (rinfo);
9375   rszk = ffeinfo_size (rinfo);  /* Known size. */
9376   rszm = ffebld_size_max (ffebld_right (reduced));
9377
9378   if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9379       && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9380       && (((lszm != FFETARGET_charactersizeNONE)
9381            && (rszm != FFETARGET_charactersizeNONE))
9382           || (ffeexpr_context_outer_ (ffeexpr_stack_)
9383               == FFEEXPR_contextLET)
9384           || (ffeexpr_context_outer_ (ffeexpr_stack_)
9385               == FFEEXPR_contextSFUNCDEF)))
9386     {
9387       nbt = FFEINFO_basictypeCHARACTER;
9388       nkd = FFEINFO_kindENTITY;
9389       if ((lszk == FFETARGET_charactersizeNONE)
9390           || (rszk == FFETARGET_charactersizeNONE))
9391         nszk = FFETARGET_charactersizeNONE;     /* Ok only in rhs of LET
9392                                                    stmt. */
9393       else
9394         nszk = lszk + rszk;
9395
9396       switch (lwh)
9397         {
9398         case FFEINFO_whereCONSTANT:
9399           switch (rwh)
9400             {
9401             case FFEINFO_whereCONSTANT:
9402               nwh = FFEINFO_whereCONSTANT;
9403               break;
9404
9405             case FFEINFO_whereIMMEDIATE:
9406               nwh = FFEINFO_whereIMMEDIATE;
9407               break;
9408
9409             default:
9410               nwh = FFEINFO_whereFLEETING;
9411               break;
9412             }
9413           break;
9414
9415         case FFEINFO_whereIMMEDIATE:
9416           switch (rwh)
9417             {
9418             case FFEINFO_whereCONSTANT:
9419             case FFEINFO_whereIMMEDIATE:
9420               nwh = FFEINFO_whereIMMEDIATE;
9421               break;
9422
9423             default:
9424               nwh = FFEINFO_whereFLEETING;
9425               break;
9426             }
9427           break;
9428
9429         default:
9430           nwh = FFEINFO_whereFLEETING;
9431           break;
9432         }
9433
9434       nkt = lkt;
9435       ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9436       ffebld_set_info (reduced, ninfo);
9437       return reduced;
9438     }
9439
9440   if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9441     {
9442       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9443           && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9444         {
9445           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9446           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9447           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9448           ffebad_finish ();
9449         }
9450     }
9451   else if (lbt != FFEINFO_basictypeCHARACTER)
9452     {
9453       if ((lbt != FFEINFO_basictypeANY)
9454           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9455         {
9456           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9457           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9458           ffebad_finish ();
9459         }
9460     }
9461   else if (rbt != FFEINFO_basictypeCHARACTER)
9462     {
9463       if ((rbt != FFEINFO_basictypeANY)
9464           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9465         {
9466           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9467           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9468           ffebad_finish ();
9469         }
9470     }
9471   else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9472     {
9473       if ((lkd != FFEINFO_kindANY)
9474           && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9475         {
9476           const char *what;
9477
9478           if (lrk != 0)
9479             what = "an array";
9480           else
9481             what = "of indeterminate length";
9482           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9483           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9484           ffebad_string (what);
9485           ffebad_finish ();
9486         }
9487     }
9488   else
9489     {
9490       if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9491         {
9492           const char *what;
9493
9494           if (rrk != 0)
9495             what = "an array";
9496           else
9497             what = "of indeterminate length";
9498           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9499           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9500           ffebad_string (what);
9501           ffebad_finish ();
9502         }
9503     }
9504
9505   reduced = ffebld_new_any ();
9506   ffebld_set_info (reduced, ffeinfo_new_any ());
9507   return reduced;
9508 }
9509
9510 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9511
9512    reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9513
9514    Makes sure the left and right arguments for reduced have basictype of
9515    INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
9516    size for reduction.  If both left
9517    and right arguments have where of CONSTANT, assign where CONSTANT to
9518    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9519    needed.  Convert typeless
9520    constants to the desired type/size explicitly.
9521
9522    If these requirements cannot be met, generate error message.  */
9523
9524 static ffebld
9525 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9526                         ffeexprExpr_ r)
9527 {
9528   ffeinfo linfo, rinfo, ninfo;
9529   ffeinfoBasictype lbt, rbt, nbt;
9530   ffeinfoKindtype lkt, rkt, nkt;
9531   ffeinfoRank lrk, rrk;
9532   ffeinfoKind lkd, rkd;
9533   ffeinfoWhere lwh, rwh, nwh;
9534   ffetargetCharacterSize lsz, rsz;
9535
9536   linfo = ffebld_info (ffebld_left (reduced));
9537   lbt = ffeinfo_basictype (linfo);
9538   lkt = ffeinfo_kindtype (linfo);
9539   lrk = ffeinfo_rank (linfo);
9540   lkd = ffeinfo_kind (linfo);
9541   lwh = ffeinfo_where (linfo);
9542   lsz = ffebld_size_known (ffebld_left (reduced));
9543
9544   rinfo = ffebld_info (ffebld_right (reduced));
9545   rbt = ffeinfo_basictype (rinfo);
9546   rkt = ffeinfo_kindtype (rinfo);
9547   rrk = ffeinfo_rank (rinfo);
9548   rkd = ffeinfo_kind (rinfo);
9549   rwh = ffeinfo_where (rinfo);
9550   rsz = ffebld_size_known (ffebld_right (reduced));
9551
9552   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9553
9554   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9555        || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9556       && (lrk == 0) && (rrk == 0))
9557     {
9558       switch (lwh)
9559         {
9560         case FFEINFO_whereCONSTANT:
9561           switch (rwh)
9562             {
9563             case FFEINFO_whereCONSTANT:
9564               nwh = FFEINFO_whereCONSTANT;
9565               break;
9566
9567             case FFEINFO_whereIMMEDIATE:
9568               nwh = FFEINFO_whereIMMEDIATE;
9569               break;
9570
9571             default:
9572               nwh = FFEINFO_whereFLEETING;
9573               break;
9574             }
9575           break;
9576
9577         case FFEINFO_whereIMMEDIATE:
9578           switch (rwh)
9579             {
9580             case FFEINFO_whereCONSTANT:
9581             case FFEINFO_whereIMMEDIATE:
9582               nwh = FFEINFO_whereIMMEDIATE;
9583               break;
9584
9585             default:
9586               nwh = FFEINFO_whereFLEETING;
9587               break;
9588             }
9589           break;
9590
9591         default:
9592           nwh = FFEINFO_whereFLEETING;
9593           break;
9594         }
9595
9596       if ((lsz != FFETARGET_charactersizeNONE)
9597           && (rsz != FFETARGET_charactersizeNONE))
9598         lsz = rsz = (lsz > rsz) ? lsz : rsz;
9599
9600       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9601                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9602       ffebld_set_info (reduced, ninfo);
9603       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9604                                       l->token, op->token, nbt, nkt, 0, lsz,
9605                                                  FFEEXPR_contextLET));
9606       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9607                                       r->token, op->token, nbt, nkt, 0, rsz,
9608                                                   FFEEXPR_contextLET));
9609       return reduced;
9610     }
9611
9612   if ((lbt == FFEINFO_basictypeLOGICAL)
9613       && (rbt == FFEINFO_basictypeLOGICAL))
9614     {
9615       /* xgettext:no-c-format */
9616       if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9617                             FFEBAD_severityFATAL))
9618         {
9619           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9620           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9621           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9622           ffebad_finish ();
9623         }
9624     }
9625   else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9626       && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9627     {
9628       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9629           && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9630         {
9631           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9632               && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9633             {
9634               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9635               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9636               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9637               ffebad_finish ();
9638             }
9639         }
9640       else
9641         {
9642           if ((lbt != FFEINFO_basictypeANY)
9643               && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9644             {
9645               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9646               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9647               ffebad_finish ();
9648             }
9649         }
9650     }
9651   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9652            && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9653     {
9654       if ((rbt != FFEINFO_basictypeANY)
9655           && ffebad_start (FFEBAD_EQOP_ARG_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 (r->token), ffelex_token_where_column (r->token));
9659           ffebad_finish ();
9660         }
9661     }
9662   else if (lrk != 0)
9663     {
9664       if ((lkd != FFEINFO_kindANY)
9665           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9666         {
9667           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9668           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9669           ffebad_string ("an array");
9670           ffebad_finish ();
9671         }
9672     }
9673   else
9674     {
9675       if ((rkd != FFEINFO_kindANY)
9676           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9677         {
9678           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9679           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9680           ffebad_string ("an array");
9681           ffebad_finish ();
9682         }
9683     }
9684
9685   reduced = ffebld_new_any ();
9686   ffebld_set_info (reduced, ffeinfo_new_any ());
9687   return reduced;
9688 }
9689
9690 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9691
9692    reduced = ffeexpr_reduced_math1_(reduced,op,r);
9693
9694    Makes sure the argument for reduced has basictype of
9695    INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
9696    assign where CONSTANT to
9697    reduced, else assign where FLEETING.
9698
9699    If these requirements cannot be met, generate error message.  */
9700
9701 static ffebld
9702 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9703 {
9704   ffeinfo rinfo, ninfo;
9705   ffeinfoBasictype rbt;
9706   ffeinfoKindtype rkt;
9707   ffeinfoRank rrk;
9708   ffeinfoKind rkd;
9709   ffeinfoWhere rwh, nwh;
9710
9711   rinfo = ffebld_info (ffebld_left (reduced));
9712   rbt = ffeinfo_basictype (rinfo);
9713   rkt = ffeinfo_kindtype (rinfo);
9714   rrk = ffeinfo_rank (rinfo);
9715   rkd = ffeinfo_kind (rinfo);
9716   rwh = ffeinfo_where (rinfo);
9717
9718   if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9719        || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9720     {
9721       switch (rwh)
9722         {
9723         case FFEINFO_whereCONSTANT:
9724           nwh = FFEINFO_whereCONSTANT;
9725           break;
9726
9727         case FFEINFO_whereIMMEDIATE:
9728           nwh = FFEINFO_whereIMMEDIATE;
9729           break;
9730
9731         default:
9732           nwh = FFEINFO_whereFLEETING;
9733           break;
9734         }
9735
9736       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9737                            FFETARGET_charactersizeNONE);
9738       ffebld_set_info (reduced, ninfo);
9739       return reduced;
9740     }
9741
9742   if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9743       && (rbt != FFEINFO_basictypeCOMPLEX))
9744     {
9745       if ((rbt != FFEINFO_basictypeANY)
9746           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9747         {
9748           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9749           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9750           ffebad_finish ();
9751         }
9752     }
9753   else
9754     {
9755       if ((rkd != FFEINFO_kindANY)
9756           && ffebad_start (FFEBAD_MATH_ARG_KIND))
9757         {
9758           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9759           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9760           ffebad_string ("an array");
9761           ffebad_finish ();
9762         }
9763     }
9764
9765   reduced = ffebld_new_any ();
9766   ffebld_set_info (reduced, ffeinfo_new_any ());
9767   return reduced;
9768 }
9769
9770 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9771
9772    reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9773
9774    Makes sure the left and right arguments for reduced have basictype of
9775    INTEGER, REAL, or COMPLEX.  Determine common basictype and
9776    size for reduction (flag expression for combined hollerith/typeless
9777    situations for later determination of effective basictype).  If both left
9778    and right arguments have where of CONSTANT, assign where CONSTANT to
9779    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9780    needed.  Convert typeless
9781    constants to the desired type/size explicitly.
9782
9783    If these requirements cannot be met, generate error message.  */
9784
9785 static ffebld
9786 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9787                         ffeexprExpr_ r)
9788 {
9789   ffeinfo linfo, rinfo, ninfo;
9790   ffeinfoBasictype lbt, rbt, nbt;
9791   ffeinfoKindtype lkt, rkt, nkt;
9792   ffeinfoRank lrk, rrk;
9793   ffeinfoKind lkd, rkd;
9794   ffeinfoWhere lwh, rwh, nwh;
9795
9796   linfo = ffebld_info (ffebld_left (reduced));
9797   lbt = ffeinfo_basictype (linfo);
9798   lkt = ffeinfo_kindtype (linfo);
9799   lrk = ffeinfo_rank (linfo);
9800   lkd = ffeinfo_kind (linfo);
9801   lwh = ffeinfo_where (linfo);
9802
9803   rinfo = ffebld_info (ffebld_right (reduced));
9804   rbt = ffeinfo_basictype (rinfo);
9805   rkt = ffeinfo_kindtype (rinfo);
9806   rrk = ffeinfo_rank (rinfo);
9807   rkd = ffeinfo_kind (rinfo);
9808   rwh = ffeinfo_where (rinfo);
9809
9810   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9811
9812   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9813        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9814     {
9815       switch (lwh)
9816         {
9817         case FFEINFO_whereCONSTANT:
9818           switch (rwh)
9819             {
9820             case FFEINFO_whereCONSTANT:
9821               nwh = FFEINFO_whereCONSTANT;
9822               break;
9823
9824             case FFEINFO_whereIMMEDIATE:
9825               nwh = FFEINFO_whereIMMEDIATE;
9826               break;
9827
9828             default:
9829               nwh = FFEINFO_whereFLEETING;
9830               break;
9831             }
9832           break;
9833
9834         case FFEINFO_whereIMMEDIATE:
9835           switch (rwh)
9836             {
9837             case FFEINFO_whereCONSTANT:
9838             case FFEINFO_whereIMMEDIATE:
9839               nwh = FFEINFO_whereIMMEDIATE;
9840               break;
9841
9842             default:
9843               nwh = FFEINFO_whereFLEETING;
9844               break;
9845             }
9846           break;
9847
9848         default:
9849           nwh = FFEINFO_whereFLEETING;
9850           break;
9851         }
9852
9853       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9854                            FFETARGET_charactersizeNONE);
9855       ffebld_set_info (reduced, ninfo);
9856       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9857               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9858                                                  FFEEXPR_contextLET));
9859       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9860               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9861                                                   FFEEXPR_contextLET));
9862       return reduced;
9863     }
9864
9865   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9866       && (lbt != FFEINFO_basictypeCOMPLEX))
9867     {
9868       if ((rbt != FFEINFO_basictypeINTEGER)
9869       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9870         {
9871           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9872               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9873             {
9874               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9875               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9876               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9877               ffebad_finish ();
9878             }
9879         }
9880       else
9881         {
9882           if ((lbt != FFEINFO_basictypeANY)
9883               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9884             {
9885               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9886               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9887               ffebad_finish ();
9888             }
9889         }
9890     }
9891   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9892            && (rbt != FFEINFO_basictypeCOMPLEX))
9893     {
9894       if ((rbt != FFEINFO_basictypeANY)
9895           && ffebad_start (FFEBAD_MATH_ARG_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 (r->token), ffelex_token_where_column (r->token));
9899           ffebad_finish ();
9900         }
9901     }
9902   else if (lrk != 0)
9903     {
9904       if ((lkd != FFEINFO_kindANY)
9905           && ffebad_start (FFEBAD_MATH_ARG_KIND))
9906         {
9907           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9908           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9909           ffebad_string ("an array");
9910           ffebad_finish ();
9911         }
9912     }
9913   else
9914     {
9915       if ((rkd != FFEINFO_kindANY)
9916           && ffebad_start (FFEBAD_MATH_ARG_KIND))
9917         {
9918           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9919           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9920           ffebad_string ("an array");
9921           ffebad_finish ();
9922         }
9923     }
9924
9925   reduced = ffebld_new_any ();
9926   ffebld_set_info (reduced, ffeinfo_new_any ());
9927   return reduced;
9928 }
9929
9930 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9931
9932    reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9933
9934    Makes sure the left and right arguments for reduced have basictype of
9935    INTEGER, REAL, or COMPLEX.  Determine common basictype and
9936    size for reduction (flag expression for combined hollerith/typeless
9937    situations for later determination of effective basictype).  If both left
9938    and right arguments have where of CONSTANT, assign where CONSTANT to
9939    reduced, else assign where FLEETING.  Create CONVERT ops for args where
9940    needed.  Note that real**int or complex**int
9941    comes out as int = real**int etc with no conversions.
9942
9943    If these requirements cannot be met, generate error message using the
9944    info in l, op, and r arguments and assign basictype, size, kind, and where
9945    of ANY.  */
9946
9947 static ffebld
9948 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9949                         ffeexprExpr_ r)
9950 {
9951   ffeinfo linfo, rinfo, ninfo;
9952   ffeinfoBasictype lbt, rbt, nbt;
9953   ffeinfoKindtype lkt, rkt, nkt;
9954   ffeinfoRank lrk, rrk;
9955   ffeinfoKind lkd, rkd;
9956   ffeinfoWhere lwh, rwh, nwh;
9957
9958   linfo = ffebld_info (ffebld_left (reduced));
9959   lbt = ffeinfo_basictype (linfo);
9960   lkt = ffeinfo_kindtype (linfo);
9961   lrk = ffeinfo_rank (linfo);
9962   lkd = ffeinfo_kind (linfo);
9963   lwh = ffeinfo_where (linfo);
9964
9965   rinfo = ffebld_info (ffebld_right (reduced));
9966   rbt = ffeinfo_basictype (rinfo);
9967   rkt = ffeinfo_kindtype (rinfo);
9968   rrk = ffeinfo_rank (rinfo);
9969   rkd = ffeinfo_kind (rinfo);
9970   rwh = ffeinfo_where (rinfo);
9971
9972   if ((rbt == FFEINFO_basictypeINTEGER)
9973       && ((lbt == FFEINFO_basictypeREAL)
9974           || (lbt == FFEINFO_basictypeCOMPLEX)))
9975     {
9976       nbt = lbt;
9977       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
9978       if (nkt != FFEINFO_kindtypeREALDEFAULT)
9979         {
9980           nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
9981           if (nkt != FFEINFO_kindtypeREALDOUBLE)
9982             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
9983         }
9984       if (rkt == FFEINFO_kindtypeINTEGER4)
9985         {
9986           /* xgettext:no-c-format */
9987           ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
9988                             FFEBAD_severityWARNING);
9989           ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9990           ffebad_finish ();
9991         }
9992       if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
9993         {
9994           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9995                                                       r->token, op->token,
9996                 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
9997                                                 FFETARGET_charactersizeNONE,
9998                                                       FFEEXPR_contextLET));
9999           rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10000         }
10001     }
10002   else
10003     {
10004       ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10005
10006 #if 0   /* INTEGER4**INTEGER4 works now. */
10007       if ((nbt == FFEINFO_basictypeINTEGER)
10008           && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10009         nkt = FFEINFO_kindtypeINTEGERDEFAULT;   /* Highest kt we can power! */
10010 #endif
10011       if (((nbt == FFEINFO_basictypeREAL)
10012            || (nbt == FFEINFO_basictypeCOMPLEX))
10013           && (nkt != FFEINFO_kindtypeREALDEFAULT))
10014         {
10015           nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10016           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10017             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10018         }
10019       /* else Gonna turn into an error below. */
10020     }
10021
10022   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10023        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10024     {
10025       switch (lwh)
10026         {
10027         case FFEINFO_whereCONSTANT:
10028           switch (rwh)
10029             {
10030             case FFEINFO_whereCONSTANT:
10031               nwh = FFEINFO_whereCONSTANT;
10032               break;
10033
10034             case FFEINFO_whereIMMEDIATE:
10035               nwh = FFEINFO_whereIMMEDIATE;
10036               break;
10037
10038             default:
10039               nwh = FFEINFO_whereFLEETING;
10040               break;
10041             }
10042           break;
10043
10044         case FFEINFO_whereIMMEDIATE:
10045           switch (rwh)
10046             {
10047             case FFEINFO_whereCONSTANT:
10048             case FFEINFO_whereIMMEDIATE:
10049               nwh = FFEINFO_whereIMMEDIATE;
10050               break;
10051
10052             default:
10053               nwh = FFEINFO_whereFLEETING;
10054               break;
10055             }
10056           break;
10057
10058         default:
10059           nwh = FFEINFO_whereFLEETING;
10060           break;
10061         }
10062
10063       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10064                            FFETARGET_charactersizeNONE);
10065       ffebld_set_info (reduced, ninfo);
10066       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10067               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10068                                                  FFEEXPR_contextLET));
10069       if (rbt != FFEINFO_basictypeINTEGER)
10070         ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10071               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10072                                                     FFEEXPR_contextLET));
10073       return reduced;
10074     }
10075
10076   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10077       && (lbt != FFEINFO_basictypeCOMPLEX))
10078     {
10079       if ((rbt != FFEINFO_basictypeINTEGER)
10080       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10081         {
10082           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10083               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10084             {
10085               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10086               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10087               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10088               ffebad_finish ();
10089             }
10090         }
10091       else
10092         {
10093           if ((lbt != FFEINFO_basictypeANY)
10094               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10095             {
10096               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10097               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10098               ffebad_finish ();
10099             }
10100         }
10101     }
10102   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10103            && (rbt != FFEINFO_basictypeCOMPLEX))
10104     {
10105       if ((rbt != FFEINFO_basictypeANY)
10106           && ffebad_start (FFEBAD_MATH_ARG_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 (r->token), ffelex_token_where_column (r->token));
10110           ffebad_finish ();
10111         }
10112     }
10113   else if (lrk != 0)
10114     {
10115       if ((lkd != FFEINFO_kindANY)
10116           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10117         {
10118           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10119           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10120           ffebad_string ("an array");
10121           ffebad_finish ();
10122         }
10123     }
10124   else
10125     {
10126       if ((rkd != FFEINFO_kindANY)
10127           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10128         {
10129           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10130           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10131           ffebad_string ("an array");
10132           ffebad_finish ();
10133         }
10134     }
10135
10136   reduced = ffebld_new_any ();
10137   ffebld_set_info (reduced, ffeinfo_new_any ());
10138   return reduced;
10139 }
10140
10141 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10142
10143    reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10144
10145    Makes sure the left and right arguments for reduced have basictype of
10146    INTEGER, REAL, or CHARACTER.  Determine common basictype and
10147    size for reduction.  If both left
10148    and right arguments have where of CONSTANT, assign where CONSTANT to
10149    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10150    needed.  Convert typeless
10151    constants to the desired type/size explicitly.
10152
10153    If these requirements cannot be met, generate error message.  */
10154
10155 static ffebld
10156 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10157                          ffeexprExpr_ r)
10158 {
10159   ffeinfo linfo, rinfo, ninfo;
10160   ffeinfoBasictype lbt, rbt, nbt;
10161   ffeinfoKindtype lkt, rkt, nkt;
10162   ffeinfoRank lrk, rrk;
10163   ffeinfoKind lkd, rkd;
10164   ffeinfoWhere lwh, rwh, nwh;
10165   ffetargetCharacterSize lsz, rsz;
10166
10167   linfo = ffebld_info (ffebld_left (reduced));
10168   lbt = ffeinfo_basictype (linfo);
10169   lkt = ffeinfo_kindtype (linfo);
10170   lrk = ffeinfo_rank (linfo);
10171   lkd = ffeinfo_kind (linfo);
10172   lwh = ffeinfo_where (linfo);
10173   lsz = ffebld_size_known (ffebld_left (reduced));
10174
10175   rinfo = ffebld_info (ffebld_right (reduced));
10176   rbt = ffeinfo_basictype (rinfo);
10177   rkt = ffeinfo_kindtype (rinfo);
10178   rrk = ffeinfo_rank (rinfo);
10179   rkd = ffeinfo_kind (rinfo);
10180   rwh = ffeinfo_where (rinfo);
10181   rsz = ffebld_size_known (ffebld_right (reduced));
10182
10183   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10184
10185   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10186        || (nbt == FFEINFO_basictypeCHARACTER))
10187       && (lrk == 0) && (rrk == 0))
10188     {
10189       switch (lwh)
10190         {
10191         case FFEINFO_whereCONSTANT:
10192           switch (rwh)
10193             {
10194             case FFEINFO_whereCONSTANT:
10195               nwh = FFEINFO_whereCONSTANT;
10196               break;
10197
10198             case FFEINFO_whereIMMEDIATE:
10199               nwh = FFEINFO_whereIMMEDIATE;
10200               break;
10201
10202             default:
10203               nwh = FFEINFO_whereFLEETING;
10204               break;
10205             }
10206           break;
10207
10208         case FFEINFO_whereIMMEDIATE:
10209           switch (rwh)
10210             {
10211             case FFEINFO_whereCONSTANT:
10212             case FFEINFO_whereIMMEDIATE:
10213               nwh = FFEINFO_whereIMMEDIATE;
10214               break;
10215
10216             default:
10217               nwh = FFEINFO_whereFLEETING;
10218               break;
10219             }
10220           break;
10221
10222         default:
10223           nwh = FFEINFO_whereFLEETING;
10224           break;
10225         }
10226
10227       if ((lsz != FFETARGET_charactersizeNONE)
10228           && (rsz != FFETARGET_charactersizeNONE))
10229         lsz = rsz = (lsz > rsz) ? lsz : rsz;
10230
10231       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10232                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10233       ffebld_set_info (reduced, ninfo);
10234       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10235                                       l->token, op->token, nbt, nkt, 0, lsz,
10236                                                  FFEEXPR_contextLET));
10237       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10238                                       r->token, op->token, nbt, nkt, 0, rsz,
10239                                                   FFEEXPR_contextLET));
10240       return reduced;
10241     }
10242
10243   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10244       && (lbt != FFEINFO_basictypeCHARACTER))
10245     {
10246       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10247           && (rbt != FFEINFO_basictypeCHARACTER))
10248         {
10249           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10250               && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10251             {
10252               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10253               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10254               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10255               ffebad_finish ();
10256             }
10257         }
10258       else
10259         {
10260           if ((lbt != FFEINFO_basictypeANY)
10261               && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10262             {
10263               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10264               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10265               ffebad_finish ();
10266             }
10267         }
10268     }
10269   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10270            && (rbt != FFEINFO_basictypeCHARACTER))
10271     {
10272       if ((rbt != FFEINFO_basictypeANY)
10273           && ffebad_start (FFEBAD_RELOP_ARG_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 (r->token), ffelex_token_where_column (r->token));
10277           ffebad_finish ();
10278         }
10279     }
10280   else if (lrk != 0)
10281     {
10282       if ((lkd != FFEINFO_kindANY)
10283           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10284         {
10285           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10286           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10287           ffebad_string ("an array");
10288           ffebad_finish ();
10289         }
10290     }
10291   else
10292     {
10293       if ((rkd != FFEINFO_kindANY)
10294           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10295         {
10296           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10297           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10298           ffebad_string ("an array");
10299           ffebad_finish ();
10300         }
10301     }
10302
10303   reduced = ffebld_new_any ();
10304   ffebld_set_info (reduced, ffeinfo_new_any ());
10305   return reduced;
10306 }
10307
10308 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10309
10310    reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10311
10312    Sigh.  */
10313
10314 static ffebld
10315 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10316 {
10317   ffeinfo rinfo;
10318   ffeinfoBasictype rbt;
10319   ffeinfoKindtype rkt;
10320   ffeinfoRank rrk;
10321   ffeinfoKind rkd;
10322   ffeinfoWhere rwh;
10323
10324   rinfo = ffebld_info (ffebld_left (reduced));
10325   rbt = ffeinfo_basictype (rinfo);
10326   rkt = ffeinfo_kindtype (rinfo);
10327   rrk = ffeinfo_rank (rinfo);
10328   rkd = ffeinfo_kind (rinfo);
10329   rwh = ffeinfo_where (rinfo);
10330
10331   if ((rbt == FFEINFO_basictypeTYPELESS)
10332       || (rbt == FFEINFO_basictypeHOLLERITH))
10333     {
10334       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10335                               r->token, op->token, FFEINFO_basictypeINTEGER,
10336                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10337                                                  FFETARGET_charactersizeNONE,
10338                                                  FFEEXPR_contextLET));
10339       rinfo = ffebld_info (ffebld_left (reduced));
10340       rbt = FFEINFO_basictypeINTEGER;
10341       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10342       rrk = 0;
10343       rkd = FFEINFO_kindENTITY;
10344       rwh = ffeinfo_where (rinfo);
10345     }
10346
10347   if (rbt == FFEINFO_basictypeLOGICAL)
10348     {
10349       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10350                               r->token, op->token, FFEINFO_basictypeINTEGER,
10351                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10352                                                  FFETARGET_charactersizeNONE,
10353                                                  FFEEXPR_contextLET));
10354     }
10355
10356   return reduced;
10357 }
10358
10359 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10360
10361    reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10362
10363    Sigh.  */
10364
10365 static ffebld
10366 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10367 {
10368   ffeinfo rinfo;
10369   ffeinfoBasictype rbt;
10370   ffeinfoKindtype rkt;
10371   ffeinfoRank rrk;
10372   ffeinfoKind rkd;
10373   ffeinfoWhere rwh;
10374
10375   rinfo = ffebld_info (ffebld_left (reduced));
10376   rbt = ffeinfo_basictype (rinfo);
10377   rkt = ffeinfo_kindtype (rinfo);
10378   rrk = ffeinfo_rank (rinfo);
10379   rkd = ffeinfo_kind (rinfo);
10380   rwh = ffeinfo_where (rinfo);
10381
10382   if ((rbt == FFEINFO_basictypeTYPELESS)
10383       || (rbt == FFEINFO_basictypeHOLLERITH))
10384     {
10385       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10386                            r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10387                                              FFEINFO_kindtypeLOGICALDEFAULT,
10388                                                  FFETARGET_charactersizeNONE,
10389                                                  FFEEXPR_contextLET));
10390       rinfo = ffebld_info (ffebld_left (reduced));
10391       rbt = FFEINFO_basictypeLOGICAL;
10392       rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10393       rrk = 0;
10394       rkd = FFEINFO_kindENTITY;
10395       rwh = ffeinfo_where (rinfo);
10396     }
10397
10398   return reduced;
10399 }
10400
10401 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10402
10403    reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10404
10405    Sigh.  */
10406
10407 static ffebld
10408 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10409                         ffeexprExpr_ r)
10410 {
10411   ffeinfo linfo, rinfo;
10412   ffeinfoBasictype lbt, rbt;
10413   ffeinfoKindtype lkt, rkt;
10414   ffeinfoRank lrk, rrk;
10415   ffeinfoKind lkd, rkd;
10416   ffeinfoWhere lwh, rwh;
10417
10418   linfo = ffebld_info (ffebld_left (reduced));
10419   lbt = ffeinfo_basictype (linfo);
10420   lkt = ffeinfo_kindtype (linfo);
10421   lrk = ffeinfo_rank (linfo);
10422   lkd = ffeinfo_kind (linfo);
10423   lwh = ffeinfo_where (linfo);
10424
10425   rinfo = ffebld_info (ffebld_right (reduced));
10426   rbt = ffeinfo_basictype (rinfo);
10427   rkt = ffeinfo_kindtype (rinfo);
10428   rrk = ffeinfo_rank (rinfo);
10429   rkd = ffeinfo_kind (rinfo);
10430   rwh = ffeinfo_where (rinfo);
10431
10432   if ((lbt == FFEINFO_basictypeTYPELESS)
10433       || (lbt == FFEINFO_basictypeHOLLERITH))
10434     {
10435       if ((rbt == FFEINFO_basictypeTYPELESS)
10436           || (rbt == FFEINFO_basictypeHOLLERITH))
10437         {
10438           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10439                               l->token, op->token, FFEINFO_basictypeINTEGER,
10440                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10441                                                 FFETARGET_charactersizeNONE,
10442                                                      FFEEXPR_contextLET));
10443           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10444                            r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10445                                              FFEINFO_kindtypeINTEGERDEFAULT,
10446                                                 FFETARGET_charactersizeNONE,
10447                                                       FFEEXPR_contextLET));
10448           linfo = ffebld_info (ffebld_left (reduced));
10449           rinfo = ffebld_info (ffebld_right (reduced));
10450           lbt = rbt = FFEINFO_basictypeINTEGER;
10451           lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10452           lrk = rrk = 0;
10453           lkd = rkd = FFEINFO_kindENTITY;
10454           lwh = ffeinfo_where (linfo);
10455           rwh = ffeinfo_where (rinfo);
10456         }
10457       else
10458         {
10459           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10460                                  l->token, ffebld_right (reduced), r->token,
10461                                                        FFEEXPR_contextLET));
10462           linfo = ffebld_info (ffebld_left (reduced));
10463           lbt = ffeinfo_basictype (linfo);
10464           lkt = ffeinfo_kindtype (linfo);
10465           lrk = ffeinfo_rank (linfo);
10466           lkd = ffeinfo_kind (linfo);
10467           lwh = ffeinfo_where (linfo);
10468         }
10469     }
10470   else
10471     {
10472       if ((rbt == FFEINFO_basictypeTYPELESS)
10473           || (rbt == FFEINFO_basictypeHOLLERITH))
10474         {
10475           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10476                                   r->token, ffebld_left (reduced), l->token,
10477                                                        FFEEXPR_contextLET));
10478           rinfo = ffebld_info (ffebld_right (reduced));
10479           rbt = ffeinfo_basictype (rinfo);
10480           rkt = ffeinfo_kindtype (rinfo);
10481           rrk = ffeinfo_rank (rinfo);
10482           rkd = ffeinfo_kind (rinfo);
10483           rwh = ffeinfo_where (rinfo);
10484         }
10485       /* else Leave it alone. */
10486     }
10487
10488   if (lbt == FFEINFO_basictypeLOGICAL)
10489     {
10490       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10491                               l->token, op->token, FFEINFO_basictypeINTEGER,
10492                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10493                                                  FFETARGET_charactersizeNONE,
10494                                                  FFEEXPR_contextLET));
10495     }
10496
10497   if (rbt == FFEINFO_basictypeLOGICAL)
10498     {
10499       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10500                               r->token, op->token, FFEINFO_basictypeINTEGER,
10501                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
10502                                                 FFETARGET_charactersizeNONE,
10503                                                   FFEEXPR_contextLET));
10504     }
10505
10506   return reduced;
10507 }
10508
10509 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10510
10511    reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10512
10513    Sigh.  */
10514
10515 static ffebld
10516 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10517                            ffeexprExpr_ r)
10518 {
10519   ffeinfo linfo, rinfo;
10520   ffeinfoBasictype lbt, rbt;
10521   ffeinfoKindtype lkt, rkt;
10522   ffeinfoRank lrk, rrk;
10523   ffeinfoKind lkd, rkd;
10524   ffeinfoWhere lwh, rwh;
10525
10526   linfo = ffebld_info (ffebld_left (reduced));
10527   lbt = ffeinfo_basictype (linfo);
10528   lkt = ffeinfo_kindtype (linfo);
10529   lrk = ffeinfo_rank (linfo);
10530   lkd = ffeinfo_kind (linfo);
10531   lwh = ffeinfo_where (linfo);
10532
10533   rinfo = ffebld_info (ffebld_right (reduced));
10534   rbt = ffeinfo_basictype (rinfo);
10535   rkt = ffeinfo_kindtype (rinfo);
10536   rrk = ffeinfo_rank (rinfo);
10537   rkd = ffeinfo_kind (rinfo);
10538   rwh = ffeinfo_where (rinfo);
10539
10540   if ((lbt == FFEINFO_basictypeTYPELESS)
10541       || (lbt == FFEINFO_basictypeHOLLERITH))
10542     {
10543       if ((rbt == FFEINFO_basictypeTYPELESS)
10544           || (rbt == FFEINFO_basictypeHOLLERITH))
10545         {
10546           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10547                               l->token, op->token, FFEINFO_basictypeLOGICAL,
10548                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
10549                                                 FFETARGET_charactersizeNONE,
10550                                                      FFEEXPR_contextLET));
10551           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10552                               r->token, op->token, FFEINFO_basictypeLOGICAL,
10553                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
10554                                                 FFETARGET_charactersizeNONE,
10555                                                       FFEEXPR_contextLET));
10556           linfo = ffebld_info (ffebld_left (reduced));
10557           rinfo = ffebld_info (ffebld_right (reduced));
10558           lbt = rbt = FFEINFO_basictypeLOGICAL;
10559           lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10560           lrk = rrk = 0;
10561           lkd = rkd = FFEINFO_kindENTITY;
10562           lwh = ffeinfo_where (linfo);
10563           rwh = ffeinfo_where (rinfo);
10564         }
10565       else
10566         {
10567           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10568                                  l->token, ffebld_right (reduced), r->token,
10569                                                        FFEEXPR_contextLET));
10570           linfo = ffebld_info (ffebld_left (reduced));
10571           lbt = ffeinfo_basictype (linfo);
10572           lkt = ffeinfo_kindtype (linfo);
10573           lrk = ffeinfo_rank (linfo);
10574           lkd = ffeinfo_kind (linfo);
10575           lwh = ffeinfo_where (linfo);
10576         }
10577     }
10578   else
10579     {
10580       if ((rbt == FFEINFO_basictypeTYPELESS)
10581           || (rbt == FFEINFO_basictypeHOLLERITH))
10582         {
10583           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10584                                   r->token, ffebld_left (reduced), l->token,
10585                                                        FFEEXPR_contextLET));
10586           rinfo = ffebld_info (ffebld_right (reduced));
10587           rbt = ffeinfo_basictype (rinfo);
10588           rkt = ffeinfo_kindtype (rinfo);
10589           rrk = ffeinfo_rank (rinfo);
10590           rkd = ffeinfo_kind (rinfo);
10591           rwh = ffeinfo_where (rinfo);
10592         }
10593       /* else Leave it alone. */
10594     }
10595
10596   return reduced;
10597 }
10598
10599 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10600    is found.
10601
10602    The idea is to process the tokens as they would be done by normal
10603    expression processing, with the key things being telling the lexer
10604    when hollerith/character constants are about to happen, until the
10605    true closing token is found.  */
10606
10607 static ffelexHandler
10608 ffeexpr_find_close_paren_ (ffelexToken t,
10609                            ffelexHandler after)
10610 {
10611   ffeexpr_find_.after = after;
10612   ffeexpr_find_.level = 1;
10613   return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10614 }
10615
10616 static ffelexHandler
10617 ffeexpr_nil_finished_ (ffelexToken t)
10618 {
10619   switch (ffelex_token_type (t))
10620     {
10621     case FFELEX_typeCLOSE_PAREN:
10622       if (--ffeexpr_find_.level == 0)
10623         return (ffelexHandler) ffeexpr_find_.after;
10624       return (ffelexHandler) ffeexpr_nil_binary_;
10625
10626     case FFELEX_typeCOMMA:
10627     case FFELEX_typeCOLON:
10628     case FFELEX_typeEQUALS:
10629     case FFELEX_typePOINTS:
10630       return (ffelexHandler) ffeexpr_nil_rhs_;
10631
10632     default:
10633       if (--ffeexpr_find_.level == 0)
10634         return (ffelexHandler) ffeexpr_find_.after (t);
10635       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10636     }
10637 }
10638
10639 static ffelexHandler
10640 ffeexpr_nil_rhs_ (ffelexToken t)
10641 {
10642   switch (ffelex_token_type (t))
10643     {
10644     case FFELEX_typeQUOTE:
10645       if (ffe_is_vxt ())
10646         return (ffelexHandler) ffeexpr_nil_quote_;
10647       ffelex_set_expecting_hollerith (-1, '\"',
10648                                       ffelex_token_where_line (t),
10649                                       ffelex_token_where_column (t));
10650       return (ffelexHandler) ffeexpr_nil_apostrophe_;
10651
10652     case FFELEX_typeAPOSTROPHE:
10653       ffelex_set_expecting_hollerith (-1, '\'',
10654                                       ffelex_token_where_line (t),
10655                                       ffelex_token_where_column (t));
10656       return (ffelexHandler) ffeexpr_nil_apostrophe_;
10657
10658     case FFELEX_typePERCENT:
10659       return (ffelexHandler) ffeexpr_nil_percent_;
10660
10661     case FFELEX_typeOPEN_PAREN:
10662       ++ffeexpr_find_.level;
10663       return (ffelexHandler) ffeexpr_nil_rhs_;
10664
10665     case FFELEX_typePLUS:
10666     case FFELEX_typeMINUS:
10667       return (ffelexHandler) ffeexpr_nil_rhs_;
10668
10669     case FFELEX_typePERIOD:
10670       return (ffelexHandler) ffeexpr_nil_period_;
10671
10672     case FFELEX_typeNUMBER:
10673       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10674       if (ffeexpr_hollerith_count_ > 0)
10675         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10676                                         '\0',
10677                                         ffelex_token_where_line (t),
10678                                         ffelex_token_where_column (t));
10679       return (ffelexHandler) ffeexpr_nil_number_;
10680
10681     case FFELEX_typeNAME:
10682     case FFELEX_typeNAMES:
10683       return (ffelexHandler) ffeexpr_nil_name_rhs_;
10684
10685     case FFELEX_typeASTERISK:
10686     case FFELEX_typeSLASH:
10687     case FFELEX_typePOWER:
10688     case FFELEX_typeCONCAT:
10689     case FFELEX_typeREL_EQ:
10690     case FFELEX_typeREL_NE:
10691     case FFELEX_typeREL_LE:
10692     case FFELEX_typeREL_GE:
10693       return (ffelexHandler) ffeexpr_nil_rhs_;
10694
10695     default:
10696       return (ffelexHandler) ffeexpr_nil_finished_ (t);
10697     }
10698 }
10699
10700 static ffelexHandler
10701 ffeexpr_nil_period_ (ffelexToken t)
10702 {
10703   switch (ffelex_token_type (t))
10704     {
10705     case FFELEX_typeNAME:
10706     case FFELEX_typeNAMES:
10707       ffeexpr_current_dotdot_ = ffestr_other (t);
10708       switch (ffeexpr_current_dotdot_)
10709         {
10710         case FFESTR_otherNone:
10711           return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10712
10713         case FFESTR_otherTRUE:
10714         case FFESTR_otherFALSE:
10715         case FFESTR_otherNOT:
10716           return (ffelexHandler) ffeexpr_nil_end_period_;
10717
10718         default:
10719           return (ffelexHandler) ffeexpr_nil_swallow_period_;
10720         }
10721       break;                    /* Nothing really reaches here. */
10722
10723     case FFELEX_typeNUMBER:
10724       return (ffelexHandler) ffeexpr_nil_real_;
10725
10726     default:
10727       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10728     }
10729 }
10730
10731 static ffelexHandler
10732 ffeexpr_nil_end_period_ (ffelexToken t)
10733 {
10734   switch (ffeexpr_current_dotdot_)
10735     {
10736     case FFESTR_otherNOT:
10737       if (ffelex_token_type (t) != FFELEX_typePERIOD)
10738         return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10739       return (ffelexHandler) ffeexpr_nil_rhs_;
10740
10741     case FFESTR_otherTRUE:
10742     case FFESTR_otherFALSE:
10743       if (ffelex_token_type (t) != FFELEX_typePERIOD)
10744         return (ffelexHandler) ffeexpr_nil_binary_ (t);
10745       return (ffelexHandler) ffeexpr_nil_binary_;
10746
10747     default:
10748       assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10749       exit (0);
10750       return NULL;
10751     }
10752 }
10753
10754 static ffelexHandler
10755 ffeexpr_nil_swallow_period_ (ffelexToken t)
10756 {
10757   if (ffelex_token_type (t) != FFELEX_typePERIOD)
10758     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10759   return (ffelexHandler) ffeexpr_nil_rhs_;
10760 }
10761
10762 static ffelexHandler
10763 ffeexpr_nil_real_ (ffelexToken t)
10764 {
10765   char d;
10766   const char *p;
10767
10768   if (((ffelex_token_type (t) != FFELEX_typeNAME)
10769        && (ffelex_token_type (t) != FFELEX_typeNAMES))
10770       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10771                                      'D', 'd')
10772              || ffesrc_char_match_init (d, 'E', 'e')
10773              || ffesrc_char_match_init (d, 'Q', 'q')))
10774            && ffeexpr_isdigits_ (++p)))
10775     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10776
10777   if (*p == '\0')
10778     return (ffelexHandler) ffeexpr_nil_real_exponent_;
10779   return (ffelexHandler) ffeexpr_nil_binary_;
10780 }
10781
10782 static ffelexHandler
10783 ffeexpr_nil_real_exponent_ (ffelexToken t)
10784 {
10785   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10786       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10787     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10788
10789   return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10790 }
10791
10792 static ffelexHandler
10793 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10794 {
10795   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10796     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10797   return (ffelexHandler) ffeexpr_nil_binary_;
10798 }
10799
10800 static ffelexHandler
10801 ffeexpr_nil_number_ (ffelexToken t)
10802 {
10803   char d;
10804   const char *p;
10805
10806   if (ffeexpr_hollerith_count_ > 0)
10807     ffelex_set_expecting_hollerith (0, '\0',
10808                                     ffewhere_line_unknown (),
10809                                     ffewhere_column_unknown ());
10810
10811   switch (ffelex_token_type (t))
10812     {
10813     case FFELEX_typeNAME:
10814     case FFELEX_typeNAMES:
10815       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10816                                    'D', 'd')
10817            || ffesrc_char_match_init (d, 'E', 'e')
10818            || ffesrc_char_match_init (d, 'Q', 'q'))
10819           && ffeexpr_isdigits_ (++p))
10820         {
10821           if (*p == '\0')
10822             {
10823               ffeexpr_find_.t = ffelex_token_use (t);
10824               return (ffelexHandler) ffeexpr_nil_number_exponent_;
10825             }
10826           return (ffelexHandler) ffeexpr_nil_binary_;
10827         }
10828       break;
10829
10830     case FFELEX_typePERIOD:
10831       ffeexpr_find_.t = ffelex_token_use (t);
10832       return (ffelexHandler) ffeexpr_nil_number_period_;
10833
10834     case FFELEX_typeHOLLERITH:
10835       return (ffelexHandler) ffeexpr_nil_binary_;
10836
10837     default:
10838       break;
10839     }
10840   return (ffelexHandler) ffeexpr_nil_binary_ (t);
10841 }
10842
10843 /* Expects ffeexpr_find_.t.  */
10844
10845 static ffelexHandler
10846 ffeexpr_nil_number_exponent_ (ffelexToken t)
10847 {
10848   ffelexHandler nexthandler;
10849
10850   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10851       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10852     {
10853       nexthandler
10854         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10855       ffelex_token_kill (ffeexpr_find_.t);
10856       return (ffelexHandler) (*nexthandler) (t);
10857     }
10858
10859   ffelex_token_kill (ffeexpr_find_.t);
10860   return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10861 }
10862
10863 static ffelexHandler
10864 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10865 {
10866   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10867     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10868
10869   return (ffelexHandler) ffeexpr_nil_binary_;
10870 }
10871
10872 /* Expects ffeexpr_find_.t.  */
10873
10874 static ffelexHandler
10875 ffeexpr_nil_number_period_ (ffelexToken t)
10876 {
10877   ffelexHandler nexthandler;
10878   char d;
10879   const char *p;
10880
10881   switch (ffelex_token_type (t))
10882     {
10883     case FFELEX_typeNAME:
10884     case FFELEX_typeNAMES:
10885       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10886                                    'D', 'd')
10887            || ffesrc_char_match_init (d, 'E', 'e')
10888            || ffesrc_char_match_init (d, 'Q', 'q'))
10889           && ffeexpr_isdigits_ (++p))
10890         {
10891           if (*p == '\0')
10892             return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10893           ffelex_token_kill (ffeexpr_find_.t);
10894           return (ffelexHandler) ffeexpr_nil_binary_;
10895         }
10896       nexthandler
10897         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10898       ffelex_token_kill (ffeexpr_find_.t);
10899       return (ffelexHandler) (*nexthandler) (t);
10900
10901     case FFELEX_typeNUMBER:
10902       ffelex_token_kill (ffeexpr_find_.t);
10903       return (ffelexHandler) ffeexpr_nil_number_real_;
10904
10905     default:
10906       break;
10907     }
10908   ffelex_token_kill (ffeexpr_find_.t);
10909   return (ffelexHandler) ffeexpr_nil_binary_ (t);
10910 }
10911
10912 /* Expects ffeexpr_find_.t.  */
10913
10914 static ffelexHandler
10915 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10916 {
10917   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10918       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10919     {
10920       ffelexHandler nexthandler;
10921
10922       nexthandler
10923         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10924       ffelex_token_kill (ffeexpr_find_.t);
10925       return (ffelexHandler) (*nexthandler) (t);
10926     }
10927
10928   ffelex_token_kill (ffeexpr_find_.t);
10929   return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10930 }
10931
10932 static ffelexHandler
10933 ffeexpr_nil_number_real_ (ffelexToken t)
10934 {
10935   char d;
10936   const char *p;
10937
10938   if (((ffelex_token_type (t) != FFELEX_typeNAME)
10939        && (ffelex_token_type (t) != FFELEX_typeNAMES))
10940       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10941                                      'D', 'd')
10942              || ffesrc_char_match_init (d, 'E', 'e')
10943              || ffesrc_char_match_init (d, 'Q', 'q')))
10944            && ffeexpr_isdigits_ (++p)))
10945     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10946
10947   if (*p == '\0')
10948     return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10949
10950   return (ffelexHandler) ffeexpr_nil_binary_;
10951 }
10952
10953 static ffelexHandler
10954 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
10955 {
10956   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10957     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10958   return (ffelexHandler) ffeexpr_nil_binary_;
10959 }
10960
10961 static ffelexHandler
10962 ffeexpr_nil_number_real_exp_ (ffelexToken t)
10963 {
10964   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10965       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10966     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10967   return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
10968 }
10969
10970 static ffelexHandler
10971 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
10972 {
10973   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10974     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10975   return (ffelexHandler) ffeexpr_nil_binary_;
10976 }
10977
10978 static ffelexHandler
10979 ffeexpr_nil_binary_ (ffelexToken t)
10980 {
10981   switch (ffelex_token_type (t))
10982     {
10983     case FFELEX_typePLUS:
10984     case FFELEX_typeMINUS:
10985     case FFELEX_typeASTERISK:
10986     case FFELEX_typeSLASH:
10987     case FFELEX_typePOWER:
10988     case FFELEX_typeCONCAT:
10989     case FFELEX_typeOPEN_ANGLE:
10990     case FFELEX_typeCLOSE_ANGLE:
10991     case FFELEX_typeREL_EQ:
10992     case FFELEX_typeREL_NE:
10993     case FFELEX_typeREL_GE:
10994     case FFELEX_typeREL_LE:
10995       return (ffelexHandler) ffeexpr_nil_rhs_;
10996
10997     case FFELEX_typePERIOD:
10998       return (ffelexHandler) ffeexpr_nil_binary_period_;
10999
11000     default:
11001       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11002     }
11003 }
11004
11005 static ffelexHandler
11006 ffeexpr_nil_binary_period_ (ffelexToken t)
11007 {
11008   switch (ffelex_token_type (t))
11009     {
11010     case FFELEX_typeNAME:
11011     case FFELEX_typeNAMES:
11012       ffeexpr_current_dotdot_ = ffestr_other (t);
11013       switch (ffeexpr_current_dotdot_)
11014         {
11015         case FFESTR_otherTRUE:
11016         case FFESTR_otherFALSE:
11017         case FFESTR_otherNOT:
11018           return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11019
11020         default:
11021           return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11022         }
11023       break;                    /* Nothing really reaches here. */
11024
11025     default:
11026       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11027     }
11028 }
11029
11030 static ffelexHandler
11031 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11032 {
11033   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11034     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11035   return (ffelexHandler) ffeexpr_nil_rhs_;
11036 }
11037
11038 static ffelexHandler
11039 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11040 {
11041   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11042     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11043   return (ffelexHandler) ffeexpr_nil_binary_;
11044 }
11045
11046 static ffelexHandler
11047 ffeexpr_nil_quote_ (ffelexToken t)
11048 {
11049   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11050     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11051   return (ffelexHandler) ffeexpr_nil_binary_;
11052 }
11053
11054 static ffelexHandler
11055 ffeexpr_nil_apostrophe_ (ffelexToken t)
11056 {
11057   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11058   return (ffelexHandler) ffeexpr_nil_apos_char_;
11059 }
11060
11061 static ffelexHandler
11062 ffeexpr_nil_apos_char_ (ffelexToken t)
11063 {
11064   char c;
11065
11066   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11067       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11068     {
11069       if ((ffelex_token_length (t) == 1)
11070           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11071                                       'B', 'b')
11072               || ffesrc_char_match_init (c, 'O', 'o')
11073               || ffesrc_char_match_init (c, 'X', 'x')
11074               || ffesrc_char_match_init (c, 'Z', 'z')))
11075         return (ffelexHandler) ffeexpr_nil_binary_;
11076     }
11077   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11078       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11079     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11080   return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11081 }
11082
11083 static ffelexHandler
11084 ffeexpr_nil_name_rhs_ (ffelexToken t)
11085 {
11086   switch (ffelex_token_type (t))
11087     {
11088     case FFELEX_typeQUOTE:
11089     case FFELEX_typeAPOSTROPHE:
11090       ffelex_set_hexnum (TRUE);
11091       return (ffelexHandler) ffeexpr_nil_name_apos_;
11092
11093     case FFELEX_typeOPEN_PAREN:
11094       ++ffeexpr_find_.level;
11095       return (ffelexHandler) ffeexpr_nil_rhs_;
11096
11097     default:
11098       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11099     }
11100 }
11101
11102 static ffelexHandler
11103 ffeexpr_nil_name_apos_ (ffelexToken t)
11104 {
11105   if (ffelex_token_type (t) == FFELEX_typeNAME)
11106     return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11107   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11108 }
11109
11110 static ffelexHandler
11111 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11112 {
11113   switch (ffelex_token_type (t))
11114     {
11115     case FFELEX_typeAPOSTROPHE:
11116     case FFELEX_typeQUOTE:
11117       return (ffelexHandler) ffeexpr_nil_finished_;
11118
11119     default:
11120       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11121     }
11122 }
11123
11124 static ffelexHandler
11125 ffeexpr_nil_percent_ (ffelexToken t)
11126 {
11127   switch (ffelex_token_type (t))
11128     {
11129     case FFELEX_typeNAME:
11130     case FFELEX_typeNAMES:
11131       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11132       ffeexpr_find_.t = ffelex_token_use (t);
11133       return (ffelexHandler) ffeexpr_nil_percent_name_;
11134
11135     default:
11136       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11137     }
11138 }
11139
11140 /* Expects ffeexpr_find_.t.  */
11141
11142 static ffelexHandler
11143 ffeexpr_nil_percent_name_ (ffelexToken t)
11144 {
11145   ffelexHandler nexthandler;
11146
11147   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11148     {
11149       nexthandler
11150         = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11151       ffelex_token_kill (ffeexpr_find_.t);
11152       return (ffelexHandler) (*nexthandler) (t);
11153     }
11154
11155   ffelex_token_kill (ffeexpr_find_.t);
11156   ++ffeexpr_find_.level;
11157   return (ffelexHandler) ffeexpr_nil_rhs_;
11158 }
11159
11160 static ffelexHandler
11161 ffeexpr_nil_substrp_ (ffelexToken t)
11162 {
11163   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11164     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11165
11166   ++ffeexpr_find_.level;
11167   return (ffelexHandler) ffeexpr_nil_rhs_;
11168 }
11169
11170 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11171
11172    ffelexToken t;
11173    return ffeexpr_finished_(t);
11174
11175    Reduces expression stack to one (or zero) elements by repeatedly reducing
11176    the top operator on the stack (or, if the top element on the stack is
11177    itself an operator, issuing an error message and discarding it).  Calls
11178    finishing routine with the expression, returning the ffelexHandler it
11179    returns to the caller.  */
11180
11181 static ffelexHandler
11182 ffeexpr_finished_ (ffelexToken t)
11183 {
11184   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
11185   ffebld expr;
11186   ffeexprCallback callback;
11187   ffeexprStack_ s;
11188   ffebldConstant constnode;     /* For detecting magical number. */
11189   ffelexToken ft;               /* Temporary copy of first token in
11190                                    expression. */
11191   ffelexHandler next;
11192   ffeinfo info;
11193   bool error = FALSE;
11194
11195   while (((operand = ffeexpr_stack_->exprstack) != NULL)
11196          && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11197     {
11198       if (operand->type == FFEEXPR_exprtypeOPERAND_)
11199         ffeexpr_reduce_ ();
11200       else
11201         {
11202           if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11203             {
11204               ffebad_here (0, ffelex_token_where_line (t),
11205                            ffelex_token_where_column (t));
11206               ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11207               ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11208               ffebad_finish ();
11209             }
11210           ffeexpr_stack_->exprstack = operand->previous;        /* Pop the useless
11211                                                                    operator. */
11212           ffeexpr_expr_kill_ (operand);
11213         }
11214     }
11215
11216   assert ((operand == NULL) || (operand->previous == NULL));
11217
11218   ffebld_pool_pop ();
11219   if (operand == NULL)
11220     expr = NULL;
11221   else
11222     {
11223       expr = operand->u.operand;
11224       info = ffebld_info (expr);
11225       if ((ffebld_op (expr) == FFEBLD_opCONTER)
11226           && (ffebld_conter_orig (expr) == NULL)
11227           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11228         {
11229           ffetarget_integer_bad_magical (operand->token);
11230         }
11231       ffeexpr_expr_kill_ (operand);
11232       ffeexpr_stack_->exprstack = NULL;
11233     }
11234
11235   ft = ffeexpr_stack_->first_token;
11236
11237 again:                          /* :::::::::::::::::::: */
11238   switch (ffeexpr_stack_->context)
11239     {
11240     case FFEEXPR_contextLET:
11241     case FFEEXPR_contextSFUNCDEF:
11242       error = (expr == NULL)
11243         || (ffeinfo_rank (info) != 0);
11244       break;
11245
11246     case FFEEXPR_contextPAREN_:
11247       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11248         break;
11249       switch (ffeinfo_basictype (info))
11250         {
11251         case FFEINFO_basictypeHOLLERITH:
11252         case FFEINFO_basictypeTYPELESS:
11253           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11254              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11255                                   FFEEXPR_contextLET);
11256           break;
11257
11258         default:
11259           break;
11260         }
11261       break;
11262
11263     case FFEEXPR_contextPARENFILENUM_:
11264       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11265         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11266       else
11267         ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11268       goto again;               /* :::::::::::::::::::: */
11269
11270     case FFEEXPR_contextPARENFILEUNIT_:
11271       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11272         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11273       else
11274         ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11275       goto again;               /* :::::::::::::::::::: */
11276
11277     case FFEEXPR_contextACTUALARGEXPR_:
11278     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11279       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11280               : ffeinfo_basictype (info))
11281         {
11282         case FFEINFO_basictypeHOLLERITH:
11283         case FFEINFO_basictypeTYPELESS:
11284           if (!ffe_is_ugly_args ()
11285               && ffebad_start (FFEBAD_ACTUALARG))
11286             {
11287               ffebad_here (0, ffelex_token_where_line (ft),
11288                            ffelex_token_where_column (ft));
11289               ffebad_finish ();
11290             }
11291           break;
11292
11293         default:
11294           break;
11295         }
11296       error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11297       break;
11298
11299     case FFEEXPR_contextACTUALARG_:
11300     case FFEEXPR_contextSFUNCDEFACTUALARG_:
11301       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11302               : ffeinfo_basictype (info))
11303         {
11304         case FFEINFO_basictypeHOLLERITH:
11305         case FFEINFO_basictypeTYPELESS:
11306 #if 0                           /* Should never get here. */
11307           expr = ffeexpr_convert (expr, ft, ft,
11308                                   FFEINFO_basictypeINTEGER,
11309                                   FFEINFO_kindtypeINTEGERDEFAULT,
11310                                   0,
11311                                   FFETARGET_charactersizeNONE,
11312                                   FFEEXPR_contextLET);
11313 #else
11314           assert ("why hollerith/typeless in actualarg_?" == NULL);
11315 #endif
11316           break;
11317
11318         default:
11319           break;
11320         }
11321       switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11322         {
11323         case FFEBLD_opSYMTER:
11324         case FFEBLD_opPERCENT_LOC:
11325         case FFEBLD_opPERCENT_VAL:
11326         case FFEBLD_opPERCENT_REF:
11327         case FFEBLD_opPERCENT_DESCR:
11328           error = FALSE;
11329           break;
11330
11331         default:
11332           error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11333           break;
11334         }
11335       {
11336         ffesymbol s;
11337         ffeinfoWhere where;
11338         ffeinfoKind kind;
11339
11340         if (!error
11341             && (expr != NULL)
11342             && (ffebld_op (expr) == FFEBLD_opSYMTER)
11343             && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11344                 (where == FFEINFO_whereINTRINSIC)
11345                 || (where == FFEINFO_whereGLOBAL)
11346                 || ((where == FFEINFO_whereDUMMY)
11347                     && ((kind = ffesymbol_kind (s)),
11348                         (kind == FFEINFO_kindFUNCTION)
11349                         || (kind == FFEINFO_kindSUBROUTINE))))
11350             && !ffesymbol_explicitwhere (s))
11351           {
11352             ffebad_start (where == FFEINFO_whereINTRINSIC
11353                           ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11354             ffebad_here (0, ffelex_token_where_line (ft),
11355                          ffelex_token_where_column (ft));
11356             ffebad_string (ffesymbol_text (s));
11357             ffebad_finish ();
11358             ffesymbol_signal_change (s);
11359             ffesymbol_set_explicitwhere (s, TRUE);
11360             ffesymbol_signal_unreported (s);
11361           }
11362       }
11363       break;
11364
11365     case FFEEXPR_contextINDEX_:
11366     case FFEEXPR_contextSFUNCDEFINDEX_:
11367       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11368         break;
11369       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11370               : ffeinfo_basictype (info))
11371         {
11372         case FFEINFO_basictypeNONE:
11373           error = FALSE;
11374           break;
11375
11376         case FFEINFO_basictypeLOGICAL:
11377           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11378              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11379                                   FFEEXPR_contextLET);
11380           /* Fall through. */
11381         case FFEINFO_basictypeREAL:
11382         case FFEINFO_basictypeCOMPLEX:
11383           if (ffe_is_pedantic ())
11384             {
11385               error = TRUE;
11386               break;
11387             }
11388           /* Fall through. */
11389         case FFEINFO_basictypeHOLLERITH:
11390         case FFEINFO_basictypeTYPELESS:
11391           error = FALSE;
11392           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11393              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11394                                   FFEEXPR_contextLET);
11395           break;
11396
11397         case FFEINFO_basictypeINTEGER:
11398           /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11399              unmolested.  Leave it to downstream to handle kinds.  */
11400           break;
11401
11402         default:
11403           error = TRUE;
11404           break;
11405         }
11406       break;                    /* expr==NULL ok for substring; element case
11407                                    caught by callback. */
11408
11409     case FFEEXPR_contextRETURN:
11410       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11411         break;
11412       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11413               : ffeinfo_basictype (info))
11414         {
11415         case FFEINFO_basictypeNONE:
11416           error = FALSE;
11417           break;
11418
11419         case FFEINFO_basictypeLOGICAL:
11420           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11421              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11422                                   FFEEXPR_contextLET);
11423           /* Fall through. */
11424         case FFEINFO_basictypeREAL:
11425         case FFEINFO_basictypeCOMPLEX:
11426           if (ffe_is_pedantic ())
11427             {
11428               error = TRUE;
11429               break;
11430             }
11431           /* Fall through. */
11432         case FFEINFO_basictypeINTEGER:
11433         case FFEINFO_basictypeHOLLERITH:
11434         case FFEINFO_basictypeTYPELESS:
11435           error = FALSE;
11436           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11437              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11438                                   FFEEXPR_contextLET);
11439           break;
11440
11441         default:
11442           error = TRUE;
11443           break;
11444         }
11445       break;
11446
11447     case FFEEXPR_contextDO:
11448       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11449         break;
11450       switch (ffeinfo_basictype (info))
11451         {
11452         case FFEINFO_basictypeLOGICAL:
11453           error = !ffe_is_ugly_logint ();
11454           if (!ffeexpr_stack_->is_rhs)
11455             break;              /* Don't convert lhs variable. */
11456           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11457                                   ffeinfo_kindtype (ffebld_info (expr)), 0,
11458                                   FFETARGET_charactersizeNONE,
11459                                   FFEEXPR_contextLET);
11460           break;
11461
11462         case FFEINFO_basictypeHOLLERITH:
11463         case FFEINFO_basictypeTYPELESS:
11464           if (!ffeexpr_stack_->is_rhs)
11465             {
11466               error = TRUE;
11467               break;            /* Don't convert lhs variable. */
11468             }
11469           break;
11470
11471         case FFEINFO_basictypeINTEGER:
11472         case FFEINFO_basictypeREAL:
11473           break;
11474
11475         default:
11476           error = TRUE;
11477           break;
11478         }
11479       if (!ffeexpr_stack_->is_rhs
11480           && (ffebld_op (expr) != FFEBLD_opSYMTER))
11481         error = TRUE;
11482       break;
11483
11484     case FFEEXPR_contextDOWHILE:
11485     case FFEEXPR_contextIF:
11486       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11487         break;
11488       switch (ffeinfo_basictype (info))
11489         {
11490         case FFEINFO_basictypeINTEGER:
11491           error = FALSE;
11492           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11493              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11494                                   FFEEXPR_contextLET);
11495           /* Fall through. */
11496         case FFEINFO_basictypeLOGICAL:
11497         case FFEINFO_basictypeHOLLERITH:
11498         case FFEINFO_basictypeTYPELESS:
11499           error = FALSE;
11500           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11501              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11502                                   FFEEXPR_contextLET);
11503           break;
11504
11505         default:
11506           error = TRUE;
11507           break;
11508         }
11509       break;
11510
11511     case FFEEXPR_contextASSIGN:
11512     case FFEEXPR_contextAGOTO:
11513       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11514               : ffeinfo_basictype (info))
11515         {
11516         case FFEINFO_basictypeINTEGER:
11517           error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11518           break;
11519
11520         case FFEINFO_basictypeLOGICAL:
11521           error = !ffe_is_ugly_logint ()
11522             || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11523           break;
11524
11525         default:
11526           error = TRUE;
11527           break;
11528         }
11529       if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11530           || (ffebld_op (expr) != FFEBLD_opSYMTER))
11531         error = TRUE;
11532       break;
11533
11534     case FFEEXPR_contextCGOTO:
11535     case FFEEXPR_contextFORMAT:
11536     case FFEEXPR_contextDIMLIST:
11537     case FFEEXPR_contextFILENUM:        /* See equiv code in _ambig_. */
11538       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11539         break;
11540       switch (ffeinfo_basictype (info))
11541         {
11542         case FFEINFO_basictypeLOGICAL:
11543           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11544              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11545                                   FFEEXPR_contextLET);
11546           /* Fall through. */
11547         case FFEINFO_basictypeREAL:
11548         case FFEINFO_basictypeCOMPLEX:
11549           if (ffe_is_pedantic ())
11550             {
11551               error = TRUE;
11552               break;
11553             }
11554           /* Fall through. */
11555         case FFEINFO_basictypeINTEGER:
11556         case FFEINFO_basictypeHOLLERITH:
11557         case FFEINFO_basictypeTYPELESS:
11558           error = FALSE;
11559           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11560              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11561                                   FFEEXPR_contextLET);
11562           break;
11563
11564         default:
11565           error = TRUE;
11566           break;
11567         }
11568       break;
11569
11570     case FFEEXPR_contextARITHIF:
11571       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11572         break;
11573       switch (ffeinfo_basictype (info))
11574         {
11575         case FFEINFO_basictypeLOGICAL:
11576           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11577              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11578                                   FFEEXPR_contextLET);
11579           if (ffe_is_pedantic ())
11580             {
11581               error = TRUE;
11582               break;
11583             }
11584           /* Fall through. */
11585         case FFEINFO_basictypeHOLLERITH:
11586         case FFEINFO_basictypeTYPELESS:
11587           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11588              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11589                                   FFEEXPR_contextLET);
11590           /* Fall through. */
11591         case FFEINFO_basictypeINTEGER:
11592         case FFEINFO_basictypeREAL:
11593           error = FALSE;
11594           break;
11595
11596         default:
11597           error = TRUE;
11598           break;
11599         }
11600       break;
11601
11602     case FFEEXPR_contextSTOP:
11603       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11604         break;
11605       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11606               : ffeinfo_basictype (info))
11607         {
11608         case FFEINFO_basictypeINTEGER:
11609           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11610           break;
11611
11612         case FFEINFO_basictypeCHARACTER:
11613           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11614           break;
11615
11616         case FFEINFO_basictypeHOLLERITH:
11617         case FFEINFO_basictypeTYPELESS:
11618           error = FALSE;
11619           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11620              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11621                                   FFEEXPR_contextLET);
11622           break;
11623
11624         case FFEINFO_basictypeNONE:
11625           error = FALSE;
11626           break;
11627
11628         default:
11629           error = TRUE;
11630           break;
11631         }
11632       if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11633                              || (ffebld_conter_orig (expr) != NULL)))
11634         error = TRUE;
11635       break;
11636
11637     case FFEEXPR_contextINCLUDE:
11638       error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11639         || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11640         || (ffebld_op (expr) != FFEBLD_opCONTER)
11641         || (ffebld_conter_orig (expr) != NULL);
11642       break;
11643
11644     case FFEEXPR_contextSELECTCASE:
11645       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11646         break;
11647       switch (ffeinfo_basictype (info))
11648         {
11649         case FFEINFO_basictypeINTEGER:
11650         case FFEINFO_basictypeCHARACTER:
11651         case FFEINFO_basictypeLOGICAL:
11652           error = FALSE;
11653           break;
11654
11655         case FFEINFO_basictypeHOLLERITH:
11656         case FFEINFO_basictypeTYPELESS:
11657           error = FALSE;
11658           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11659              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11660                                   FFEEXPR_contextLET);
11661           break;
11662
11663         default:
11664           error = TRUE;
11665           break;
11666         }
11667       break;
11668
11669     case FFEEXPR_contextCASE:
11670       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11671         break;
11672       switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11673               : ffeinfo_basictype (info))
11674         {
11675         case FFEINFO_basictypeINTEGER:
11676         case FFEINFO_basictypeCHARACTER:
11677         case FFEINFO_basictypeLOGICAL:
11678           error = FALSE;
11679           break;
11680
11681         case FFEINFO_basictypeHOLLERITH:
11682         case FFEINFO_basictypeTYPELESS:
11683           error = FALSE;
11684           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11685              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11686                                   FFEEXPR_contextLET);
11687           break;
11688
11689         default:
11690           error = TRUE;
11691           break;
11692         }
11693       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11694         error = TRUE;
11695       break;
11696
11697     case FFEEXPR_contextCHARACTERSIZE:
11698     case FFEEXPR_contextKINDTYPE:
11699     case FFEEXPR_contextDIMLISTCOMMON:
11700       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11701         break;
11702       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11703               : ffeinfo_basictype (info))
11704         {
11705         case FFEINFO_basictypeLOGICAL:
11706           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11707              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11708                                   FFEEXPR_contextLET);
11709           /* Fall through. */
11710         case FFEINFO_basictypeREAL:
11711         case FFEINFO_basictypeCOMPLEX:
11712           if (ffe_is_pedantic ())
11713             {
11714               error = TRUE;
11715               break;
11716             }
11717           /* Fall through. */
11718         case FFEINFO_basictypeINTEGER:
11719         case FFEINFO_basictypeHOLLERITH:
11720         case FFEINFO_basictypeTYPELESS:
11721           error = FALSE;
11722           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11723              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11724                                   FFEEXPR_contextLET);
11725           break;
11726
11727         default:
11728           error = TRUE;
11729           break;
11730         }
11731       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11732         error = TRUE;
11733       break;
11734
11735     case FFEEXPR_contextEQVINDEX_:
11736       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11737         break;
11738       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11739               : ffeinfo_basictype (info))
11740         {
11741         case FFEINFO_basictypeNONE:
11742           error = FALSE;
11743           break;
11744
11745         case FFEINFO_basictypeLOGICAL:
11746           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11747              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11748                                   FFEEXPR_contextLET);
11749           /* Fall through. */
11750         case FFEINFO_basictypeREAL:
11751         case FFEINFO_basictypeCOMPLEX:
11752           if (ffe_is_pedantic ())
11753             {
11754               error = TRUE;
11755               break;
11756             }
11757           /* Fall through. */
11758         case FFEINFO_basictypeINTEGER:
11759         case FFEINFO_basictypeHOLLERITH:
11760         case FFEINFO_basictypeTYPELESS:
11761           error = FALSE;
11762           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11763              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11764                                   FFEEXPR_contextLET);
11765           break;
11766
11767         default:
11768           error = TRUE;
11769           break;
11770         }
11771       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11772         error = TRUE;
11773       break;
11774
11775     case FFEEXPR_contextPARAMETER:
11776       if (ffeexpr_stack_->is_rhs)
11777         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11778           || (ffebld_op (expr) != FFEBLD_opCONTER);
11779       else
11780         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11781           || (ffebld_op (expr) != FFEBLD_opSYMTER);
11782       break;
11783
11784     case FFEEXPR_contextINDEXORACTUALARG_:
11785       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11786         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11787       else
11788         ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11789       goto again;               /* :::::::::::::::::::: */
11790
11791     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11792       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11793         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11794       else
11795         ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11796       goto again;               /* :::::::::::::::::::: */
11797
11798     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11799       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11800         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11801       else
11802         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11803       goto again;               /* :::::::::::::::::::: */
11804
11805     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11806       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11807         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11808       else
11809         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11810       goto again;               /* :::::::::::::::::::: */
11811
11812     case FFEEXPR_contextIMPDOCTRL_:
11813       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11814         break;
11815       if (!ffeexpr_stack_->is_rhs
11816           && (ffebld_op (expr) != FFEBLD_opSYMTER))
11817         error = TRUE;
11818       switch (ffeinfo_basictype (info))
11819         {
11820         case FFEINFO_basictypeLOGICAL:
11821           if (! ffe_is_ugly_logint ())
11822             error = TRUE;
11823           if (! ffeexpr_stack_->is_rhs)
11824             break;
11825           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11826                                   ffeinfo_kindtype (info), 0,
11827                                   FFETARGET_charactersizeNONE,
11828                                   FFEEXPR_contextLET);
11829           break;
11830
11831         case FFEINFO_basictypeINTEGER:
11832         case FFEINFO_basictypeHOLLERITH:
11833         case FFEINFO_basictypeTYPELESS:
11834           break;
11835
11836         case FFEINFO_basictypeREAL:
11837           if (!ffeexpr_stack_->is_rhs
11838               && ffe_is_warn_surprising ()
11839               && !error)
11840             {
11841               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
11842               ffebad_here (0, ffelex_token_where_line (ft),
11843                            ffelex_token_where_column (ft));
11844               ffebad_string (ffelex_token_text (ft));
11845               ffebad_finish ();
11846             }
11847           break;
11848
11849         default:
11850           error = TRUE;
11851           break;
11852         }
11853       break;
11854
11855     case FFEEXPR_contextDATAIMPDOCTRL_:
11856       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11857         break;
11858       if (ffeexpr_stack_->is_rhs)
11859         {
11860           if ((ffebld_op (expr) != FFEBLD_opCONTER)
11861               && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11862             error = TRUE;
11863         }
11864       else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11865                || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11866         error = TRUE;
11867       switch (ffeinfo_basictype (info))
11868         {
11869         case FFEINFO_basictypeLOGICAL:
11870           if (! ffeexpr_stack_->is_rhs)
11871             break;
11872           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11873                                   ffeinfo_kindtype (info), 0,
11874                                   FFETARGET_charactersizeNONE,
11875                                   FFEEXPR_contextLET);
11876           /* Fall through.  */
11877         case FFEINFO_basictypeINTEGER:
11878           if (ffeexpr_stack_->is_rhs
11879               && (ffeinfo_kindtype (ffebld_info (expr))
11880                   != FFEINFO_kindtypeINTEGERDEFAULT))
11881             expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11882                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
11883                                     FFETARGET_charactersizeNONE,
11884                                     FFEEXPR_contextLET);
11885           break;
11886
11887         case FFEINFO_basictypeHOLLERITH:
11888         case FFEINFO_basictypeTYPELESS:
11889           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11890              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11891                                   FFEEXPR_contextLET);
11892           break;
11893
11894         case FFEINFO_basictypeREAL:
11895           if (!ffeexpr_stack_->is_rhs
11896               && ffe_is_warn_surprising ()
11897               && !error)
11898             {
11899               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
11900               ffebad_here (0, ffelex_token_where_line (ft),
11901                            ffelex_token_where_column (ft));
11902               ffebad_string (ffelex_token_text (ft));
11903               ffebad_finish ();
11904             }
11905           break;
11906
11907         default:
11908           error = TRUE;
11909           break;
11910         }
11911       break;
11912
11913     case FFEEXPR_contextIMPDOITEM_:
11914       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11915         {
11916           ffeexpr_stack_->is_rhs = FALSE;
11917           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11918           goto again;           /* :::::::::::::::::::: */
11919         }
11920       /* Fall through. */
11921     case FFEEXPR_contextIOLIST:
11922     case FFEEXPR_contextFILEVXTCODE:
11923       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11924               : ffeinfo_basictype (info))
11925         {
11926         case FFEINFO_basictypeHOLLERITH:
11927         case FFEINFO_basictypeTYPELESS:
11928           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11929              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11930                                   FFEEXPR_contextLET);
11931           break;
11932
11933         default:
11934           break;
11935         }
11936       error = (expr == NULL)
11937         || ((ffeinfo_rank (info) != 0)
11938             && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11939                 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11940                 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11941                     == FFEBLD_opSTAR)));        /* Bad if null expr, or if
11942                                                    array that is not a SYMTER
11943                                                    (can't happen yet, I
11944                                                    think) or has a NULL or
11945                                                    STAR (assumed) array
11946                                                    size. */
11947       break;
11948
11949     case FFEEXPR_contextIMPDOITEMDF_:
11950       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11951         {
11952           ffeexpr_stack_->is_rhs = FALSE;
11953           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11954           goto again;           /* :::::::::::::::::::: */
11955         }
11956       /* Fall through. */
11957     case FFEEXPR_contextIOLISTDF:
11958       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11959               : ffeinfo_basictype (info))
11960         {
11961         case FFEINFO_basictypeHOLLERITH:
11962         case FFEINFO_basictypeTYPELESS:
11963           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11964              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11965                                   FFEEXPR_contextLET);
11966           break;
11967
11968         default:
11969           break;
11970         }
11971       error
11972         = (expr == NULL)
11973           || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
11974               && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
11975             || ((ffeinfo_rank (info) != 0)
11976                 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11977                     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11978                     || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11979                         == FFEBLD_opSTAR)));    /* Bad if null expr,
11980                                                    non-default-kindtype
11981                                                    character expr, or if
11982                                                    array that is not a SYMTER
11983                                                    (can't happen yet, I
11984                                                    think) or has a NULL or
11985                                                    STAR (assumed) array
11986                                                    size. */
11987       break;
11988
11989     case FFEEXPR_contextDATAIMPDOITEM_:
11990       error = (expr == NULL)
11991         || (ffebld_op (expr) != FFEBLD_opARRAYREF)
11992         || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
11993             && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
11994       break;
11995
11996     case FFEEXPR_contextDATAIMPDOINDEX_:
11997       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11998         break;
11999       switch (ffeinfo_basictype (info))
12000         {
12001         case FFEINFO_basictypeLOGICAL:
12002           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12003              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12004                                   FFEEXPR_contextLET);
12005           /* Fall through. */
12006         case FFEINFO_basictypeREAL:
12007         case FFEINFO_basictypeCOMPLEX:
12008           if (ffe_is_pedantic ())
12009             {
12010               error = TRUE;
12011               break;
12012             }
12013           /* Fall through. */
12014         case FFEINFO_basictypeINTEGER:
12015         case FFEINFO_basictypeHOLLERITH:
12016         case FFEINFO_basictypeTYPELESS:
12017           error = FALSE;
12018           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12019              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12020                                   FFEEXPR_contextLET);
12021           break;
12022
12023         default:
12024           error = TRUE;
12025           break;
12026         }
12027       if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12028           && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12029         error = TRUE;
12030       break;
12031
12032     case FFEEXPR_contextDATA:
12033       if (expr == NULL)
12034         error = TRUE;
12035       else if (ffeexpr_stack_->is_rhs)
12036         error = (ffebld_op (expr) != FFEBLD_opCONTER);
12037       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12038         error = FALSE;
12039       else
12040         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12041       break;
12042
12043     case FFEEXPR_contextINITVAL:
12044       error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12045       break;
12046
12047     case FFEEXPR_contextEQUIVALENCE:
12048       if (expr == NULL)
12049         error = TRUE;
12050       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12051         error = FALSE;
12052       else
12053         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12054       break;
12055
12056     case FFEEXPR_contextFILEASSOC:
12057     case FFEEXPR_contextFILEINT:
12058       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12059               : ffeinfo_basictype (info))
12060         {
12061         case FFEINFO_basictypeINTEGER:
12062           /* Maybe this should be supported someday, but, right now,
12063              g77 can't generate a call to libf2c to write to an
12064              integer other than the default size.  */
12065           error = ((! ffeexpr_stack_->is_rhs)
12066                    && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12067           break;
12068
12069         default:
12070           error = TRUE;
12071           break;
12072         }
12073       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12074         error = TRUE;
12075       break;
12076
12077     case FFEEXPR_contextFILEDFINT:
12078       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12079               : ffeinfo_basictype (info))
12080         {
12081         case FFEINFO_basictypeINTEGER:
12082           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12083           break;
12084
12085         default:
12086           error = TRUE;
12087           break;
12088         }
12089       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12090         error = TRUE;
12091       break;
12092
12093     case FFEEXPR_contextFILELOG:
12094       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12095               : ffeinfo_basictype (info))
12096         {
12097         case FFEINFO_basictypeLOGICAL:
12098           error = FALSE;
12099           break;
12100
12101         default:
12102           error = TRUE;
12103           break;
12104         }
12105       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12106         error = TRUE;
12107       break;
12108
12109     case FFEEXPR_contextFILECHAR:
12110       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12111               : ffeinfo_basictype (info))
12112         {
12113         case FFEINFO_basictypeCHARACTER:
12114           error = FALSE;
12115           break;
12116
12117         default:
12118           error = TRUE;
12119           break;
12120         }
12121       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12122         error = TRUE;
12123       break;
12124
12125     case FFEEXPR_contextFILENUMCHAR:
12126       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12127         break;
12128       switch (ffeinfo_basictype (info))
12129         {
12130         case FFEINFO_basictypeLOGICAL:
12131           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12132              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12133                                   FFEEXPR_contextLET);
12134           /* Fall through. */
12135         case FFEINFO_basictypeREAL:
12136         case FFEINFO_basictypeCOMPLEX:
12137           if (ffe_is_pedantic ())
12138             {
12139               error = TRUE;
12140               break;
12141             }
12142           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12143              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12144                                   FFEEXPR_contextLET);
12145           break;
12146
12147         case FFEINFO_basictypeINTEGER:
12148         case FFEINFO_basictypeCHARACTER:
12149           error = FALSE;
12150           break;
12151
12152         default:
12153           error = TRUE;
12154           break;
12155         }
12156       break;
12157
12158     case FFEEXPR_contextFILEDFCHAR:
12159       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12160         break;
12161       switch (ffeinfo_basictype (info))
12162         {
12163         case FFEINFO_basictypeCHARACTER:
12164           error
12165             = (ffeinfo_kindtype (info)
12166                != FFEINFO_kindtypeCHARACTERDEFAULT);
12167           break;
12168
12169         default:
12170           error = TRUE;
12171           break;
12172         }
12173       if (!ffeexpr_stack_->is_rhs
12174           && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12175         error = TRUE;
12176       break;
12177
12178     case FFEEXPR_contextFILEUNIT:       /* See equiv code in _ambig_. */
12179       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12180               : ffeinfo_basictype (info))
12181         {
12182         case FFEINFO_basictypeLOGICAL:
12183           if ((error = (ffeinfo_rank (info) != 0)))
12184             break;
12185           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12186              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12187                                   FFEEXPR_contextLET);
12188           /* Fall through. */
12189         case FFEINFO_basictypeREAL:
12190         case FFEINFO_basictypeCOMPLEX:
12191           if ((error = (ffeinfo_rank (info) != 0)))
12192             break;
12193           if (ffe_is_pedantic ())
12194             {
12195               error = TRUE;
12196               break;
12197             }
12198           /* Fall through. */
12199         case FFEINFO_basictypeINTEGER:
12200         case FFEINFO_basictypeHOLLERITH:
12201         case FFEINFO_basictypeTYPELESS:
12202           if ((error = (ffeinfo_rank (info) != 0)))
12203             break;
12204           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12205              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12206                                   FFEEXPR_contextLET);
12207           break;
12208
12209         case FFEINFO_basictypeCHARACTER:
12210           switch (ffebld_op (expr))
12211             {                   /* As if _lhs had been called instead of
12212                                    _rhs. */
12213             case FFEBLD_opSYMTER:
12214               error
12215                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12216               break;
12217
12218             case FFEBLD_opSUBSTR:
12219               error = (ffeinfo_where (ffebld_info (expr))
12220                        == FFEINFO_whereCONSTANT_SUBOBJECT);
12221               break;
12222
12223             case FFEBLD_opARRAYREF:
12224               error = FALSE;
12225               break;
12226
12227             default:
12228               error = TRUE;
12229               break;
12230             }
12231           if (!error
12232            && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12233                || ((ffeinfo_rank (info) != 0)
12234                    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12235                      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12236                   || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12237                       == FFEBLD_opSTAR)))))     /* Bad if
12238                                                    non-default-kindtype
12239                                                    character expr, or if
12240                                                    array that is not a SYMTER
12241                                                    (can't happen yet, I
12242                                                    think), or has a NULL or
12243                                                    STAR (assumed) array
12244                                                    size. */
12245             error = TRUE;
12246           break;
12247
12248         default:
12249           error = TRUE;
12250           break;
12251         }
12252       break;
12253
12254     case FFEEXPR_contextFILEFORMAT:
12255       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12256               : ffeinfo_basictype (info))
12257         {
12258         case FFEINFO_basictypeINTEGER:
12259           error = (expr == NULL)
12260             || ((ffeinfo_rank (info) != 0) ?
12261                 ffe_is_pedantic ()      /* F77 C5. */
12262                 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12263             || (ffebld_op (expr) != FFEBLD_opSYMTER);
12264           break;
12265
12266         case FFEINFO_basictypeLOGICAL:
12267         case FFEINFO_basictypeREAL:
12268         case FFEINFO_basictypeCOMPLEX:
12269           /* F77 C5 -- must be an array of hollerith.  */
12270           error
12271             = ffe_is_pedantic ()
12272               || (ffeinfo_rank (info) == 0);
12273           break;
12274
12275         case FFEINFO_basictypeCHARACTER:
12276           if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12277               || ((ffeinfo_rank (info) != 0)
12278                   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12279                       || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12280                       || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12281                           == FFEBLD_opSTAR))))  /* Bad if
12282                                                    non-default-kindtype
12283                                                    character expr, or if
12284                                                    array that is not a SYMTER
12285                                                    (can't happen yet, I
12286                                                    think), or has a NULL or
12287                                                    STAR (assumed) array
12288                                                    size. */
12289             error = TRUE;
12290           else
12291             error = FALSE;
12292           break;
12293
12294         default:
12295           error = TRUE;
12296           break;
12297         }
12298       break;
12299
12300     case FFEEXPR_contextLOC_:
12301       /* See also ffeintrin_check_loc_.  */
12302       if ((expr == NULL)
12303           || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12304           || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12305               && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12306               && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12307         error = TRUE;
12308       break;
12309
12310     default:
12311       error = FALSE;
12312       break;
12313     }
12314
12315   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12316     {
12317       ffebad_start (FFEBAD_EXPR_WRONG);
12318       ffebad_here (0, ffelex_token_where_line (ft),
12319                    ffelex_token_where_column (ft));
12320       ffebad_finish ();
12321       expr = ffebld_new_any ();
12322       ffebld_set_info (expr, ffeinfo_new_any ());
12323     }
12324
12325   callback = ffeexpr_stack_->callback;
12326   s = ffeexpr_stack_->previous;
12327   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12328                   sizeof (*ffeexpr_stack_));
12329   ffeexpr_stack_ = s;
12330   next = (ffelexHandler) (*callback) (ft, expr, t);
12331   ffelex_token_kill (ft);
12332   return (ffelexHandler) next;
12333 }
12334
12335 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12336
12337    ffebld expr;
12338    expr = ffeexpr_finished_ambig_(expr);
12339
12340    Replicates a bit of ffeexpr_finished_'s task when in a context
12341    of UNIT or FORMAT.  */
12342
12343 static ffebld
12344 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12345 {
12346   ffeinfo info = ffebld_info (expr);
12347   bool error;
12348
12349   switch (ffeexpr_stack_->context)
12350     {
12351     case FFEEXPR_contextFILENUMAMBIG:   /* Same as FILENUM in _finished_. */
12352       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12353               : ffeinfo_basictype (info))
12354         {
12355         case FFEINFO_basictypeLOGICAL:
12356           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12357              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12358                                   FFEEXPR_contextLET);
12359           /* Fall through. */
12360         case FFEINFO_basictypeREAL:
12361         case FFEINFO_basictypeCOMPLEX:
12362           if (ffe_is_pedantic ())
12363             {
12364               error = TRUE;
12365               break;
12366             }
12367           /* Fall through. */
12368         case FFEINFO_basictypeINTEGER:
12369         case FFEINFO_basictypeHOLLERITH:
12370         case FFEINFO_basictypeTYPELESS:
12371           error = FALSE;
12372           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12373              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12374                                   FFEEXPR_contextLET);
12375           break;
12376
12377         default:
12378           error = TRUE;
12379           break;
12380         }
12381       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12382         error = TRUE;
12383       break;
12384
12385     case FFEEXPR_contextFILEUNITAMBIG:  /* Same as FILEUNIT in _finished_. */
12386       if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12387         {
12388           error = FALSE;
12389           break;
12390         }
12391       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12392               : ffeinfo_basictype (info))
12393         {
12394         case FFEINFO_basictypeLOGICAL:
12395           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12396              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12397                                   FFEEXPR_contextLET);
12398           /* Fall through. */
12399         case FFEINFO_basictypeREAL:
12400         case FFEINFO_basictypeCOMPLEX:
12401           if (ffe_is_pedantic ())
12402             {
12403               error = TRUE;
12404               break;
12405             }
12406           /* Fall through. */
12407         case FFEINFO_basictypeINTEGER:
12408         case FFEINFO_basictypeHOLLERITH:
12409         case FFEINFO_basictypeTYPELESS:
12410           error = (ffeinfo_rank (info) != 0);
12411           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12412              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12413                                   FFEEXPR_contextLET);
12414           break;
12415
12416         case FFEINFO_basictypeCHARACTER:
12417           switch (ffebld_op (expr))
12418             {                   /* As if _lhs had been called instead of
12419                                    _rhs. */
12420             case FFEBLD_opSYMTER:
12421               error
12422                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12423               break;
12424
12425             case FFEBLD_opSUBSTR:
12426               error = (ffeinfo_where (ffebld_info (expr))
12427                        == FFEINFO_whereCONSTANT_SUBOBJECT);
12428               break;
12429
12430             case FFEBLD_opARRAYREF:
12431               error = FALSE;
12432               break;
12433
12434             default:
12435               error = TRUE;
12436               break;
12437             }
12438           break;
12439
12440         default:
12441           error = TRUE;
12442           break;
12443         }
12444       break;
12445
12446     default:
12447       assert ("bad context" == NULL);
12448       error = TRUE;
12449       break;
12450     }
12451
12452   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12453     {
12454       ffebad_start (FFEBAD_EXPR_WRONG);
12455       ffebad_here (0, ffelex_token_where_line (ft),
12456                    ffelex_token_where_column (ft));
12457       ffebad_finish ();
12458       expr = ffebld_new_any ();
12459       ffebld_set_info (expr, ffeinfo_new_any ());
12460     }
12461
12462   return expr;
12463 }
12464
12465 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12466
12467    Return a pointer to this function to the lexer (ffelex), which will
12468    invoke it for the next token.
12469
12470    Basically a smaller version of _rhs_; keep them both in sync, of course.  */
12471
12472 static ffelexHandler
12473 ffeexpr_token_lhs_ (ffelexToken t)
12474 {
12475
12476   /* When changing the list of valid initial lhs tokens, check whether to
12477      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12478      READ (expr) <token> case -- it assumes it knows which tokens <token> can
12479      be to indicate an lhs (or implied DO), which right now is the set
12480      {NAME,OPEN_PAREN}.
12481
12482      This comment also appears in ffeexpr_token_first_lhs_. */
12483
12484   switch (ffelex_token_type (t))
12485     {
12486     case FFELEX_typeNAME:
12487     case FFELEX_typeNAMES:
12488       ffeexpr_tokens_[0] = ffelex_token_use (t);
12489       return (ffelexHandler) ffeexpr_token_name_lhs_;
12490
12491     default:
12492       return (ffelexHandler) ffeexpr_finished_ (t);
12493     }
12494 }
12495
12496 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12497
12498    Return a pointer to this function to the lexer (ffelex), which will
12499    invoke it for the next token.
12500
12501    The initial state and the post-binary-operator state are the same and
12502    both handled here, with the expression stack used to distinguish
12503    between them.  Binary operators are invalid here; unary operators,
12504    constants, subexpressions, and name references are valid.  */
12505
12506 static ffelexHandler
12507 ffeexpr_token_rhs_ (ffelexToken t)
12508 {
12509   ffeexprExpr_ e;
12510
12511   switch (ffelex_token_type (t))
12512     {
12513     case FFELEX_typeQUOTE:
12514       if (ffe_is_vxt ())
12515         {
12516           ffeexpr_tokens_[0] = ffelex_token_use (t);
12517           return (ffelexHandler) ffeexpr_token_quote_;
12518         }
12519       ffeexpr_tokens_[0] = ffelex_token_use (t);
12520       ffelex_set_expecting_hollerith (-1, '\"',
12521                                       ffelex_token_where_line (t),
12522                                       ffelex_token_where_column (t));
12523       /* Don't have to unset this one. */
12524       return (ffelexHandler) ffeexpr_token_apostrophe_;
12525
12526     case FFELEX_typeAPOSTROPHE:
12527       ffeexpr_tokens_[0] = ffelex_token_use (t);
12528       ffelex_set_expecting_hollerith (-1, '\'',
12529                                       ffelex_token_where_line (t),
12530                                       ffelex_token_where_column (t));
12531       /* Don't have to unset this one. */
12532       return (ffelexHandler) ffeexpr_token_apostrophe_;
12533
12534     case FFELEX_typePERCENT:
12535       ffeexpr_tokens_[0] = ffelex_token_use (t);
12536       return (ffelexHandler) ffeexpr_token_percent_;
12537
12538     case FFELEX_typeOPEN_PAREN:
12539       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12540       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12541                                           FFEEXPR_contextPAREN_,
12542                                           ffeexpr_cb_close_paren_c_);
12543
12544     case FFELEX_typePLUS:
12545       e = ffeexpr_expr_new_ ();
12546       e->type = FFEEXPR_exprtypeUNARY_;
12547       e->token = ffelex_token_use (t);
12548       e->u.operator.op = FFEEXPR_operatorADD_;
12549       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12550       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12551       ffeexpr_exprstack_push_unary_ (e);
12552       return (ffelexHandler) ffeexpr_token_rhs_;
12553
12554     case FFELEX_typeMINUS:
12555       e = ffeexpr_expr_new_ ();
12556       e->type = FFEEXPR_exprtypeUNARY_;
12557       e->token = ffelex_token_use (t);
12558       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12559       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12560       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12561       ffeexpr_exprstack_push_unary_ (e);
12562       return (ffelexHandler) ffeexpr_token_rhs_;
12563
12564     case FFELEX_typePERIOD:
12565       ffeexpr_tokens_[0] = ffelex_token_use (t);
12566       return (ffelexHandler) ffeexpr_token_period_;
12567
12568     case FFELEX_typeNUMBER:
12569       ffeexpr_tokens_[0] = ffelex_token_use (t);
12570       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12571       if (ffeexpr_hollerith_count_ > 0)
12572         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12573                                         '\0',
12574                                         ffelex_token_where_line (t),
12575                                         ffelex_token_where_column (t));
12576       return (ffelexHandler) ffeexpr_token_number_;
12577
12578     case FFELEX_typeNAME:
12579     case FFELEX_typeNAMES:
12580       ffeexpr_tokens_[0] = ffelex_token_use (t);
12581       switch (ffeexpr_stack_->context)
12582         {
12583         case FFEEXPR_contextACTUALARG_:
12584         case FFEEXPR_contextINDEXORACTUALARG_:
12585         case FFEEXPR_contextSFUNCDEFACTUALARG_:
12586         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12587           return (ffelexHandler) ffeexpr_token_name_arg_;
12588
12589         default:
12590           return (ffelexHandler) ffeexpr_token_name_rhs_;
12591         }
12592
12593     case FFELEX_typeASTERISK:
12594     case FFELEX_typeSLASH:
12595     case FFELEX_typePOWER:
12596     case FFELEX_typeCONCAT:
12597     case FFELEX_typeREL_EQ:
12598     case FFELEX_typeREL_NE:
12599     case FFELEX_typeREL_LE:
12600     case FFELEX_typeREL_GE:
12601       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12602         {
12603           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12604           ffebad_finish ();
12605         }
12606       return (ffelexHandler) ffeexpr_token_rhs_;
12607
12608 #if 0
12609     case FFELEX_typeEQUALS:
12610     case FFELEX_typePOINTS:
12611     case FFELEX_typeCLOSE_ANGLE:
12612     case FFELEX_typeCLOSE_PAREN:
12613     case FFELEX_typeCOMMA:
12614     case FFELEX_typeCOLON:
12615     case FFELEX_typeEOS:
12616     case FFELEX_typeSEMICOLON:
12617 #endif
12618     default:
12619       return (ffelexHandler) ffeexpr_finished_ (t);
12620     }
12621 }
12622
12623 /* ffeexpr_token_period_ -- Rhs PERIOD
12624
12625    Return a pointer to this function to the lexer (ffelex), which will
12626    invoke it for the next token.
12627
12628    Handle a period detected at rhs (expecting unary op or operand) state.
12629    Must begin a floating-point value (as in .12) or a dot-dot name, of
12630    which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
12631    valid names represent binary operators, which are invalid here because
12632    there isn't an operand at the top of the stack.  */
12633
12634 static ffelexHandler
12635 ffeexpr_token_period_ (ffelexToken t)
12636 {
12637   switch (ffelex_token_type (t))
12638     {
12639     case FFELEX_typeNAME:
12640     case FFELEX_typeNAMES:
12641       ffeexpr_current_dotdot_ = ffestr_other (t);
12642       switch (ffeexpr_current_dotdot_)
12643         {
12644         case FFESTR_otherNone:
12645           if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12646             {
12647               ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12648                            ffelex_token_where_column (ffeexpr_tokens_[0]));
12649               ffebad_finish ();
12650             }
12651           ffelex_token_kill (ffeexpr_tokens_[0]);
12652           return (ffelexHandler) ffeexpr_token_rhs_ (t);
12653
12654         case FFESTR_otherTRUE:
12655         case FFESTR_otherFALSE:
12656         case FFESTR_otherNOT:
12657           ffeexpr_tokens_[1] = ffelex_token_use (t);
12658           return (ffelexHandler) ffeexpr_token_end_period_;
12659
12660         default:
12661           if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12662             {
12663               ffebad_here (0, ffelex_token_where_line (t),
12664                            ffelex_token_where_column (t));
12665               ffebad_finish ();
12666             }
12667           ffelex_token_kill (ffeexpr_tokens_[0]);
12668           return (ffelexHandler) ffeexpr_token_swallow_period_;
12669         }
12670       break;                    /* Nothing really reaches here. */
12671
12672     case FFELEX_typeNUMBER:
12673       ffeexpr_tokens_[1] = ffelex_token_use (t);
12674       return (ffelexHandler) ffeexpr_token_real_;
12675
12676     default:
12677       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12678         {
12679           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12680                        ffelex_token_where_column (ffeexpr_tokens_[0]));
12681           ffebad_finish ();
12682         }
12683       ffelex_token_kill (ffeexpr_tokens_[0]);
12684       return (ffelexHandler) ffeexpr_token_rhs_ (t);
12685     }
12686 }
12687
12688 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12689
12690    Return a pointer to this function to the lexer (ffelex), which will
12691    invoke it for the next token.
12692
12693    Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12694    or operator) state.  If period isn't found, issue a diagnostic but
12695    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
12696    dotdot representation of the name in between the two PERIOD tokens.  */
12697
12698 static ffelexHandler
12699 ffeexpr_token_end_period_ (ffelexToken t)
12700 {
12701   ffeexprExpr_ e;
12702
12703   if (ffelex_token_type (t) != FFELEX_typePERIOD)
12704     {
12705       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12706         {
12707           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12708                        ffelex_token_where_column (ffeexpr_tokens_[0]));
12709           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12710           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12711           ffebad_finish ();
12712         }
12713     }
12714
12715   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill "NOT"/"TRUE"/"FALSE"
12716                                                    token. */
12717
12718   e = ffeexpr_expr_new_ ();
12719   e->token = ffeexpr_tokens_[0];
12720
12721   switch (ffeexpr_current_dotdot_)
12722     {
12723     case FFESTR_otherNOT:
12724       e->type = FFEEXPR_exprtypeUNARY_;
12725       e->u.operator.op = FFEEXPR_operatorNOT_;
12726       e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12727       e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12728       ffeexpr_exprstack_push_unary_ (e);
12729       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12730         return (ffelexHandler) ffeexpr_token_rhs_ (t);
12731       return (ffelexHandler) ffeexpr_token_rhs_;
12732
12733     case FFESTR_otherTRUE:
12734       e->type = FFEEXPR_exprtypeOPERAND_;
12735       e->u.operand
12736         = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12737       ffebld_set_info (e->u.operand,
12738       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12739                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12740       ffeexpr_exprstack_push_operand_ (e);
12741       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12742         return (ffelexHandler) ffeexpr_token_binary_ (t);
12743       return (ffelexHandler) ffeexpr_token_binary_;
12744
12745     case FFESTR_otherFALSE:
12746       e->type = FFEEXPR_exprtypeOPERAND_;
12747       e->u.operand
12748         = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12749       ffebld_set_info (e->u.operand,
12750       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12751                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12752       ffeexpr_exprstack_push_operand_ (e);
12753       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12754         return (ffelexHandler) ffeexpr_token_binary_ (t);
12755       return (ffelexHandler) ffeexpr_token_binary_;
12756
12757     default:
12758       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12759       exit (0);
12760       return NULL;
12761     }
12762 }
12763
12764 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12765
12766    Return a pointer to this function to the lexer (ffelex), which will
12767    invoke it for the next token.
12768
12769    A diagnostic has already been issued; just swallow a period if there is
12770    one, then continue with ffeexpr_token_rhs_.  */
12771
12772 static ffelexHandler
12773 ffeexpr_token_swallow_period_ (ffelexToken t)
12774 {
12775   if (ffelex_token_type (t) != FFELEX_typePERIOD)
12776     return (ffelexHandler) ffeexpr_token_rhs_ (t);
12777
12778   return (ffelexHandler) ffeexpr_token_rhs_;
12779 }
12780
12781 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12782
12783    Return a pointer to this function to the lexer (ffelex), which will
12784    invoke it for the next token.
12785
12786    After a period and a string of digits, check next token for possible
12787    exponent designation (D, E, or Q as first/only character) and continue
12788    real-number handling accordingly.  Else form basic real constant, push
12789    onto expression stack, and enter binary state using current token (which,
12790    if it is a name not beginning with D, E, or Q, will certainly result
12791    in an error, but that's not for this routine to deal with).  */
12792
12793 static ffelexHandler
12794 ffeexpr_token_real_ (ffelexToken t)
12795 {
12796   char d;
12797   const char *p;
12798
12799   if (((ffelex_token_type (t) != FFELEX_typeNAME)
12800        && (ffelex_token_type (t) != FFELEX_typeNAMES))
12801       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12802                                      'D', 'd')
12803              || ffesrc_char_match_init (d, 'E', 'e')
12804              || ffesrc_char_match_init (d, 'Q', 'q')))
12805            && ffeexpr_isdigits_ (++p)))
12806     {
12807 #if 0
12808       /* This code has been removed because it seems inconsistent to
12809          produce a diagnostic in this case, but not all of the other
12810          ones that look for an exponent and cannot recognize one.  */
12811       if (((ffelex_token_type (t) == FFELEX_typeNAME)
12812            || (ffelex_token_type (t) == FFELEX_typeNAMES))
12813           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12814         {
12815           char bad[2];
12816
12817           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12818           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12819                        ffelex_token_where_column (ffeexpr_tokens_[0]));
12820           bad[0] = *(p - 1);
12821           bad[1] = '\0';
12822           ffebad_string (bad);
12823           ffebad_finish ();
12824         }
12825 #endif
12826       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12827                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12828                                  NULL, NULL, NULL);
12829
12830       ffelex_token_kill (ffeexpr_tokens_[0]);
12831       ffelex_token_kill (ffeexpr_tokens_[1]);
12832       return (ffelexHandler) ffeexpr_token_binary_ (t);
12833     }
12834
12835   /* Just exponent character by itself?  In which case, PLUS or MINUS must
12836      surely be next, followed by a NUMBER token. */
12837
12838   if (*p == '\0')
12839     {
12840       ffeexpr_tokens_[2] = ffelex_token_use (t);
12841       return (ffelexHandler) ffeexpr_token_real_exponent_;
12842     }
12843
12844   ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12845                              t, NULL, NULL);
12846
12847   ffelex_token_kill (ffeexpr_tokens_[0]);
12848   ffelex_token_kill (ffeexpr_tokens_[1]);
12849   return (ffelexHandler) ffeexpr_token_binary_;
12850 }
12851
12852 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12853
12854    Return a pointer to this function to the lexer (ffelex), which will
12855    invoke it for the next token.
12856
12857    Ensures this token is PLUS or MINUS, preserves it, goes to final state
12858    for real number (exponent digits).  Else issues diagnostic, assumes a
12859    zero exponent field for number, passes token on to binary state as if
12860    previous token had been "E0" instead of "E", for example.  */
12861
12862 static ffelexHandler
12863 ffeexpr_token_real_exponent_ (ffelexToken t)
12864 {
12865   if ((ffelex_token_type (t) != FFELEX_typePLUS)
12866       && (ffelex_token_type (t) != FFELEX_typeMINUS))
12867     {
12868       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12869         {
12870           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12871                        ffelex_token_where_column (ffeexpr_tokens_[2]));
12872           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12873           ffebad_finish ();
12874         }
12875
12876       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12877                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12878                                  NULL, NULL, NULL);
12879
12880       ffelex_token_kill (ffeexpr_tokens_[0]);
12881       ffelex_token_kill (ffeexpr_tokens_[1]);
12882       ffelex_token_kill (ffeexpr_tokens_[2]);
12883       return (ffelexHandler) ffeexpr_token_binary_ (t);
12884     }
12885
12886   ffeexpr_tokens_[3] = ffelex_token_use (t);
12887   return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12888 }
12889
12890 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12891
12892    Return a pointer to this function to the lexer (ffelex), which will
12893    invoke it for the next token.
12894
12895    Make sure token is a NUMBER, make a real constant out of all we have and
12896    push it onto the expression stack.  Else issue diagnostic and pretend
12897    exponent field was a zero.  */
12898
12899 static ffelexHandler
12900 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12901 {
12902   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12903     {
12904       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12905         {
12906           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12907                        ffelex_token_where_column (ffeexpr_tokens_[2]));
12908           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12909           ffebad_finish ();
12910         }
12911
12912       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12913                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12914                                  NULL, NULL, NULL);
12915
12916       ffelex_token_kill (ffeexpr_tokens_[0]);
12917       ffelex_token_kill (ffeexpr_tokens_[1]);
12918       ffelex_token_kill (ffeexpr_tokens_[2]);
12919       ffelex_token_kill (ffeexpr_tokens_[3]);
12920       return (ffelexHandler) ffeexpr_token_binary_ (t);
12921     }
12922
12923   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12924                  ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12925                              ffeexpr_tokens_[3], t);
12926
12927   ffelex_token_kill (ffeexpr_tokens_[0]);
12928   ffelex_token_kill (ffeexpr_tokens_[1]);
12929   ffelex_token_kill (ffeexpr_tokens_[2]);
12930   ffelex_token_kill (ffeexpr_tokens_[3]);
12931   return (ffelexHandler) ffeexpr_token_binary_;
12932 }
12933
12934 /* ffeexpr_token_number_ -- Rhs NUMBER
12935
12936    Return a pointer to this function to the lexer (ffelex), which will
12937    invoke it for the next token.
12938
12939    If the token is a period, we may have a floating-point number, or an
12940    integer followed by a dotdot binary operator.  If the token is a name
12941    beginning with D, E, or Q, we definitely have a floating-point number.
12942    If the token is a hollerith constant, that's what we've got, so push
12943    it onto the expression stack and continue with the binary state.
12944
12945    Otherwise, we have an integer followed by something the binary state
12946    should be able to swallow.  */
12947
12948 static ffelexHandler
12949 ffeexpr_token_number_ (ffelexToken t)
12950 {
12951   ffeexprExpr_ e;
12952   ffeinfo ni;
12953   char d;
12954   const char *p;
12955
12956   if (ffeexpr_hollerith_count_ > 0)
12957     ffelex_set_expecting_hollerith (0, '\0',
12958                                     ffewhere_line_unknown (),
12959                                     ffewhere_column_unknown ());
12960
12961   /* See if we've got a floating-point number here. */
12962
12963   switch (ffelex_token_type (t))
12964     {
12965     case FFELEX_typeNAME:
12966     case FFELEX_typeNAMES:
12967       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12968                                    'D', 'd')
12969            || ffesrc_char_match_init (d, 'E', 'e')
12970            || ffesrc_char_match_init (d, 'Q', 'q'))
12971           && ffeexpr_isdigits_ (++p))
12972         {
12973
12974           /* Just exponent character by itself?  In which case, PLUS or MINUS
12975              must surely be next, followed by a NUMBER token. */
12976
12977           if (*p == '\0')
12978             {
12979               ffeexpr_tokens_[1] = ffelex_token_use (t);
12980               return (ffelexHandler) ffeexpr_token_number_exponent_;
12981             }
12982           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
12983                                      NULL, NULL);
12984
12985           ffelex_token_kill (ffeexpr_tokens_[0]);
12986           return (ffelexHandler) ffeexpr_token_binary_;
12987         }
12988       break;
12989
12990     case FFELEX_typePERIOD:
12991       ffeexpr_tokens_[1] = ffelex_token_use (t);
12992       return (ffelexHandler) ffeexpr_token_number_period_;
12993
12994     case FFELEX_typeHOLLERITH:
12995       e = ffeexpr_expr_new_ ();
12996       e->type = FFEEXPR_exprtypeOPERAND_;
12997       e->token = ffeexpr_tokens_[0];
12998       e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
12999       ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13000                         0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13001                         ffelex_token_length (t));
13002       ffebld_set_info (e->u.operand, ni);
13003       ffeexpr_exprstack_push_operand_ (e);
13004       return (ffelexHandler) ffeexpr_token_binary_;
13005
13006     default:
13007       break;
13008     }
13009
13010   /* Nothing specific we were looking for, so make an integer and pass the
13011      current token to the binary state. */
13012
13013   ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13014                              NULL, NULL, NULL);
13015   return (ffelexHandler) ffeexpr_token_binary_ (t);
13016 }
13017
13018 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13019
13020    Return a pointer to this function to the lexer (ffelex), which will
13021    invoke it for the next token.
13022
13023    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13024    for real number (exponent digits).  Else treats number as integer, passes
13025    name to binary, passes current token to subsequent handler.  */
13026
13027 static ffelexHandler
13028 ffeexpr_token_number_exponent_ (ffelexToken t)
13029 {
13030   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13031       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13032     {
13033       ffeexprExpr_ e;
13034       ffelexHandler nexthandler;
13035
13036       e = ffeexpr_expr_new_ ();
13037       e->type = FFEEXPR_exprtypeOPERAND_;
13038       e->token = ffeexpr_tokens_[0];
13039       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13040                                         (ffeexpr_tokens_[0]));
13041       ffebld_set_info (e->u.operand,
13042       ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13043                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13044       ffeexpr_exprstack_push_operand_ (e);
13045       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13046       ffelex_token_kill (ffeexpr_tokens_[1]);
13047       return (ffelexHandler) (*nexthandler) (t);
13048     }
13049
13050   ffeexpr_tokens_[2] = ffelex_token_use (t);
13051   return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13052 }
13053
13054 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13055
13056    Return a pointer to this function to the lexer (ffelex), which will
13057    invoke it for the next token.
13058
13059    Make sure token is a NUMBER, make a real constant out of all we have and
13060    push it onto the expression stack.  Else issue diagnostic and pretend
13061    exponent field was a zero.  */
13062
13063 static ffelexHandler
13064 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13065 {
13066   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13067     {
13068       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13069         {
13070           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13071                        ffelex_token_where_column (ffeexpr_tokens_[1]));
13072           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13073           ffebad_finish ();
13074         }
13075
13076       ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13077                                  ffeexpr_tokens_[0], NULL, NULL,
13078                                  ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13079                                  NULL);
13080
13081       ffelex_token_kill (ffeexpr_tokens_[0]);
13082       ffelex_token_kill (ffeexpr_tokens_[1]);
13083       ffelex_token_kill (ffeexpr_tokens_[2]);
13084       return (ffelexHandler) ffeexpr_token_binary_ (t);
13085     }
13086
13087   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13088                              ffeexpr_tokens_[0], NULL, NULL,
13089                              ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13090
13091   ffelex_token_kill (ffeexpr_tokens_[0]);
13092   ffelex_token_kill (ffeexpr_tokens_[1]);
13093   ffelex_token_kill (ffeexpr_tokens_[2]);
13094   return (ffelexHandler) ffeexpr_token_binary_;
13095 }
13096
13097 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13098
13099    Return a pointer to this function to the lexer (ffelex), which will
13100    invoke it for the next token.
13101
13102    Handle a period detected following a number at rhs state.  Must begin a
13103    floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
13104
13105 static ffelexHandler
13106 ffeexpr_token_number_period_ (ffelexToken t)
13107 {
13108   ffeexprExpr_ e;
13109   ffelexHandler nexthandler;
13110   const char *p;
13111   char d;
13112
13113   switch (ffelex_token_type (t))
13114     {
13115     case FFELEX_typeNAME:
13116     case FFELEX_typeNAMES:
13117       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13118                                    'D', 'd')
13119            || ffesrc_char_match_init (d, 'E', 'e')
13120            || ffesrc_char_match_init (d, 'Q', 'q'))
13121           && ffeexpr_isdigits_ (++p))
13122         {
13123
13124           /* Just exponent character by itself?  In which case, PLUS or MINUS
13125              must surely be next, followed by a NUMBER token. */
13126
13127           if (*p == '\0')
13128             {
13129               ffeexpr_tokens_[2] = ffelex_token_use (t);
13130               return (ffelexHandler) ffeexpr_token_number_per_exp_;
13131             }
13132           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13133                                      ffeexpr_tokens_[1], NULL, t, NULL,
13134                                      NULL);
13135
13136           ffelex_token_kill (ffeexpr_tokens_[0]);
13137           ffelex_token_kill (ffeexpr_tokens_[1]);
13138           return (ffelexHandler) ffeexpr_token_binary_;
13139         }
13140       /* A name not representing an exponent, so assume it will be something
13141          like EQ, make an integer from the number, pass the period to binary
13142          state and the current token to the resulting state. */
13143
13144       e = ffeexpr_expr_new_ ();
13145       e->type = FFEEXPR_exprtypeOPERAND_;
13146       e->token = ffeexpr_tokens_[0];
13147       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13148                                         (ffeexpr_tokens_[0]));
13149       ffebld_set_info (e->u.operand,
13150                        ffeinfo_new (FFEINFO_basictypeINTEGER,
13151                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
13152                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13153                                     FFETARGET_charactersizeNONE));
13154       ffeexpr_exprstack_push_operand_ (e);
13155       nexthandler = (ffelexHandler) ffeexpr_token_binary_
13156         (ffeexpr_tokens_[1]);
13157       ffelex_token_kill (ffeexpr_tokens_[1]);
13158       return (ffelexHandler) (*nexthandler) (t);
13159
13160     case FFELEX_typeNUMBER:
13161       ffeexpr_tokens_[2] = ffelex_token_use (t);
13162       return (ffelexHandler) ffeexpr_token_number_real_;
13163
13164     default:
13165       break;
13166     }
13167
13168   /* Nothing specific we were looking for, so make a real number and pass the
13169      period and then the current token to the binary state. */
13170
13171   ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13172                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13173                              NULL, NULL, NULL, NULL);
13174
13175   ffelex_token_kill (ffeexpr_tokens_[0]);
13176   ffelex_token_kill (ffeexpr_tokens_[1]);
13177   return (ffelexHandler) ffeexpr_token_binary_ (t);
13178 }
13179
13180 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13181
13182    Return a pointer to this function to the lexer (ffelex), which will
13183    invoke it for the next token.
13184
13185    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13186    for real number (exponent digits).  Else treats number as real, passes
13187    name to binary, passes current token to subsequent handler.  */
13188
13189 static ffelexHandler
13190 ffeexpr_token_number_per_exp_ (ffelexToken t)
13191 {
13192   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13193       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13194     {
13195       ffelexHandler nexthandler;
13196
13197       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13198                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13199                                  NULL, NULL, NULL, NULL);
13200
13201       ffelex_token_kill (ffeexpr_tokens_[0]);
13202       ffelex_token_kill (ffeexpr_tokens_[1]);
13203       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13204       ffelex_token_kill (ffeexpr_tokens_[2]);
13205       return (ffelexHandler) (*nexthandler) (t);
13206     }
13207
13208   ffeexpr_tokens_[3] = ffelex_token_use (t);
13209   return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13210 }
13211
13212 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13213
13214    Return a pointer to this function to the lexer (ffelex), which will
13215    invoke it for the next token.
13216
13217    After a number, period, and number, check next token for possible
13218    exponent designation (D, E, or Q as first/only character) and continue
13219    real-number handling accordingly.  Else form basic real constant, push
13220    onto expression stack, and enter binary state using current token (which,
13221    if it is a name not beginning with D, E, or Q, will certainly result
13222    in an error, but that's not for this routine to deal with).  */
13223
13224 static ffelexHandler
13225 ffeexpr_token_number_real_ (ffelexToken t)
13226 {
13227   char d;
13228   const char *p;
13229
13230   if (((ffelex_token_type (t) != FFELEX_typeNAME)
13231        && (ffelex_token_type (t) != FFELEX_typeNAMES))
13232       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13233                                      'D', 'd')
13234              || ffesrc_char_match_init (d, 'E', 'e')
13235              || ffesrc_char_match_init (d, 'Q', 'q')))
13236            && ffeexpr_isdigits_ (++p)))
13237     {
13238 #if 0
13239       /* This code has been removed because it seems inconsistent to
13240          produce a diagnostic in this case, but not all of the other
13241          ones that look for an exponent and cannot recognize one.  */
13242       if (((ffelex_token_type (t) == FFELEX_typeNAME)
13243            || (ffelex_token_type (t) == FFELEX_typeNAMES))
13244           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13245         {
13246           char bad[2];
13247
13248           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13249           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13250                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13251           bad[0] = *(p - 1);
13252           bad[1] = '\0';
13253           ffebad_string (bad);
13254           ffebad_finish ();
13255         }
13256 #endif
13257       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13258                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13259                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
13260
13261       ffelex_token_kill (ffeexpr_tokens_[0]);
13262       ffelex_token_kill (ffeexpr_tokens_[1]);
13263       ffelex_token_kill (ffeexpr_tokens_[2]);
13264       return (ffelexHandler) ffeexpr_token_binary_ (t);
13265     }
13266
13267   /* Just exponent character by itself?  In which case, PLUS or MINUS must
13268      surely be next, followed by a NUMBER token. */
13269
13270   if (*p == '\0')
13271     {
13272       ffeexpr_tokens_[3] = ffelex_token_use (t);
13273       return (ffelexHandler) ffeexpr_token_number_real_exp_;
13274     }
13275
13276   ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13277                              ffeexpr_tokens_[2], t, NULL, NULL);
13278
13279   ffelex_token_kill (ffeexpr_tokens_[0]);
13280   ffelex_token_kill (ffeexpr_tokens_[1]);
13281   ffelex_token_kill (ffeexpr_tokens_[2]);
13282   return (ffelexHandler) ffeexpr_token_binary_;
13283 }
13284
13285 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13286
13287    Return a pointer to this function to the lexer (ffelex), which will
13288    invoke it for the next token.
13289
13290    Make sure token is a NUMBER, make a real constant out of all we have and
13291    push it onto the expression stack.  Else issue diagnostic and pretend
13292    exponent field was a zero.  */
13293
13294 static ffelexHandler
13295 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13296 {
13297   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13298     {
13299       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13300         {
13301           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13302                        ffelex_token_where_column (ffeexpr_tokens_[2]));
13303           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13304           ffebad_finish ();
13305         }
13306
13307       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13308                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13309                                  NULL, NULL, NULL, NULL);
13310
13311       ffelex_token_kill (ffeexpr_tokens_[0]);
13312       ffelex_token_kill (ffeexpr_tokens_[1]);
13313       ffelex_token_kill (ffeexpr_tokens_[2]);
13314       ffelex_token_kill (ffeexpr_tokens_[3]);
13315       return (ffelexHandler) ffeexpr_token_binary_ (t);
13316     }
13317
13318   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13319                              ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13320                              ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13321
13322   ffelex_token_kill (ffeexpr_tokens_[0]);
13323   ffelex_token_kill (ffeexpr_tokens_[1]);
13324   ffelex_token_kill (ffeexpr_tokens_[2]);
13325   ffelex_token_kill (ffeexpr_tokens_[3]);
13326   return (ffelexHandler) ffeexpr_token_binary_;
13327 }
13328
13329 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13330
13331    Return a pointer to this function to the lexer (ffelex), which will
13332    invoke it for the next token.
13333
13334    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13335    for real number (exponent digits).  Else issues diagnostic, assumes a
13336    zero exponent field for number, passes token on to binary state as if
13337    previous token had been "E0" instead of "E", for example.  */
13338
13339 static ffelexHandler
13340 ffeexpr_token_number_real_exp_ (ffelexToken t)
13341 {
13342   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13343       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13344     {
13345       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13346         {
13347           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13348                        ffelex_token_where_column (ffeexpr_tokens_[3]));
13349           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13350           ffebad_finish ();
13351         }
13352
13353       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13354                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13355                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
13356
13357       ffelex_token_kill (ffeexpr_tokens_[0]);
13358       ffelex_token_kill (ffeexpr_tokens_[1]);
13359       ffelex_token_kill (ffeexpr_tokens_[2]);
13360       ffelex_token_kill (ffeexpr_tokens_[3]);
13361       return (ffelexHandler) ffeexpr_token_binary_ (t);
13362     }
13363
13364   ffeexpr_tokens_[4] = ffelex_token_use (t);
13365   return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13366 }
13367
13368 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13369                                   PLUS/MINUS
13370
13371    Return a pointer to this function to the lexer (ffelex), which will
13372    invoke it for the next token.
13373
13374    Make sure token is a NUMBER, make a real constant out of all we have and
13375    push it onto the expression stack.  Else issue diagnostic and pretend
13376    exponent field was a zero.  */
13377
13378 static ffelexHandler
13379 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13380 {
13381   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13382     {
13383       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13384         {
13385           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13386                        ffelex_token_where_column (ffeexpr_tokens_[3]));
13387           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13388           ffebad_finish ();
13389         }
13390
13391       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13392                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13393                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
13394
13395       ffelex_token_kill (ffeexpr_tokens_[0]);
13396       ffelex_token_kill (ffeexpr_tokens_[1]);
13397       ffelex_token_kill (ffeexpr_tokens_[2]);
13398       ffelex_token_kill (ffeexpr_tokens_[3]);
13399       ffelex_token_kill (ffeexpr_tokens_[4]);
13400       return (ffelexHandler) ffeexpr_token_binary_ (t);
13401     }
13402
13403   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13404                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13405                              ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13406                              ffeexpr_tokens_[4], t);
13407
13408   ffelex_token_kill (ffeexpr_tokens_[0]);
13409   ffelex_token_kill (ffeexpr_tokens_[1]);
13410   ffelex_token_kill (ffeexpr_tokens_[2]);
13411   ffelex_token_kill (ffeexpr_tokens_[3]);
13412   ffelex_token_kill (ffeexpr_tokens_[4]);
13413   return (ffelexHandler) ffeexpr_token_binary_;
13414 }
13415
13416 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13417
13418    Return a pointer to this function to the lexer (ffelex), which will
13419    invoke it for the next token.
13420
13421    The possibility of a binary operator is handled here, meaning the previous
13422    token was an operand.  */
13423
13424 static ffelexHandler
13425 ffeexpr_token_binary_ (ffelexToken t)
13426 {
13427   ffeexprExpr_ e;
13428
13429   if (!ffeexpr_stack_->is_rhs)
13430     return (ffelexHandler) ffeexpr_finished_ (t);       /* For now. */
13431
13432   switch (ffelex_token_type (t))
13433     {
13434     case FFELEX_typePLUS:
13435       e = ffeexpr_expr_new_ ();
13436       e->type = FFEEXPR_exprtypeBINARY_;
13437       e->token = ffelex_token_use (t);
13438       e->u.operator.op = FFEEXPR_operatorADD_;
13439       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13440       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13441       ffeexpr_exprstack_push_binary_ (e);
13442       return (ffelexHandler) ffeexpr_token_rhs_;
13443
13444     case FFELEX_typeMINUS:
13445       e = ffeexpr_expr_new_ ();
13446       e->type = FFEEXPR_exprtypeBINARY_;
13447       e->token = ffelex_token_use (t);
13448       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13449       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13450       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13451       ffeexpr_exprstack_push_binary_ (e);
13452       return (ffelexHandler) ffeexpr_token_rhs_;
13453
13454     case FFELEX_typeASTERISK:
13455       switch (ffeexpr_stack_->context)
13456         {
13457         case FFEEXPR_contextDATA:
13458           return (ffelexHandler) ffeexpr_finished_ (t);
13459
13460         default:
13461           break;
13462         }
13463       e = ffeexpr_expr_new_ ();
13464       e->type = FFEEXPR_exprtypeBINARY_;
13465       e->token = ffelex_token_use (t);
13466       e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13467       e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13468       e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13469       ffeexpr_exprstack_push_binary_ (e);
13470       return (ffelexHandler) ffeexpr_token_rhs_;
13471
13472     case FFELEX_typeSLASH:
13473       switch (ffeexpr_stack_->context)
13474         {
13475         case FFEEXPR_contextDATA:
13476           return (ffelexHandler) ffeexpr_finished_ (t);
13477
13478         default:
13479           break;
13480         }
13481       e = ffeexpr_expr_new_ ();
13482       e->type = FFEEXPR_exprtypeBINARY_;
13483       e->token = ffelex_token_use (t);
13484       e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13485       e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13486       e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13487       ffeexpr_exprstack_push_binary_ (e);
13488       return (ffelexHandler) ffeexpr_token_rhs_;
13489
13490     case FFELEX_typePOWER:
13491       e = ffeexpr_expr_new_ ();
13492       e->type = FFEEXPR_exprtypeBINARY_;
13493       e->token = ffelex_token_use (t);
13494       e->u.operator.op = FFEEXPR_operatorPOWER_;
13495       e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13496       e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13497       ffeexpr_exprstack_push_binary_ (e);
13498       return (ffelexHandler) ffeexpr_token_rhs_;
13499
13500     case FFELEX_typeCONCAT:
13501       e = ffeexpr_expr_new_ ();
13502       e->type = FFEEXPR_exprtypeBINARY_;
13503       e->token = ffelex_token_use (t);
13504       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13505       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13506       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13507       ffeexpr_exprstack_push_binary_ (e);
13508       return (ffelexHandler) ffeexpr_token_rhs_;
13509
13510     case FFELEX_typeOPEN_ANGLE:
13511       switch (ffeexpr_stack_->context)
13512         {
13513         case FFEEXPR_contextFORMAT:
13514           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13515           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13516           ffebad_finish ();
13517           break;
13518
13519         default:
13520           break;
13521         }
13522       e = ffeexpr_expr_new_ ();
13523       e->type = FFEEXPR_exprtypeBINARY_;
13524       e->token = ffelex_token_use (t);
13525       e->u.operator.op = FFEEXPR_operatorLT_;
13526       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13527       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13528       ffeexpr_exprstack_push_binary_ (e);
13529       return (ffelexHandler) ffeexpr_token_rhs_;
13530
13531     case FFELEX_typeCLOSE_ANGLE:
13532       switch (ffeexpr_stack_->context)
13533         {
13534         case FFEEXPR_contextFORMAT:
13535           return ffeexpr_finished_ (t);
13536
13537         default:
13538           break;
13539         }
13540       e = ffeexpr_expr_new_ ();
13541       e->type = FFEEXPR_exprtypeBINARY_;
13542       e->token = ffelex_token_use (t);
13543       e->u.operator.op = FFEEXPR_operatorGT_;
13544       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13545       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13546       ffeexpr_exprstack_push_binary_ (e);
13547       return (ffelexHandler) ffeexpr_token_rhs_;
13548
13549     case FFELEX_typeREL_EQ:
13550       switch (ffeexpr_stack_->context)
13551         {
13552         case FFEEXPR_contextFORMAT:
13553           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13554           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13555           ffebad_finish ();
13556           break;
13557
13558         default:
13559           break;
13560         }
13561       e = ffeexpr_expr_new_ ();
13562       e->type = FFEEXPR_exprtypeBINARY_;
13563       e->token = ffelex_token_use (t);
13564       e->u.operator.op = FFEEXPR_operatorEQ_;
13565       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13566       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13567       ffeexpr_exprstack_push_binary_ (e);
13568       return (ffelexHandler) ffeexpr_token_rhs_;
13569
13570     case FFELEX_typeREL_NE:
13571       switch (ffeexpr_stack_->context)
13572         {
13573         case FFEEXPR_contextFORMAT:
13574           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13575           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13576           ffebad_finish ();
13577           break;
13578
13579         default:
13580           break;
13581         }
13582       e = ffeexpr_expr_new_ ();
13583       e->type = FFEEXPR_exprtypeBINARY_;
13584       e->token = ffelex_token_use (t);
13585       e->u.operator.op = FFEEXPR_operatorNE_;
13586       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13587       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13588       ffeexpr_exprstack_push_binary_ (e);
13589       return (ffelexHandler) ffeexpr_token_rhs_;
13590
13591     case FFELEX_typeREL_LE:
13592       switch (ffeexpr_stack_->context)
13593         {
13594         case FFEEXPR_contextFORMAT:
13595           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13596           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13597           ffebad_finish ();
13598           break;
13599
13600         default:
13601           break;
13602         }
13603       e = ffeexpr_expr_new_ ();
13604       e->type = FFEEXPR_exprtypeBINARY_;
13605       e->token = ffelex_token_use (t);
13606       e->u.operator.op = FFEEXPR_operatorLE_;
13607       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13608       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13609       ffeexpr_exprstack_push_binary_ (e);
13610       return (ffelexHandler) ffeexpr_token_rhs_;
13611
13612     case FFELEX_typeREL_GE:
13613       switch (ffeexpr_stack_->context)
13614         {
13615         case FFEEXPR_contextFORMAT:
13616           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13617           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13618           ffebad_finish ();
13619           break;
13620
13621         default:
13622           break;
13623         }
13624       e = ffeexpr_expr_new_ ();
13625       e->type = FFEEXPR_exprtypeBINARY_;
13626       e->token = ffelex_token_use (t);
13627       e->u.operator.op = FFEEXPR_operatorGE_;
13628       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13629       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13630       ffeexpr_exprstack_push_binary_ (e);
13631       return (ffelexHandler) ffeexpr_token_rhs_;
13632
13633     case FFELEX_typePERIOD:
13634       ffeexpr_tokens_[0] = ffelex_token_use (t);
13635       return (ffelexHandler) ffeexpr_token_binary_period_;
13636
13637 #if 0
13638     case FFELEX_typeOPEN_PAREN:
13639     case FFELEX_typeCLOSE_PAREN:
13640     case FFELEX_typeEQUALS:
13641     case FFELEX_typePOINTS:
13642     case FFELEX_typeCOMMA:
13643     case FFELEX_typeCOLON:
13644     case FFELEX_typeEOS:
13645     case FFELEX_typeSEMICOLON:
13646     case FFELEX_typeNAME:
13647     case FFELEX_typeNAMES:
13648 #endif
13649     default:
13650       return (ffelexHandler) ffeexpr_finished_ (t);
13651     }
13652 }
13653
13654 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13655
13656    Return a pointer to this function to the lexer (ffelex), which will
13657    invoke it for the next token.
13658
13659    Handle a period detected at binary (expecting binary op or end) state.
13660    Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13661    valid.  */
13662
13663 static ffelexHandler
13664 ffeexpr_token_binary_period_ (ffelexToken t)
13665 {
13666   ffeexprExpr_ operand;
13667
13668   switch (ffelex_token_type (t))
13669     {
13670     case FFELEX_typeNAME:
13671     case FFELEX_typeNAMES:
13672       ffeexpr_current_dotdot_ = ffestr_other (t);
13673       switch (ffeexpr_current_dotdot_)
13674         {
13675         case FFESTR_otherTRUE:
13676         case FFESTR_otherFALSE:
13677         case FFESTR_otherNOT:
13678           if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13679             {
13680               operand = ffeexpr_stack_->exprstack;
13681               assert (operand != NULL);
13682               assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13683               ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13684               ffebad_here (1, ffelex_token_where_line (t),
13685                            ffelex_token_where_column (t));
13686               ffebad_finish ();
13687             }
13688           ffelex_token_kill (ffeexpr_tokens_[0]);
13689           return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13690
13691         default:
13692           ffeexpr_tokens_[1] = ffelex_token_use (t);
13693           return (ffelexHandler) ffeexpr_token_binary_end_per_;
13694         }
13695       break;                    /* Nothing really reaches here. */
13696
13697     default:
13698       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13699         {
13700           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13701                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13702           ffebad_finish ();
13703         }
13704       ffelex_token_kill (ffeexpr_tokens_[0]);
13705       return (ffelexHandler) ffeexpr_token_binary_ (t);
13706     }
13707 }
13708
13709 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13710
13711    Return a pointer to this function to the lexer (ffelex), which will
13712    invoke it for the next token.
13713
13714    Expecting a period to close a dot-dot at binary (binary op
13715    or operator) state.  If period isn't found, issue a diagnostic but
13716    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
13717    dotdot representation of the name in between the two PERIOD tokens.  */
13718
13719 static ffelexHandler
13720 ffeexpr_token_binary_end_per_ (ffelexToken t)
13721 {
13722   ffeexprExpr_ e;
13723
13724   e = ffeexpr_expr_new_ ();
13725   e->type = FFEEXPR_exprtypeBINARY_;
13726   e->token = ffeexpr_tokens_[0];
13727
13728   switch (ffeexpr_current_dotdot_)
13729     {
13730     case FFESTR_otherAND:
13731       e->u.operator.op = FFEEXPR_operatorAND_;
13732       e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13733       e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13734       break;
13735
13736     case FFESTR_otherOR:
13737       e->u.operator.op = FFEEXPR_operatorOR_;
13738       e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13739       e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13740       break;
13741
13742     case FFESTR_otherXOR:
13743       e->u.operator.op = FFEEXPR_operatorXOR_;
13744       e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13745       e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13746       break;
13747
13748     case FFESTR_otherEQV:
13749       e->u.operator.op = FFEEXPR_operatorEQV_;
13750       e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13751       e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13752       break;
13753
13754     case FFESTR_otherNEQV:
13755       e->u.operator.op = FFEEXPR_operatorNEQV_;
13756       e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13757       e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13758       break;
13759
13760     case FFESTR_otherLT:
13761       e->u.operator.op = FFEEXPR_operatorLT_;
13762       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13763       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13764       break;
13765
13766     case FFESTR_otherLE:
13767       e->u.operator.op = FFEEXPR_operatorLE_;
13768       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13769       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13770       break;
13771
13772     case FFESTR_otherEQ:
13773       e->u.operator.op = FFEEXPR_operatorEQ_;
13774       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13775       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13776       break;
13777
13778     case FFESTR_otherNE:
13779       e->u.operator.op = FFEEXPR_operatorNE_;
13780       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13781       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13782       break;
13783
13784     case FFESTR_otherGT:
13785       e->u.operator.op = FFEEXPR_operatorGT_;
13786       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13787       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13788       break;
13789
13790     case FFESTR_otherGE:
13791       e->u.operator.op = FFEEXPR_operatorGE_;
13792       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13793       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13794       break;
13795
13796     default:
13797       if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13798         {
13799           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13800                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13801           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13802           ffebad_finish ();
13803         }
13804       e->u.operator.op = FFEEXPR_operatorEQ_;
13805       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13806       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13807       break;
13808     }
13809
13810   ffeexpr_exprstack_push_binary_ (e);
13811
13812   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13813     {
13814       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13815         {
13816           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13817                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13818           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13819           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13820           ffebad_finish ();
13821         }
13822       ffelex_token_kill (ffeexpr_tokens_[1]);   /* Kill dot-dot token. */
13823       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13824     }
13825
13826   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill dot-dot token. */
13827   return (ffelexHandler) ffeexpr_token_rhs_;
13828 }
13829
13830 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13831
13832    Return a pointer to this function to the lexer (ffelex), which will
13833    invoke it for the next token.
13834
13835    A diagnostic has already been issued; just swallow a period if there is
13836    one, then continue with ffeexpr_token_binary_.  */
13837
13838 static ffelexHandler
13839 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13840 {
13841   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13842     return (ffelexHandler) ffeexpr_token_binary_ (t);
13843
13844   return (ffelexHandler) ffeexpr_token_binary_;
13845 }
13846
13847 /* ffeexpr_token_quote_ -- Rhs QUOTE
13848
13849    Return a pointer to this function to the lexer (ffelex), which will
13850    invoke it for the next token.
13851
13852    Expecting a NUMBER that we'll treat as an octal integer.  */
13853
13854 static ffelexHandler
13855 ffeexpr_token_quote_ (ffelexToken t)
13856 {
13857   ffeexprExpr_ e;
13858   ffebld anyexpr;
13859
13860   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13861     {
13862       if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13863         {
13864           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13865                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13866           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13867           ffebad_finish ();
13868         }
13869       ffelex_token_kill (ffeexpr_tokens_[0]);
13870       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13871     }
13872
13873   /* This is kind of a kludge to prevent any whining about magical numbers
13874      that start out as these octal integers, so "20000000000 (on a 32-bit
13875      2's-complement machine) by itself won't produce an error. */
13876
13877   anyexpr = ffebld_new_any ();
13878   ffebld_set_info (anyexpr, ffeinfo_new_any ());
13879
13880   e = ffeexpr_expr_new_ ();
13881   e->type = FFEEXPR_exprtypeOPERAND_;
13882   e->token = ffeexpr_tokens_[0];
13883   e->u.operand = ffebld_new_conter_with_orig
13884     (ffebld_constant_new_integeroctal (t), anyexpr);
13885   ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13886                       FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13887                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13888   ffeexpr_exprstack_push_operand_ (e);
13889   return (ffelexHandler) ffeexpr_token_binary_;
13890 }
13891
13892 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13893
13894    Return a pointer to this function to the lexer (ffelex), which will
13895    invoke it for the next token.
13896
13897    Handle an open-apostrophe, which begins either a character ('char-const'),
13898    typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13899    'hex-const'X) constant.  */
13900
13901 static ffelexHandler
13902 ffeexpr_token_apostrophe_ (ffelexToken t)
13903 {
13904   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13905   if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13906     {
13907       ffebad_start (FFEBAD_NULL_CHAR_CONST);
13908       ffebad_here (0, ffelex_token_where_line (t),
13909                    ffelex_token_where_column (t));
13910       ffebad_finish ();
13911     }
13912   ffeexpr_tokens_[1] = ffelex_token_use (t);
13913   return (ffelexHandler) ffeexpr_token_apos_char_;
13914 }
13915
13916 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13917
13918    Return a pointer to this function to the lexer (ffelex), which will
13919    invoke it for the next token.
13920
13921    Close-apostrophe is implicit; if this token is NAME, it is a possible
13922    typeless-constant radix specifier.  */
13923
13924 static ffelexHandler
13925 ffeexpr_token_apos_char_ (ffelexToken t)
13926 {
13927   ffeexprExpr_ e;
13928   ffeinfo ni;
13929   char c;
13930   ffetargetCharacterSize size;
13931
13932   if ((ffelex_token_type (t) == FFELEX_typeNAME)
13933       || (ffelex_token_type (t) == FFELEX_typeNAMES))
13934     {
13935       if ((ffelex_token_length (t) == 1)
13936           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13937                                       'b')
13938               || ffesrc_char_match_init (c, 'O', 'o')
13939               || ffesrc_char_match_init (c, 'X', 'x')
13940               || ffesrc_char_match_init (c, 'Z', 'z')))
13941         {
13942           e = ffeexpr_expr_new_ ();
13943           e->type = FFEEXPR_exprtypeOPERAND_;
13944           e->token = ffeexpr_tokens_[0];
13945           switch (c)
13946             {
13947             case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13948               e->u.operand = ffebld_new_conter
13949                 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13950               size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
13951               break;
13952
13953             case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
13954               e->u.operand = ffebld_new_conter
13955                 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
13956               size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
13957               break;
13958
13959             case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
13960               e->u.operand = ffebld_new_conter
13961                 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
13962               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13963               break;
13964
13965             case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
13966               e->u.operand = ffebld_new_conter
13967                 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
13968               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13969               break;
13970
13971             default:
13972             no_match:           /* :::::::::::::::::::: */
13973               assert ("not BOXZ!" == NULL);
13974               size = 0;
13975               break;
13976             }
13977           ffebld_set_info (e->u.operand,
13978                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
13979                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
13980           ffeexpr_exprstack_push_operand_ (e);
13981           ffelex_token_kill (ffeexpr_tokens_[1]);
13982           return (ffelexHandler) ffeexpr_token_binary_;
13983         }
13984     }
13985   e = ffeexpr_expr_new_ ();
13986   e->type = FFEEXPR_exprtypeOPERAND_;
13987   e->token = ffeexpr_tokens_[0];
13988   e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
13989                                     (ffeexpr_tokens_[1]));
13990   ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
13991                     0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13992                     ffelex_token_length (ffeexpr_tokens_[1]));
13993   ffebld_set_info (e->u.operand, ni);
13994   ffelex_token_kill (ffeexpr_tokens_[1]);
13995   ffeexpr_exprstack_push_operand_ (e);
13996   if ((ffelex_token_type (t) == FFELEX_typeNAME)
13997       || (ffelex_token_type (t) == FFELEX_typeNAMES))
13998     {
13999       if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14000         {
14001           ffebad_string (ffelex_token_text (t));
14002           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14003           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14004                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14005           ffebad_finish ();
14006         }
14007       e = ffeexpr_expr_new_ ();
14008       e->type = FFEEXPR_exprtypeBINARY_;
14009       e->token = ffelex_token_use (t);
14010       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14011       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14012       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14013       ffeexpr_exprstack_push_binary_ (e);
14014       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14015     }
14016   ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();   /* Allow "'hello'(3:5)". */
14017   return (ffelexHandler) ffeexpr_token_substrp_ (t);
14018 }
14019
14020 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14021
14022    Return a pointer to this function to the lexer (ffelex), which will
14023    invoke it for the next token.
14024
14025    Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14026    (RECORD%MEMBER), or nothing at all.  */
14027
14028 static ffelexHandler
14029 ffeexpr_token_name_lhs_ (ffelexToken t)
14030 {
14031   ffeexprExpr_ e;
14032   ffeexprParenType_ paren_type;
14033   ffesymbol s;
14034   ffebld expr;
14035   ffeinfo info;
14036
14037   switch (ffelex_token_type (t))
14038     {
14039     case FFELEX_typeOPEN_PAREN:
14040       switch (ffeexpr_stack_->context)
14041         {
14042         case FFEEXPR_contextASSIGN:
14043         case FFEEXPR_contextAGOTO:
14044         case FFEEXPR_contextFILEUNIT_DF:
14045           goto just_name;       /* :::::::::::::::::::: */
14046
14047         default:
14048           break;
14049         }
14050       e = ffeexpr_expr_new_ ();
14051       e->type = FFEEXPR_exprtypeOPERAND_;
14052       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14053       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14054                                           &paren_type);
14055
14056       switch (ffesymbol_where (s))
14057         {
14058         case FFEINFO_whereLOCAL:
14059           if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14060             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Recursion. */
14061           break;
14062
14063         case FFEINFO_whereINTRINSIC:
14064         case FFEINFO_whereGLOBAL:
14065           if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14066             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Can call intrin. */
14067           break;
14068
14069         case FFEINFO_whereCOMMON:
14070         case FFEINFO_whereDUMMY:
14071         case FFEINFO_whereRESULT:
14072           break;
14073
14074         case FFEINFO_whereNONE:
14075         case FFEINFO_whereANY:
14076           break;
14077
14078         default:
14079           ffesymbol_error (s, ffeexpr_tokens_[0]);
14080           break;
14081         }
14082
14083       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14084         {
14085           e->u.operand = ffebld_new_any ();
14086           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14087         }
14088       else
14089         {
14090           e->u.operand = ffebld_new_symter (s,
14091                                             ffesymbol_generic (s),
14092                                             ffesymbol_specific (s),
14093                                             ffesymbol_implementation (s));
14094           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14095         }
14096       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
14097       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14098       switch (paren_type)
14099         {
14100         case FFEEXPR_parentypeSUBROUTINE_:
14101           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14102           return
14103             (ffelexHandler)
14104             ffeexpr_rhs (ffeexpr_stack_->pool,
14105                          FFEEXPR_contextACTUALARG_,
14106                          ffeexpr_token_arguments_);
14107
14108         case FFEEXPR_parentypeARRAY_:
14109           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14110           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14111           ffeexpr_stack_->rank = 0;
14112           ffeexpr_stack_->constant = TRUE;
14113           ffeexpr_stack_->immediate = TRUE;
14114           switch (ffeexpr_stack_->context)
14115             {
14116             case FFEEXPR_contextDATAIMPDOITEM_:
14117               return
14118                 (ffelexHandler)
14119                 ffeexpr_rhs (ffeexpr_stack_->pool,
14120                              FFEEXPR_contextDATAIMPDOINDEX_,
14121                              ffeexpr_token_elements_);
14122
14123             case FFEEXPR_contextEQUIVALENCE:
14124               return
14125                 (ffelexHandler)
14126                 ffeexpr_rhs (ffeexpr_stack_->pool,
14127                              FFEEXPR_contextEQVINDEX_,
14128                              ffeexpr_token_elements_);
14129
14130             default:
14131               return
14132                 (ffelexHandler)
14133                 ffeexpr_rhs (ffeexpr_stack_->pool,
14134                              FFEEXPR_contextINDEX_,
14135                              ffeexpr_token_elements_);
14136             }
14137
14138         case FFEEXPR_parentypeSUBSTRING_:
14139           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14140                                                   ffeexpr_tokens_[0]);
14141           return
14142             (ffelexHandler)
14143             ffeexpr_rhs (ffeexpr_stack_->pool,
14144                          FFEEXPR_contextINDEX_,
14145                          ffeexpr_token_substring_);
14146
14147         case FFEEXPR_parentypeEQUIVALENCE_:
14148           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14149           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14150           ffeexpr_stack_->rank = 0;
14151           ffeexpr_stack_->constant = TRUE;
14152           ffeexpr_stack_->immediate = TRUE;
14153           return
14154             (ffelexHandler)
14155             ffeexpr_rhs (ffeexpr_stack_->pool,
14156                          FFEEXPR_contextEQVINDEX_,
14157                          ffeexpr_token_equivalence_);
14158
14159         case FFEEXPR_parentypeFUNCTION_:        /* Invalid case. */
14160         case FFEEXPR_parentypeFUNSUBSTR_:       /* Invalid case. */
14161           ffesymbol_error (s, ffeexpr_tokens_[0]);
14162           /* Fall through. */
14163         case FFEEXPR_parentypeANY_:
14164           e->u.operand = ffebld_new_any ();
14165           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14166           return
14167             (ffelexHandler)
14168             ffeexpr_rhs (ffeexpr_stack_->pool,
14169                          FFEEXPR_contextACTUALARG_,
14170                          ffeexpr_token_anything_);
14171
14172         default:
14173           assert ("bad paren type" == NULL);
14174           break;
14175         }
14176
14177     case FFELEX_typeEQUALS:     /* As in "VAR=". */
14178       switch (ffeexpr_stack_->context)
14179         {
14180         case FFEEXPR_contextIMPDOITEM_: /* within
14181                                                    "(,VAR=start,end[,incr])". */
14182         case FFEEXPR_contextIMPDOITEMDF_:
14183           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14184           break;
14185
14186         case FFEEXPR_contextDATAIMPDOITEM_:
14187           ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14188           break;
14189
14190         default:
14191           break;
14192         }
14193       break;
14194
14195 #if 0
14196     case FFELEX_typePERIOD:
14197     case FFELEX_typePERCENT:
14198       assert ("FOO%, FOO. not yet supported!~~" == NULL);
14199       break;
14200 #endif
14201
14202     default:
14203       break;
14204     }
14205
14206 just_name:                      /* :::::::::::::::::::: */
14207   e = ffeexpr_expr_new_ ();
14208   e->type = FFEEXPR_exprtypeOPERAND_;
14209   e->token = ffeexpr_tokens_[0];
14210   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14211                                   (ffeexpr_stack_->context
14212                                    == FFEEXPR_contextSUBROUTINEREF));
14213
14214   switch (ffesymbol_where (s))
14215     {
14216     case FFEINFO_whereCONSTANT:
14217       if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14218           || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14219         ffesymbol_error (s, ffeexpr_tokens_[0]);
14220       break;
14221
14222     case FFEINFO_whereIMMEDIATE:
14223       if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14224           && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14225         ffesymbol_error (s, ffeexpr_tokens_[0]);
14226       break;
14227
14228     case FFEINFO_whereLOCAL:
14229       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14230         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Recurse!. */
14231       break;
14232
14233     case FFEINFO_whereINTRINSIC:
14234       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14235         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Can call intrin. */
14236       break;
14237
14238     default:
14239       break;
14240     }
14241
14242   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14243     {
14244       expr = ffebld_new_any ();
14245       info = ffeinfo_new_any ();
14246       ffebld_set_info (expr, info);
14247     }
14248   else
14249     {
14250       expr = ffebld_new_symter (s,
14251                                 ffesymbol_generic (s),
14252                                 ffesymbol_specific (s),
14253                                 ffesymbol_implementation (s));
14254       info = ffesymbol_info (s);
14255       ffebld_set_info (expr, info);
14256       if (ffesymbol_is_doiter (s))
14257         {
14258           ffebad_start (FFEBAD_DOITER);
14259           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14260                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14261           ffest_ffebad_here_doiter (1, s);
14262           ffebad_string (ffesymbol_text (s));
14263           ffebad_finish ();
14264         }
14265       expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14266     }
14267
14268   if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14269     {
14270       if (ffebld_op (expr) == FFEBLD_opANY)
14271         {
14272           expr = ffebld_new_any ();
14273           ffebld_set_info (expr, ffeinfo_new_any ());
14274         }
14275       else
14276         {
14277           expr = ffebld_new_subrref (expr, NULL);       /* No argument list. */
14278           if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14279             ffeintrin_fulfill_generic (&expr, &info, e->token);
14280           else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14281             ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14282           else
14283             ffeexpr_fulfill_call_ (&expr, e->token);
14284
14285           if (ffebld_op (expr) != FFEBLD_opANY)
14286             ffebld_set_info (expr,
14287                              ffeinfo_new (ffeinfo_basictype (info),
14288                                           ffeinfo_kindtype (info),
14289                                           0,
14290                                           FFEINFO_kindENTITY,
14291                                           FFEINFO_whereFLEETING,
14292                                           ffeinfo_size (info)));
14293           else
14294             ffebld_set_info (expr, ffeinfo_new_any ());
14295         }
14296     }
14297
14298   e->u.operand = expr;
14299   ffeexpr_exprstack_push_operand_ (e);
14300   return (ffelexHandler) ffeexpr_finished_ (t);
14301 }
14302
14303 /* ffeexpr_token_name_arg_ -- Rhs NAME
14304
14305    Return a pointer to this function to the lexer (ffelex), which will
14306    invoke it for the next token.
14307
14308    Handle first token in an actual-arg (or possible actual-arg) context
14309    being a NAME, and use second token to refine the context.  */
14310
14311 static ffelexHandler
14312 ffeexpr_token_name_arg_ (ffelexToken t)
14313 {
14314   switch (ffelex_token_type (t))
14315     {
14316     case FFELEX_typeCLOSE_PAREN:
14317     case FFELEX_typeCOMMA:
14318       switch (ffeexpr_stack_->context)
14319         {
14320         case FFEEXPR_contextINDEXORACTUALARG_:
14321           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14322           break;
14323
14324         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14325           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14326           break;
14327
14328         default:
14329           break;
14330         }
14331       break;
14332
14333     default:
14334       switch (ffeexpr_stack_->context)
14335         {
14336         case FFEEXPR_contextACTUALARG_:
14337           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14338           break;
14339
14340         case FFEEXPR_contextINDEXORACTUALARG_:
14341           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14342           break;
14343
14344         case FFEEXPR_contextSFUNCDEFACTUALARG_:
14345           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14346           break;
14347
14348         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14349           ffeexpr_stack_->context
14350             = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14351           break;
14352
14353         default:
14354           assert ("bad context in _name_arg_" == NULL);
14355           break;
14356         }
14357       break;
14358     }
14359
14360   return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14361 }
14362
14363 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14364
14365    Return a pointer to this function to the lexer (ffelex), which will
14366    invoke it for the next token.
14367
14368    Handle a name followed by open-paren, apostrophe (O'octal-const',
14369    Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14370
14371    26-Nov-91  JCB  1.2
14372       When followed by apostrophe or quote, set lex hexnum flag on so
14373       [0-9] as first char of next token seen as starting a potentially
14374       hex number (NAME).
14375    04-Oct-91  JCB  1.1
14376       In case of intrinsic, decorate its SYMTER with the type info for
14377       the specific intrinsic.  */
14378
14379 static ffelexHandler
14380 ffeexpr_token_name_rhs_ (ffelexToken t)
14381 {
14382   ffeexprExpr_ e;
14383   ffeexprParenType_ paren_type;
14384   ffesymbol s;
14385   bool sfdef;
14386
14387   switch (ffelex_token_type (t))
14388     {
14389     case FFELEX_typeQUOTE:
14390     case FFELEX_typeAPOSTROPHE:
14391       ffeexpr_tokens_[1] = ffelex_token_use (t);
14392       ffelex_set_hexnum (TRUE);
14393       return (ffelexHandler) ffeexpr_token_name_apos_;
14394
14395     case FFELEX_typeOPEN_PAREN:
14396       e = ffeexpr_expr_new_ ();
14397       e->type = FFEEXPR_exprtypeOPERAND_;
14398       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14399       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14400                                           &paren_type);
14401       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14402         e->u.operand = ffebld_new_any ();
14403       else
14404         e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14405                                           ffesymbol_specific (s),
14406                                           ffesymbol_implementation (s));
14407       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
14408       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14409       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14410         {
14411         case FFEEXPR_contextSFUNCDEF:
14412         case FFEEXPR_contextSFUNCDEFINDEX_:
14413         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14414         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14415           sfdef = TRUE;
14416           break;
14417
14418         case FFEEXPR_contextSFUNCDEFACTUALARG_:
14419         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14420           assert ("weird context!" == NULL);
14421           sfdef = FALSE;
14422           break;
14423
14424         default:
14425           sfdef = FALSE;
14426           break;
14427         }
14428       switch (paren_type)
14429         {
14430         case FFEEXPR_parentypeFUNCTION_:
14431           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14432           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14433           if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14434             {                   /* A statement function. */
14435               ffeexpr_stack_->num_args
14436                 = ffebld_list_length
14437                   (ffeexpr_stack_->next_dummy
14438                    = ffesymbol_dummyargs (s));
14439               ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
14440             }
14441           else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14442                    && !ffe_is_pedantic_not_90 ()
14443                    && ((ffesymbol_implementation (s)
14444                         == FFEINTRIN_impICHAR)
14445                        || (ffesymbol_implementation (s)
14446                            == FFEINTRIN_impIACHAR)
14447                        || (ffesymbol_implementation (s)
14448                            == FFEINTRIN_impLEN)))
14449             {                   /* Allow arbitrary concatenations. */
14450               return
14451                 (ffelexHandler)
14452                   ffeexpr_rhs (ffeexpr_stack_->pool,
14453                                sfdef
14454                                ? FFEEXPR_contextSFUNCDEF
14455                                : FFEEXPR_contextLET,
14456                                ffeexpr_token_arguments_);
14457             }
14458           return
14459             (ffelexHandler)
14460             ffeexpr_rhs (ffeexpr_stack_->pool,
14461                          sfdef
14462                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
14463                          : FFEEXPR_contextACTUALARG_,
14464                          ffeexpr_token_arguments_);
14465
14466         case FFEEXPR_parentypeARRAY_:
14467           ffebld_set_info (e->u.operand,
14468                            ffesymbol_info (ffebld_symter (e->u.operand)));
14469           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14470           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14471           ffeexpr_stack_->rank = 0;
14472           ffeexpr_stack_->constant = TRUE;
14473           ffeexpr_stack_->immediate = TRUE;
14474           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14475                                               sfdef
14476                                               ? FFEEXPR_contextSFUNCDEFINDEX_
14477                                               : FFEEXPR_contextINDEX_,
14478                                               ffeexpr_token_elements_);
14479
14480         case FFEEXPR_parentypeSUBSTRING_:
14481           ffebld_set_info (e->u.operand,
14482                            ffesymbol_info (ffebld_symter (e->u.operand)));
14483           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14484                                                   ffeexpr_tokens_[0]);
14485           return
14486             (ffelexHandler)
14487             ffeexpr_rhs (ffeexpr_stack_->pool,
14488                          sfdef
14489                          ? FFEEXPR_contextSFUNCDEFINDEX_
14490                          : FFEEXPR_contextINDEX_,
14491                          ffeexpr_token_substring_);
14492
14493         case FFEEXPR_parentypeFUNSUBSTR_:
14494           return
14495             (ffelexHandler)
14496             ffeexpr_rhs (ffeexpr_stack_->pool,
14497                          sfdef
14498                          ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14499                          : FFEEXPR_contextINDEXORACTUALARG_,
14500                          ffeexpr_token_funsubstr_);
14501
14502         case FFEEXPR_parentypeANY_:
14503           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14504           return
14505             (ffelexHandler)
14506             ffeexpr_rhs (ffeexpr_stack_->pool,
14507                          sfdef
14508                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
14509                          : FFEEXPR_contextACTUALARG_,
14510                          ffeexpr_token_anything_);
14511
14512         default:
14513           assert ("bad paren type" == NULL);
14514           break;
14515         }
14516
14517     case FFELEX_typeEQUALS:     /* As in "VAR=". */
14518       switch (ffeexpr_stack_->context)
14519         {
14520         case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
14521         case FFEEXPR_contextIMPDOITEMDF_:
14522           ffeexpr_stack_->is_rhs = FALSE;       /* Really an lhs construct. */
14523           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14524           break;
14525
14526         default:
14527           break;
14528         }
14529       break;
14530
14531 #if 0
14532     case FFELEX_typePERIOD:
14533     case FFELEX_typePERCENT:
14534       ~~Support these two someday, though not required
14535         assert ("FOO%, FOO. not yet supported!~~" == NULL);
14536       break;
14537 #endif
14538
14539     default:
14540       break;
14541     }
14542
14543   switch (ffeexpr_stack_->context)
14544     {
14545     case FFEEXPR_contextINDEXORACTUALARG_:
14546     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14547       assert ("strange context" == NULL);
14548       break;
14549
14550     default:
14551       break;
14552     }
14553
14554   e = ffeexpr_expr_new_ ();
14555   e->type = FFEEXPR_exprtypeOPERAND_;
14556   e->token = ffeexpr_tokens_[0];
14557   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14558   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14559     {
14560       e->u.operand = ffebld_new_any ();
14561       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14562     }
14563   else
14564     {
14565       e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14566                                         ffesymbol_specific (s),
14567                                         ffesymbol_implementation (s));
14568       if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14569         ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14570       else
14571         {                       /* Decorate the SYMTER with the actual type
14572                                    of the intrinsic. */
14573           ffebld_set_info (e->u.operand, ffeinfo_new
14574                         (ffeintrin_basictype (ffesymbol_specific (s)),
14575                          ffeintrin_kindtype (ffesymbol_specific (s)),
14576                          0,
14577                          ffesymbol_kind (s),
14578                          ffesymbol_where (s),
14579                          FFETARGET_charactersizeNONE));
14580         }
14581       if (ffesymbol_is_doiter (s))
14582         ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14583       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14584                                               ffeexpr_tokens_[0]);
14585     }
14586   ffeexpr_exprstack_push_operand_ (e);
14587   return (ffelexHandler) ffeexpr_token_binary_ (t);
14588 }
14589
14590 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14591
14592    Return a pointer to this function to the lexer (ffelex), which will
14593    invoke it for the next token.
14594
14595    Expecting a NAME token, analyze the previous NAME token to see what kind,
14596    if any, typeless constant we've got.
14597
14598    01-Sep-90  JCB  1.1
14599       Expect a NAME instead of CHARACTER in this situation.  */
14600
14601 static ffelexHandler
14602 ffeexpr_token_name_apos_ (ffelexToken t)
14603 {
14604   ffeexprExpr_ e;
14605
14606   ffelex_set_hexnum (FALSE);
14607
14608   switch (ffelex_token_type (t))
14609     {
14610     case FFELEX_typeNAME:
14611       ffeexpr_tokens_[2] = ffelex_token_use (t);
14612       return (ffelexHandler) ffeexpr_token_name_apos_name_;
14613
14614     default:
14615       break;
14616     }
14617
14618   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14619     {
14620       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14621       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14622                    ffelex_token_where_column (ffeexpr_tokens_[0]));
14623       ffebad_here (1, ffelex_token_where_line (t),
14624                    ffelex_token_where_column (t));
14625       ffebad_finish ();
14626     }
14627
14628   ffelex_token_kill (ffeexpr_tokens_[1]);
14629
14630   e = ffeexpr_expr_new_ ();
14631   e->type = FFEEXPR_exprtypeOPERAND_;
14632   e->u.operand = ffebld_new_any ();
14633   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14634   e->token = ffeexpr_tokens_[0];
14635   ffeexpr_exprstack_push_operand_ (e);
14636
14637   return (ffelexHandler) ffeexpr_token_binary_ (t);
14638 }
14639
14640 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14641
14642    Return a pointer to this function to the lexer (ffelex), which will
14643    invoke it for the next token.
14644
14645    Expecting an APOSTROPHE token, analyze the previous NAME token to see
14646    what kind, if any, typeless constant we've got.  */
14647
14648 static ffelexHandler
14649 ffeexpr_token_name_apos_name_ (ffelexToken t)
14650 {
14651   ffeexprExpr_ e;
14652   char c;
14653
14654   e = ffeexpr_expr_new_ ();
14655   e->type = FFEEXPR_exprtypeOPERAND_;
14656   e->token = ffeexpr_tokens_[0];
14657
14658   if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14659       && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14660       && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14661                                   'B', 'b')
14662           || ffesrc_char_match_init (c, 'O', 'o')
14663           || ffesrc_char_match_init (c, 'X', 'x')
14664           || ffesrc_char_match_init (c, 'Z', 'z')))
14665     {
14666       ffetargetCharacterSize size;
14667
14668       if (!ffe_is_typeless_boz ()) {
14669
14670       switch (c)
14671         {
14672         case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14673           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14674                                             (ffeexpr_tokens_[2]));
14675           break;
14676
14677         case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14678           e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14679                                             (ffeexpr_tokens_[2]));
14680           break;
14681
14682         case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14683           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14684                                             (ffeexpr_tokens_[2]));
14685           break;
14686
14687         case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14688           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14689                                             (ffeexpr_tokens_[2]));
14690           break;
14691
14692         default:
14693         no_imatch:              /* :::::::::::::::::::: */
14694           assert ("not BOXZ!" == NULL);
14695           abort ();
14696         }
14697
14698         ffebld_set_info (e->u.operand,
14699                          ffeinfo_new (FFEINFO_basictypeINTEGER,
14700                                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
14701                                       FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14702                                       FFETARGET_charactersizeNONE));
14703         ffeexpr_exprstack_push_operand_ (e);
14704         ffelex_token_kill (ffeexpr_tokens_[1]);
14705         ffelex_token_kill (ffeexpr_tokens_[2]);
14706         return (ffelexHandler) ffeexpr_token_binary_;
14707       }
14708
14709       switch (c)
14710         {
14711         case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14712           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14713                                             (ffeexpr_tokens_[2]));
14714           size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14715           break;
14716
14717         case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14718           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14719                                             (ffeexpr_tokens_[2]));
14720           size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14721           break;
14722
14723         case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14724           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14725                                             (ffeexpr_tokens_[2]));
14726           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14727           break;
14728
14729         case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14730           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14731                                             (ffeexpr_tokens_[2]));
14732           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14733           break;
14734
14735         default:
14736         no_match:               /* :::::::::::::::::::: */
14737           assert ("not BOXZ!" == NULL);
14738           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14739                                             (ffeexpr_tokens_[2]));
14740           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14741           break;
14742         }
14743       ffebld_set_info (e->u.operand,
14744                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14745                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14746       ffeexpr_exprstack_push_operand_ (e);
14747       ffelex_token_kill (ffeexpr_tokens_[1]);
14748       ffelex_token_kill (ffeexpr_tokens_[2]);
14749       return (ffelexHandler) ffeexpr_token_binary_;
14750     }
14751
14752   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14753     {
14754       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14755       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14756                    ffelex_token_where_column (ffeexpr_tokens_[0]));
14757       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14758       ffebad_finish ();
14759     }
14760
14761   ffelex_token_kill (ffeexpr_tokens_[1]);
14762   ffelex_token_kill (ffeexpr_tokens_[2]);
14763
14764   e->type = FFEEXPR_exprtypeOPERAND_;
14765   e->u.operand = ffebld_new_any ();
14766   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14767   e->token = ffeexpr_tokens_[0];
14768   ffeexpr_exprstack_push_operand_ (e);
14769
14770   switch (ffelex_token_type (t))
14771     {
14772     case FFELEX_typeAPOSTROPHE:
14773     case FFELEX_typeQUOTE:
14774       return (ffelexHandler) ffeexpr_token_binary_;
14775
14776     default:
14777       return (ffelexHandler) ffeexpr_token_binary_ (t);
14778     }
14779 }
14780
14781 /* ffeexpr_token_percent_ -- Rhs PERCENT
14782
14783    Handle a percent sign possibly followed by "LOC".  If followed instead
14784    by "VAL", "REF", or "DESCR", issue an error message and substitute
14785    "LOC".  If followed by something else, treat the percent sign as a
14786    spurious incorrect token and reprocess the token via _rhs_.  */
14787
14788 static ffelexHandler
14789 ffeexpr_token_percent_ (ffelexToken t)
14790 {
14791   switch (ffelex_token_type (t))
14792     {
14793     case FFELEX_typeNAME:
14794     case FFELEX_typeNAMES:
14795       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14796       ffeexpr_tokens_[1] = ffelex_token_use (t);
14797       return (ffelexHandler) ffeexpr_token_percent_name_;
14798
14799     default:
14800       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14801         {
14802           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14803                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14804           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14805                    ffelex_token_where_column (ffeexpr_stack_->first_token));
14806           ffebad_finish ();
14807         }
14808       ffelex_token_kill (ffeexpr_tokens_[0]);
14809       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14810     }
14811 }
14812
14813 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14814
14815    Make sure the token is OPEN_PAREN and prepare for the one-item list of
14816    LHS expressions.  Else display an error message.  */
14817
14818 static ffelexHandler
14819 ffeexpr_token_percent_name_ (ffelexToken t)
14820 {
14821   ffelexHandler nexthandler;
14822
14823   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14824     {
14825       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14826         {
14827           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14828                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14829           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14830                    ffelex_token_where_column (ffeexpr_stack_->first_token));
14831           ffebad_finish ();
14832         }
14833       ffelex_token_kill (ffeexpr_tokens_[0]);
14834       nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14835       ffelex_token_kill (ffeexpr_tokens_[1]);
14836       return (ffelexHandler) (*nexthandler) (t);
14837     }
14838
14839   switch (ffeexpr_stack_->percent)
14840     {
14841     default:
14842       if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14843         {
14844           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14845                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14846           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14847           ffebad_finish ();
14848         }
14849       ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14850       /* Fall through. */
14851     case FFEEXPR_percentLOC_:
14852       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14853       ffelex_token_kill (ffeexpr_tokens_[1]);
14854       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14855       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14856                                           FFEEXPR_contextLOC_,
14857                                           ffeexpr_cb_end_loc_);
14858     }
14859 }
14860
14861 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14862
14863    See prototype.
14864
14865    Pass 'E', 'D', or 'Q' for exponent letter.  */
14866
14867 static void
14868 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14869                            ffelexToken decimal, ffelexToken fraction,
14870                            ffelexToken exponent, ffelexToken exponent_sign,
14871                            ffelexToken exponent_digits)
14872 {
14873   ffeexprExpr_ e;
14874
14875   e = ffeexpr_expr_new_ ();
14876   e->type = FFEEXPR_exprtypeOPERAND_;
14877   if (integer != NULL)
14878     e->token = ffelex_token_use (integer);
14879   else
14880     {
14881       assert (decimal != NULL);
14882       e->token = ffelex_token_use (decimal);
14883     }
14884
14885   switch (exp_letter)
14886     {
14887 #if !FFETARGET_okREALQUAD
14888     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14889       if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14890         {
14891           ffebad_here (0, ffelex_token_where_line (e->token),
14892                        ffelex_token_where_column (e->token));
14893           ffebad_finish ();
14894         }
14895       goto match_d;             /* The FFESRC_CASE_* macros don't
14896                                    allow fall-through! */
14897 #endif
14898
14899     case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14900       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14901                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14902       ffebld_set_info (e->u.operand,
14903              ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14904                           0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14905       break;
14906
14907     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14908       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14909                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14910       ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14911                          FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14912                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14913       break;
14914
14915 #if FFETARGET_okREALQUAD
14916     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14917       e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14918                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14919       ffebld_set_info (e->u.operand,
14920                ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14921                             0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14922       break;
14923 #endif
14924
14925     case 'I':   /* Make an integer. */
14926       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14927                                         (ffeexpr_tokens_[0]));
14928       ffebld_set_info (e->u.operand,
14929                        ffeinfo_new (FFEINFO_basictypeINTEGER,
14930                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
14931                                     FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14932                                     FFETARGET_charactersizeNONE));
14933       break;
14934
14935     default:
14936     no_match:                   /* :::::::::::::::::::: */
14937       assert ("Lost the exponent letter!" == NULL);
14938     }
14939
14940   ffeexpr_exprstack_push_operand_ (e);
14941 }
14942
14943 /* Just like ffesymbol_declare_local, except performs any implicit info
14944    assignment necessary.  */
14945
14946 static ffesymbol
14947 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14948 {
14949   ffesymbol s;
14950   ffeinfoKind k;
14951   bool bad;
14952
14953   s = ffesymbol_declare_local (t, maybe_intrin);
14954
14955   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14956     /* Special-case these since they can involve a different concept
14957        of "state" (in the stmtfunc name space).  */
14958     {
14959     case FFEEXPR_contextDATAIMPDOINDEX_:
14960     case FFEEXPR_contextDATAIMPDOCTRL_:
14961       if (ffeexpr_context_outer_ (ffeexpr_stack_)
14962           == FFEEXPR_contextDATAIMPDOINDEX_)
14963         s = ffeexpr_sym_impdoitem_ (s, t);
14964       else
14965         if (ffeexpr_stack_->is_rhs)
14966           s = ffeexpr_sym_impdoitem_ (s, t);
14967         else
14968           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
14969       bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
14970         || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
14971             && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
14972       if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
14973         ffesymbol_error (s, t);
14974       return s;
14975
14976     default:
14977       break;
14978     }
14979
14980   switch ((ffesymbol_sfdummyparent (s) == NULL)
14981           ? ffesymbol_state (s)
14982           : FFESYMBOL_stateUNDERSTOOD)
14983     {
14984     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
14985                                    context. */
14986       if (!ffest_seen_first_exec ())
14987         goto seen;              /* :::::::::::::::::::: */
14988       /* Fall through. */
14989     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
14990       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14991         {
14992         case FFEEXPR_contextSUBROUTINEREF:
14993           s = ffeexpr_sym_lhs_call_ (s, t);
14994           break;
14995
14996         case FFEEXPR_contextFILEEXTFUNC:
14997           s = ffeexpr_sym_lhs_extfunc_ (s, t);
14998           break;
14999
15000         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15001           s = ffecom_sym_exec_transition (s);
15002           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15003             goto understood;    /* :::::::::::::::::::: */
15004           /* Fall through. */
15005         case FFEEXPR_contextACTUALARG_:
15006           s = ffeexpr_sym_rhs_actualarg_ (s, t);
15007           break;
15008
15009         case FFEEXPR_contextDATA:
15010           if (ffeexpr_stack_->is_rhs)
15011             s = ffeexpr_sym_rhs_let_ (s, t);
15012           else
15013             s = ffeexpr_sym_lhs_data_ (s, t);
15014           break;
15015
15016         case FFEEXPR_contextDATAIMPDOITEM_:
15017           s = ffeexpr_sym_lhs_data_ (s, t);
15018           break;
15019
15020         case FFEEXPR_contextSFUNCDEF:
15021         case FFEEXPR_contextSFUNCDEFINDEX_:
15022         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15023         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15024           s = ffecom_sym_exec_transition (s);
15025           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15026             goto understood;    /* :::::::::::::::::::: */
15027           /* Fall through. */
15028         case FFEEXPR_contextLET:
15029         case FFEEXPR_contextPAREN_:
15030         case FFEEXPR_contextACTUALARGEXPR_:
15031         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15032         case FFEEXPR_contextASSIGN:
15033         case FFEEXPR_contextIOLIST:
15034         case FFEEXPR_contextIOLISTDF:
15035         case FFEEXPR_contextDO:
15036         case FFEEXPR_contextDOWHILE:
15037         case FFEEXPR_contextAGOTO:
15038         case FFEEXPR_contextCGOTO:
15039         case FFEEXPR_contextIF:
15040         case FFEEXPR_contextARITHIF:
15041         case FFEEXPR_contextFORMAT:
15042         case FFEEXPR_contextSTOP:
15043         case FFEEXPR_contextRETURN:
15044         case FFEEXPR_contextSELECTCASE:
15045         case FFEEXPR_contextCASE:
15046         case FFEEXPR_contextFILEASSOC:
15047         case FFEEXPR_contextFILEINT:
15048         case FFEEXPR_contextFILEDFINT:
15049         case FFEEXPR_contextFILELOG:
15050         case FFEEXPR_contextFILENUM:
15051         case FFEEXPR_contextFILENUMAMBIG:
15052         case FFEEXPR_contextFILECHAR:
15053         case FFEEXPR_contextFILENUMCHAR:
15054         case FFEEXPR_contextFILEDFCHAR:
15055         case FFEEXPR_contextFILEKEY:
15056         case FFEEXPR_contextFILEUNIT:
15057         case FFEEXPR_contextFILEUNIT_DF:
15058         case FFEEXPR_contextFILEUNITAMBIG:
15059         case FFEEXPR_contextFILEFORMAT:
15060         case FFEEXPR_contextFILENAMELIST:
15061         case FFEEXPR_contextFILEVXTCODE:
15062         case FFEEXPR_contextINDEX_:
15063         case FFEEXPR_contextIMPDOITEM_:
15064         case FFEEXPR_contextIMPDOITEMDF_:
15065         case FFEEXPR_contextIMPDOCTRL_:
15066         case FFEEXPR_contextLOC_:
15067           if (ffeexpr_stack_->is_rhs)
15068             s = ffeexpr_sym_rhs_let_ (s, t);
15069           else
15070             s = ffeexpr_sym_lhs_let_ (s, t);
15071           break;
15072
15073         case FFEEXPR_contextCHARACTERSIZE:
15074         case FFEEXPR_contextEQUIVALENCE:
15075         case FFEEXPR_contextINCLUDE:
15076         case FFEEXPR_contextPARAMETER:
15077         case FFEEXPR_contextDIMLIST:
15078         case FFEEXPR_contextDIMLISTCOMMON:
15079         case FFEEXPR_contextKINDTYPE:
15080         case FFEEXPR_contextINITVAL:
15081         case FFEEXPR_contextEQVINDEX_:
15082           break;                /* Will turn into errors below. */
15083
15084         default:
15085           ffesymbol_error (s, t);
15086           break;
15087         }
15088       /* Fall through. */
15089     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
15090     understood:         /* :::::::::::::::::::: */
15091       k = ffesymbol_kind (s);
15092       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15093         {
15094         case FFEEXPR_contextSUBROUTINEREF:
15095           bad = ((k != FFEINFO_kindSUBROUTINE)
15096                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15097                      || (k != FFEINFO_kindNONE)));
15098           break;
15099
15100         case FFEEXPR_contextFILEEXTFUNC:
15101           bad = (k != FFEINFO_kindFUNCTION)
15102             || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15103           break;
15104
15105         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15106         case FFEEXPR_contextACTUALARG_:
15107           switch (k)
15108             {
15109             case FFEINFO_kindENTITY:
15110               bad = FALSE;
15111               break;
15112
15113             case FFEINFO_kindFUNCTION:
15114             case FFEINFO_kindSUBROUTINE:
15115               bad
15116                 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15117                    && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15118                    && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15119                        || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15120               break;
15121
15122             case FFEINFO_kindNONE:
15123               if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15124                 {
15125                   bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15126                   break;
15127                 }
15128
15129               /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15130                  and in the former case, attrsTYPE is set, so we
15131                  see this as an error as we should, since CHAR*(*)
15132                  cannot be actually referenced in a main/block data
15133                  program unit.  */
15134
15135               if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15136                                           | FFESYMBOL_attrsEXTERNAL
15137                                           | FFESYMBOL_attrsTYPE))
15138                   == FFESYMBOL_attrsEXTERNAL)
15139                 bad = FALSE;
15140               else
15141                 bad = TRUE;
15142               break;
15143
15144             default:
15145               bad = TRUE;
15146               break;
15147             }
15148           break;
15149
15150         case FFEEXPR_contextDATA:
15151           if (ffeexpr_stack_->is_rhs)
15152             bad = (k != FFEINFO_kindENTITY)
15153               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15154           else
15155             bad = (k != FFEINFO_kindENTITY)
15156               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15157                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15158                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15159           break;
15160
15161         case FFEEXPR_contextDATAIMPDOITEM_:
15162           bad = TRUE;           /* Unadorned item never valid. */
15163           break;
15164
15165         case FFEEXPR_contextSFUNCDEF:
15166         case FFEEXPR_contextSFUNCDEFINDEX_:
15167         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15168         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15169         case FFEEXPR_contextLET:
15170         case FFEEXPR_contextPAREN_:
15171         case FFEEXPR_contextACTUALARGEXPR_:
15172         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15173         case FFEEXPR_contextASSIGN:
15174         case FFEEXPR_contextIOLIST:
15175         case FFEEXPR_contextIOLISTDF:
15176         case FFEEXPR_contextDO:
15177         case FFEEXPR_contextDOWHILE:
15178         case FFEEXPR_contextAGOTO:
15179         case FFEEXPR_contextCGOTO:
15180         case FFEEXPR_contextIF:
15181         case FFEEXPR_contextARITHIF:
15182         case FFEEXPR_contextFORMAT:
15183         case FFEEXPR_contextSTOP:
15184         case FFEEXPR_contextRETURN:
15185         case FFEEXPR_contextSELECTCASE:
15186         case FFEEXPR_contextCASE:
15187         case FFEEXPR_contextFILEASSOC:
15188         case FFEEXPR_contextFILEINT:
15189         case FFEEXPR_contextFILEDFINT:
15190         case FFEEXPR_contextFILELOG:
15191         case FFEEXPR_contextFILENUM:
15192         case FFEEXPR_contextFILENUMAMBIG:
15193         case FFEEXPR_contextFILECHAR:
15194         case FFEEXPR_contextFILENUMCHAR:
15195         case FFEEXPR_contextFILEDFCHAR:
15196         case FFEEXPR_contextFILEKEY:
15197         case FFEEXPR_contextFILEUNIT:
15198         case FFEEXPR_contextFILEUNIT_DF:
15199         case FFEEXPR_contextFILEUNITAMBIG:
15200         case FFEEXPR_contextFILEFORMAT:
15201         case FFEEXPR_contextFILENAMELIST:
15202         case FFEEXPR_contextFILEVXTCODE:
15203         case FFEEXPR_contextINDEX_:
15204         case FFEEXPR_contextIMPDOITEM_:
15205         case FFEEXPR_contextIMPDOITEMDF_:
15206         case FFEEXPR_contextIMPDOCTRL_:
15207         case FFEEXPR_contextLOC_:
15208           bad = (k != FFEINFO_kindENTITY);      /* This catches "SUBROUTINE
15209                                                    X(A);EXTERNAL A;CALL
15210                                                    Y(A);B=A", for example. */
15211           break;
15212
15213         case FFEEXPR_contextCHARACTERSIZE:
15214         case FFEEXPR_contextEQUIVALENCE:
15215         case FFEEXPR_contextPARAMETER:
15216         case FFEEXPR_contextDIMLIST:
15217         case FFEEXPR_contextDIMLISTCOMMON:
15218         case FFEEXPR_contextKINDTYPE:
15219         case FFEEXPR_contextINITVAL:
15220         case FFEEXPR_contextEQVINDEX_:
15221           bad = (k != FFEINFO_kindENTITY)
15222             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15223           break;
15224
15225         case FFEEXPR_contextINCLUDE:
15226           bad = TRUE;
15227           break;
15228
15229         default:
15230           bad = TRUE;
15231           break;
15232         }
15233       if (bad && (k != FFEINFO_kindANY))
15234         ffesymbol_error (s, t);
15235       return s;
15236
15237     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
15238     seen:                       /* :::::::::::::::::::: */
15239       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15240         {
15241         case FFEEXPR_contextPARAMETER:
15242           if (ffeexpr_stack_->is_rhs)
15243             ffesymbol_error (s, t);
15244           else
15245             s = ffeexpr_sym_lhs_parameter_ (s, t);
15246           break;
15247
15248         case FFEEXPR_contextDATA:
15249           s = ffecom_sym_exec_transition (s);
15250           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15251             goto understood;    /* :::::::::::::::::::: */
15252           if (ffeexpr_stack_->is_rhs)
15253             ffesymbol_error (s, t);
15254           else
15255             s = ffeexpr_sym_lhs_data_ (s, t);
15256           goto understood;      /* :::::::::::::::::::: */
15257
15258         case FFEEXPR_contextDATAIMPDOITEM_:
15259           s = ffecom_sym_exec_transition (s);
15260           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15261             goto understood;    /* :::::::::::::::::::: */
15262           s = ffeexpr_sym_lhs_data_ (s, t);
15263           goto understood;      /* :::::::::::::::::::: */
15264
15265         case FFEEXPR_contextEQUIVALENCE:
15266           s = ffeexpr_sym_lhs_equivalence_ (s, t);
15267           break;
15268
15269         case FFEEXPR_contextDIMLIST:
15270           s = ffeexpr_sym_rhs_dimlist_ (s, t);
15271           break;
15272
15273         case FFEEXPR_contextCHARACTERSIZE:
15274         case FFEEXPR_contextKINDTYPE:
15275         case FFEEXPR_contextDIMLISTCOMMON:
15276         case FFEEXPR_contextINITVAL:
15277         case FFEEXPR_contextEQVINDEX_:
15278           ffesymbol_error (s, t);
15279           break;
15280
15281         case FFEEXPR_contextINCLUDE:
15282           ffesymbol_error (s, t);
15283           break;
15284
15285         case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
15286         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15287           s = ffecom_sym_exec_transition (s);
15288           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15289             goto understood;    /* :::::::::::::::::::: */
15290           s = ffeexpr_sym_rhs_actualarg_ (s, t);
15291           goto understood;      /* :::::::::::::::::::: */
15292
15293         case FFEEXPR_contextINDEX_:
15294         case FFEEXPR_contextACTUALARGEXPR_:
15295         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15296         case FFEEXPR_contextSFUNCDEF:
15297         case FFEEXPR_contextSFUNCDEFINDEX_:
15298         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15299         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15300           assert (ffeexpr_stack_->is_rhs);
15301           s = ffecom_sym_exec_transition (s);
15302           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15303             goto understood;    /* :::::::::::::::::::: */
15304           s = ffeexpr_sym_rhs_let_ (s, t);
15305           goto understood;      /* :::::::::::::::::::: */
15306
15307         default:
15308           ffesymbol_error (s, t);
15309           break;
15310         }
15311       return s;
15312
15313     default:
15314       assert ("bad symbol state" == NULL);
15315       return NULL;
15316       break;
15317     }
15318 }
15319
15320 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15321    Could be found via the "statement-function" name space (in which case
15322    it should become an iterator) or the local name space (in which case
15323    it should be either a named constant, or a variable that will have an
15324    sfunc name space sibling that should become an iterator).  */
15325
15326 static ffesymbol
15327 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15328 {
15329   ffesymbol s;
15330   ffesymbolAttrs sa;
15331   ffesymbolAttrs na;
15332   ffesymbolState ss;
15333   ffesymbolState ns;
15334   ffeinfoKind kind;
15335   ffeinfoWhere where;
15336
15337   ss = ffesymbol_state (sp);
15338
15339   if (ffesymbol_sfdummyparent (sp) != NULL)
15340     {                           /* Have symbol in sfunc name space. */
15341       switch (ss)
15342         {
15343         case FFESYMBOL_stateNONE:       /* Used as iterator already. */
15344           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15345             ffesymbol_error (sp, t);    /* Can't use dead iterator. */
15346           else
15347             {                   /* Can use dead iterator because we're at at
15348                                    least an innermore (higher-numbered) level
15349                                    than the iterator's outermost
15350                                    (lowest-numbered) level. */
15351               ffesymbol_signal_change (sp);
15352               ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15353               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15354               ffesymbol_signal_unreported (sp);
15355             }
15356           break;
15357
15358         case FFESYMBOL_stateSEEN:       /* Seen already in this or other
15359                                            implied-DO.  Set symbol level
15360                                            number to outermost value, as that
15361                                            tells us we can see it as iterator
15362                                            at that level at the innermost. */
15363           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15364             {
15365               ffesymbol_signal_change (sp);
15366               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15367               ffesymbol_signal_unreported (sp);
15368             }
15369           break;
15370
15371         case FFESYMBOL_stateUNCERTAIN:  /* Iterator. */
15372           assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15373           ffesymbol_error (sp, t);      /* (,,,I=I,10). */
15374           break;
15375
15376         case FFESYMBOL_stateUNDERSTOOD:
15377           break;                /* ANY. */
15378
15379         default:
15380           assert ("Foo Bar!!" == NULL);
15381           break;
15382         }
15383
15384       return sp;
15385     }
15386
15387   /* Got symbol in local name space, so we haven't seen it in impdo yet.
15388      First, if it is brand-new and we're in executable statements, set the
15389      attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15390      Second, if it is now a constant (PARAMETER), then just return it, it
15391      can't be an implied-do iterator.  If it is understood, complain if it is
15392      not a valid variable, but make the inner name space iterator anyway and
15393      return that.  If it is not understood, improve understanding of the
15394      symbol accordingly, complain accordingly, in either case make the inner
15395      name space iterator and return that.  */
15396
15397   sa = ffesymbol_attrs (sp);
15398
15399   if (ffesymbol_state_is_specable (ss)
15400       && ffest_seen_first_exec ())
15401     {
15402       assert (sa == FFESYMBOL_attrsetNONE);
15403       ffesymbol_signal_change (sp);
15404       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15405       ffesymbol_resolve_intrin (sp);
15406       if (ffeimplic_establish_symbol (sp))
15407         ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15408       else
15409         ffesymbol_error (sp, t);
15410
15411       /* After the exec transition, the state will either be UNCERTAIN (could
15412          be a dummy or local var) or UNDERSTOOD (local var, because this is a
15413          PROGRAM/BLOCKDATA program unit).  */
15414
15415       sp = ffecom_sym_exec_transition (sp);
15416       sa = ffesymbol_attrs (sp);
15417       ss = ffesymbol_state (sp);
15418     }
15419
15420   ns = ss;
15421   kind = ffesymbol_kind (sp);
15422   where = ffesymbol_where (sp);
15423
15424   if (ss == FFESYMBOL_stateUNDERSTOOD)
15425     {
15426       if (kind != FFEINFO_kindENTITY)
15427         ffesymbol_error (sp, t);
15428       if (where == FFEINFO_whereCONSTANT)
15429         return sp;
15430     }
15431   else
15432     {
15433       /* Enhance understanding of local symbol.  This used to imply exec
15434          transition, but that doesn't seem necessary, since the local symbol
15435          doesn't actually get put into an ffebld tree here -- we just learn
15436          more about it, just like when we see a local symbol's name in the
15437          dummy-arg list of a statement function.  */
15438
15439       if (ss != FFESYMBOL_stateUNCERTAIN)
15440         {
15441           /* Figure out what kind of object we've got based on previous
15442              declarations of or references to the object. */
15443
15444           ns = FFESYMBOL_stateSEEN;
15445
15446           if (sa & FFESYMBOL_attrsANY)
15447             na = sa;
15448           else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15449                             | FFESYMBOL_attrsANY
15450                             | FFESYMBOL_attrsCOMMON
15451                             | FFESYMBOL_attrsDUMMY
15452                             | FFESYMBOL_attrsEQUIV
15453                             | FFESYMBOL_attrsINIT
15454                             | FFESYMBOL_attrsNAMELIST
15455                             | FFESYMBOL_attrsRESULT
15456                             | FFESYMBOL_attrsSAVE
15457                             | FFESYMBOL_attrsSFARG
15458                             | FFESYMBOL_attrsTYPE)))
15459             na = sa | FFESYMBOL_attrsSFARG;
15460           else
15461             na = FFESYMBOL_attrsetNONE;
15462         }
15463       else
15464         {                       /* stateUNCERTAIN. */
15465           na = sa | FFESYMBOL_attrsSFARG;
15466           ns = FFESYMBOL_stateUNDERSTOOD;
15467
15468           assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15469                            | FFESYMBOL_attrsADJUSTABLE
15470                            | FFESYMBOL_attrsANYLEN
15471                            | FFESYMBOL_attrsARRAY
15472                            | FFESYMBOL_attrsDUMMY
15473                            | FFESYMBOL_attrsEXTERNAL
15474                            | FFESYMBOL_attrsSFARG
15475                            | FFESYMBOL_attrsTYPE)));
15476
15477           if (sa & FFESYMBOL_attrsEXTERNAL)
15478             {
15479               assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15480                                | FFESYMBOL_attrsDUMMY
15481                                | FFESYMBOL_attrsEXTERNAL
15482                                | FFESYMBOL_attrsTYPE)));
15483
15484               na = FFESYMBOL_attrsetNONE;
15485             }
15486           else if (sa & FFESYMBOL_attrsDUMMY)
15487             {
15488               assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15489               assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15490                                | FFESYMBOL_attrsEXTERNAL
15491                                | FFESYMBOL_attrsTYPE)));
15492
15493               kind = FFEINFO_kindENTITY;
15494             }
15495           else if (sa & FFESYMBOL_attrsARRAY)
15496             {
15497               assert (!(sa & ~(FFESYMBOL_attrsARRAY
15498                                | FFESYMBOL_attrsADJUSTABLE
15499                                | FFESYMBOL_attrsTYPE)));
15500
15501               na = FFESYMBOL_attrsetNONE;
15502             }
15503           else if (sa & FFESYMBOL_attrsSFARG)
15504             {
15505               assert (!(sa & ~(FFESYMBOL_attrsSFARG
15506                                | FFESYMBOL_attrsTYPE)));
15507
15508               ns = FFESYMBOL_stateUNCERTAIN;
15509             }
15510           else if (sa & FFESYMBOL_attrsTYPE)
15511             {
15512               assert (!(sa & (FFESYMBOL_attrsARRAY
15513                               | FFESYMBOL_attrsDUMMY
15514                               | FFESYMBOL_attrsEXTERNAL
15515                               | FFESYMBOL_attrsSFARG)));        /* Handled above. */
15516               assert (!(sa & ~(FFESYMBOL_attrsTYPE
15517                                | FFESYMBOL_attrsADJUSTABLE
15518                                | FFESYMBOL_attrsANYLEN
15519                                | FFESYMBOL_attrsARRAY
15520                                | FFESYMBOL_attrsDUMMY
15521                                | FFESYMBOL_attrsEXTERNAL
15522                                | FFESYMBOL_attrsSFARG)));
15523
15524               kind = FFEINFO_kindENTITY;
15525
15526               if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15527                 na = FFESYMBOL_attrsetNONE;
15528               else if (ffest_is_entry_valid ())
15529                 ns = FFESYMBOL_stateUNCERTAIN;  /* Could be DUMMY or LOCAL. */
15530               else
15531                 where = FFEINFO_whereLOCAL;
15532             }
15533           else
15534             na = FFESYMBOL_attrsetNONE; /* Error. */
15535         }
15536
15537       /* Now see what we've got for a new object: NONE means a new error
15538          cropped up; ANY means an old error to be ignored; otherwise,
15539          everything's ok, update the object (symbol) and continue on. */
15540
15541       if (na == FFESYMBOL_attrsetNONE)
15542         ffesymbol_error (sp, t);
15543       else if (!(na & FFESYMBOL_attrsANY))
15544         {
15545           ffesymbol_signal_change (sp); /* May need to back up to previous
15546                                            version. */
15547           if (!ffeimplic_establish_symbol (sp))
15548             ffesymbol_error (sp, t);
15549           else
15550             {
15551               ffesymbol_set_info (sp,
15552                                   ffeinfo_new (ffesymbol_basictype (sp),
15553                                                ffesymbol_kindtype (sp),
15554                                                ffesymbol_rank (sp),
15555                                                kind,
15556                                                where,
15557                                                ffesymbol_size (sp)));
15558               ffesymbol_set_attrs (sp, na);
15559               ffesymbol_set_state (sp, ns);
15560               ffesymbol_resolve_intrin (sp);
15561               if (!ffesymbol_state_is_specable (ns))
15562                 sp = ffecom_sym_learned (sp);
15563               ffesymbol_signal_unreported (sp); /* For debugging purposes. */
15564             }
15565         }
15566     }
15567
15568   /* Here we create the sfunc-name-space symbol representing what should
15569      become an iterator in this name space at this or an outermore (lower-
15570      numbered) expression level, else the implied-DO construct is in error.  */
15571
15572   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
15573                                            also sets sfa_dummy_parent to
15574                                            parent symbol. */
15575   assert (sp == ffesymbol_sfdummyparent (s));
15576
15577   ffesymbol_signal_change (s);
15578   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15579   ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15580   ffesymbol_set_info (s,
15581                       ffeinfo_new (FFEINFO_basictypeINTEGER,
15582                                    FFEINFO_kindtypeINTEGERDEFAULT,
15583                                    0,
15584                                    FFEINFO_kindENTITY,
15585                                    FFEINFO_whereIMMEDIATE,
15586                                    FFETARGET_charactersizeNONE));
15587   ffesymbol_signal_unreported (s);
15588
15589   if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15590        && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15591     ffesymbol_error (s, t);
15592
15593   return s;
15594 }
15595
15596 /* Have FOO in CALL FOO.  Local name space, executable context only.  */
15597
15598 static ffesymbol
15599 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15600 {
15601   ffesymbolAttrs sa;
15602   ffesymbolAttrs na;
15603   ffeinfoKind kind;
15604   ffeinfoWhere where;
15605   ffeintrinGen gen;
15606   ffeintrinSpec spec;
15607   ffeintrinImp imp;
15608   bool error = FALSE;
15609
15610   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15611           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15612
15613   na = sa = ffesymbol_attrs (s);
15614
15615   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15616                    | FFESYMBOL_attrsADJUSTABLE
15617                    | FFESYMBOL_attrsANYLEN
15618                    | FFESYMBOL_attrsARRAY
15619                    | FFESYMBOL_attrsDUMMY
15620                    | FFESYMBOL_attrsEXTERNAL
15621                    | FFESYMBOL_attrsSFARG
15622                    | FFESYMBOL_attrsTYPE)));
15623
15624   kind = ffesymbol_kind (s);
15625   where = ffesymbol_where (s);
15626
15627   /* Figure out what kind of object we've got based on previous declarations
15628      of or references to the object. */
15629
15630   if (sa & FFESYMBOL_attrsEXTERNAL)
15631     {
15632       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15633                        | FFESYMBOL_attrsDUMMY
15634                        | FFESYMBOL_attrsEXTERNAL
15635                        | FFESYMBOL_attrsTYPE)));
15636
15637       if (sa & FFESYMBOL_attrsTYPE)
15638         error = TRUE;
15639       else
15640         /* Not TYPE. */
15641         {
15642           kind = FFEINFO_kindSUBROUTINE;
15643
15644           if (sa & FFESYMBOL_attrsDUMMY)
15645             ;                   /* Not TYPE. */
15646           else if (sa & FFESYMBOL_attrsACTUALARG)
15647             ;                   /* Not DUMMY or TYPE. */
15648           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
15649             where = FFEINFO_whereGLOBAL;
15650         }
15651     }
15652   else if (sa & FFESYMBOL_attrsDUMMY)
15653     {
15654       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15655       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15656                        | FFESYMBOL_attrsEXTERNAL
15657                        | FFESYMBOL_attrsTYPE)));
15658
15659       if (sa & FFESYMBOL_attrsTYPE)
15660         error = TRUE;
15661       else
15662         kind = FFEINFO_kindSUBROUTINE;
15663     }
15664   else if (sa & FFESYMBOL_attrsARRAY)
15665     {
15666       assert (!(sa & ~(FFESYMBOL_attrsARRAY
15667                        | FFESYMBOL_attrsADJUSTABLE
15668                        | FFESYMBOL_attrsTYPE)));
15669
15670       error = TRUE;
15671     }
15672   else if (sa & FFESYMBOL_attrsSFARG)
15673     {
15674       assert (!(sa & ~(FFESYMBOL_attrsSFARG
15675                        | FFESYMBOL_attrsTYPE)));
15676
15677       error = TRUE;
15678     }
15679   else if (sa & FFESYMBOL_attrsTYPE)
15680     {
15681       assert (!(sa & (FFESYMBOL_attrsARRAY
15682                       | FFESYMBOL_attrsDUMMY
15683                       | FFESYMBOL_attrsEXTERNAL
15684                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
15685       assert (!(sa & ~(FFESYMBOL_attrsTYPE
15686                        | FFESYMBOL_attrsADJUSTABLE
15687                        | FFESYMBOL_attrsANYLEN
15688                        | FFESYMBOL_attrsARRAY
15689                        | FFESYMBOL_attrsDUMMY
15690                        | FFESYMBOL_attrsEXTERNAL
15691                        | FFESYMBOL_attrsSFARG)));
15692
15693       error = TRUE;
15694     }
15695   else if (sa == FFESYMBOL_attrsetNONE)
15696     {
15697       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15698
15699       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15700                                   &gen, &spec, &imp))
15701         {
15702           ffesymbol_signal_change (s);  /* May need to back up to previous
15703                                            version. */
15704           ffesymbol_set_generic (s, gen);
15705           ffesymbol_set_specific (s, spec);
15706           ffesymbol_set_implementation (s, imp);
15707           ffesymbol_set_info (s,
15708                               ffeinfo_new (FFEINFO_basictypeNONE,
15709                                            FFEINFO_kindtypeNONE,
15710                                            0,
15711                                            FFEINFO_kindSUBROUTINE,
15712                                            FFEINFO_whereINTRINSIC,
15713                                            FFETARGET_charactersizeNONE));
15714           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15715           ffesymbol_resolve_intrin (s);
15716           ffesymbol_reference (s, t, FALSE);
15717           s = ffecom_sym_learned (s);
15718           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
15719
15720           return s;
15721         }
15722
15723       kind = FFEINFO_kindSUBROUTINE;
15724       where = FFEINFO_whereGLOBAL;
15725     }
15726   else
15727     error = TRUE;
15728
15729   /* Now see what we've got for a new object: NONE means a new error cropped
15730      up; ANY means an old error to be ignored; otherwise, everything's ok,
15731      update the object (symbol) and continue on. */
15732
15733   if (error)
15734     ffesymbol_error (s, t);
15735   else if (!(na & FFESYMBOL_attrsANY))
15736     {
15737       ffesymbol_signal_change (s);      /* May need to back up to previous
15738                                            version. */
15739       ffesymbol_set_info (s,
15740                           ffeinfo_new (ffesymbol_basictype (s),
15741                                        ffesymbol_kindtype (s),
15742                                        ffesymbol_rank (s),
15743                                        kind,    /* SUBROUTINE. */
15744                                        where,   /* GLOBAL or DUMMY. */
15745                                        ffesymbol_size (s)));
15746       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15747       ffesymbol_resolve_intrin (s);
15748       ffesymbol_reference (s, t, FALSE);
15749       s = ffecom_sym_learned (s);
15750       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
15751     }
15752
15753   return s;
15754 }
15755
15756 /* Have FOO in DATA FOO/.../.  Local name space and executable context
15757    only.  (This will change in the future when DATA FOO may be followed
15758    by COMMON FOO or even INTEGER FOO(10), etc.)  */
15759
15760 static ffesymbol
15761 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15762 {
15763   ffesymbolAttrs sa;
15764   ffesymbolAttrs na;
15765   ffeinfoKind kind;
15766   ffeinfoWhere where;
15767   bool error = FALSE;
15768
15769   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15770           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15771
15772   na = sa = ffesymbol_attrs (s);
15773
15774   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15775                    | FFESYMBOL_attrsADJUSTABLE
15776                    | FFESYMBOL_attrsANYLEN
15777                    | FFESYMBOL_attrsARRAY
15778                    | FFESYMBOL_attrsDUMMY
15779                    | FFESYMBOL_attrsEXTERNAL
15780                    | FFESYMBOL_attrsSFARG
15781                    | FFESYMBOL_attrsTYPE)));
15782
15783   kind = ffesymbol_kind (s);
15784   where = ffesymbol_where (s);
15785
15786   /* Figure out what kind of object we've got based on previous declarations
15787      of or references to the object. */
15788
15789   if (sa & FFESYMBOL_attrsEXTERNAL)
15790     {
15791       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15792                        | FFESYMBOL_attrsDUMMY
15793                        | FFESYMBOL_attrsEXTERNAL
15794                        | FFESYMBOL_attrsTYPE)));
15795
15796       error = TRUE;
15797     }
15798   else if (sa & FFESYMBOL_attrsDUMMY)
15799     {
15800       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15801       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15802                        | FFESYMBOL_attrsEXTERNAL
15803                        | FFESYMBOL_attrsTYPE)));
15804
15805       error = TRUE;
15806     }
15807   else if (sa & FFESYMBOL_attrsARRAY)
15808     {
15809       assert (!(sa & ~(FFESYMBOL_attrsARRAY
15810                        | FFESYMBOL_attrsADJUSTABLE
15811                        | FFESYMBOL_attrsTYPE)));
15812
15813       if (sa & FFESYMBOL_attrsADJUSTABLE)
15814         error = TRUE;
15815       where = FFEINFO_whereLOCAL;
15816     }
15817   else if (sa & FFESYMBOL_attrsSFARG)
15818     {
15819       assert (!(sa & ~(FFESYMBOL_attrsSFARG
15820                        | FFESYMBOL_attrsTYPE)));
15821
15822       where = FFEINFO_whereLOCAL;
15823     }
15824   else if (sa & FFESYMBOL_attrsTYPE)
15825     {
15826       assert (!(sa & (FFESYMBOL_attrsARRAY
15827                       | FFESYMBOL_attrsDUMMY
15828                       | FFESYMBOL_attrsEXTERNAL
15829                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
15830       assert (!(sa & ~(FFESYMBOL_attrsTYPE
15831                        | FFESYMBOL_attrsADJUSTABLE
15832                        | FFESYMBOL_attrsANYLEN
15833                        | FFESYMBOL_attrsARRAY
15834                        | FFESYMBOL_attrsDUMMY
15835                        | FFESYMBOL_attrsEXTERNAL
15836                        | FFESYMBOL_attrsSFARG)));
15837
15838       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15839         error = TRUE;
15840       else
15841         {
15842           kind = FFEINFO_kindENTITY;
15843           where = FFEINFO_whereLOCAL;
15844         }
15845     }
15846   else if (sa == FFESYMBOL_attrsetNONE)
15847     {
15848       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15849       kind = FFEINFO_kindENTITY;
15850       where = FFEINFO_whereLOCAL;
15851     }
15852   else
15853     error = TRUE;
15854
15855   /* Now see what we've got for a new object: NONE means a new error cropped
15856      up; ANY means an old error to be ignored; otherwise, everything's ok,
15857      update the object (symbol) and continue on. */
15858
15859   if (error)
15860     ffesymbol_error (s, t);
15861   else if (!(na & FFESYMBOL_attrsANY))
15862     {
15863       ffesymbol_signal_change (s);      /* May need to back up to previous
15864                                            version. */
15865       if (!ffeimplic_establish_symbol (s))
15866         {
15867           ffesymbol_error (s, t);
15868           return s;
15869         }
15870       ffesymbol_set_info (s,
15871                           ffeinfo_new (ffesymbol_basictype (s),
15872                                        ffesymbol_kindtype (s),
15873                                        ffesymbol_rank (s),
15874                                        kind,    /* ENTITY. */
15875                                        where,   /* LOCAL. */
15876                                        ffesymbol_size (s)));
15877       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15878       ffesymbol_resolve_intrin (s);
15879       s = ffecom_sym_learned (s);
15880       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
15881     }
15882
15883   return s;
15884 }
15885
15886 /* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
15887    EQUIVALENCE (...,BAR(FOO),...).  */
15888
15889 static ffesymbol
15890 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15891 {
15892   ffesymbolAttrs sa;
15893   ffesymbolAttrs na;
15894   ffeinfoKind kind;
15895   ffeinfoWhere where;
15896
15897   na = sa = ffesymbol_attrs (s);
15898   kind = FFEINFO_kindENTITY;
15899   where = ffesymbol_where (s);
15900
15901   /* Figure out what kind of object we've got based on previous declarations
15902      of or references to the object. */
15903
15904   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15905                | FFESYMBOL_attrsARRAY
15906                | FFESYMBOL_attrsCOMMON
15907                | FFESYMBOL_attrsEQUIV
15908                | FFESYMBOL_attrsINIT
15909                | FFESYMBOL_attrsNAMELIST
15910                | FFESYMBOL_attrsSAVE
15911                | FFESYMBOL_attrsSFARG
15912                | FFESYMBOL_attrsTYPE)))
15913     na = sa | FFESYMBOL_attrsEQUIV;
15914   else
15915     na = FFESYMBOL_attrsetNONE;
15916
15917   /* Don't know why we're bothering to set kind and where in this code, but
15918      added the following to make it complete, in case it's really important.
15919      Generally this is left up to symbol exec transition.  */
15920
15921   if (where == FFEINFO_whereNONE)
15922     {
15923       if (na & (FFESYMBOL_attrsADJUSTS
15924                 | FFESYMBOL_attrsCOMMON))
15925         where = FFEINFO_whereCOMMON;
15926       else if (na & FFESYMBOL_attrsSAVE)
15927         where = FFEINFO_whereLOCAL;
15928     }
15929
15930   /* Now see what we've got for a new object: NONE means a new error cropped
15931      up; ANY means an old error to be ignored; otherwise, everything's ok,
15932      update the object (symbol) and continue on. */
15933
15934   if (na == FFESYMBOL_attrsetNONE)
15935     ffesymbol_error (s, t);
15936   else if (!(na & FFESYMBOL_attrsANY))
15937     {
15938       ffesymbol_signal_change (s);      /* May need to back up to previous
15939                                            version. */
15940       ffesymbol_set_info (s,
15941                           ffeinfo_new (ffesymbol_basictype (s),
15942                                        ffesymbol_kindtype (s),
15943                                        ffesymbol_rank (s),
15944                                        kind,    /* Always ENTITY. */
15945                                        where,   /* NONE, COMMON, or LOCAL. */
15946                                        ffesymbol_size (s)));
15947       ffesymbol_set_attrs (s, na);
15948       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15949       ffesymbol_resolve_intrin (s);
15950       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
15951     }
15952
15953   return s;
15954 }
15955
15956 /* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
15957
15958    Note that I think this should be considered semantically similar to
15959    doing CALL XYZ(FOO), in that it should be considered like an
15960    ACTUALARG context.  In particular, without EXTERNAL being specified,
15961    it should not be allowed.  */
15962
15963 static ffesymbol
15964 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
15965 {
15966   ffesymbolAttrs sa;
15967   ffesymbolAttrs na;
15968   ffeinfoKind kind;
15969   ffeinfoWhere where;
15970   bool needs_type = FALSE;
15971   bool error = FALSE;
15972
15973   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15974           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15975
15976   na = sa = ffesymbol_attrs (s);
15977
15978   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15979                    | FFESYMBOL_attrsADJUSTABLE
15980                    | FFESYMBOL_attrsANYLEN
15981                    | FFESYMBOL_attrsARRAY
15982                    | FFESYMBOL_attrsDUMMY
15983                    | FFESYMBOL_attrsEXTERNAL
15984                    | FFESYMBOL_attrsSFARG
15985                    | FFESYMBOL_attrsTYPE)));
15986
15987   kind = ffesymbol_kind (s);
15988   where = ffesymbol_where (s);
15989
15990   /* Figure out what kind of object we've got based on previous declarations
15991      of or references to the object. */
15992
15993   if (sa & FFESYMBOL_attrsEXTERNAL)
15994     {
15995       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15996                        | FFESYMBOL_attrsDUMMY
15997                        | FFESYMBOL_attrsEXTERNAL
15998                        | FFESYMBOL_attrsTYPE)));
15999
16000       if (sa & FFESYMBOL_attrsTYPE)
16001         where = FFEINFO_whereGLOBAL;
16002       else
16003         /* Not TYPE. */
16004         {
16005           kind = FFEINFO_kindFUNCTION;
16006           needs_type = TRUE;
16007
16008           if (sa & FFESYMBOL_attrsDUMMY)
16009             ;                   /* Not TYPE. */
16010           else if (sa & FFESYMBOL_attrsACTUALARG)
16011             ;                   /* Not DUMMY or TYPE. */
16012           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
16013             where = FFEINFO_whereGLOBAL;
16014         }
16015     }
16016   else if (sa & FFESYMBOL_attrsDUMMY)
16017     {
16018       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16019       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16020                        | FFESYMBOL_attrsEXTERNAL
16021                        | FFESYMBOL_attrsTYPE)));
16022
16023       kind = FFEINFO_kindFUNCTION;
16024       if (!(sa & FFESYMBOL_attrsTYPE))
16025         needs_type = TRUE;
16026     }
16027   else if (sa & FFESYMBOL_attrsARRAY)
16028     {
16029       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16030                        | FFESYMBOL_attrsADJUSTABLE
16031                        | FFESYMBOL_attrsTYPE)));
16032
16033       error = TRUE;
16034     }
16035   else if (sa & FFESYMBOL_attrsSFARG)
16036     {
16037       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16038                        | FFESYMBOL_attrsTYPE)));
16039
16040       error = TRUE;
16041     }
16042   else if (sa & FFESYMBOL_attrsTYPE)
16043     {
16044       assert (!(sa & (FFESYMBOL_attrsARRAY
16045                       | FFESYMBOL_attrsDUMMY
16046                       | FFESYMBOL_attrsEXTERNAL
16047                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16048       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16049                        | FFESYMBOL_attrsADJUSTABLE
16050                        | FFESYMBOL_attrsANYLEN
16051                        | FFESYMBOL_attrsARRAY
16052                        | FFESYMBOL_attrsDUMMY
16053                        | FFESYMBOL_attrsEXTERNAL
16054                        | FFESYMBOL_attrsSFARG)));
16055
16056       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16057         error = TRUE;
16058       else
16059         {
16060           kind = FFEINFO_kindFUNCTION;
16061           where = FFEINFO_whereGLOBAL;
16062         }
16063     }
16064   else if (sa == FFESYMBOL_attrsetNONE)
16065     {
16066       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16067       kind = FFEINFO_kindFUNCTION;
16068       where = FFEINFO_whereGLOBAL;
16069       needs_type = TRUE;
16070     }
16071   else
16072     error = TRUE;
16073
16074   /* Now see what we've got for a new object: NONE means a new error cropped
16075      up; ANY means an old error to be ignored; otherwise, everything's ok,
16076      update the object (symbol) and continue on. */
16077
16078   if (error)
16079     ffesymbol_error (s, t);
16080   else if (!(na & FFESYMBOL_attrsANY))
16081     {
16082       ffesymbol_signal_change (s);      /* May need to back up to previous
16083                                            version. */
16084       if (needs_type && !ffeimplic_establish_symbol (s))
16085         {
16086           ffesymbol_error (s, t);
16087           return s;
16088         }
16089       if (!ffesymbol_explicitwhere (s))
16090         {
16091           ffebad_start (FFEBAD_NEED_EXTERNAL);
16092           ffebad_here (0, ffelex_token_where_line (t),
16093                        ffelex_token_where_column (t));
16094           ffebad_string (ffesymbol_text (s));
16095           ffebad_finish ();
16096           ffesymbol_set_explicitwhere (s, TRUE);
16097         }
16098       ffesymbol_set_info (s,
16099                           ffeinfo_new (ffesymbol_basictype (s),
16100                                        ffesymbol_kindtype (s),
16101                                        ffesymbol_rank (s),
16102                                        kind,    /* FUNCTION. */
16103                                        where,   /* GLOBAL or DUMMY. */
16104                                        ffesymbol_size (s)));
16105       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16106       ffesymbol_resolve_intrin (s);
16107       ffesymbol_reference (s, t, FALSE);
16108       s = ffecom_sym_learned (s);
16109       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16110     }
16111
16112   return s;
16113 }
16114
16115 /* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
16116
16117 static ffesymbol
16118 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16119 {
16120   ffesymbolState ss;
16121
16122   /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16123      reference to it already within the imp-DO construct at this level, so as
16124      to get a symbol that is in the sfunc name space. But this is an
16125      erroneous construct, and should be caught elsewhere.  */
16126
16127   if (ffesymbol_sfdummyparent (s) == NULL)
16128     {
16129       s = ffeexpr_sym_impdoitem_ (s, t);
16130       if (ffesymbol_sfdummyparent (s) == NULL)
16131         {                       /* PARAMETER FOO...DATA (A(I),FOO=...). */
16132           ffesymbol_error (s, t);
16133           return s;
16134         }
16135     }
16136
16137   ss = ffesymbol_state (s);
16138
16139   switch (ss)
16140     {
16141     case FFESYMBOL_stateNONE:   /* Used as iterator already. */
16142       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16143         ffesymbol_error (s, t); /* Can't reuse dead iterator.  F90 disallows
16144                                    this; F77 allows it but it is a stupid
16145                                    feature. */
16146       else
16147         {                       /* Can use dead iterator because we're at at
16148                                    least a innermore (higher-numbered) level
16149                                    than the iterator's outermost
16150                                    (lowest-numbered) level.  This should be
16151                                    diagnosed later, because it means an item
16152                                    in this list didn't reference this
16153                                    iterator. */
16154 #if 1
16155           ffesymbol_error (s, t);       /* For now, complain. */
16156 #else /* Someday will detect all cases where initializer doesn't reference
16157          all applicable iterators, in which case reenable this code. */
16158           ffesymbol_signal_change (s);
16159           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16160           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16161           ffesymbol_signal_unreported (s);
16162 #endif
16163         }
16164       break;
16165
16166     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
16167                                    If seen in outermore level, can't be an
16168                                    iterator here, so complain.  If not seen
16169                                    at current level, complain for now,
16170                                    because that indicates something F90
16171                                    rejects (though we currently don't detect
16172                                    all such cases for now). */
16173       if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16174         {
16175           ffesymbol_signal_change (s);
16176           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16177           ffesymbol_signal_unreported (s);
16178         }
16179       else
16180         ffesymbol_error (s, t);
16181       break;
16182
16183     case FFESYMBOL_stateUNCERTAIN:      /* Already iterator! */
16184       assert ("DATA implied-DO control var seen twice!!" == NULL);
16185       ffesymbol_error (s, t);
16186       break;
16187
16188     case FFESYMBOL_stateUNDERSTOOD:
16189       break;                    /* ANY. */
16190
16191     default:
16192       assert ("Foo Bletch!!" == NULL);
16193       break;
16194     }
16195
16196   return s;
16197 }
16198
16199 /* Have FOO in PARAMETER (FOO=...).  */
16200
16201 static ffesymbol
16202 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16203 {
16204   ffesymbolAttrs sa;
16205
16206   sa = ffesymbol_attrs (s);
16207
16208   /* Figure out what kind of object we've got based on previous declarations
16209      of or references to the object. */
16210
16211   if (sa & ~(FFESYMBOL_attrsANYLEN
16212              | FFESYMBOL_attrsTYPE))
16213     {
16214       if (!(sa & FFESYMBOL_attrsANY))
16215         ffesymbol_error (s, t);
16216     }
16217   else
16218     {
16219       ffesymbol_signal_change (s);      /* May need to back up to previous
16220                                            version. */
16221       if (!ffeimplic_establish_symbol (s))
16222         {
16223           ffesymbol_error (s, t);
16224           return s;
16225         }
16226       ffesymbol_set_info (s,
16227                           ffeinfo_new (ffesymbol_basictype (s),
16228                                        ffesymbol_kindtype (s),
16229                                        ffesymbol_rank (s),
16230                                        FFEINFO_kindENTITY,
16231                                        FFEINFO_whereCONSTANT,
16232                                        ffesymbol_size (s)));
16233       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16234       ffesymbol_resolve_intrin (s);
16235       s = ffecom_sym_learned (s);
16236       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16237     }
16238
16239   return s;
16240 }
16241
16242 /* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
16243    embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
16244
16245 static ffesymbol
16246 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16247 {
16248   ffesymbolAttrs sa;
16249   ffesymbolAttrs na;
16250   ffeinfoKind kind;
16251   ffeinfoWhere where;
16252   ffesymbolState ns;
16253   bool needs_type = FALSE;
16254
16255   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16256           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16257
16258   na = sa = ffesymbol_attrs (s);
16259
16260   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16261                    | FFESYMBOL_attrsADJUSTABLE
16262                    | FFESYMBOL_attrsANYLEN
16263                    | FFESYMBOL_attrsARRAY
16264                    | FFESYMBOL_attrsDUMMY
16265                    | FFESYMBOL_attrsEXTERNAL
16266                    | FFESYMBOL_attrsSFARG
16267                    | FFESYMBOL_attrsTYPE)));
16268
16269   kind = ffesymbol_kind (s);
16270   where = ffesymbol_where (s);
16271
16272   /* Figure out what kind of object we've got based on previous declarations
16273      of or references to the object. */
16274
16275   ns = FFESYMBOL_stateUNDERSTOOD;
16276
16277   if (sa & FFESYMBOL_attrsEXTERNAL)
16278     {
16279       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16280                        | FFESYMBOL_attrsDUMMY
16281                        | FFESYMBOL_attrsEXTERNAL
16282                        | FFESYMBOL_attrsTYPE)));
16283
16284       if (sa & FFESYMBOL_attrsTYPE)
16285         where = FFEINFO_whereGLOBAL;
16286       else
16287         /* Not TYPE. */
16288         {
16289           ns = FFESYMBOL_stateUNCERTAIN;
16290
16291           if (sa & FFESYMBOL_attrsDUMMY)
16292             assert (kind == FFEINFO_kindNONE);  /* FUNCTION, SUBROUTINE. */
16293           else if (sa & FFESYMBOL_attrsACTUALARG)
16294             ;                   /* Not DUMMY or TYPE. */
16295           else
16296             /* Not ACTUALARG, DUMMY, or TYPE. */
16297             {
16298               assert (kind == FFEINFO_kindNONE);        /* FUNCTION, SUBROUTINE. */
16299               na |= FFESYMBOL_attrsACTUALARG;
16300               where = FFEINFO_whereGLOBAL;
16301             }
16302         }
16303     }
16304   else if (sa & FFESYMBOL_attrsDUMMY)
16305     {
16306       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16307       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16308                        | FFESYMBOL_attrsEXTERNAL
16309                        | FFESYMBOL_attrsTYPE)));
16310
16311       kind = FFEINFO_kindENTITY;
16312       if (!(sa & FFESYMBOL_attrsTYPE))
16313         needs_type = TRUE;
16314     }
16315   else if (sa & FFESYMBOL_attrsARRAY)
16316     {
16317       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16318                        | FFESYMBOL_attrsADJUSTABLE
16319                        | FFESYMBOL_attrsTYPE)));
16320
16321       where = FFEINFO_whereLOCAL;
16322     }
16323   else if (sa & FFESYMBOL_attrsSFARG)
16324     {
16325       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16326                        | FFESYMBOL_attrsTYPE)));
16327
16328       where = FFEINFO_whereLOCAL;
16329     }
16330   else if (sa & FFESYMBOL_attrsTYPE)
16331     {
16332       assert (!(sa & (FFESYMBOL_attrsARRAY
16333                       | FFESYMBOL_attrsDUMMY
16334                       | FFESYMBOL_attrsEXTERNAL
16335                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16336       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16337                        | FFESYMBOL_attrsADJUSTABLE
16338                        | FFESYMBOL_attrsANYLEN
16339                        | FFESYMBOL_attrsARRAY
16340                        | FFESYMBOL_attrsDUMMY
16341                        | FFESYMBOL_attrsEXTERNAL
16342                        | FFESYMBOL_attrsSFARG)));
16343
16344       if (sa & FFESYMBOL_attrsANYLEN)
16345         ns = FFESYMBOL_stateNONE;
16346       else
16347         {
16348           kind = FFEINFO_kindENTITY;
16349           where = FFEINFO_whereLOCAL;
16350         }
16351     }
16352   else if (sa == FFESYMBOL_attrsetNONE)
16353     {
16354       /* New state is left empty because there isn't any state flag to
16355          set for this case, and it's UNDERSTOOD after all.  */
16356       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16357       kind = FFEINFO_kindENTITY;
16358       where = FFEINFO_whereLOCAL;
16359       needs_type = TRUE;
16360     }
16361   else
16362     ns = FFESYMBOL_stateNONE;   /* Error. */
16363
16364   /* Now see what we've got for a new object: NONE means a new error cropped
16365      up; ANY means an old error to be ignored; otherwise, everything's ok,
16366      update the object (symbol) and continue on. */
16367
16368   if (ns == FFESYMBOL_stateNONE)
16369     ffesymbol_error (s, t);
16370   else if (!(na & FFESYMBOL_attrsANY))
16371     {
16372       ffesymbol_signal_change (s);      /* May need to back up to previous
16373                                            version. */
16374       if (needs_type && !ffeimplic_establish_symbol (s))
16375         {
16376           ffesymbol_error (s, t);
16377           return s;
16378         }
16379       ffesymbol_set_info (s,
16380                           ffeinfo_new (ffesymbol_basictype (s),
16381                                        ffesymbol_kindtype (s),
16382                                        ffesymbol_rank (s),
16383                                        kind,
16384                                        where,
16385                                        ffesymbol_size (s)));
16386       ffesymbol_set_attrs (s, na);
16387       ffesymbol_set_state (s, ns);
16388       s = ffecom_sym_learned (s);
16389       ffesymbol_reference (s, t, FALSE);
16390       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16391     }
16392
16393   return s;
16394 }
16395
16396 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16397    a reference to FOO.  */
16398
16399 static ffesymbol
16400 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16401 {
16402   ffesymbolAttrs sa;
16403   ffesymbolAttrs na;
16404   ffeinfoKind kind;
16405   ffeinfoWhere where;
16406
16407   na = sa = ffesymbol_attrs (s);
16408   kind = FFEINFO_kindENTITY;
16409   where = ffesymbol_where (s);
16410
16411   /* Figure out what kind of object we've got based on previous declarations
16412      of or references to the object. */
16413
16414   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16415                | FFESYMBOL_attrsCOMMON
16416                | FFESYMBOL_attrsDUMMY
16417                | FFESYMBOL_attrsEQUIV
16418                | FFESYMBOL_attrsINIT
16419                | FFESYMBOL_attrsNAMELIST
16420                | FFESYMBOL_attrsSFARG
16421                | FFESYMBOL_attrsARRAY
16422                | FFESYMBOL_attrsTYPE)))
16423     na = sa | FFESYMBOL_attrsADJUSTS;
16424   else
16425     na = FFESYMBOL_attrsetNONE;
16426
16427   /* Since this symbol definitely is going into an expression (the
16428      dimension-list for some dummy array, presumably), figure out WHERE if
16429      possible.  */
16430
16431   if (where == FFEINFO_whereNONE)
16432     {
16433       if (na & (FFESYMBOL_attrsCOMMON
16434                 | FFESYMBOL_attrsEQUIV
16435                 | FFESYMBOL_attrsINIT
16436                 | FFESYMBOL_attrsNAMELIST))
16437         where = FFEINFO_whereCOMMON;
16438       else if (na & FFESYMBOL_attrsDUMMY)
16439         where = FFEINFO_whereDUMMY;
16440     }
16441
16442   /* Now see what we've got for a new object: NONE means a new error cropped
16443      up; ANY means an old error to be ignored; otherwise, everything's ok,
16444      update the object (symbol) and continue on. */
16445
16446   if (na == FFESYMBOL_attrsetNONE)
16447     ffesymbol_error (s, t);
16448   else if (!(na & FFESYMBOL_attrsANY))
16449     {
16450       ffesymbol_signal_change (s);      /* May need to back up to previous
16451                                            version. */
16452       if (!ffeimplic_establish_symbol (s))
16453         {
16454           ffesymbol_error (s, t);
16455           return s;
16456         }
16457       ffesymbol_set_info (s,
16458                           ffeinfo_new (ffesymbol_basictype (s),
16459                                        ffesymbol_kindtype (s),
16460                                        ffesymbol_rank (s),
16461                                        kind,    /* Always ENTITY. */
16462                                        where,   /* NONE, COMMON, or DUMMY. */
16463                                        ffesymbol_size (s)));
16464       ffesymbol_set_attrs (s, na);
16465       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16466       ffesymbol_resolve_intrin (s);
16467       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16468     }
16469
16470   return s;
16471 }
16472
16473 /* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
16474    XYZ = BAR(FOO), as such cases are handled elsewhere.  */
16475
16476 static ffesymbol
16477 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16478 {
16479   ffesymbolAttrs sa;
16480   ffesymbolAttrs na;
16481   ffeinfoKind kind;
16482   ffeinfoWhere where;
16483   bool error = FALSE;
16484
16485   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16486           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16487
16488   na = sa = ffesymbol_attrs (s);
16489
16490   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16491                    | FFESYMBOL_attrsADJUSTABLE
16492                    | FFESYMBOL_attrsANYLEN
16493                    | FFESYMBOL_attrsARRAY
16494                    | FFESYMBOL_attrsDUMMY
16495                    | FFESYMBOL_attrsEXTERNAL
16496                    | FFESYMBOL_attrsSFARG
16497                    | FFESYMBOL_attrsTYPE)));
16498
16499   kind = ffesymbol_kind (s);
16500   where = ffesymbol_where (s);
16501
16502   /* Figure out what kind of object we've got based on previous declarations
16503      of or references to the object. */
16504
16505   if (sa & FFESYMBOL_attrsEXTERNAL)
16506     {
16507       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16508                        | FFESYMBOL_attrsDUMMY
16509                        | FFESYMBOL_attrsEXTERNAL
16510                        | FFESYMBOL_attrsTYPE)));
16511
16512       error = TRUE;
16513     }
16514   else if (sa & FFESYMBOL_attrsDUMMY)
16515     {
16516       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16517       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16518                        | FFESYMBOL_attrsEXTERNAL
16519                        | FFESYMBOL_attrsTYPE)));
16520
16521       kind = FFEINFO_kindENTITY;
16522     }
16523   else if (sa & FFESYMBOL_attrsARRAY)
16524     {
16525       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16526                        | FFESYMBOL_attrsADJUSTABLE
16527                        | FFESYMBOL_attrsTYPE)));
16528
16529       where = FFEINFO_whereLOCAL;
16530     }
16531   else if (sa & FFESYMBOL_attrsSFARG)
16532     {
16533       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16534                        | FFESYMBOL_attrsTYPE)));
16535
16536       where = FFEINFO_whereLOCAL;
16537     }
16538   else if (sa & FFESYMBOL_attrsTYPE)
16539     {
16540       assert (!(sa & (FFESYMBOL_attrsARRAY
16541                       | FFESYMBOL_attrsDUMMY
16542                       | FFESYMBOL_attrsEXTERNAL
16543                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16544       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16545                        | FFESYMBOL_attrsADJUSTABLE
16546                        | FFESYMBOL_attrsANYLEN
16547                        | FFESYMBOL_attrsARRAY
16548                        | FFESYMBOL_attrsDUMMY
16549                        | FFESYMBOL_attrsEXTERNAL
16550                        | FFESYMBOL_attrsSFARG)));
16551
16552       if (sa & FFESYMBOL_attrsANYLEN)
16553         error = TRUE;
16554       else
16555         {
16556           kind = FFEINFO_kindENTITY;
16557           where = FFEINFO_whereLOCAL;
16558         }
16559     }
16560   else if (sa == FFESYMBOL_attrsetNONE)
16561     {
16562       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16563       kind = FFEINFO_kindENTITY;
16564       where = FFEINFO_whereLOCAL;
16565     }
16566   else
16567     error = TRUE;
16568
16569   /* Now see what we've got for a new object: NONE means a new error cropped
16570      up; ANY means an old error to be ignored; otherwise, everything's ok,
16571      update the object (symbol) and continue on. */
16572
16573   if (error)
16574     ffesymbol_error (s, t);
16575   else if (!(na & FFESYMBOL_attrsANY))
16576     {
16577       ffesymbol_signal_change (s);      /* May need to back up to previous
16578                                            version. */
16579       if (!ffeimplic_establish_symbol (s))
16580         {
16581           ffesymbol_error (s, t);
16582           return s;
16583         }
16584       ffesymbol_set_info (s,
16585                           ffeinfo_new (ffesymbol_basictype (s),
16586                                        ffesymbol_kindtype (s),
16587                                        ffesymbol_rank (s),
16588                                        kind,    /* ENTITY. */
16589                                        where,   /* LOCAL. */
16590                                        ffesymbol_size (s)));
16591       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16592       ffesymbol_resolve_intrin (s);
16593       s = ffecom_sym_learned (s);
16594       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16595     }
16596
16597   return s;
16598 }
16599
16600 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16601
16602    ffelexToken t;
16603    bool maybe_intrin;
16604    ffeexprParenType_ paren_type;
16605    ffesymbol s;
16606    s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16607
16608    Just like ffesymbol_declare_local, except performs any implicit info
16609    assignment necessary, and it returns the type of the parenthesized list
16610    (list of function args, list of array args, or substring spec).  */
16611
16612 static ffesymbol
16613 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16614                                 ffeexprParenType_ *paren_type)
16615 {
16616   ffesymbol s;
16617   ffesymbolState st;            /* Effective state. */
16618   ffeinfoKind k;
16619   bool bad;
16620
16621   if (maybe_intrin && ffesrc_check_symbol ())
16622     {                           /* Knock off some easy cases. */
16623       switch (ffeexpr_stack_->context)
16624         {
16625         case FFEEXPR_contextSUBROUTINEREF:
16626         case FFEEXPR_contextDATA:
16627         case FFEEXPR_contextDATAIMPDOINDEX_:
16628         case FFEEXPR_contextSFUNCDEF:
16629         case FFEEXPR_contextSFUNCDEFINDEX_:
16630         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16631         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16632         case FFEEXPR_contextLET:
16633         case FFEEXPR_contextPAREN_:
16634         case FFEEXPR_contextACTUALARGEXPR_:
16635         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16636         case FFEEXPR_contextIOLIST:
16637         case FFEEXPR_contextIOLISTDF:
16638         case FFEEXPR_contextDO:
16639         case FFEEXPR_contextDOWHILE:
16640         case FFEEXPR_contextACTUALARG_:
16641         case FFEEXPR_contextCGOTO:
16642         case FFEEXPR_contextIF:
16643         case FFEEXPR_contextARITHIF:
16644         case FFEEXPR_contextFORMAT:
16645         case FFEEXPR_contextSTOP:
16646         case FFEEXPR_contextRETURN:
16647         case FFEEXPR_contextSELECTCASE:
16648         case FFEEXPR_contextCASE:
16649         case FFEEXPR_contextFILEASSOC:
16650         case FFEEXPR_contextFILEINT:
16651         case FFEEXPR_contextFILEDFINT:
16652         case FFEEXPR_contextFILELOG:
16653         case FFEEXPR_contextFILENUM:
16654         case FFEEXPR_contextFILENUMAMBIG:
16655         case FFEEXPR_contextFILECHAR:
16656         case FFEEXPR_contextFILENUMCHAR:
16657         case FFEEXPR_contextFILEDFCHAR:
16658         case FFEEXPR_contextFILEKEY:
16659         case FFEEXPR_contextFILEUNIT:
16660         case FFEEXPR_contextFILEUNIT_DF:
16661         case FFEEXPR_contextFILEUNITAMBIG:
16662         case FFEEXPR_contextFILEFORMAT:
16663         case FFEEXPR_contextFILENAMELIST:
16664         case FFEEXPR_contextFILEVXTCODE:
16665         case FFEEXPR_contextINDEX_:
16666         case FFEEXPR_contextIMPDOITEM_:
16667         case FFEEXPR_contextIMPDOITEMDF_:
16668         case FFEEXPR_contextIMPDOCTRL_:
16669         case FFEEXPR_contextDATAIMPDOCTRL_:
16670         case FFEEXPR_contextCHARACTERSIZE:
16671         case FFEEXPR_contextPARAMETER:
16672         case FFEEXPR_contextDIMLIST:
16673         case FFEEXPR_contextDIMLISTCOMMON:
16674         case FFEEXPR_contextKINDTYPE:
16675         case FFEEXPR_contextINITVAL:
16676         case FFEEXPR_contextEQVINDEX_:
16677           break;                /* These could be intrinsic invocations. */
16678
16679         case FFEEXPR_contextAGOTO:
16680         case FFEEXPR_contextFILEFORMATNML:
16681         case FFEEXPR_contextALLOCATE:
16682         case FFEEXPR_contextDEALLOCATE:
16683         case FFEEXPR_contextHEAPSTAT:
16684         case FFEEXPR_contextNULLIFY:
16685         case FFEEXPR_contextINCLUDE:
16686         case FFEEXPR_contextDATAIMPDOITEM_:
16687         case FFEEXPR_contextLOC_:
16688         case FFEEXPR_contextINDEXORACTUALARG_:
16689         case FFEEXPR_contextSFUNCDEFACTUALARG_:
16690         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16691         case FFEEXPR_contextPARENFILENUM_:
16692         case FFEEXPR_contextPARENFILEUNIT_:
16693           maybe_intrin = FALSE;
16694           break;                /* Can't be intrinsic invocation. */
16695
16696         default:
16697           assert ("blah! blah! waaauuggh!" == NULL);
16698           break;
16699         }
16700     }
16701
16702   s = ffesymbol_declare_local (t, maybe_intrin);
16703
16704   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16705     /* Special-case these since they can involve a different concept
16706        of "state" (in the stmtfunc name space).  */
16707     {
16708     case FFEEXPR_contextDATAIMPDOINDEX_:
16709     case FFEEXPR_contextDATAIMPDOCTRL_:
16710       if (ffeexpr_context_outer_ (ffeexpr_stack_)
16711           == FFEEXPR_contextDATAIMPDOINDEX_)
16712         s = ffeexpr_sym_impdoitem_ (s, t);
16713       else
16714         if (ffeexpr_stack_->is_rhs)
16715           s = ffeexpr_sym_impdoitem_ (s, t);
16716         else
16717           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16718       if (ffesymbol_kind (s) != FFEINFO_kindANY)
16719         ffesymbol_error (s, t);
16720       return s;
16721
16722     default:
16723       break;
16724     }
16725
16726   switch ((ffesymbol_sfdummyparent (s) == NULL)
16727           ? ffesymbol_state (s)
16728           : FFESYMBOL_stateUNDERSTOOD)
16729     {
16730     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
16731                                    context. */
16732       if (!ffest_seen_first_exec ())
16733         goto seen;              /* :::::::::::::::::::: */
16734       /* Fall through. */
16735     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
16736       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16737         {
16738         case FFEEXPR_contextSUBROUTINEREF:
16739           s = ffeexpr_sym_lhs_call_ (s, t);     /* "CALL FOO"=="CALL
16740                                                    FOO(...)". */
16741           break;
16742
16743         case FFEEXPR_contextDATA:
16744           if (ffeexpr_stack_->is_rhs)
16745             s = ffeexpr_sym_rhs_let_ (s, t);
16746           else
16747             s = ffeexpr_sym_lhs_data_ (s, t);
16748           break;
16749
16750         case FFEEXPR_contextDATAIMPDOITEM_:
16751           s = ffeexpr_sym_lhs_data_ (s, t);
16752           break;
16753
16754         case FFEEXPR_contextSFUNCDEF:
16755         case FFEEXPR_contextSFUNCDEFINDEX_:
16756         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16757         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16758           s = ffecom_sym_exec_transition (s);
16759           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16760             goto understood;    /* :::::::::::::::::::: */
16761           /* Fall through. */
16762         case FFEEXPR_contextLET:
16763         case FFEEXPR_contextPAREN_:
16764         case FFEEXPR_contextACTUALARGEXPR_:
16765         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16766         case FFEEXPR_contextIOLIST:
16767         case FFEEXPR_contextIOLISTDF:
16768         case FFEEXPR_contextDO:
16769         case FFEEXPR_contextDOWHILE:
16770         case FFEEXPR_contextACTUALARG_:
16771         case FFEEXPR_contextCGOTO:
16772         case FFEEXPR_contextIF:
16773         case FFEEXPR_contextARITHIF:
16774         case FFEEXPR_contextFORMAT:
16775         case FFEEXPR_contextSTOP:
16776         case FFEEXPR_contextRETURN:
16777         case FFEEXPR_contextSELECTCASE:
16778         case FFEEXPR_contextCASE:
16779         case FFEEXPR_contextFILEASSOC:
16780         case FFEEXPR_contextFILEINT:
16781         case FFEEXPR_contextFILEDFINT:
16782         case FFEEXPR_contextFILELOG:
16783         case FFEEXPR_contextFILENUM:
16784         case FFEEXPR_contextFILENUMAMBIG:
16785         case FFEEXPR_contextFILECHAR:
16786         case FFEEXPR_contextFILENUMCHAR:
16787         case FFEEXPR_contextFILEDFCHAR:
16788         case FFEEXPR_contextFILEKEY:
16789         case FFEEXPR_contextFILEUNIT:
16790         case FFEEXPR_contextFILEUNIT_DF:
16791         case FFEEXPR_contextFILEUNITAMBIG:
16792         case FFEEXPR_contextFILEFORMAT:
16793         case FFEEXPR_contextFILENAMELIST:
16794         case FFEEXPR_contextFILEVXTCODE:
16795         case FFEEXPR_contextINDEX_:
16796         case FFEEXPR_contextIMPDOITEM_:
16797         case FFEEXPR_contextIMPDOITEMDF_:
16798         case FFEEXPR_contextIMPDOCTRL_:
16799         case FFEEXPR_contextLOC_:
16800           if (ffeexpr_stack_->is_rhs)
16801             s = ffeexpr_paren_rhs_let_ (s, t);
16802           else
16803             s = ffeexpr_paren_lhs_let_ (s, t);
16804           break;
16805
16806         case FFEEXPR_contextASSIGN:
16807         case FFEEXPR_contextAGOTO:
16808         case FFEEXPR_contextCHARACTERSIZE:
16809         case FFEEXPR_contextEQUIVALENCE:
16810         case FFEEXPR_contextINCLUDE:
16811         case FFEEXPR_contextPARAMETER:
16812         case FFEEXPR_contextDIMLIST:
16813         case FFEEXPR_contextDIMLISTCOMMON:
16814         case FFEEXPR_contextKINDTYPE:
16815         case FFEEXPR_contextINITVAL:
16816         case FFEEXPR_contextEQVINDEX_:
16817           break;                /* Will turn into errors below. */
16818
16819         default:
16820           ffesymbol_error (s, t);
16821           break;
16822         }
16823       /* Fall through. */
16824     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
16825     understood:         /* :::::::::::::::::::: */
16826
16827       /* State might have changed, update it.  */
16828       st = ((ffesymbol_sfdummyparent (s) == NULL)
16829             ? ffesymbol_state (s)
16830             : FFESYMBOL_stateUNDERSTOOD);
16831
16832       k = ffesymbol_kind (s);
16833       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16834         {
16835         case FFEEXPR_contextSUBROUTINEREF:
16836           bad = ((k != FFEINFO_kindSUBROUTINE)
16837                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16838                      || (k != FFEINFO_kindNONE)));
16839           break;
16840
16841         case FFEEXPR_contextDATA:
16842           if (ffeexpr_stack_->is_rhs)
16843             bad = (k != FFEINFO_kindENTITY)
16844               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16845           else
16846             bad = (k != FFEINFO_kindENTITY)
16847               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16848                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16849                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16850           break;
16851
16852         case FFEEXPR_contextDATAIMPDOITEM_:
16853           bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16854             || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16855                 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16856                 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16857           break;
16858
16859         case FFEEXPR_contextSFUNCDEF:
16860         case FFEEXPR_contextSFUNCDEFINDEX_:
16861         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16862         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16863         case FFEEXPR_contextLET:
16864         case FFEEXPR_contextPAREN_:
16865         case FFEEXPR_contextACTUALARGEXPR_:
16866         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16867         case FFEEXPR_contextIOLIST:
16868         case FFEEXPR_contextIOLISTDF:
16869         case FFEEXPR_contextDO:
16870         case FFEEXPR_contextDOWHILE:
16871         case FFEEXPR_contextACTUALARG_:
16872         case FFEEXPR_contextCGOTO:
16873         case FFEEXPR_contextIF:
16874         case FFEEXPR_contextARITHIF:
16875         case FFEEXPR_contextFORMAT:
16876         case FFEEXPR_contextSTOP:
16877         case FFEEXPR_contextRETURN:
16878         case FFEEXPR_contextSELECTCASE:
16879         case FFEEXPR_contextCASE:
16880         case FFEEXPR_contextFILEASSOC:
16881         case FFEEXPR_contextFILEINT:
16882         case FFEEXPR_contextFILEDFINT:
16883         case FFEEXPR_contextFILELOG:
16884         case FFEEXPR_contextFILENUM:
16885         case FFEEXPR_contextFILENUMAMBIG:
16886         case FFEEXPR_contextFILECHAR:
16887         case FFEEXPR_contextFILENUMCHAR:
16888         case FFEEXPR_contextFILEDFCHAR:
16889         case FFEEXPR_contextFILEKEY:
16890         case FFEEXPR_contextFILEUNIT:
16891         case FFEEXPR_contextFILEUNIT_DF:
16892         case FFEEXPR_contextFILEUNITAMBIG:
16893         case FFEEXPR_contextFILEFORMAT:
16894         case FFEEXPR_contextFILENAMELIST:
16895         case FFEEXPR_contextFILEVXTCODE:
16896         case FFEEXPR_contextINDEX_:
16897         case FFEEXPR_contextIMPDOITEM_:
16898         case FFEEXPR_contextIMPDOITEMDF_:
16899         case FFEEXPR_contextIMPDOCTRL_:
16900         case FFEEXPR_contextLOC_:
16901           bad = FALSE;          /* Let paren-switch handle the cases. */
16902           break;
16903
16904         case FFEEXPR_contextASSIGN:
16905         case FFEEXPR_contextAGOTO:
16906         case FFEEXPR_contextCHARACTERSIZE:
16907         case FFEEXPR_contextEQUIVALENCE:
16908         case FFEEXPR_contextPARAMETER:
16909         case FFEEXPR_contextDIMLIST:
16910         case FFEEXPR_contextDIMLISTCOMMON:
16911         case FFEEXPR_contextKINDTYPE:
16912         case FFEEXPR_contextINITVAL:
16913         case FFEEXPR_contextEQVINDEX_:
16914           bad = (k != FFEINFO_kindENTITY)
16915             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16916           break;
16917
16918         case FFEEXPR_contextINCLUDE:
16919           bad = TRUE;
16920           break;
16921
16922         default:
16923           bad = TRUE;
16924           break;
16925         }
16926
16927       switch (bad ? FFEINFO_kindANY : k)
16928         {
16929         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
16930           if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16931             {
16932               if (ffeexpr_context_outer_ (ffeexpr_stack_)
16933                   == FFEEXPR_contextSUBROUTINEREF)
16934                 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16935               else
16936                 *paren_type = FFEEXPR_parentypeFUNCTION_;
16937               break;
16938             }
16939           if (st == FFESYMBOL_stateUNDERSTOOD)
16940             {
16941               bad = TRUE;
16942               *paren_type = FFEEXPR_parentypeANY_;
16943             }
16944           else
16945             *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16946           break;
16947
16948         case FFEINFO_kindFUNCTION:
16949           *paren_type = FFEEXPR_parentypeFUNCTION_;
16950           switch (ffesymbol_where (s))
16951             {
16952             case FFEINFO_whereLOCAL:
16953               bad = TRUE;       /* Attempt to recurse! */
16954               break;
16955
16956             case FFEINFO_whereCONSTANT:
16957               bad = ((ffesymbol_sfexpr (s) == NULL)
16958                      || (ffebld_op (ffesymbol_sfexpr (s))
16959                          == FFEBLD_opANY));     /* Attempt to recurse! */
16960               break;
16961
16962             default:
16963               break;
16964             }
16965           break;
16966
16967         case FFEINFO_kindSUBROUTINE:
16968           if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
16969               || (ffeexpr_stack_->previous != NULL))
16970             {
16971               bad = TRUE;
16972               *paren_type = FFEEXPR_parentypeANY_;
16973               break;
16974             }
16975
16976           *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16977           switch (ffesymbol_where (s))
16978             {
16979             case FFEINFO_whereLOCAL:
16980             case FFEINFO_whereCONSTANT:
16981               bad = TRUE;       /* Attempt to recurse! */
16982               break;
16983
16984             default:
16985               break;
16986             }
16987           break;
16988
16989         case FFEINFO_kindENTITY:
16990           if (ffesymbol_rank (s) == 0)
16991             {
16992               if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
16993                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
16994               else
16995                 {
16996                   bad = TRUE;
16997                   *paren_type = FFEEXPR_parentypeANY_;
16998                 }
16999             }
17000           else
17001             *paren_type = FFEEXPR_parentypeARRAY_;
17002           break;
17003
17004         default:
17005         case FFEINFO_kindANY:
17006           bad = TRUE;
17007           *paren_type = FFEEXPR_parentypeANY_;
17008           break;
17009         }
17010
17011       if (bad)
17012         {
17013           if (k == FFEINFO_kindANY)
17014             ffest_shutdown ();
17015           else
17016             ffesymbol_error (s, t);
17017         }
17018
17019       return s;
17020
17021     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
17022     seen:                       /* :::::::::::::::::::: */
17023       bad = TRUE;
17024       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17025         {
17026         case FFEEXPR_contextPARAMETER:
17027           if (ffeexpr_stack_->is_rhs)
17028             ffesymbol_error (s, t);
17029           else
17030             s = ffeexpr_sym_lhs_parameter_ (s, t);
17031           break;
17032
17033         case FFEEXPR_contextDATA:
17034           s = ffecom_sym_exec_transition (s);
17035           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17036             goto understood;    /* :::::::::::::::::::: */
17037           if (ffeexpr_stack_->is_rhs)
17038             ffesymbol_error (s, t);
17039           else
17040             s = ffeexpr_sym_lhs_data_ (s, t);
17041           goto understood;      /* :::::::::::::::::::: */
17042
17043         case FFEEXPR_contextDATAIMPDOITEM_:
17044           s = ffecom_sym_exec_transition (s);
17045           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17046             goto understood;    /* :::::::::::::::::::: */
17047           s = ffeexpr_sym_lhs_data_ (s, t);
17048           goto understood;      /* :::::::::::::::::::: */
17049
17050         case FFEEXPR_contextEQUIVALENCE:
17051           s = ffeexpr_sym_lhs_equivalence_ (s, t);
17052           bad = FALSE;
17053           break;
17054
17055         case FFEEXPR_contextDIMLIST:
17056           s = ffeexpr_sym_rhs_dimlist_ (s, t);
17057           bad = FALSE;
17058           break;
17059
17060         case FFEEXPR_contextCHARACTERSIZE:
17061         case FFEEXPR_contextKINDTYPE:
17062         case FFEEXPR_contextDIMLISTCOMMON:
17063         case FFEEXPR_contextINITVAL:
17064         case FFEEXPR_contextEQVINDEX_:
17065           break;
17066
17067         case FFEEXPR_contextINCLUDE:
17068           break;
17069
17070         case FFEEXPR_contextINDEX_:
17071         case FFEEXPR_contextACTUALARGEXPR_:
17072         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17073         case FFEEXPR_contextSFUNCDEF:
17074         case FFEEXPR_contextSFUNCDEFINDEX_:
17075         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17076         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17077           assert (ffeexpr_stack_->is_rhs);
17078           s = ffecom_sym_exec_transition (s);
17079           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17080             goto understood;    /* :::::::::::::::::::: */
17081           s = ffeexpr_paren_rhs_let_ (s, t);
17082           goto understood;      /* :::::::::::::::::::: */
17083
17084         default:
17085           break;
17086         }
17087       k = ffesymbol_kind (s);
17088       switch (bad ? FFEINFO_kindANY : k)
17089         {
17090         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
17091           *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17092           break;
17093
17094         case FFEINFO_kindFUNCTION:
17095           *paren_type = FFEEXPR_parentypeFUNCTION_;
17096           switch (ffesymbol_where (s))
17097             {
17098             case FFEINFO_whereLOCAL:
17099               bad = TRUE;       /* Attempt to recurse! */
17100               break;
17101
17102             case FFEINFO_whereCONSTANT:
17103               bad = ((ffesymbol_sfexpr (s) == NULL)
17104                      || (ffebld_op (ffesymbol_sfexpr (s))
17105                          == FFEBLD_opANY));     /* Attempt to recurse! */
17106               break;
17107
17108             default:
17109               break;
17110             }
17111           break;
17112
17113         case FFEINFO_kindSUBROUTINE:
17114           *paren_type = FFEEXPR_parentypeANY_;
17115           bad = TRUE;           /* Cannot possibly be in
17116                                    contextSUBROUTINEREF. */
17117           break;
17118
17119         case FFEINFO_kindENTITY:
17120           if (ffesymbol_rank (s) == 0)
17121             {
17122               if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17123                 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17124               else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17125                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17126               else
17127                 {
17128                   bad = TRUE;
17129                   *paren_type = FFEEXPR_parentypeANY_;
17130                 }
17131             }
17132           else
17133             *paren_type = FFEEXPR_parentypeARRAY_;
17134           break;
17135
17136         default:
17137         case FFEINFO_kindANY:
17138           bad = TRUE;
17139           *paren_type = FFEEXPR_parentypeANY_;
17140           break;
17141         }
17142
17143       if (bad)
17144         {
17145           if (k == FFEINFO_kindANY)
17146             ffest_shutdown ();
17147           else
17148             ffesymbol_error (s, t);
17149         }
17150
17151       return s;
17152
17153     default:
17154       assert ("bad symbol state" == NULL);
17155       return NULL;
17156     }
17157 }
17158
17159 /* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
17160
17161 static ffesymbol
17162 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17163 {
17164   ffesymbolAttrs sa;
17165   ffesymbolAttrs na;
17166   ffeinfoKind kind;
17167   ffeinfoWhere where;
17168   ffeintrinGen gen;
17169   ffeintrinSpec spec;
17170   ffeintrinImp imp;
17171   bool maybe_ambig = FALSE;
17172   bool error = FALSE;
17173
17174   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17175           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17176
17177   na = sa = ffesymbol_attrs (s);
17178
17179   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17180                    | FFESYMBOL_attrsADJUSTABLE
17181                    | FFESYMBOL_attrsANYLEN
17182                    | FFESYMBOL_attrsARRAY
17183                    | FFESYMBOL_attrsDUMMY
17184                    | FFESYMBOL_attrsEXTERNAL
17185                    | FFESYMBOL_attrsSFARG
17186                    | FFESYMBOL_attrsTYPE)));
17187
17188   kind = ffesymbol_kind (s);
17189   where = ffesymbol_where (s);
17190
17191   /* Figure out what kind of object we've got based on previous declarations
17192      of or references to the object. */
17193
17194   if (sa & FFESYMBOL_attrsEXTERNAL)
17195     {
17196       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17197                        | FFESYMBOL_attrsDUMMY
17198                        | FFESYMBOL_attrsEXTERNAL
17199                        | FFESYMBOL_attrsTYPE)));
17200
17201       if (sa & FFESYMBOL_attrsTYPE)
17202         where = FFEINFO_whereGLOBAL;
17203       else
17204         /* Not TYPE. */
17205         {
17206           kind = FFEINFO_kindFUNCTION;
17207
17208           if (sa & FFESYMBOL_attrsDUMMY)
17209             ;                   /* Not TYPE. */
17210           else if (sa & FFESYMBOL_attrsACTUALARG)
17211             ;                   /* Not DUMMY or TYPE. */
17212           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
17213             where = FFEINFO_whereGLOBAL;
17214         }
17215     }
17216   else if (sa & FFESYMBOL_attrsDUMMY)
17217     {
17218       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17219       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17220                        | FFESYMBOL_attrsEXTERNAL
17221                        | FFESYMBOL_attrsTYPE)));
17222
17223       kind = FFEINFO_kindFUNCTION;
17224       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure; kind
17225                                    could be ENTITY w/substring ref. */
17226     }
17227   else if (sa & FFESYMBOL_attrsARRAY)
17228     {
17229       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17230                        | FFESYMBOL_attrsADJUSTABLE
17231                        | FFESYMBOL_attrsTYPE)));
17232
17233       where = FFEINFO_whereLOCAL;
17234     }
17235   else if (sa & FFESYMBOL_attrsSFARG)
17236     {
17237       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17238                        | FFESYMBOL_attrsTYPE)));
17239
17240       where = FFEINFO_whereLOCAL;       /* Actually an error, but at least we
17241                                            know it's a local var. */
17242     }
17243   else if (sa & FFESYMBOL_attrsTYPE)
17244     {
17245       assert (!(sa & (FFESYMBOL_attrsARRAY
17246                       | FFESYMBOL_attrsDUMMY
17247                       | FFESYMBOL_attrsEXTERNAL
17248                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
17249       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17250                        | FFESYMBOL_attrsADJUSTABLE
17251                        | FFESYMBOL_attrsANYLEN
17252                        | FFESYMBOL_attrsARRAY
17253                        | FFESYMBOL_attrsDUMMY
17254                        | FFESYMBOL_attrsEXTERNAL
17255                        | FFESYMBOL_attrsSFARG)));
17256
17257       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17258                                   &gen, &spec, &imp))
17259         {
17260           if (!(sa & FFESYMBOL_attrsANYLEN)
17261               && (ffeimplic_peek_symbol_type (s, NULL)
17262                   == FFEINFO_basictypeCHARACTER))
17263             return s;           /* Haven't learned anything yet. */
17264
17265           ffesymbol_signal_change (s);  /* May need to back up to previous
17266                                            version. */
17267           ffesymbol_set_generic (s, gen);
17268           ffesymbol_set_specific (s, spec);
17269           ffesymbol_set_implementation (s, imp);
17270           ffesymbol_set_info (s,
17271                               ffeinfo_new (ffesymbol_basictype (s),
17272                                            ffesymbol_kindtype (s),
17273                                            0,
17274                                            FFEINFO_kindFUNCTION,
17275                                            FFEINFO_whereINTRINSIC,
17276                                            ffesymbol_size (s)));
17277           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17278           ffesymbol_resolve_intrin (s);
17279           ffesymbol_reference (s, t, FALSE);
17280           s = ffecom_sym_learned (s);
17281           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
17282
17283           return s;
17284         }
17285       if (sa & FFESYMBOL_attrsANYLEN)
17286         error = TRUE;           /* Error, since the only way we can,
17287                                    given CHARACTER*(*) FOO, accept
17288                                    FOO(...) is for FOO to be a dummy
17289                                    arg or constant, but it can't
17290                                    become either now. */
17291       else if (sa & FFESYMBOL_attrsADJUSTABLE)
17292         {
17293           kind = FFEINFO_kindENTITY;
17294           where = FFEINFO_whereLOCAL;
17295         }
17296       else
17297         {
17298           kind = FFEINFO_kindFUNCTION;
17299           where = FFEINFO_whereGLOBAL;
17300           maybe_ambig = TRUE;   /* If basictypeCHARACTER, can't be sure;
17301                                    could be ENTITY/LOCAL w/substring ref. */
17302         }
17303     }
17304   else if (sa == FFESYMBOL_attrsetNONE)
17305     {
17306       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17307
17308       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17309                                   &gen, &spec, &imp))
17310         {
17311           if (ffeimplic_peek_symbol_type (s, NULL)
17312               == FFEINFO_basictypeCHARACTER)
17313             return s;           /* Haven't learned anything yet. */
17314
17315           ffesymbol_signal_change (s);  /* May need to back up to previous
17316                                            version. */
17317           ffesymbol_set_generic (s, gen);
17318           ffesymbol_set_specific (s, spec);
17319           ffesymbol_set_implementation (s, imp);
17320           ffesymbol_set_info (s,
17321                               ffeinfo_new (ffesymbol_basictype (s),
17322                                            ffesymbol_kindtype (s),
17323                                            0,
17324                                            FFEINFO_kindFUNCTION,
17325                                            FFEINFO_whereINTRINSIC,
17326                                            ffesymbol_size (s)));
17327           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17328           ffesymbol_resolve_intrin (s);
17329           s = ffecom_sym_learned (s);
17330           ffesymbol_reference (s, t, FALSE);
17331           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
17332           return s;
17333         }
17334
17335       kind = FFEINFO_kindFUNCTION;
17336       where = FFEINFO_whereGLOBAL;
17337       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure;
17338                                    could be ENTITY/LOCAL w/substring ref. */
17339     }
17340   else
17341     error = TRUE;
17342
17343   /* Now see what we've got for a new object: NONE means a new error cropped
17344      up; ANY means an old error to be ignored; otherwise, everything's ok,
17345      update the object (symbol) and continue on. */
17346
17347   if (error)
17348     ffesymbol_error (s, t);
17349   else if (!(na & FFESYMBOL_attrsANY))
17350     {
17351       ffesymbol_signal_change (s);      /* May need to back up to previous
17352                                            version. */
17353       if (!ffeimplic_establish_symbol (s))
17354         {
17355           ffesymbol_error (s, t);
17356           return s;
17357         }
17358       if (maybe_ambig
17359           && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17360         return s;               /* Still not sure, let caller deal with it
17361                                    based on (...). */
17362
17363       ffesymbol_set_info (s,
17364                           ffeinfo_new (ffesymbol_basictype (s),
17365                                        ffesymbol_kindtype (s),
17366                                        ffesymbol_rank (s),
17367                                        kind,
17368                                        where,
17369                                        ffesymbol_size (s)));
17370       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17371       ffesymbol_resolve_intrin (s);
17372       s = ffecom_sym_learned (s);
17373       ffesymbol_reference (s, t, FALSE);
17374       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17375     }
17376
17377   return s;
17378 }
17379
17380 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17381
17382    Return a pointer to this function to the lexer (ffelex), which will
17383    invoke it for the next token.
17384
17385    Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
17386
17387 static ffelexHandler
17388 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17389 {
17390   ffeexprExpr_ procedure;
17391   ffebld reduced;
17392   ffeinfo info;
17393   ffeexprContext ctx;
17394   bool check_intrin = FALSE;    /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17395
17396   procedure = ffeexpr_stack_->exprstack;
17397   info = ffebld_info (procedure->u.operand);
17398
17399   /* Is there an expression to add?  If the expression is nil,
17400      it might still be an argument.  It is if:
17401
17402        -  The current token is comma, or
17403
17404        -  The -fugly-comma flag was specified *and* the procedure
17405           being invoked is external.
17406
17407      Otherwise, if neither of the above is the case, just
17408      ignore this (nil) expression.  */
17409
17410   if ((expr != NULL)
17411       || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17412       || (ffe_is_ugly_comma ()
17413           && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17414     {
17415       /* This expression, even if nil, is apparently intended as an argument.  */
17416
17417       /* Internal procedure (CONTAINS, or statement function)?  */
17418
17419       if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17420         {
17421           if ((expr == NULL)
17422               && ffebad_start (FFEBAD_NULL_ARGUMENT))
17423             {
17424               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17425                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17426               ffebad_here (1, ffelex_token_where_line (t),
17427                            ffelex_token_where_column (t));
17428               ffebad_finish ();
17429             }
17430
17431           if (expr == NULL)
17432             ;
17433           else
17434             {
17435               if (ffeexpr_stack_->next_dummy == NULL)
17436                 {                       /* Report later which was the first extra argument. */
17437                   if (ffeexpr_stack_->tokens[1] == NULL)
17438                     {
17439                       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17440                       ffeexpr_stack_->num_args = 0;
17441                     }
17442                   ++ffeexpr_stack_->num_args;   /* Count # of extra arguments. */
17443                 }
17444               else
17445                 {
17446                   if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17447                       && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17448                     {
17449                       ffebad_here (0,
17450                                    ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17451                                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17452                       ffebad_here (1, ffelex_token_where_line (ft),
17453                                    ffelex_token_where_column (ft));
17454                       ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17455                                                      (ffebld_symter (ffebld_head
17456                                                                      (ffeexpr_stack_->next_dummy)))));
17457                       ffebad_finish ();
17458                     }
17459                   else
17460                     {
17461                       expr = ffeexpr_convert_expr (expr, ft,
17462                                                    ffebld_head (ffeexpr_stack_->next_dummy),
17463                                                    ffeexpr_stack_->tokens[0],
17464                                                    FFEEXPR_contextLET);
17465                       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17466                     }
17467                   --ffeexpr_stack_->num_args;   /* Count down # of args. */
17468                   ffeexpr_stack_->next_dummy
17469                     = ffebld_trail (ffeexpr_stack_->next_dummy);
17470                 }
17471             }
17472         }
17473       else
17474         {
17475           if ((expr == NULL)
17476               && ffe_is_pedantic ()
17477               && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17478             {
17479               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17480                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17481               ffebad_here (1, ffelex_token_where_line (t),
17482                            ffelex_token_where_column (t));
17483               ffebad_finish ();
17484             }
17485           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17486         }
17487     }
17488
17489   switch (ffelex_token_type (t))
17490     {
17491     case FFELEX_typeCOMMA:
17492       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17493         {
17494         case FFEEXPR_contextSFUNCDEF:
17495         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17496         case FFEEXPR_contextSFUNCDEFINDEX_:
17497         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17498           ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17499           break;
17500
17501         case FFEEXPR_contextSFUNCDEFACTUALARG_:
17502         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17503           assert ("bad context" == NULL);
17504           ctx = FFEEXPR_context;
17505           break;
17506
17507         default:
17508           ctx = FFEEXPR_contextACTUALARG_;
17509           break;
17510         }
17511       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17512                                           ffeexpr_token_arguments_);
17513
17514     default:
17515       break;
17516     }
17517
17518   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17519       && (ffeexpr_stack_->next_dummy != NULL))
17520     {                           /* Too few arguments. */
17521       if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17522         {
17523           char num[10];
17524
17525           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17526
17527           ffebad_here (0, ffelex_token_where_line (t),
17528                        ffelex_token_where_column (t));
17529           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17530                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17531           ffebad_string (num);
17532           ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17533                               (ffebld_head (ffeexpr_stack_->next_dummy)))));
17534           ffebad_finish ();
17535         }
17536       for (;
17537            ffeexpr_stack_->next_dummy != NULL;
17538            ffeexpr_stack_->next_dummy
17539            = ffebld_trail (ffeexpr_stack_->next_dummy))
17540         {
17541           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17542           ffebld_set_info (expr, ffeinfo_new_any ());
17543           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17544         }
17545     }
17546
17547   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17548       && (ffeexpr_stack_->tokens[1] != NULL))
17549     {                           /* Too many arguments to statement function. */
17550       if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17551         {
17552           char num[10];
17553
17554           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17555
17556           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17557                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17558           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17559                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17560           ffebad_string (num);
17561           ffebad_finish ();
17562         }
17563       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17564     }
17565   ffebld_end_list (&ffeexpr_stack_->bottom);
17566
17567   if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17568     {
17569       reduced = ffebld_new_any ();
17570       ffebld_set_info (reduced, ffeinfo_new_any ());
17571     }
17572   else
17573     {
17574       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17575         reduced = ffebld_new_funcref (procedure->u.operand,
17576                                       ffeexpr_stack_->expr);
17577       else
17578         reduced = ffebld_new_subrref (procedure->u.operand,
17579                                       ffeexpr_stack_->expr);
17580       if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17581         ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17582       else if (ffebld_symter_specific (procedure->u.operand)
17583                != FFEINTRIN_specNONE)
17584         ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17585                                     ffeexpr_stack_->tokens[0]);
17586       else
17587         ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17588
17589       if (ffebld_op (reduced) != FFEBLD_opANY)
17590         ffebld_set_info (reduced,
17591                          ffeinfo_new (ffeinfo_basictype (info),
17592                                       ffeinfo_kindtype (info),
17593                                       0,
17594                                       FFEINFO_kindENTITY,
17595                                       FFEINFO_whereFLEETING,
17596                                       ffeinfo_size (info)));
17597       else
17598         ffebld_set_info (reduced, ffeinfo_new_any ());
17599     }
17600   if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17601     reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17602   ffeexpr_stack_->exprstack = procedure->previous;      /* Pops
17603                                                            not-quite-operand off
17604                                                            stack. */
17605   procedure->u.operand = reduced;       /* Save the line/column ffewhere
17606                                            info. */
17607   ffeexpr_exprstack_push_operand_ (procedure);  /* Push it back on stack. */
17608   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17609     {
17610       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17611       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FUNC(3)(1:1)".... */
17612
17613       /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17614          Z is DOUBLE COMPLEX), and a command-line option doesn't already
17615          establish interpretation, probably complain.  */
17616
17617       if (check_intrin
17618           && !ffe_is_90 ()
17619           && !ffe_is_ugly_complex ())
17620         {
17621           /* If the outer expression is REAL(me...), issue diagnostic
17622              only if next token isn't the close-paren for REAL(me).  */
17623
17624           if ((ffeexpr_stack_->previous != NULL)
17625               && (ffeexpr_stack_->previous->exprstack != NULL)
17626               && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17627               && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17628               && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17629               && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17630             return (ffelexHandler) ffeexpr_token_intrincheck_;
17631
17632           /* Diagnose the ambiguity now.  */
17633
17634           if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17635             {
17636               ffebad_string (ffeintrin_name_implementation
17637                              (ffebld_symter_implementation
17638                               (ffebld_left
17639                                (ffeexpr_stack_->exprstack->u.operand))));
17640               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17641                            ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17642               ffebad_finish ();
17643             }
17644         }
17645       return (ffelexHandler) ffeexpr_token_substrp_;
17646     }
17647
17648   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17649     {
17650       ffebad_here (0, ffelex_token_where_line (t),
17651                    ffelex_token_where_column (t));
17652       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17653                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17654       ffebad_finish ();
17655     }
17656   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17657   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17658   return
17659     (ffelexHandler) ffeexpr_find_close_paren_ (t,
17660                                                (ffelexHandler)
17661                                                ffeexpr_token_substrp_);
17662 }
17663
17664 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17665
17666    Return a pointer to this array to the lexer (ffelex), which will
17667    invoke it for the next token.
17668
17669    Handle expression and COMMA or CLOSE_PAREN.  */
17670
17671 static ffelexHandler
17672 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17673 {
17674   ffeexprExpr_ array;
17675   ffebld reduced;
17676   ffeinfo info;
17677   ffeinfoWhere where;
17678   ffetargetIntegerDefault val;
17679   ffetargetIntegerDefault lval = 0;
17680   ffetargetIntegerDefault uval = 0;
17681   ffebld lbound;
17682   ffebld ubound;
17683   bool lcheck;
17684   bool ucheck;
17685
17686   array = ffeexpr_stack_->exprstack;
17687   info = ffebld_info (array->u.operand);
17688
17689   if ((expr == NULL)            /* && ((ffeexpr_stack_->rank != 0) ||
17690                                    (ffelex_token_type(t) ==
17691          FFELEX_typeCOMMA)) */ )
17692     {
17693       if (ffebad_start (FFEBAD_NULL_ELEMENT))
17694         {
17695           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17696                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17697           ffebad_here (1, ffelex_token_where_line (t),
17698                        ffelex_token_where_column (t));
17699           ffebad_finish ();
17700         }
17701       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17702         {                       /* Don't bother if we're going to complain
17703                                    later! */
17704           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17705           ffebld_set_info (expr, ffeinfo_new_any ());
17706         }
17707     }
17708
17709   if (expr == NULL)
17710     ;
17711   else if (ffeinfo_rank (info) == 0)
17712     {                           /* In EQUIVALENCE context, ffeinfo_rank(info)
17713                                    may == 0. */
17714       ++ffeexpr_stack_->rank;   /* Track anyway, may need for new VXT
17715                                    feature. */
17716       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17717     }
17718   else
17719     {
17720       ++ffeexpr_stack_->rank;
17721       if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17722         {                       /* Report later which was the first extra
17723                                    element. */
17724           if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17725             ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17726         }
17727       else
17728         {
17729           switch (ffeinfo_where (ffebld_info (expr)))
17730             {
17731             case FFEINFO_whereCONSTANT:
17732               break;
17733
17734             case FFEINFO_whereIMMEDIATE:
17735               ffeexpr_stack_->constant = FALSE;
17736               break;
17737
17738             default:
17739               ffeexpr_stack_->constant = FALSE;
17740               ffeexpr_stack_->immediate = FALSE;
17741               break;
17742             }
17743           if (ffebld_op (expr) == FFEBLD_opCONTER
17744               && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17745             {
17746               val = ffebld_constant_integerdefault (ffebld_conter (expr));
17747
17748               lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17749               if (lbound == NULL)
17750                 {
17751                   lcheck = TRUE;
17752                   lval = 1;
17753                 }
17754               else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17755                 {
17756                   lcheck = TRUE;
17757                   lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17758                 }
17759               else
17760                 lcheck = FALSE;
17761
17762               ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17763               assert (ubound != NULL);
17764               if (ffebld_op (ubound) == FFEBLD_opCONTER)
17765                 {
17766                   ucheck = TRUE;
17767                   uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17768                 }
17769               else
17770                 ucheck = FALSE;
17771
17772               if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17773                 {
17774                   ffebad_start (FFEBAD_RANGE_ARRAY);
17775                   ffebad_here (0, ffelex_token_where_line (ft),
17776                                ffelex_token_where_column (ft));
17777                   ffebad_finish ();
17778                 }
17779             }
17780           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17781           ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17782         }
17783     }
17784
17785   switch (ffelex_token_type (t))
17786     {
17787     case FFELEX_typeCOMMA:
17788       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17789         {
17790         case FFEEXPR_contextDATAIMPDOITEM_:
17791           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17792                                               FFEEXPR_contextDATAIMPDOINDEX_,
17793                                               ffeexpr_token_elements_);
17794
17795         case FFEEXPR_contextEQUIVALENCE:
17796           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17797                                               FFEEXPR_contextEQVINDEX_,
17798                                               ffeexpr_token_elements_);
17799
17800         case FFEEXPR_contextSFUNCDEF:
17801         case FFEEXPR_contextSFUNCDEFINDEX_:
17802           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17803                                               FFEEXPR_contextSFUNCDEFINDEX_,
17804                                               ffeexpr_token_elements_);
17805
17806         case FFEEXPR_contextSFUNCDEFACTUALARG_:
17807         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17808           assert ("bad context" == NULL);
17809           break;
17810
17811         default:
17812           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17813                                               FFEEXPR_contextINDEX_,
17814                                               ffeexpr_token_elements_);
17815         }
17816
17817     default:
17818       break;
17819     }
17820
17821   if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17822       && (ffeinfo_rank (info) != 0))
17823     {
17824       char num[10];
17825
17826       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17827         {
17828           if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17829             {
17830               sprintf (num, "%d",
17831                        (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17832
17833               ffebad_here (0, ffelex_token_where_line (t),
17834                            ffelex_token_where_column (t));
17835               ffebad_here (1,
17836                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17837                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17838               ffebad_string (num);
17839               ffebad_finish ();
17840             }
17841         }
17842       else
17843         {
17844           if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17845             {
17846               sprintf (num, "%d",
17847                        (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17848
17849               ffebad_here (0,
17850                         ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17851                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17852               ffebad_here (1,
17853                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17854                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17855               ffebad_string (num);
17856               ffebad_finish ();
17857             }
17858           ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17859         }
17860       while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17861         {
17862           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17863           ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17864                                               FFEINFO_kindtypeINTEGERDEFAULT,
17865                                               0, FFEINFO_kindENTITY,
17866                                               FFEINFO_whereCONSTANT,
17867                                               FFETARGET_charactersizeNONE));
17868           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17869         }
17870     }
17871   ffebld_end_list (&ffeexpr_stack_->bottom);
17872
17873   if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17874     {
17875       reduced = ffebld_new_any ();
17876       ffebld_set_info (reduced, ffeinfo_new_any ());
17877     }
17878   else
17879     {
17880       reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17881       if (ffeexpr_stack_->constant)
17882         where = FFEINFO_whereFLEETING_CADDR;
17883       else if (ffeexpr_stack_->immediate)
17884         where = FFEINFO_whereFLEETING_IADDR;
17885       else
17886         where = FFEINFO_whereFLEETING;
17887       ffebld_set_info (reduced,
17888                        ffeinfo_new (ffeinfo_basictype (info),
17889                                     ffeinfo_kindtype (info),
17890                                     0,
17891                                     FFEINFO_kindENTITY,
17892                                     where,
17893                                     ffeinfo_size (info)));
17894       reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17895     }
17896
17897   ffeexpr_stack_->exprstack = array->previous;  /* Pops not-quite-operand off
17898                                                    stack. */
17899   array->u.operand = reduced;   /* Save the line/column ffewhere info. */
17900   ffeexpr_exprstack_push_operand_ (array);      /* Push it back on stack. */
17901
17902   switch (ffeinfo_basictype (info))
17903     {
17904     case FFEINFO_basictypeCHARACTER:
17905       ffeexpr_is_substr_ok_ = TRUE;     /* Everyone likes "FOO(3)(1:1)".... */
17906       break;
17907
17908     case FFEINFO_basictypeNONE:
17909       ffeexpr_is_substr_ok_ = TRUE;
17910       assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17911       break;
17912
17913     default:
17914       ffeexpr_is_substr_ok_ = FALSE;
17915       break;
17916     }
17917
17918   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17919     {
17920       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17921       return (ffelexHandler) ffeexpr_token_substrp_;
17922     }
17923
17924   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17925     {
17926       ffebad_here (0, ffelex_token_where_line (t),
17927                    ffelex_token_where_column (t));
17928       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17929                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17930       ffebad_finish ();
17931     }
17932   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17933   return
17934     (ffelexHandler) ffeexpr_find_close_paren_ (t,
17935                                                (ffelexHandler)
17936                                                ffeexpr_token_substrp_);
17937 }
17938
17939 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17940
17941    Return a pointer to this array to the lexer (ffelex), which will
17942    invoke it for the next token.
17943
17944    If token is COLON, pass off to _substr_, else init list and pass off
17945    to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
17946    ? marks the token, and where FOO's rank/type has not yet been established,
17947    meaning we could be in a list of indices or in a substring
17948    specification.  */
17949
17950 static ffelexHandler
17951 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
17952 {
17953   if (ffelex_token_type (t) == FFELEX_typeCOLON)
17954     return ffeexpr_token_substring_ (ft, expr, t);
17955
17956   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
17957   return ffeexpr_token_elements_ (ft, expr, t);
17958 }
17959
17960 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
17961
17962    Return a pointer to this function to the lexer (ffelex), which will
17963    invoke it for the next token.
17964
17965    Handle expression (which may be null) and COLON.  */
17966
17967 static ffelexHandler
17968 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
17969 {
17970   ffeexprExpr_ string;
17971   ffeinfo info;
17972   ffetargetIntegerDefault i;
17973   ffeexprContext ctx;
17974   ffetargetCharacterSize size;
17975
17976   string = ffeexpr_stack_->exprstack;
17977   info = ffebld_info (string->u.operand);
17978   size = ffebld_size_max (string->u.operand);
17979
17980   if (ffelex_token_type (t) == FFELEX_typeCOLON)
17981     {
17982       if ((expr != NULL)
17983           && (ffebld_op (expr) == FFEBLD_opCONTER)
17984           && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
17985                < 1)
17986               || ((size != FFETARGET_charactersizeNONE) && (i > size))))
17987         {
17988           ffebad_start (FFEBAD_RANGE_SUBSTR);
17989           ffebad_here (0, ffelex_token_where_line (ft),
17990                        ffelex_token_where_column (ft));
17991           ffebad_finish ();
17992         }
17993       ffeexpr_stack_->expr = expr;
17994
17995       switch (ffeexpr_stack_->context)
17996         {
17997         case FFEEXPR_contextSFUNCDEF:
17998         case FFEEXPR_contextSFUNCDEFINDEX_:
17999           ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18000           break;
18001
18002         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18003         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18004           assert ("bad context" == NULL);
18005           ctx = FFEEXPR_context;
18006           break;
18007
18008         default:
18009           ctx = FFEEXPR_contextINDEX_;
18010           break;
18011         }
18012
18013       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18014                                           ffeexpr_token_substring_1_);
18015     }
18016
18017   if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18018     {
18019       ffebad_here (0, ffelex_token_where_line (t),
18020                    ffelex_token_where_column (t));
18021       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18022                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18023       ffebad_finish ();
18024     }
18025
18026   ffeexpr_stack_->expr = NULL;
18027   return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18028 }
18029
18030 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18031
18032    Return a pointer to this function to the lexer (ffelex), which will
18033    invoke it for the next token.
18034
18035    Handle expression (which might be null) and CLOSE_PAREN.  */
18036
18037 static ffelexHandler
18038 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18039 {
18040   ffeexprExpr_ string;
18041   ffebld reduced;
18042   ffebld substrlist;
18043   ffebld first = ffeexpr_stack_->expr;
18044   ffebld strop;
18045   ffeinfo info;
18046   ffeinfoWhere lwh;
18047   ffeinfoWhere rwh;
18048   ffeinfoWhere where;
18049   ffeinfoKindtype first_kt;
18050   ffeinfoKindtype last_kt;
18051   ffetargetIntegerDefault first_val;
18052   ffetargetIntegerDefault last_val;
18053   ffetargetCharacterSize size;
18054   ffetargetCharacterSize strop_size_max;
18055   bool first_known;
18056
18057   string = ffeexpr_stack_->exprstack;
18058   strop = string->u.operand;
18059   info = ffebld_info (strop);
18060
18061   if (first == NULL
18062       || (ffebld_op (first) == FFEBLD_opCONTER
18063           && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18064     {                           /* The starting point is known. */
18065       first_val = (first == NULL) ? 1
18066         : ffebld_constant_integerdefault (ffebld_conter (first));
18067       first_known = TRUE;
18068     }
18069   else
18070     {                           /* Assume start of the entity. */
18071       first_val = 1;
18072       first_known = FALSE;
18073     }
18074
18075   if (last != NULL
18076       && (ffebld_op (last) == FFEBLD_opCONTER
18077           && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18078     {                           /* The ending point is known. */
18079       last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18080
18081       if (first_known)
18082         {                       /* The beginning point is a constant. */
18083           if (first_val <= last_val)
18084             size = last_val - first_val + 1;
18085           else
18086             {
18087               if (0 && ffe_is_90 ())
18088                 size = 0;
18089               else
18090                 {
18091                   size = 1;
18092                   ffebad_start (FFEBAD_ZERO_SIZE);
18093                   ffebad_here (0, ffelex_token_where_line (ft),
18094                                ffelex_token_where_column (ft));
18095                   ffebad_finish ();
18096                 }
18097             }
18098         }
18099       else
18100         size = FFETARGET_charactersizeNONE;
18101
18102       strop_size_max = ffebld_size_max (strop);
18103
18104       if ((strop_size_max != FFETARGET_charactersizeNONE)
18105           && (last_val > strop_size_max))
18106         {                       /* Beyond maximum possible end of string. */
18107           ffebad_start (FFEBAD_RANGE_SUBSTR);
18108           ffebad_here (0, ffelex_token_where_line (ft),
18109                        ffelex_token_where_column (ft));
18110           ffebad_finish ();
18111         }
18112     }
18113   else
18114     size = FFETARGET_charactersizeNONE; /* The size is not known. */
18115
18116 #if 0                           /* Don't do this, or "is size of target
18117                                    known?" would no longer be easily
18118                                    answerable.  To see if there is a max
18119                                    size, use ffebld_size_max; to get only the
18120                                    known size, else NONE, use
18121                                    ffebld_size_known; use ffebld_size if
18122                                    values are sure to be the same (not
18123                                    opSUBSTR or opCONCATENATE or known to have
18124                                    known length). By getting rid of this
18125                                    "useful info" stuff, we don't end up
18126                                    blank-padding the constant in the
18127                                    assignment "A(I:J)='XYZ'" to the known
18128                                    length of A. */
18129   if (size == FFETARGET_charactersizeNONE)
18130     size = strop_size_max;      /* Assume we use the entire string. */
18131 #endif
18132
18133   substrlist
18134     = ffebld_new_item
18135     (first,
18136      ffebld_new_item
18137      (last,
18138       NULL
18139      )
18140     )
18141     ;
18142
18143   if (first == NULL)
18144     lwh = FFEINFO_whereCONSTANT;
18145   else
18146     lwh = ffeinfo_where (ffebld_info (first));
18147   if (last == NULL)
18148     rwh = FFEINFO_whereCONSTANT;
18149   else
18150     rwh = ffeinfo_where (ffebld_info (last));
18151
18152   switch (lwh)
18153     {
18154     case FFEINFO_whereCONSTANT:
18155       switch (rwh)
18156         {
18157         case FFEINFO_whereCONSTANT:
18158           where = FFEINFO_whereCONSTANT;
18159           break;
18160
18161         case FFEINFO_whereIMMEDIATE:
18162           where = FFEINFO_whereIMMEDIATE;
18163           break;
18164
18165         default:
18166           where = FFEINFO_whereFLEETING;
18167           break;
18168         }
18169       break;
18170
18171     case FFEINFO_whereIMMEDIATE:
18172       switch (rwh)
18173         {
18174         case FFEINFO_whereCONSTANT:
18175         case FFEINFO_whereIMMEDIATE:
18176           where = FFEINFO_whereIMMEDIATE;
18177           break;
18178
18179         default:
18180           where = FFEINFO_whereFLEETING;
18181           break;
18182         }
18183       break;
18184
18185     default:
18186       where = FFEINFO_whereFLEETING;
18187       break;
18188     }
18189
18190   if (first == NULL)
18191     first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18192   else
18193     first_kt = ffeinfo_kindtype (ffebld_info (first));
18194   if (last == NULL)
18195     last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18196   else
18197     last_kt = ffeinfo_kindtype (ffebld_info (last));
18198
18199   switch (where)
18200     {
18201     case FFEINFO_whereCONSTANT:
18202       switch (ffeinfo_where (info))
18203         {
18204         case FFEINFO_whereCONSTANT:
18205           break;
18206
18207         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
18208           where = FFEINFO_whereIMMEDIATE;
18209           break;
18210
18211         default:
18212           where = FFEINFO_whereFLEETING_CADDR;
18213           break;
18214         }
18215       break;
18216
18217     case FFEINFO_whereIMMEDIATE:
18218       switch (ffeinfo_where (info))
18219         {
18220         case FFEINFO_whereCONSTANT:
18221         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
18222           break;
18223
18224         default:
18225           where = FFEINFO_whereFLEETING_IADDR;
18226           break;
18227         }
18228       break;
18229
18230     default:
18231       switch (ffeinfo_where (info))
18232         {
18233         case FFEINFO_whereCONSTANT:
18234           where = FFEINFO_whereCONSTANT_SUBOBJECT;      /* An F90 concept. */
18235           break;
18236
18237         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
18238         default:
18239           where = FFEINFO_whereFLEETING;
18240           break;
18241         }
18242       break;
18243     }
18244
18245   if (ffebld_op (strop) == FFEBLD_opANY)
18246     {
18247       reduced = ffebld_new_any ();
18248       ffebld_set_info (reduced, ffeinfo_new_any ());
18249     }
18250   else
18251     {
18252       reduced = ffebld_new_substr (strop, substrlist);
18253       ffebld_set_info (reduced, ffeinfo_new
18254                        (FFEINFO_basictypeCHARACTER,
18255                         ffeinfo_kindtype (info),
18256                         0,
18257                         FFEINFO_kindENTITY,
18258                         where,
18259                         size));
18260       reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18261     }
18262
18263   ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
18264                                                    stack. */
18265   string->u.operand = reduced;  /* Save the line/column ffewhere info. */
18266   ffeexpr_exprstack_push_operand_ (string);     /* Push it back on stack. */
18267
18268   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18269     {
18270       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18271       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FOO(3:5)(1:1)".... */
18272       return (ffelexHandler) ffeexpr_token_substrp_;
18273     }
18274
18275   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18276     {
18277       ffebad_here (0, ffelex_token_where_line (t),
18278                    ffelex_token_where_column (t));
18279       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18280                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18281       ffebad_finish ();
18282     }
18283
18284   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18285   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18286   return
18287     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18288                                                (ffelexHandler)
18289                                                ffeexpr_token_substrp_);
18290 }
18291
18292 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18293
18294    Return a pointer to this function to the lexer (ffelex), which will
18295    invoke it for the next token.
18296
18297    If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18298    issue error message if flag (serves as argument) is set.  Else, just
18299    forward token to binary_.  */
18300
18301 static ffelexHandler
18302 ffeexpr_token_substrp_ (ffelexToken t)
18303 {
18304   ffeexprContext ctx;
18305
18306   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18307     return (ffelexHandler) ffeexpr_token_binary_ (t);
18308
18309   ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18310
18311   switch (ffeexpr_stack_->context)
18312     {
18313     case FFEEXPR_contextSFUNCDEF:
18314     case FFEEXPR_contextSFUNCDEFINDEX_:
18315       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18316       break;
18317
18318     case FFEEXPR_contextSFUNCDEFACTUALARG_:
18319     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18320       assert ("bad context" == NULL);
18321       ctx = FFEEXPR_context;
18322       break;
18323
18324     default:
18325       ctx = FFEEXPR_contextINDEX_;
18326       break;
18327     }
18328
18329   if (!ffeexpr_is_substr_ok_)
18330     {
18331       if (ffebad_start (FFEBAD_BAD_SUBSTR))
18332         {
18333           ffebad_here (0, ffelex_token_where_line (t),
18334                        ffelex_token_where_column (t));
18335           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18336                        ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18337           ffebad_finish ();
18338         }
18339
18340       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18341                                           ffeexpr_token_anything_);
18342     }
18343
18344   return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18345                                       ffeexpr_token_substring_);
18346 }
18347
18348 static ffelexHandler
18349 ffeexpr_token_intrincheck_ (ffelexToken t)
18350 {
18351   if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18352       && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18353     {
18354       ffebad_string (ffeintrin_name_implementation
18355                      (ffebld_symter_implementation
18356                       (ffebld_left
18357                        (ffeexpr_stack_->exprstack->u.operand))));
18358       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18359                    ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18360       ffebad_finish ();
18361     }
18362
18363   return (ffelexHandler) ffeexpr_token_substrp_ (t);
18364 }
18365
18366 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18367
18368    Return a pointer to this function to the lexer (ffelex), which will
18369    invoke it for the next token.
18370
18371    If COLON, do everything we would have done since _parenthesized_ if
18372    we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18373    If not COLON, do likewise for kindFUNCTION instead.  */
18374
18375 static ffelexHandler
18376 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18377 {
18378   ffeinfoWhere where;
18379   ffesymbol s;
18380   ffesymbolAttrs sa;
18381   ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18382   bool needs_type;
18383   ffeintrinGen gen;
18384   ffeintrinSpec spec;
18385   ffeintrinImp imp;
18386
18387   s = ffebld_symter (symter);
18388   sa = ffesymbol_attrs (s);
18389   where = ffesymbol_where (s);
18390
18391   /* We get here only if we don't already know enough about FOO when seeing a
18392      FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
18393      "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18394      Else FOO is a function, either intrinsic or external.  If intrinsic, it
18395      wouldn't necessarily be CHARACTER type, so unless it has already been
18396      declared DUMMY, it hasn't had its type established yet.  It can't be
18397      CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
18398
18399   assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18400                    | FFESYMBOL_attrsTYPE)));
18401
18402   needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18403
18404   ffesymbol_signal_change (s);  /* Probably already done, but in case.... */
18405
18406   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18407     {                           /* Definitely an ENTITY (char substring). */
18408       if (needs_type && !ffeimplic_establish_symbol (s))
18409         {
18410           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18411           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18412         }
18413
18414       ffesymbol_set_info (s,
18415                           ffeinfo_new (ffesymbol_basictype (s),
18416                                        ffesymbol_kindtype (s),
18417                                        ffesymbol_rank (s),
18418                                        FFEINFO_kindENTITY,
18419                                        (where == FFEINFO_whereNONE)
18420                                        ? FFEINFO_whereLOCAL
18421                                        : where,
18422                                        ffesymbol_size (s)));
18423       ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18424
18425       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18426       ffesymbol_resolve_intrin (s);
18427       s = ffecom_sym_learned (s);
18428       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
18429
18430       ffeexpr_stack_->exprstack->u.operand
18431         = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18432
18433       return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18434     }
18435
18436   /* The "stuff" isn't a substring notation, so we now know the overall
18437      reference is to a function.  */
18438
18439   if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18440                               FALSE, &gen, &spec, &imp))
18441     {
18442       ffebld_symter_set_generic (symter, gen);
18443       ffebld_symter_set_specific (symter, spec);
18444       ffebld_symter_set_implementation (symter, imp);
18445       ffesymbol_set_generic (s, gen);
18446       ffesymbol_set_specific (s, spec);
18447       ffesymbol_set_implementation (s, imp);
18448       ffesymbol_set_info (s,
18449                           ffeinfo_new (ffesymbol_basictype (s),
18450                                        ffesymbol_kindtype (s),
18451                                        0,
18452                                        FFEINFO_kindFUNCTION,
18453                                        FFEINFO_whereINTRINSIC,
18454                                        ffesymbol_size (s)));
18455     }
18456   else
18457     {                           /* Not intrinsic, now needs CHAR type. */
18458       if (!ffeimplic_establish_symbol (s))
18459         {
18460           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18461           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18462         }
18463
18464       ffesymbol_set_info (s,
18465                           ffeinfo_new (ffesymbol_basictype (s),
18466                                        ffesymbol_kindtype (s),
18467                                        ffesymbol_rank (s),
18468                                        FFEINFO_kindFUNCTION,
18469                                        (where == FFEINFO_whereNONE)
18470                                        ? FFEINFO_whereGLOBAL
18471                                        : where,
18472                                        ffesymbol_size (s)));
18473     }
18474
18475   ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18476
18477   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18478   ffesymbol_resolve_intrin (s);
18479   s = ffecom_sym_learned (s);
18480   ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18481   ffesymbol_signal_unreported (s);      /* For debugging purposes. */
18482   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18483   return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18484 }
18485
18486 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18487
18488    Handle basically any expression, looking for CLOSE_PAREN.  */
18489
18490 static ffelexHandler
18491 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18492                          ffelexToken t)
18493 {
18494   ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18495
18496   switch (ffelex_token_type (t))
18497     {
18498     case FFELEX_typeCOMMA:
18499     case FFELEX_typeCOLON:
18500       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18501                                           FFEEXPR_contextACTUALARG_,
18502                                           ffeexpr_token_anything_);
18503
18504     default:
18505       e->u.operand = ffebld_new_any ();
18506       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18507       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18508       ffeexpr_is_substr_ok_ = FALSE;
18509       if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18510         return (ffelexHandler) ffeexpr_token_substrp_;
18511       return (ffelexHandler) ffeexpr_token_substrp_ (t);
18512     }
18513 }
18514
18515 /* Terminate module.  */
18516
18517 void
18518 ffeexpr_terminate_2 (void)
18519 {
18520   assert (ffeexpr_stack_ == NULL);
18521   assert (ffeexpr_level_ == 0);
18522 }