contrib/gcc/f/expr.c

   1 /* expr.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1998 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None.
  24
  25    Description:
  26       Handles syntactic and semantic analysis of Fortran expressions.
  27
  28    Modifications:
  29 */
  30
  31 /* Include files. */
  32
  33 #include "proj.h"
  34 #include "expr.h"
  35 #include "bad.h"
  36 #include "bld.h"
  37 #include "com.h"
  38 #include "global.h"
  39 #include "implic.h"
  40 #include "intrin.h"
  41 #include "info.h"
  42 #include "lex.h"
  43 #include "malloc.h"
  44 #include "src.h"
  45 #include "st.h"
  46 #include "symbol.h"
  47 #include "str.h"
  48 #include "target.h"
  49 #include "where.h"
  50
  51 /* Externals defined here. */
  52
  53
  54 /* Simple definitions and enumerations. */
  55
  56 typedef enum
  57   {
  58     FFEEXPR_exprtypeUNKNOWN_,
  59     FFEEXPR_exprtypeOPERAND_,
  60     FFEEXPR_exprtypeUNARY_,
  61     FFEEXPR_exprtypeBINARY_,
  62     FFEEXPR_exprtype_
  63   } ffeexprExprtype_;
  64
  65 typedef enum
  66   {
  67     FFEEXPR_operatorPOWER_,
  68     FFEEXPR_operatorMULTIPLY_,
  69     FFEEXPR_operatorDIVIDE_,
  70     FFEEXPR_operatorADD_,
  71     FFEEXPR_operatorSUBTRACT_,
  72     FFEEXPR_operatorCONCATENATE_,
  73     FFEEXPR_operatorLT_,
  74     FFEEXPR_operatorLE_,
  75     FFEEXPR_operatorEQ_,
  76     FFEEXPR_operatorNE_,
  77     FFEEXPR_operatorGT_,
  78     FFEEXPR_operatorGE_,
  79     FFEEXPR_operatorNOT_,
  80     FFEEXPR_operatorAND_,
  81     FFEEXPR_operatorOR_,
  82     FFEEXPR_operatorXOR_,
  83     FFEEXPR_operatorEQV_,
  84     FFEEXPR_operatorNEQV_,
  85     FFEEXPR_operator_
  86   } ffeexprOperator_;
  87
  88 typedef enum
  89   {
  90     FFEEXPR_operatorprecedenceHIGHEST_ = 1,
  91     FFEEXPR_operatorprecedencePOWER_ = 1,
  92     FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
  93     FFEEXPR_operatorprecedenceDIVIDE_ = 2,
  94     FFEEXPR_operatorprecedenceADD_ = 3,
  95     FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
  96     FFEEXPR_operatorprecedenceLOWARITH_ = 3,
  97     FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
  98     FFEEXPR_operatorprecedenceLT_ = 4,
  99     FFEEXPR_operatorprecedenceLE_ = 4,
 100     FFEEXPR_operatorprecedenceEQ_ = 4,
 101     FFEEXPR_operatorprecedenceNE_ = 4,
 102     FFEEXPR_operatorprecedenceGT_ = 4,
 103     FFEEXPR_operatorprecedenceGE_ = 4,
 104     FFEEXPR_operatorprecedenceNOT_ = 5,
 105     FFEEXPR_operatorprecedenceAND_ = 6,
 106     FFEEXPR_operatorprecedenceOR_ = 7,
 107     FFEEXPR_operatorprecedenceXOR_ = 8,
 108     FFEEXPR_operatorprecedenceEQV_ = 8,
 109     FFEEXPR_operatorprecedenceNEQV_ = 8,
 110     FFEEXPR_operatorprecedenceLOWEST_ = 8,
 111     FFEEXPR_operatorprecedence_
 112   } ffeexprOperatorPrecedence_;
 113
 114 #define FFEEXPR_operatorassociativityL2R_ TRUE
 115 #define FFEEXPR_operatorassociativityR2L_ FALSE
 116 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
 117 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
 118 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
 119 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
 120 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
 121 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
 122 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
 123 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
 124 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
 125 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
 126 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
 127 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
 128 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
 129 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
 130 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
 131 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
 132 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
 133 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
 134
 135 typedef enum
 136   {
 137     FFEEXPR_parentypeFUNCTION_,
 138     FFEEXPR_parentypeSUBROUTINE_,
 139     FFEEXPR_parentypeARRAY_,
 140     FFEEXPR_parentypeSUBSTRING_,
 141     FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
 142     FFEEXPR_parentypeEQUIVALENCE_,      /* Ambig: ARRAY_ or SUBSTRING_. */
 143     FFEEXPR_parentypeANY_,      /* Allow basically anything. */
 144     FFEEXPR_parentype_
 145   } ffeexprParenType_;
 146
 147 typedef enum
 148   {
 149     FFEEXPR_percentNONE_,
 150     FFEEXPR_percentLOC_,
 151     FFEEXPR_percentVAL_,
 152     FFEEXPR_percentREF_,
 153     FFEEXPR_percentDESCR_,
 154     FFEEXPR_percent_
 155   } ffeexprPercent_;
 156
 157 /* Internal typedefs. */
 158
 159 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
 160 typedef bool ffeexprOperatorAssociativity_;
 161 typedef struct _ffeexpr_stack_ *ffeexprStack_;
 162
 163 /* Private include files. */
 164
 165
 166 /* Internal structure definitions. */
 167
 168 struct _ffeexpr_expr_
 169   {
 170     ffeexprExpr_ previous;
 171     ffelexToken token;
 172     ffeexprExprtype_ type;
 173     union
 174       {
 175         struct
 176           {
 177             ffeexprOperator_ op;
 178             ffeexprOperatorPrecedence_ prec;
 179             ffeexprOperatorAssociativity_ as;
 180           }
 181         operator;
 182         ffebld operand;
 183       }
 184     u;
 185   };
 186
 187 struct _ffeexpr_stack_
 188   {
 189     ffeexprStack_ previous;
 190     mallocPool pool;
 191     ffeexprContext context;
 192     ffeexprCallback callback;
 193     ffelexToken first_token;
 194     ffeexprExpr_ exprstack;
 195     ffelexToken tokens[10];     /* Used in certain cases, like (unary)
 196                                    open-paren. */
 197     ffebld expr;                /* For first of
 198                                    complex/implied-do/substring/array-elements
 199                                    / actual-args expression. */
 200     ffebld bound_list;          /* For tracking dimension bounds list of
 201                                    array. */
 202     ffebldListBottom bottom;    /* For building lists. */
 203     ffeinfoRank rank;           /* For elements in an array reference. */
 204     bool constant;              /* TRUE while elements seen so far are
 205                                    constants. */
 206     bool immediate;             /* TRUE while elements seen so far are
 207                                    immediate/constants. */
 208     ffebld next_dummy;          /* Next SFUNC dummy arg in arg list. */
 209     ffebldListLength num_args;  /* Number of dummy args expected in arg list. */
 210     bool is_rhs;                /* TRUE if rhs context, FALSE otherwise. */
 211     ffeexprPercent_ percent;    /* Current %FOO keyword. */
 212   };
 213
 214 struct _ffeexpr_find_
 215   {
 216     ffelexToken t;
 217     ffelexHandler after;
 218     int level;
 219   };
 220
 221 /* Static objects accessed by functions in this module. */
 222
 223 static ffeexprStack_ ffeexpr_stack_;    /* Expression stack for semantic. */
 224 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
 225 static ffestrOther ffeexpr_current_dotdot_;     /* Current .FOO. keyword. */
 226 static long ffeexpr_hollerith_count_;   /* ffeexpr_token_number_ and caller. */
 227 static int ffeexpr_level_;      /* Level of DATA implied-DO construct. */
 228 static bool ffeexpr_is_substr_ok_;      /* If OPEN_PAREN as binary "op" ok. */
 229 static struct _ffeexpr_find_ ffeexpr_find_;
 230
 231 /* Static functions (internal). */
 232
 233 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
 234                                               ffelexToken t);
 235 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
 236                                                     ffebld expr,
 237                                                     ffelexToken t);
 238 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
 239 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
 240                                                 ffebld expr, ffelexToken t);
 241 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
 242                                           ffelexToken t);
 243 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
 244                                                  ffebld expr, ffelexToken t);
 245 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
 246                                            ffelexToken t);
 247 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
 248                                           ffelexToken t);
 249 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
 250                                             ffelexToken t);
 251 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
 252                                             ffelexToken t);
 253 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
 254                                             ffelexToken t);
 255 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
 256                                             ffelexToken t);
 257 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
 258 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
 259                                           ffelexToken t);
 260 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
 261                                              ffelexToken t);
 262 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
 263 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
 264 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
 265                                   ffebld dovar, ffelexToken dovar_t);
 266 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
 267 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
 268 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
 269 static ffeexprExpr_ ffeexpr_expr_new_ (void);
 270 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
 271 static bool ffeexpr_isdigits_ (const char *p);
 272 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
 273 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
 274 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
 275 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
 276 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
 277 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
 278 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
 279 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
 280 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
 281 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
 282 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
 283 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
 284 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
 285 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
 286 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
 287 static void ffeexpr_reduce_ (void);
 288 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
 289                                       ffeexprExpr_ r);
 290 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
 291                                       ffeexprExpr_ op, ffeexprExpr_ r);
 292 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
 293                                             ffeexprExpr_ op, ffeexprExpr_ r);
 294 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
 295                                       ffeexprExpr_ op, ffeexprExpr_ r);
 296 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
 297                                       ffeexprExpr_ r);
 298 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
 299                                       ffeexprExpr_ op, ffeexprExpr_ r);
 300 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
 301                                       ffeexprExpr_ op, ffeexprExpr_ r);
 302 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
 303                                        ffeexprExpr_ op, ffeexprExpr_ r);
 304 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
 305 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
 306                                          ffeexprExpr_ r);
 307 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
 308                                       ffeexprExpr_ op, ffeexprExpr_ r);
 309 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
 310                                          ffeexprExpr_ op, ffeexprExpr_ r);
 311 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
 312                                                 ffelexHandler after);
 313 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
 314 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
 315 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
 316 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
 317 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
 318 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
 319 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
 320 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
 321 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
 322 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
 323 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
 324 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
 325 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
 326 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
 327 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
 328 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
 329 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
 330 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
 331 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
 332 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
 333 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
 334 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
 335 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
 336 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
 337 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
 338 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
 339 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
 340 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
 341 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
 342 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
 343 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
 344 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
 345 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
 346 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
 347 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
 348 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
 349 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
 350 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
 351 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
 352 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
 353 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
 354 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
 355 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
 356 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
 357 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
 358 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
 359 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
 360 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
 361 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
 362 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
 363 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
 364 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
 365 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
 366 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
 367 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
 368 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
 369 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
 370 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
 371 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
 372 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
 373 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
 374 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
 375 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
 376 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
 377                                                ffelexToken t);
 378 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
 379                                               ffelexToken t);
 380 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
 381                                                  ffelexToken t);
 382 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
 383                                                ffelexToken t);
 384 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
 385                                                  ffelexToken t);
 386 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
 387 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
 388 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
 389                                                ffelexToken t);
 390 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
 391                                               ffelexToken t);
 392 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
 393             ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
 394                     ffelexToken exponent_sign, ffelexToken exponent_digits);
 395 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
 396 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
 397 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
 398 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
 399 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
 400 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
 401 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
 402 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
 403 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
 404 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
 405 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
 406 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
 407                                                  bool maybe_intrin,
 408                                              ffeexprParenType_ *paren_type);
 409 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
 410
 411 /* Internal macros. */
 412
 413 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 414 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 415 \f
 416 /* ffeexpr_collapse_convert -- Collapse convert expr
 417
 418    ffebld expr;
 419    ffelexToken token;
 420    expr = ffeexpr_collapse_convert(expr,token);
 421
 422    If the result of the expr is a constant, replaces the expr with the
 423    computed constant.  */
 424
 425 ffebld
 426 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
 427 {
 428   ffebad error = FFEBAD;
 429   ffebld l;
 430   ffebldConstantUnion u;
 431   ffeinfoBasictype bt;
 432   ffeinfoKindtype kt;
 433   ffetargetCharacterSize sz;
 434   ffetargetCharacterSize sz2;
 435
 436   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
 437     return expr;
 438
 439   l = ffebld_left (expr);
 440
 441   if (ffebld_op (l) != FFEBLD_opCONTER)
 442     return expr;
 443
 444   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
 445     {
 446     case FFEINFO_basictypeANY:
 447       return expr;
 448
 449     case FFEINFO_basictypeINTEGER:
 450       sz = FFETARGET_charactersizeNONE;
 451       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
 452         {
 453 #if FFETARGET_okINTEGER1
 454         case FFEINFO_kindtypeINTEGER1:
 455           switch (ffeinfo_basictype (ffebld_info (l)))
 456             {
 457             case FFEINFO_basictypeINTEGER:
 458               switch (ffeinfo_kindtype (ffebld_info (l)))
 459                 {
 460 #if FFETARGET_okINTEGER2
 461                 case FFEINFO_kindtypeINTEGER2:
 462                   error = ffetarget_convert_integer1_integer2
 463                     (ffebld_cu_ptr_integer1 (u),
 464                      ffebld_constant_integer2 (ffebld_conter (l)));
 465                   break;
 466 #endif
 467
 468 #if FFETARGET_okINTEGER3
 469                 case FFEINFO_kindtypeINTEGER3:
 470                   error = ffetarget_convert_integer1_integer3
 471                     (ffebld_cu_ptr_integer1 (u),
 472                      ffebld_constant_integer3 (ffebld_conter (l)));
 473                   break;
 474 #endif
 475
 476 #if FFETARGET_okINTEGER4
 477                 case FFEINFO_kindtypeINTEGER4:
 478                   error = ffetarget_convert_integer1_integer4
 479                     (ffebld_cu_ptr_integer1 (u),
 480                      ffebld_constant_integer4 (ffebld_conter (l)));
 481                   break;
 482 #endif
 483
 484                 default:
 485                   assert ("INTEGER1/INTEGER bad source kind type" == NULL);
 486                   break;
 487                 }
 488               break;
 489
 490             case FFEINFO_basictypeREAL:
 491               switch (ffeinfo_kindtype (ffebld_info (l)))
 492                 {
 493 #if FFETARGET_okREAL1
 494                 case FFEINFO_kindtypeREAL1:
 495                   error = ffetarget_convert_integer1_real1
 496                     (ffebld_cu_ptr_integer1 (u),
 497                      ffebld_constant_real1 (ffebld_conter (l)));
 498                   break;
 499 #endif
 500
 501 #if FFETARGET_okREAL2
 502                 case FFEINFO_kindtypeREAL2:
 503                   error = ffetarget_convert_integer1_real2
 504                     (ffebld_cu_ptr_integer1 (u),
 505                      ffebld_constant_real2 (ffebld_conter (l)));
 506                   break;
 507 #endif
 508
 509 #if FFETARGET_okREAL3
 510                 case FFEINFO_kindtypeREAL3:
 511                   error = ffetarget_convert_integer1_real3
 512                     (ffebld_cu_ptr_integer1 (u),
 513                      ffebld_constant_real3 (ffebld_conter (l)));
 514                   break;
 515 #endif
 516
 517 #if FFETARGET_okREAL4
 518                 case FFEINFO_kindtypeREAL4:
 519                   error = ffetarget_convert_integer1_real4
 520                     (ffebld_cu_ptr_integer1 (u),
 521                      ffebld_constant_real4 (ffebld_conter (l)));
 522                   break;
 523 #endif
 524
 525                 default:
 526                   assert ("INTEGER1/REAL bad source kind type" == NULL);
 527                   break;
 528                 }
 529               break;
 530
 531             case FFEINFO_basictypeCOMPLEX:
 532               switch (ffeinfo_kindtype (ffebld_info (l)))
 533                 {
 534 #if FFETARGET_okCOMPLEX1
 535                 case FFEINFO_kindtypeREAL1:
 536                   error = ffetarget_convert_integer1_complex1
 537                     (ffebld_cu_ptr_integer1 (u),
 538                      ffebld_constant_complex1 (ffebld_conter (l)));
 539                   break;
 540 #endif
 541
 542 #if FFETARGET_okCOMPLEX2
 543                 case FFEINFO_kindtypeREAL2:
 544                   error = ffetarget_convert_integer1_complex2
 545                     (ffebld_cu_ptr_integer1 (u),
 546                      ffebld_constant_complex2 (ffebld_conter (l)));
 547                   break;
 548 #endif
 549
 550 #if FFETARGET_okCOMPLEX3
 551                 case FFEINFO_kindtypeREAL3:
 552                   error = ffetarget_convert_integer1_complex3
 553                     (ffebld_cu_ptr_integer1 (u),
 554                      ffebld_constant_complex3 (ffebld_conter (l)));
 555                   break;
 556 #endif
 557
 558 #if FFETARGET_okCOMPLEX4
 559                 case FFEINFO_kindtypeREAL4:
 560                   error = ffetarget_convert_integer1_complex4
 561                     (ffebld_cu_ptr_integer1 (u),
 562                      ffebld_constant_complex4 (ffebld_conter (l)));
 563                   break;
 564 #endif
 565
 566                 default:
 567                   assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
 568                   break;
 569                 }
 570               break;
 571
 572             case FFEINFO_basictypeLOGICAL:
 573               switch (ffeinfo_kindtype (ffebld_info (l)))
 574                 {
 575 #if FFETARGET_okLOGICAL1
 576                 case FFEINFO_kindtypeLOGICAL1:
 577                   error = ffetarget_convert_integer1_logical1
 578                     (ffebld_cu_ptr_integer1 (u),
 579                      ffebld_constant_logical1 (ffebld_conter (l)));
 580                   break;
 581 #endif
 582
 583 #if FFETARGET_okLOGICAL2
 584                 case FFEINFO_kindtypeLOGICAL2:
 585                   error = ffetarget_convert_integer1_logical2
 586                     (ffebld_cu_ptr_integer1 (u),
 587                      ffebld_constant_logical2 (ffebld_conter (l)));
 588                   break;
 589 #endif
 590
 591 #if FFETARGET_okLOGICAL3
 592                 case FFEINFO_kindtypeLOGICAL3:
 593                   error = ffetarget_convert_integer1_logical3
 594                     (ffebld_cu_ptr_integer1 (u),
 595                      ffebld_constant_logical3 (ffebld_conter (l)));
 596                   break;
 597 #endif
 598
 599 #if FFETARGET_okLOGICAL4
 600                 case FFEINFO_kindtypeLOGICAL4:
 601                   error = ffetarget_convert_integer1_logical4
 602                     (ffebld_cu_ptr_integer1 (u),
 603                      ffebld_constant_logical4 (ffebld_conter (l)));
 604                   break;
 605 #endif
 606
 607                 default:
 608                   assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
 609                   break;
 610                 }
 611               break;
 612
 613             case FFEINFO_basictypeCHARACTER:
 614               error = ffetarget_convert_integer1_character1
 615                 (ffebld_cu_ptr_integer1 (u),
 616                  ffebld_constant_character1 (ffebld_conter (l)));
 617               break;
 618
 619             case FFEINFO_basictypeHOLLERITH:
 620               error = ffetarget_convert_integer1_hollerith
 621                 (ffebld_cu_ptr_integer1 (u),
 622                  ffebld_constant_hollerith (ffebld_conter (l)));
 623               break;
 624
 625             case FFEINFO_basictypeTYPELESS:
 626               error = ffetarget_convert_integer1_typeless
 627                 (ffebld_cu_ptr_integer1 (u),
 628                  ffebld_constant_typeless (ffebld_conter (l)));
 629               break;
 630
 631             default:
 632               assert ("INTEGER1 bad type" == NULL);
 633               break;
 634             }
 635
 636           /* If conversion operation is not implemented, return original expr.  */
 637           if (error == FFEBAD_NOCANDO)
 638             return expr;
 639
 640           expr = ffebld_new_conter_with_orig
 641             (ffebld_constant_new_integer1_val
 642              (ffebld_cu_val_integer1 (u)), expr);
 643           break;
 644 #endif
 645
 646 #if FFETARGET_okINTEGER2
 647         case FFEINFO_kindtypeINTEGER2:
 648           switch (ffeinfo_basictype (ffebld_info (l)))
 649             {
 650             case FFEINFO_basictypeINTEGER:
 651               switch (ffeinfo_kindtype (ffebld_info (l)))
 652                 {
 653 #if FFETARGET_okINTEGER1
 654                 case FFEINFO_kindtypeINTEGER1:
 655                   error = ffetarget_convert_integer2_integer1
 656                     (ffebld_cu_ptr_integer2 (u),
 657                      ffebld_constant_integer1 (ffebld_conter (l)));
 658                   break;
 659 #endif
 660
 661 #if FFETARGET_okINTEGER3
 662                 case FFEINFO_kindtypeINTEGER3:
 663                   error = ffetarget_convert_integer2_integer3
 664                     (ffebld_cu_ptr_integer2 (u),
 665                      ffebld_constant_integer3 (ffebld_conter (l)));
 666                   break;
 667 #endif
 668
 669 #if FFETARGET_okINTEGER4
 670                 case FFEINFO_kindtypeINTEGER4:
 671                   error = ffetarget_convert_integer2_integer4
 672                     (ffebld_cu_ptr_integer2 (u),
 673                      ffebld_constant_integer4 (ffebld_conter (l)));
 674                   break;
 675 #endif
 676
 677                 default:
 678                   assert ("INTEGER2/INTEGER bad source kind type" == NULL);
 679                   break;
 680                 }
 681               break;
 682
 683             case FFEINFO_basictypeREAL:
 684               switch (ffeinfo_kindtype (ffebld_info (l)))
 685                 {
 686 #if FFETARGET_okREAL1
 687                 case FFEINFO_kindtypeREAL1:
 688                   error = ffetarget_convert_integer2_real1
 689                     (ffebld_cu_ptr_integer2 (u),
 690                      ffebld_constant_real1 (ffebld_conter (l)));
 691                   break;
 692 #endif
 693
 694 #if FFETARGET_okREAL2
 695                 case FFEINFO_kindtypeREAL2:
 696                   error = ffetarget_convert_integer2_real2
 697                     (ffebld_cu_ptr_integer2 (u),
 698                      ffebld_constant_real2 (ffebld_conter (l)));
 699                   break;
 700 #endif
 701
 702 #if FFETARGET_okREAL3
 703                 case FFEINFO_kindtypeREAL3:
 704                   error = ffetarget_convert_integer2_real3
 705                     (ffebld_cu_ptr_integer2 (u),
 706                      ffebld_constant_real3 (ffebld_conter (l)));
 707                   break;
 708 #endif
 709
 710 #if FFETARGET_okREAL4
 711                 case FFEINFO_kindtypeREAL4:
 712                   error = ffetarget_convert_integer2_real4
 713                     (ffebld_cu_ptr_integer2 (u),
 714                      ffebld_constant_real4 (ffebld_conter (l)));
 715                   break;
 716 #endif
 717
 718                 default:
 719                   assert ("INTEGER2/REAL bad source kind type" == NULL);
 720                   break;
 721                 }
 722               break;
 723
 724             case FFEINFO_basictypeCOMPLEX:
 725               switch (ffeinfo_kindtype (ffebld_info (l)))
 726                 {
 727 #if FFETARGET_okCOMPLEX1
 728                 case FFEINFO_kindtypeREAL1:
 729                   error = ffetarget_convert_integer2_complex1
 730                     (ffebld_cu_ptr_integer2 (u),
 731                      ffebld_constant_complex1 (ffebld_conter (l)));
 732                   break;
 733 #endif
 734
 735 #if FFETARGET_okCOMPLEX2
 736                 case FFEINFO_kindtypeREAL2:
 737                   error = ffetarget_convert_integer2_complex2
 738                     (ffebld_cu_ptr_integer2 (u),
 739                      ffebld_constant_complex2 (ffebld_conter (l)));
 740                   break;
 741 #endif
 742
 743 #if FFETARGET_okCOMPLEX3
 744                 case FFEINFO_kindtypeREAL3:
 745                   error = ffetarget_convert_integer2_complex3
 746                     (ffebld_cu_ptr_integer2 (u),
 747                      ffebld_constant_complex3 (ffebld_conter (l)));
 748                   break;
 749 #endif
 750
 751 #if FFETARGET_okCOMPLEX4
 752                 case FFEINFO_kindtypeREAL4:
 753                   error = ffetarget_convert_integer2_complex4
 754                     (ffebld_cu_ptr_integer2 (u),
 755                      ffebld_constant_complex4 (ffebld_conter (l)));
 756                   break;
 757 #endif
 758
 759                 default:
 760                   assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
 761                   break;
 762                 }
 763               break;
 764
 765             case FFEINFO_basictypeLOGICAL:
 766               switch (ffeinfo_kindtype (ffebld_info (l)))
 767                 {
 768 #if FFETARGET_okLOGICAL1
 769                 case FFEINFO_kindtypeLOGICAL1:
 770                   error = ffetarget_convert_integer2_logical1
 771                     (ffebld_cu_ptr_integer2 (u),
 772                      ffebld_constant_logical1 (ffebld_conter (l)));
 773                   break;
 774 #endif
 775
 776 #if FFETARGET_okLOGICAL2
 777                 case FFEINFO_kindtypeLOGICAL2:
 778                   error = ffetarget_convert_integer2_logical2
 779                     (ffebld_cu_ptr_integer2 (u),
 780                      ffebld_constant_logical2 (ffebld_conter (l)));
 781                   break;
 782 #endif
 783
 784 #if FFETARGET_okLOGICAL3
 785                 case FFEINFO_kindtypeLOGICAL3:
 786                   error = ffetarget_convert_integer2_logical3
 787                     (ffebld_cu_ptr_integer2 (u),
 788                      ffebld_constant_logical3 (ffebld_conter (l)));
 789                   break;
 790 #endif
 791
 792 #if FFETARGET_okLOGICAL4
 793                 case FFEINFO_kindtypeLOGICAL4:
 794                   error = ffetarget_convert_integer2_logical4
 795                     (ffebld_cu_ptr_integer2 (u),
 796                      ffebld_constant_logical4 (ffebld_conter (l)));
 797                   break;
 798 #endif
 799
 800                 default:
 801                   assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
 802                   break;
 803                 }
 804               break;
 805
 806             case FFEINFO_basictypeCHARACTER:
 807               error = ffetarget_convert_integer2_character1
 808                 (ffebld_cu_ptr_integer2 (u),
 809                  ffebld_constant_character1 (ffebld_conter (l)));
 810               break;
 811
 812             case FFEINFO_basictypeHOLLERITH:
 813               error = ffetarget_convert_integer2_hollerith
 814                 (ffebld_cu_ptr_integer2 (u),
 815                  ffebld_constant_hollerith (ffebld_conter (l)));
 816               break;
 817
 818             case FFEINFO_basictypeTYPELESS:
 819               error = ffetarget_convert_integer2_typeless
 820                 (ffebld_cu_ptr_integer2 (u),
 821                  ffebld_constant_typeless (ffebld_conter (l)));
 822               break;
 823
 824             default:
 825               assert ("INTEGER2 bad type" == NULL);
 826               break;
 827             }
 828
 829           /* If conversion operation is not implemented, return original expr.  */
 830           if (error == FFEBAD_NOCANDO)
 831             return expr;
 832
 833           expr = ffebld_new_conter_with_orig
 834             (ffebld_constant_new_integer2_val
 835              (ffebld_cu_val_integer2 (u)), expr);
 836           break;
 837 #endif
 838
 839 #if FFETARGET_okINTEGER3
 840         case FFEINFO_kindtypeINTEGER3:
 841           switch (ffeinfo_basictype (ffebld_info (l)))
 842             {
 843             case FFEINFO_basictypeINTEGER:
 844               switch (ffeinfo_kindtype (ffebld_info (l)))
 845                 {
 846 #if FFETARGET_okINTEGER1
 847                 case FFEINFO_kindtypeINTEGER1:
 848                   error = ffetarget_convert_integer3_integer1
 849                     (ffebld_cu_ptr_integer3 (u),
 850                      ffebld_constant_integer1 (ffebld_conter (l)));
 851                   break;
 852 #endif
 853
 854 #if FFETARGET_okINTEGER2
 855                 case FFEINFO_kindtypeINTEGER2:
 856                   error = ffetarget_convert_integer3_integer2
 857                     (ffebld_cu_ptr_integer3 (u),
 858                      ffebld_constant_integer2 (ffebld_conter (l)));
 859                   break;
 860 #endif
 861
 862 #if FFETARGET_okINTEGER4
 863                 case FFEINFO_kindtypeINTEGER4:
 864                   error = ffetarget_convert_integer3_integer4
 865                     (ffebld_cu_ptr_integer3 (u),
 866                      ffebld_constant_integer4 (ffebld_conter (l)));
 867                   break;
 868 #endif
 869
 870                 default:
 871                   assert ("INTEGER3/INTEGER bad source kind type" == NULL);
 872                   break;
 873                 }
 874               break;
 875
 876             case FFEINFO_basictypeREAL:
 877               switch (ffeinfo_kindtype (ffebld_info (l)))
 878                 {
 879 #if FFETARGET_okREAL1
 880                 case FFEINFO_kindtypeREAL1:
 881                   error = ffetarget_convert_integer3_real1
 882                     (ffebld_cu_ptr_integer3 (u),
 883                      ffebld_constant_real1 (ffebld_conter (l)));
 884                   break;
 885 #endif
 886
 887 #if FFETARGET_okREAL2
 888                 case FFEINFO_kindtypeREAL2:
 889                   error = ffetarget_convert_integer3_real2
 890                     (ffebld_cu_ptr_integer3 (u),
 891                      ffebld_constant_real2 (ffebld_conter (l)));
 892                   break;
 893 #endif
 894
 895 #if FFETARGET_okREAL3
 896                 case FFEINFO_kindtypeREAL3:
 897                   error = ffetarget_convert_integer3_real3
 898                     (ffebld_cu_ptr_integer3 (u),
 899                      ffebld_constant_real3 (ffebld_conter (l)));
 900                   break;
 901 #endif
 902
 903 #if FFETARGET_okREAL4
 904                 case FFEINFO_kindtypeREAL4:
 905                   error = ffetarget_convert_integer3_real4
 906                     (ffebld_cu_ptr_integer3 (u),
 907                      ffebld_constant_real4 (ffebld_conter (l)));
 908                   break;
 909 #endif
 910
 911                 default:
 912                   assert ("INTEGER3/REAL bad source kind type" == NULL);
 913                   break;
 914                 }
 915               break;
 916
 917             case FFEINFO_basictypeCOMPLEX:
 918               switch (ffeinfo_kindtype (ffebld_info (l)))
 919                 {
 920 #if FFETARGET_okCOMPLEX1
 921                 case FFEINFO_kindtypeREAL1:
 922                   error = ffetarget_convert_integer3_complex1
 923                     (ffebld_cu_ptr_integer3 (u),
 924                      ffebld_constant_complex1 (ffebld_conter (l)));
 925                   break;
 926 #endif
 927
 928 #if FFETARGET_okCOMPLEX2
 929                 case FFEINFO_kindtypeREAL2:
 930                   error = ffetarget_convert_integer3_complex2
 931                     (ffebld_cu_ptr_integer3 (u),
 932                      ffebld_constant_complex2 (ffebld_conter (l)));
 933                   break;
 934 #endif
 935
 936 #if FFETARGET_okCOMPLEX3
 937                 case FFEINFO_kindtypeREAL3:
 938                   error = ffetarget_convert_integer3_complex3
 939                     (ffebld_cu_ptr_integer3 (u),
 940                      ffebld_constant_complex3 (ffebld_conter (l)));
 941                   break;
 942 #endif
 943
 944 #if FFETARGET_okCOMPLEX4
 945                 case FFEINFO_kindtypeREAL4:
 946                   error = ffetarget_convert_integer3_complex4
 947                     (ffebld_cu_ptr_integer3 (u),
 948                      ffebld_constant_complex4 (ffebld_conter (l)));
 949                   break;
 950 #endif
 951
 952                 default:
 953                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
 954                   break;
 955                 }
 956               break;
 957
 958             case FFEINFO_basictypeLOGICAL:
 959               switch (ffeinfo_kindtype (ffebld_info (l)))
 960                 {
 961 #if FFETARGET_okLOGICAL1
 962                 case FFEINFO_kindtypeLOGICAL1:
 963                   error = ffetarget_convert_integer3_logical1
 964                     (ffebld_cu_ptr_integer3 (u),
 965                      ffebld_constant_logical1 (ffebld_conter (l)));
 966                   break;
 967 #endif
 968
 969 #if FFETARGET_okLOGICAL2
 970                 case FFEINFO_kindtypeLOGICAL2:
 971                   error = ffetarget_convert_integer3_logical2
 972                     (ffebld_cu_ptr_integer3 (u),
 973                      ffebld_constant_logical2 (ffebld_conter (l)));
 974                   break;
 975 #endif
 976
 977 #if FFETARGET_okLOGICAL3
 978                 case FFEINFO_kindtypeLOGICAL3:
 979                   error = ffetarget_convert_integer3_logical3
 980                     (ffebld_cu_ptr_integer3 (u),
 981                      ffebld_constant_logical3 (ffebld_conter (l)));
 982                   break;
 983 #endif
 984
 985 #if FFETARGET_okLOGICAL4
 986                 case FFEINFO_kindtypeLOGICAL4:
 987                   error = ffetarget_convert_integer3_logical4
 988                     (ffebld_cu_ptr_integer3 (u),
 989                      ffebld_constant_logical4 (ffebld_conter (l)));
 990                   break;
 991 #endif
 992
 993                 default:
 994                   assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
 995                   break;
 996                 }
 997               break;
 998
 999             case FFEINFO_basictypeCHARACTER:
1000               error = ffetarget_convert_integer3_character1
1001                 (ffebld_cu_ptr_integer3 (u),
1002                  ffebld_constant_character1 (ffebld_conter (l)));
1003               break;
1004
1005             case FFEINFO_basictypeHOLLERITH:
1006               error = ffetarget_convert_integer3_hollerith
1007                 (ffebld_cu_ptr_integer3 (u),
1008                  ffebld_constant_hollerith (ffebld_conter (l)));
1009               break;
1010
1011             case FFEINFO_basictypeTYPELESS:
1012               error = ffetarget_convert_integer3_typeless
1013                 (ffebld_cu_ptr_integer3 (u),
1014                  ffebld_constant_typeless (ffebld_conter (l)));
1015               break;
1016
1017             default:
1018               assert ("INTEGER3 bad type" == NULL);
1019               break;
1020             }
1021
1022           /* If conversion operation is not implemented, return original expr.  */
1023           if (error == FFEBAD_NOCANDO)
1024             return expr;
1025
1026           expr = ffebld_new_conter_with_orig
1027             (ffebld_constant_new_integer3_val
1028              (ffebld_cu_val_integer3 (u)), expr);
1029           break;
1030 #endif
1031
1032 #if FFETARGET_okINTEGER4
1033         case FFEINFO_kindtypeINTEGER4:
1034           switch (ffeinfo_basictype (ffebld_info (l)))
1035             {
1036             case FFEINFO_basictypeINTEGER:
1037               switch (ffeinfo_kindtype (ffebld_info (l)))
1038                 {
1039 #if FFETARGET_okINTEGER1
1040                 case FFEINFO_kindtypeINTEGER1:
1041                   error = ffetarget_convert_integer4_integer1
1042                     (ffebld_cu_ptr_integer4 (u),
1043                      ffebld_constant_integer1 (ffebld_conter (l)));
1044                   break;
1045 #endif
1046
1047 #if FFETARGET_okINTEGER2
1048                 case FFEINFO_kindtypeINTEGER2:
1049                   error = ffetarget_convert_integer4_integer2
1050                     (ffebld_cu_ptr_integer4 (u),
1051                      ffebld_constant_integer2 (ffebld_conter (l)));
1052                   break;
1053 #endif
1054
1055 #if FFETARGET_okINTEGER3
1056                 case FFEINFO_kindtypeINTEGER3:
1057                   error = ffetarget_convert_integer4_integer3
1058                     (ffebld_cu_ptr_integer4 (u),
1059                      ffebld_constant_integer3 (ffebld_conter (l)));
1060                   break;
1061 #endif
1062
1063                 default:
1064                   assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1065                   break;
1066                 }
1067               break;
1068
1069             case FFEINFO_basictypeREAL:
1070               switch (ffeinfo_kindtype (ffebld_info (l)))
1071                 {
1072 #if FFETARGET_okREAL1
1073                 case FFEINFO_kindtypeREAL1:
1074                   error = ffetarget_convert_integer4_real1
1075                     (ffebld_cu_ptr_integer4 (u),
1076                      ffebld_constant_real1 (ffebld_conter (l)));
1077                   break;
1078 #endif
1079
1080 #if FFETARGET_okREAL2
1081                 case FFEINFO_kindtypeREAL2:
1082                   error = ffetarget_convert_integer4_real2
1083                     (ffebld_cu_ptr_integer4 (u),
1084                      ffebld_constant_real2 (ffebld_conter (l)));
1085                   break;
1086 #endif
1087
1088 #if FFETARGET_okREAL3
1089                 case FFEINFO_kindtypeREAL3:
1090                   error = ffetarget_convert_integer4_real3
1091                     (ffebld_cu_ptr_integer4 (u),
1092                      ffebld_constant_real3 (ffebld_conter (l)));
1093                   break;
1094 #endif
1095
1096 #if FFETARGET_okREAL4
1097                 case FFEINFO_kindtypeREAL4:
1098                   error = ffetarget_convert_integer4_real4
1099                     (ffebld_cu_ptr_integer4 (u),
1100                      ffebld_constant_real4 (ffebld_conter (l)));
1101                   break;
1102 #endif
1103
1104                 default:
1105                   assert ("INTEGER4/REAL bad source kind type" == NULL);
1106                   break;
1107                 }
1108               break;
1109
1110             case FFEINFO_basictypeCOMPLEX:
1111               switch (ffeinfo_kindtype (ffebld_info (l)))
1112                 {
1113 #if FFETARGET_okCOMPLEX1
1114                 case FFEINFO_kindtypeREAL1:
1115                   error = ffetarget_convert_integer4_complex1
1116                     (ffebld_cu_ptr_integer4 (u),
1117                      ffebld_constant_complex1 (ffebld_conter (l)));
1118                   break;
1119 #endif
1120
1121 #if FFETARGET_okCOMPLEX2
1122                 case FFEINFO_kindtypeREAL2:
1123                   error = ffetarget_convert_integer4_complex2
1124                     (ffebld_cu_ptr_integer4 (u),
1125                      ffebld_constant_complex2 (ffebld_conter (l)));
1126                   break;
1127 #endif
1128
1129 #if FFETARGET_okCOMPLEX3
1130                 case FFEINFO_kindtypeREAL3:
1131                   error = ffetarget_convert_integer4_complex3
1132                     (ffebld_cu_ptr_integer4 (u),
1133                      ffebld_constant_complex3 (ffebld_conter (l)));
1134                   break;
1135 #endif
1136
1137 #if FFETARGET_okCOMPLEX4
1138                 case FFEINFO_kindtypeREAL4:
1139                   error = ffetarget_convert_integer4_complex4
1140                     (ffebld_cu_ptr_integer4 (u),
1141                      ffebld_constant_complex4 (ffebld_conter (l)));
1142                   break;
1143 #endif
1144
1145                 default:
1146                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1147                   break;
1148                 }
1149               break;
1150
1151             case FFEINFO_basictypeLOGICAL:
1152               switch (ffeinfo_kindtype (ffebld_info (l)))
1153                 {
1154 #if FFETARGET_okLOGICAL1
1155                 case FFEINFO_kindtypeLOGICAL1:
1156                   error = ffetarget_convert_integer4_logical1
1157                     (ffebld_cu_ptr_integer4 (u),
1158                      ffebld_constant_logical1 (ffebld_conter (l)));
1159                   break;
1160 #endif
1161
1162 #if FFETARGET_okLOGICAL2
1163                 case FFEINFO_kindtypeLOGICAL2:
1164                   error = ffetarget_convert_integer4_logical2
1165                     (ffebld_cu_ptr_integer4 (u),
1166                      ffebld_constant_logical2 (ffebld_conter (l)));
1167                   break;
1168 #endif
1169
1170 #if FFETARGET_okLOGICAL3
1171                 case FFEINFO_kindtypeLOGICAL3:
1172                   error = ffetarget_convert_integer4_logical3
1173                     (ffebld_cu_ptr_integer4 (u),
1174                      ffebld_constant_logical3 (ffebld_conter (l)));
1175                   break;
1176 #endif
1177
1178 #if FFETARGET_okLOGICAL4
1179                 case FFEINFO_kindtypeLOGICAL4:
1180                   error = ffetarget_convert_integer4_logical4
1181                     (ffebld_cu_ptr_integer4 (u),
1182                      ffebld_constant_logical4 (ffebld_conter (l)));
1183                   break;
1184 #endif
1185
1186                 default:
1187                   assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1188                   break;
1189                 }
1190               break;
1191
1192             case FFEINFO_basictypeCHARACTER:
1193               error = ffetarget_convert_integer4_character1
1194                 (ffebld_cu_ptr_integer4 (u),
1195                  ffebld_constant_character1 (ffebld_conter (l)));
1196               break;
1197
1198             case FFEINFO_basictypeHOLLERITH:
1199               error = ffetarget_convert_integer4_hollerith
1200                 (ffebld_cu_ptr_integer4 (u),
1201                  ffebld_constant_hollerith (ffebld_conter (l)));
1202               break;
1203
1204             case FFEINFO_basictypeTYPELESS:
1205               error = ffetarget_convert_integer4_typeless
1206                 (ffebld_cu_ptr_integer4 (u),
1207                  ffebld_constant_typeless (ffebld_conter (l)));
1208               break;
1209
1210             default:
1211               assert ("INTEGER4 bad type" == NULL);
1212               break;
1213             }
1214
1215           /* If conversion operation is not implemented, return original expr.  */
1216           if (error == FFEBAD_NOCANDO)
1217             return expr;
1218
1219           expr = ffebld_new_conter_with_orig
1220             (ffebld_constant_new_integer4_val
1221              (ffebld_cu_val_integer4 (u)), expr);
1222           break;
1223 #endif
1224
1225         default:
1226           assert ("bad integer kind type" == NULL);
1227           break;
1228         }
1229       break;
1230
1231     case FFEINFO_basictypeLOGICAL:
1232       sz = FFETARGET_charactersizeNONE;
1233       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1234         {
1235 #if FFETARGET_okLOGICAL1
1236         case FFEINFO_kindtypeLOGICAL1:
1237           switch (ffeinfo_basictype (ffebld_info (l)))
1238             {
1239             case FFEINFO_basictypeLOGICAL:
1240               switch (ffeinfo_kindtype (ffebld_info (l)))
1241                 {
1242 #if FFETARGET_okLOGICAL2
1243                 case FFEINFO_kindtypeLOGICAL2:
1244                   error = ffetarget_convert_logical1_logical2
1245                     (ffebld_cu_ptr_logical1 (u),
1246                      ffebld_constant_logical2 (ffebld_conter (l)));
1247                   break;
1248 #endif
1249
1250 #if FFETARGET_okLOGICAL3
1251                 case FFEINFO_kindtypeLOGICAL3:
1252                   error = ffetarget_convert_logical1_logical3
1253                     (ffebld_cu_ptr_logical1 (u),
1254                      ffebld_constant_logical3 (ffebld_conter (l)));
1255                   break;
1256 #endif
1257
1258 #if FFETARGET_okLOGICAL4
1259                 case FFEINFO_kindtypeLOGICAL4:
1260                   error = ffetarget_convert_logical1_logical4
1261                     (ffebld_cu_ptr_logical1 (u),
1262                      ffebld_constant_logical4 (ffebld_conter (l)));
1263                   break;
1264 #endif
1265
1266                 default:
1267                   assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1268                   break;
1269                 }
1270               break;
1271
1272             case FFEINFO_basictypeINTEGER:
1273               switch (ffeinfo_kindtype (ffebld_info (l)))
1274                 {
1275 #if FFETARGET_okINTEGER1
1276                 case FFEINFO_kindtypeINTEGER1:
1277                   error = ffetarget_convert_logical1_integer1
1278                     (ffebld_cu_ptr_logical1 (u),
1279                      ffebld_constant_integer1 (ffebld_conter (l)));
1280                   break;
1281 #endif
1282
1283 #if FFETARGET_okINTEGER2
1284                 case FFEINFO_kindtypeINTEGER2:
1285                   error = ffetarget_convert_logical1_integer2
1286                     (ffebld_cu_ptr_logical1 (u),
1287                      ffebld_constant_integer2 (ffebld_conter (l)));
1288                   break;
1289 #endif
1290
1291 #if FFETARGET_okINTEGER3
1292                 case FFEINFO_kindtypeINTEGER3:
1293                   error = ffetarget_convert_logical1_integer3
1294                     (ffebld_cu_ptr_logical1 (u),
1295                      ffebld_constant_integer3 (ffebld_conter (l)));
1296                   break;
1297 #endif
1298
1299 #if FFETARGET_okINTEGER4
1300                 case FFEINFO_kindtypeINTEGER4:
1301                   error = ffetarget_convert_logical1_integer4
1302                     (ffebld_cu_ptr_logical1 (u),
1303                      ffebld_constant_integer4 (ffebld_conter (l)));
1304                   break;
1305 #endif
1306
1307                 default:
1308                   assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1309                   break;
1310                 }
1311               break;
1312
1313             case FFEINFO_basictypeCHARACTER:
1314               error = ffetarget_convert_logical1_character1
1315                 (ffebld_cu_ptr_logical1 (u),
1316                  ffebld_constant_character1 (ffebld_conter (l)));
1317               break;
1318
1319             case FFEINFO_basictypeHOLLERITH:
1320               error = ffetarget_convert_logical1_hollerith
1321                 (ffebld_cu_ptr_logical1 (u),
1322                  ffebld_constant_hollerith (ffebld_conter (l)));
1323               break;
1324
1325             case FFEINFO_basictypeTYPELESS:
1326               error = ffetarget_convert_logical1_typeless
1327                 (ffebld_cu_ptr_logical1 (u),
1328                  ffebld_constant_typeless (ffebld_conter (l)));
1329               break;
1330
1331             default:
1332               assert ("LOGICAL1 bad type" == NULL);
1333               break;
1334             }
1335
1336           /* If conversion operation is not implemented, return original expr.  */
1337           if (error == FFEBAD_NOCANDO)
1338             return expr;
1339
1340           expr = ffebld_new_conter_with_orig
1341             (ffebld_constant_new_logical1_val
1342              (ffebld_cu_val_logical1 (u)), expr);
1343           break;
1344 #endif
1345
1346 #if FFETARGET_okLOGICAL2
1347         case FFEINFO_kindtypeLOGICAL2:
1348           switch (ffeinfo_basictype (ffebld_info (l)))
1349             {
1350             case FFEINFO_basictypeLOGICAL:
1351               switch (ffeinfo_kindtype (ffebld_info (l)))
1352                 {
1353 #if FFETARGET_okLOGICAL1
1354                 case FFEINFO_kindtypeLOGICAL1:
1355                   error = ffetarget_convert_logical2_logical1
1356                     (ffebld_cu_ptr_logical2 (u),
1357                      ffebld_constant_logical1 (ffebld_conter (l)));
1358                   break;
1359 #endif
1360
1361 #if FFETARGET_okLOGICAL3
1362                 case FFEINFO_kindtypeLOGICAL3:
1363                   error = ffetarget_convert_logical2_logical3
1364                     (ffebld_cu_ptr_logical2 (u),
1365                      ffebld_constant_logical3 (ffebld_conter (l)));
1366                   break;
1367 #endif
1368
1369 #if FFETARGET_okLOGICAL4
1370                 case FFEINFO_kindtypeLOGICAL4:
1371                   error = ffetarget_convert_logical2_logical4
1372                     (ffebld_cu_ptr_logical2 (u),
1373                      ffebld_constant_logical4 (ffebld_conter (l)));
1374                   break;
1375 #endif
1376
1377                 default:
1378                   assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1379                   break;
1380                 }
1381               break;
1382
1383             case FFEINFO_basictypeINTEGER:
1384               switch (ffeinfo_kindtype (ffebld_info (l)))
1385                 {
1386 #if FFETARGET_okINTEGER1
1387                 case FFEINFO_kindtypeINTEGER1:
1388                   error = ffetarget_convert_logical2_integer1
1389                     (ffebld_cu_ptr_logical2 (u),
1390                      ffebld_constant_integer1 (ffebld_conter (l)));
1391                   break;
1392 #endif
1393
1394 #if FFETARGET_okINTEGER2
1395                 case FFEINFO_kindtypeINTEGER2:
1396                   error = ffetarget_convert_logical2_integer2
1397                     (ffebld_cu_ptr_logical2 (u),
1398                      ffebld_constant_integer2 (ffebld_conter (l)));
1399                   break;
1400 #endif
1401
1402 #if FFETARGET_okINTEGER3
1403                 case FFEINFO_kindtypeINTEGER3:
1404                   error = ffetarget_convert_logical2_integer3
1405                     (ffebld_cu_ptr_logical2 (u),
1406                      ffebld_constant_integer3 (ffebld_conter (l)));
1407                   break;
1408 #endif
1409
1410 #if FFETARGET_okINTEGER4
1411                 case FFEINFO_kindtypeINTEGER4:
1412                   error = ffetarget_convert_logical2_integer4
1413                     (ffebld_cu_ptr_logical2 (u),
1414                      ffebld_constant_integer4 (ffebld_conter (l)));
1415                   break;
1416 #endif
1417
1418                 default:
1419                   assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1420                   break;
1421                 }
1422               break;
1423
1424             case FFEINFO_basictypeCHARACTER:
1425               error = ffetarget_convert_logical2_character1
1426                 (ffebld_cu_ptr_logical2 (u),
1427                  ffebld_constant_character1 (ffebld_conter (l)));
1428               break;
1429
1430             case FFEINFO_basictypeHOLLERITH:
1431               error = ffetarget_convert_logical2_hollerith
1432                 (ffebld_cu_ptr_logical2 (u),
1433                  ffebld_constant_hollerith (ffebld_conter (l)));
1434               break;
1435
1436             case FFEINFO_basictypeTYPELESS:
1437               error = ffetarget_convert_logical2_typeless
1438                 (ffebld_cu_ptr_logical2 (u),
1439                  ffebld_constant_typeless (ffebld_conter (l)));
1440               break;
1441
1442             default:
1443               assert ("LOGICAL2 bad type" == NULL);
1444               break;
1445             }
1446
1447           /* If conversion operation is not implemented, return original expr.  */
1448           if (error == FFEBAD_NOCANDO)
1449             return expr;
1450
1451           expr = ffebld_new_conter_with_orig
1452             (ffebld_constant_new_logical2_val
1453              (ffebld_cu_val_logical2 (u)), expr);
1454           break;
1455 #endif
1456
1457 #if FFETARGET_okLOGICAL3
1458         case FFEINFO_kindtypeLOGICAL3:
1459           switch (ffeinfo_basictype (ffebld_info (l)))
1460             {
1461             case FFEINFO_basictypeLOGICAL:
1462               switch (ffeinfo_kindtype (ffebld_info (l)))
1463                 {
1464 #if FFETARGET_okLOGICAL1
1465                 case FFEINFO_kindtypeLOGICAL1:
1466                   error = ffetarget_convert_logical3_logical1
1467                     (ffebld_cu_ptr_logical3 (u),
1468                      ffebld_constant_logical1 (ffebld_conter (l)));
1469                   break;
1470 #endif
1471
1472 #if FFETARGET_okLOGICAL2
1473                 case FFEINFO_kindtypeLOGICAL2:
1474                   error = ffetarget_convert_logical3_logical2
1475                     (ffebld_cu_ptr_logical3 (u),
1476                      ffebld_constant_logical2 (ffebld_conter (l)));
1477                   break;
1478 #endif
1479
1480 #if FFETARGET_okLOGICAL4
1481                 case FFEINFO_kindtypeLOGICAL4:
1482                   error = ffetarget_convert_logical3_logical4
1483                     (ffebld_cu_ptr_logical3 (u),
1484                      ffebld_constant_logical4 (ffebld_conter (l)));
1485                   break;
1486 #endif
1487
1488                 default:
1489                   assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1490                   break;
1491                 }
1492               break;
1493
1494             case FFEINFO_basictypeINTEGER:
1495               switch (ffeinfo_kindtype (ffebld_info (l)))
1496                 {
1497 #if FFETARGET_okINTEGER1
1498                 case FFEINFO_kindtypeINTEGER1:
1499                   error = ffetarget_convert_logical3_integer1
1500                     (ffebld_cu_ptr_logical3 (u),
1501                      ffebld_constant_integer1 (ffebld_conter (l)));
1502                   break;
1503 #endif
1504
1505 #if FFETARGET_okINTEGER2
1506                 case FFEINFO_kindtypeINTEGER2:
1507                   error = ffetarget_convert_logical3_integer2
1508                     (ffebld_cu_ptr_logical3 (u),
1509                      ffebld_constant_integer2 (ffebld_conter (l)));
1510                   break;
1511 #endif
1512
1513 #if FFETARGET_okINTEGER3
1514                 case FFEINFO_kindtypeINTEGER3:
1515                   error = ffetarget_convert_logical3_integer3
1516                     (ffebld_cu_ptr_logical3 (u),
1517                      ffebld_constant_integer3 (ffebld_conter (l)));
1518                   break;
1519 #endif
1520
1521 #if FFETARGET_okINTEGER4
1522                 case FFEINFO_kindtypeINTEGER4:
1523                   error = ffetarget_convert_logical3_integer4
1524                     (ffebld_cu_ptr_logical3 (u),
1525                      ffebld_constant_integer4 (ffebld_conter (l)));
1526                   break;
1527 #endif
1528
1529                 default:
1530                   assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1531                   break;
1532                 }
1533               break;
1534
1535             case FFEINFO_basictypeCHARACTER:
1536               error = ffetarget_convert_logical3_character1
1537                 (ffebld_cu_ptr_logical3 (u),
1538                  ffebld_constant_character1 (ffebld_conter (l)));
1539               break;
1540
1541             case FFEINFO_basictypeHOLLERITH:
1542               error = ffetarget_convert_logical3_hollerith
1543                 (ffebld_cu_ptr_logical3 (u),
1544                  ffebld_constant_hollerith (ffebld_conter (l)));
1545               break;
1546
1547             case FFEINFO_basictypeTYPELESS:
1548               error = ffetarget_convert_logical3_typeless
1549                 (ffebld_cu_ptr_logical3 (u),
1550                  ffebld_constant_typeless (ffebld_conter (l)));
1551               break;
1552
1553             default:
1554               assert ("LOGICAL3 bad type" == NULL);
1555               break;
1556             }
1557
1558           /* If conversion operation is not implemented, return original expr.  */
1559           if (error == FFEBAD_NOCANDO)
1560             return expr;
1561
1562           expr = ffebld_new_conter_with_orig
1563             (ffebld_constant_new_logical3_val
1564              (ffebld_cu_val_logical3 (u)), expr);
1565           break;
1566 #endif
1567
1568 #if FFETARGET_okLOGICAL4
1569         case FFEINFO_kindtypeLOGICAL4:
1570           switch (ffeinfo_basictype (ffebld_info (l)))
1571             {
1572             case FFEINFO_basictypeLOGICAL:
1573               switch (ffeinfo_kindtype (ffebld_info (l)))
1574                 {
1575 #if FFETARGET_okLOGICAL1
1576                 case FFEINFO_kindtypeLOGICAL1:
1577                   error = ffetarget_convert_logical4_logical1
1578                     (ffebld_cu_ptr_logical4 (u),
1579                      ffebld_constant_logical1 (ffebld_conter (l)));
1580                   break;
1581 #endif
1582
1583 #if FFETARGET_okLOGICAL2
1584                 case FFEINFO_kindtypeLOGICAL2:
1585                   error = ffetarget_convert_logical4_logical2
1586                     (ffebld_cu_ptr_logical4 (u),
1587                      ffebld_constant_logical2 (ffebld_conter (l)));
1588                   break;
1589 #endif
1590
1591 #if FFETARGET_okLOGICAL3
1592                 case FFEINFO_kindtypeLOGICAL3:
1593                   error = ffetarget_convert_logical4_logical3
1594                     (ffebld_cu_ptr_logical4 (u),
1595                      ffebld_constant_logical3 (ffebld_conter (l)));
1596                   break;
1597 #endif
1598
1599                 default:
1600                   assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1601                   break;
1602                 }
1603               break;
1604
1605             case FFEINFO_basictypeINTEGER:
1606               switch (ffeinfo_kindtype (ffebld_info (l)))
1607                 {
1608 #if FFETARGET_okINTEGER1
1609                 case FFEINFO_kindtypeINTEGER1:
1610                   error = ffetarget_convert_logical4_integer1
1611                     (ffebld_cu_ptr_logical4 (u),
1612                      ffebld_constant_integer1 (ffebld_conter (l)));
1613                   break;
1614 #endif
1615
1616 #if FFETARGET_okINTEGER2
1617                 case FFEINFO_kindtypeINTEGER2:
1618                   error = ffetarget_convert_logical4_integer2
1619                     (ffebld_cu_ptr_logical4 (u),
1620                      ffebld_constant_integer2 (ffebld_conter (l)));
1621                   break;
1622 #endif
1623
1624 #if FFETARGET_okINTEGER3
1625                 case FFEINFO_kindtypeINTEGER3:
1626                   error = ffetarget_convert_logical4_integer3
1627                     (ffebld_cu_ptr_logical4 (u),
1628                      ffebld_constant_integer3 (ffebld_conter (l)));
1629                   break;
1630 #endif
1631
1632 #if FFETARGET_okINTEGER4
1633                 case FFEINFO_kindtypeINTEGER4:
1634                   error = ffetarget_convert_logical4_integer4
1635                     (ffebld_cu_ptr_logical4 (u),
1636                      ffebld_constant_integer4 (ffebld_conter (l)));
1637                   break;
1638 #endif
1639
1640                 default:
1641                   assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1642                   break;
1643                 }
1644               break;
1645
1646             case FFEINFO_basictypeCHARACTER:
1647               error = ffetarget_convert_logical4_character1
1648                 (ffebld_cu_ptr_logical4 (u),
1649                  ffebld_constant_character1 (ffebld_conter (l)));
1650               break;
1651
1652             case FFEINFO_basictypeHOLLERITH:
1653               error = ffetarget_convert_logical4_hollerith
1654                 (ffebld_cu_ptr_logical4 (u),
1655                  ffebld_constant_hollerith (ffebld_conter (l)));
1656               break;
1657
1658             case FFEINFO_basictypeTYPELESS:
1659               error = ffetarget_convert_logical4_typeless
1660                 (ffebld_cu_ptr_logical4 (u),
1661                  ffebld_constant_typeless (ffebld_conter (l)));
1662               break;
1663
1664             default:
1665               assert ("LOGICAL4 bad type" == NULL);
1666               break;
1667             }
1668
1669           /* If conversion operation is not implemented, return original expr.  */
1670           if (error == FFEBAD_NOCANDO)
1671             return expr;
1672
1673           expr = ffebld_new_conter_with_orig
1674             (ffebld_constant_new_logical4_val
1675              (ffebld_cu_val_logical4 (u)), expr);
1676           break;
1677 #endif
1678
1679         default:
1680           assert ("bad logical kind type" == NULL);
1681           break;
1682         }
1683       break;
1684
1685     case FFEINFO_basictypeREAL:
1686       sz = FFETARGET_charactersizeNONE;
1687       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1688         {
1689 #if FFETARGET_okREAL1
1690         case FFEINFO_kindtypeREAL1:
1691           switch (ffeinfo_basictype (ffebld_info (l)))
1692             {
1693             case FFEINFO_basictypeINTEGER:
1694               switch (ffeinfo_kindtype (ffebld_info (l)))
1695                 {
1696 #if FFETARGET_okINTEGER1
1697                 case FFEINFO_kindtypeINTEGER1:
1698                   error = ffetarget_convert_real1_integer1
1699                     (ffebld_cu_ptr_real1 (u),
1700                      ffebld_constant_integer1 (ffebld_conter (l)));
1701                   break;
1702 #endif
1703
1704 #if FFETARGET_okINTEGER2
1705                 case FFEINFO_kindtypeINTEGER2:
1706                   error = ffetarget_convert_real1_integer2
1707                     (ffebld_cu_ptr_real1 (u),
1708                      ffebld_constant_integer2 (ffebld_conter (l)));
1709                   break;
1710 #endif
1711
1712 #if FFETARGET_okINTEGER3
1713                 case FFEINFO_kindtypeINTEGER3:
1714                   error = ffetarget_convert_real1_integer3
1715                     (ffebld_cu_ptr_real1 (u),
1716                      ffebld_constant_integer3 (ffebld_conter (l)));
1717                   break;
1718 #endif
1719
1720 #if FFETARGET_okINTEGER4
1721                 case FFEINFO_kindtypeINTEGER4:
1722                   error = ffetarget_convert_real1_integer4
1723                     (ffebld_cu_ptr_real1 (u),
1724                      ffebld_constant_integer4 (ffebld_conter (l)));
1725                   break;
1726 #endif
1727
1728                 default:
1729                   assert ("REAL1/INTEGER bad source kind type" == NULL);
1730                   break;
1731                 }
1732               break;
1733
1734             case FFEINFO_basictypeREAL:
1735               switch (ffeinfo_kindtype (ffebld_info (l)))
1736                 {
1737 #if FFETARGET_okREAL2
1738                 case FFEINFO_kindtypeREAL2:
1739                   error = ffetarget_convert_real1_real2
1740                     (ffebld_cu_ptr_real1 (u),
1741                      ffebld_constant_real2 (ffebld_conter (l)));
1742                   break;
1743 #endif
1744
1745 #if FFETARGET_okREAL3
1746                 case FFEINFO_kindtypeREAL3:
1747                   error = ffetarget_convert_real1_real3
1748                     (ffebld_cu_ptr_real1 (u),
1749                      ffebld_constant_real3 (ffebld_conter (l)));
1750                   break;
1751 #endif
1752
1753 #if FFETARGET_okREAL4
1754                 case FFEINFO_kindtypeREAL4:
1755                   error = ffetarget_convert_real1_real4
1756                     (ffebld_cu_ptr_real1 (u),
1757                      ffebld_constant_real4 (ffebld_conter (l)));
1758                   break;
1759 #endif
1760
1761                 default:
1762                   assert ("REAL1/REAL bad source kind type" == NULL);
1763                   break;
1764                 }
1765               break;
1766
1767             case FFEINFO_basictypeCOMPLEX:
1768               switch (ffeinfo_kindtype (ffebld_info (l)))
1769                 {
1770 #if FFETARGET_okCOMPLEX1
1771                 case FFEINFO_kindtypeREAL1:
1772                   error = ffetarget_convert_real1_complex1
1773                     (ffebld_cu_ptr_real1 (u),
1774                      ffebld_constant_complex1 (ffebld_conter (l)));
1775                   break;
1776 #endif
1777
1778 #if FFETARGET_okCOMPLEX2
1779                 case FFEINFO_kindtypeREAL2:
1780                   error = ffetarget_convert_real1_complex2
1781                     (ffebld_cu_ptr_real1 (u),
1782                      ffebld_constant_complex2 (ffebld_conter (l)));
1783                   break;
1784 #endif
1785
1786 #if FFETARGET_okCOMPLEX3
1787                 case FFEINFO_kindtypeREAL3:
1788                   error = ffetarget_convert_real1_complex3
1789                     (ffebld_cu_ptr_real1 (u),
1790                      ffebld_constant_complex3 (ffebld_conter (l)));
1791                   break;
1792 #endif
1793
1794 #if FFETARGET_okCOMPLEX4
1795                 case FFEINFO_kindtypeREAL4:
1796                   error = ffetarget_convert_real1_complex4
1797                     (ffebld_cu_ptr_real1 (u),
1798                      ffebld_constant_complex4 (ffebld_conter (l)));
1799                   break;
1800 #endif
1801
1802                 default:
1803                   assert ("REAL1/COMPLEX bad source kind type" == NULL);
1804                   break;
1805                 }
1806               break;
1807
1808             case FFEINFO_basictypeCHARACTER:
1809               error = ffetarget_convert_real1_character1
1810                 (ffebld_cu_ptr_real1 (u),
1811                  ffebld_constant_character1 (ffebld_conter (l)));
1812               break;
1813
1814             case FFEINFO_basictypeHOLLERITH:
1815               error = ffetarget_convert_real1_hollerith
1816                 (ffebld_cu_ptr_real1 (u),
1817                  ffebld_constant_hollerith (ffebld_conter (l)));
1818               break;
1819
1820             case FFEINFO_basictypeTYPELESS:
1821               error = ffetarget_convert_real1_typeless
1822                 (ffebld_cu_ptr_real1 (u),
1823                  ffebld_constant_typeless (ffebld_conter (l)));
1824               break;
1825
1826             default:
1827               assert ("REAL1 bad type" == NULL);
1828               break;
1829             }
1830
1831           /* If conversion operation is not implemented, return original expr.  */
1832           if (error == FFEBAD_NOCANDO)
1833             return expr;
1834
1835           expr = ffebld_new_conter_with_orig
1836             (ffebld_constant_new_real1_val
1837              (ffebld_cu_val_real1 (u)), expr);
1838           break;
1839 #endif
1840
1841 #if FFETARGET_okREAL2
1842         case FFEINFO_kindtypeREAL2:
1843           switch (ffeinfo_basictype (ffebld_info (l)))
1844             {
1845             case FFEINFO_basictypeINTEGER:
1846               switch (ffeinfo_kindtype (ffebld_info (l)))
1847                 {
1848 #if FFETARGET_okINTEGER1
1849                 case FFEINFO_kindtypeINTEGER1:
1850                   error = ffetarget_convert_real2_integer1
1851                     (ffebld_cu_ptr_real2 (u),
1852                      ffebld_constant_integer1 (ffebld_conter (l)));
1853                   break;
1854 #endif
1855
1856 #if FFETARGET_okINTEGER2
1857                 case FFEINFO_kindtypeINTEGER2:
1858                   error = ffetarget_convert_real2_integer2
1859                     (ffebld_cu_ptr_real2 (u),
1860                      ffebld_constant_integer2 (ffebld_conter (l)));
1861                   break;
1862 #endif
1863
1864 #if FFETARGET_okINTEGER3
1865                 case FFEINFO_kindtypeINTEGER3:
1866                   error = ffetarget_convert_real2_integer3
1867                     (ffebld_cu_ptr_real2 (u),
1868                      ffebld_constant_integer3 (ffebld_conter (l)));
1869                   break;
1870 #endif
1871
1872 #if FFETARGET_okINTEGER4
1873                 case FFEINFO_kindtypeINTEGER4:
1874                   error = ffetarget_convert_real2_integer4
1875                     (ffebld_cu_ptr_real2 (u),
1876                      ffebld_constant_integer4 (ffebld_conter (l)));
1877                   break;
1878 #endif
1879
1880                 default:
1881                   assert ("REAL2/INTEGER bad source kind type" == NULL);
1882                   break;
1883                 }
1884               break;
1885
1886             case FFEINFO_basictypeREAL:
1887               switch (ffeinfo_kindtype (ffebld_info (l)))
1888                 {
1889 #if FFETARGET_okREAL1
1890                 case FFEINFO_kindtypeREAL1:
1891                   error = ffetarget_convert_real2_real1
1892                     (ffebld_cu_ptr_real2 (u),
1893                      ffebld_constant_real1 (ffebld_conter (l)));
1894                   break;
1895 #endif
1896
1897 #if FFETARGET_okREAL3
1898                 case FFEINFO_kindtypeREAL3:
1899                   error = ffetarget_convert_real2_real3
1900                     (ffebld_cu_ptr_real2 (u),
1901                      ffebld_constant_real3 (ffebld_conter (l)));
1902                   break;
1903 #endif
1904
1905 #if FFETARGET_okREAL4
1906                 case FFEINFO_kindtypeREAL4:
1907                   error = ffetarget_convert_real2_real4
1908                     (ffebld_cu_ptr_real2 (u),
1909                      ffebld_constant_real4 (ffebld_conter (l)));
1910                   break;
1911 #endif
1912
1913                 default:
1914                   assert ("REAL2/REAL bad source kind type" == NULL);
1915                   break;
1916                 }
1917               break;
1918
1919             case FFEINFO_basictypeCOMPLEX:
1920               switch (ffeinfo_kindtype (ffebld_info (l)))
1921                 {
1922 #if FFETARGET_okCOMPLEX1
1923                 case FFEINFO_kindtypeREAL1:
1924                   error = ffetarget_convert_real2_complex1
1925                     (ffebld_cu_ptr_real2 (u),
1926                      ffebld_constant_complex1 (ffebld_conter (l)));
1927                   break;
1928 #endif
1929
1930 #if FFETARGET_okCOMPLEX2
1931                 case FFEINFO_kindtypeREAL2:
1932                   error = ffetarget_convert_real2_complex2
1933                     (ffebld_cu_ptr_real2 (u),
1934                      ffebld_constant_complex2 (ffebld_conter (l)));
1935                   break;
1936 #endif
1937
1938 #if FFETARGET_okCOMPLEX3
1939                 case FFEINFO_kindtypeREAL3:
1940                   error = ffetarget_convert_real2_complex3
1941                     (ffebld_cu_ptr_real2 (u),
1942                      ffebld_constant_complex3 (ffebld_conter (l)));
1943                   break;
1944 #endif
1945
1946 #if FFETARGET_okCOMPLEX4
1947                 case FFEINFO_kindtypeREAL4:
1948                   error = ffetarget_convert_real2_complex4
1949                     (ffebld_cu_ptr_real2 (u),
1950                      ffebld_constant_complex4 (ffebld_conter (l)));
1951                   break;
1952 #endif
1953
1954                 default:
1955                   assert ("REAL2/COMPLEX bad source kind type" == NULL);
1956                   break;
1957                 }
1958               break;
1959
1960             case FFEINFO_basictypeCHARACTER:
1961               error = ffetarget_convert_real2_character1
1962                 (ffebld_cu_ptr_real2 (u),
1963                  ffebld_constant_character1 (ffebld_conter (l)));
1964               break;
1965
1966             case FFEINFO_basictypeHOLLERITH:
1967               error = ffetarget_convert_real2_hollerith
1968                 (ffebld_cu_ptr_real2 (u),
1969                  ffebld_constant_hollerith (ffebld_conter (l)));
1970               break;
1971
1972             case FFEINFO_basictypeTYPELESS:
1973               error = ffetarget_convert_real2_typeless
1974                 (ffebld_cu_ptr_real2 (u),
1975                  ffebld_constant_typeless (ffebld_conter (l)));
1976               break;
1977
1978             default:
1979               assert ("REAL2 bad type" == NULL);
1980               break;
1981             }
1982
1983           /* If conversion operation is not implemented, return original expr.  */
1984           if (error == FFEBAD_NOCANDO)
1985             return expr;
1986
1987           expr = ffebld_new_conter_with_orig
1988             (ffebld_constant_new_real2_val
1989              (ffebld_cu_val_real2 (u)), expr);
1990           break;
1991 #endif
1992
1993 #if FFETARGET_okREAL3
1994         case FFEINFO_kindtypeREAL3:
1995           switch (ffeinfo_basictype (ffebld_info (l)))
1996             {
1997             case FFEINFO_basictypeINTEGER:
1998               switch (ffeinfo_kindtype (ffebld_info (l)))
1999                 {
2000 #if FFETARGET_okINTEGER1
2001                 case FFEINFO_kindtypeINTEGER1:
2002                   error = ffetarget_convert_real3_integer1
2003                     (ffebld_cu_ptr_real3 (u),
2004                      ffebld_constant_integer1 (ffebld_conter (l)));
2005                   break;
2006 #endif
2007
2008 #if FFETARGET_okINTEGER2
2009                 case FFEINFO_kindtypeINTEGER2:
2010                   error = ffetarget_convert_real3_integer2
2011                     (ffebld_cu_ptr_real3 (u),
2012                      ffebld_constant_integer2 (ffebld_conter (l)));
2013                   break;
2014 #endif
2015
2016 #if FFETARGET_okINTEGER3
2017                 case FFEINFO_kindtypeINTEGER3:
2018                   error = ffetarget_convert_real3_integer3
2019                     (ffebld_cu_ptr_real3 (u),
2020                      ffebld_constant_integer3 (ffebld_conter (l)));
2021                   break;
2022 #endif
2023
2024 #if FFETARGET_okINTEGER4
2025                 case FFEINFO_kindtypeINTEGER4:
2026                   error = ffetarget_convert_real3_integer4
2027                     (ffebld_cu_ptr_real3 (u),
2028                      ffebld_constant_integer4 (ffebld_conter (l)));
2029                   break;
2030 #endif
2031
2032                 default:
2033                   assert ("REAL3/INTEGER bad source kind type" == NULL);
2034                   break;
2035                 }
2036               break;
2037
2038             case FFEINFO_basictypeREAL:
2039               switch (ffeinfo_kindtype (ffebld_info (l)))
2040                 {
2041 #if FFETARGET_okREAL1
2042                 case FFEINFO_kindtypeREAL1:
2043                   error = ffetarget_convert_real3_real1
2044                     (ffebld_cu_ptr_real3 (u),
2045                      ffebld_constant_real1 (ffebld_conter (l)));
2046                   break;
2047 #endif
2048
2049 #if FFETARGET_okREAL2
2050                 case FFEINFO_kindtypeREAL2:
2051                   error = ffetarget_convert_real3_real2
2052                     (ffebld_cu_ptr_real3 (u),
2053                      ffebld_constant_real2 (ffebld_conter (l)));
2054                   break;
2055 #endif
2056
2057 #if FFETARGET_okREAL4
2058                 case FFEINFO_kindtypeREAL4:
2059                   error = ffetarget_convert_real3_real4
2060                     (ffebld_cu_ptr_real3 (u),
2061                      ffebld_constant_real4 (ffebld_conter (l)));
2062                   break;
2063 #endif
2064
2065                 default:
2066                   assert ("REAL3/REAL bad source kind type" == NULL);
2067                   break;
2068                 }
2069               break;
2070
2071             case FFEINFO_basictypeCOMPLEX:
2072               switch (ffeinfo_kindtype (ffebld_info (l)))
2073                 {
2074 #if FFETARGET_okCOMPLEX1
2075                 case FFEINFO_kindtypeREAL1:
2076                   error = ffetarget_convert_real3_complex1
2077                     (ffebld_cu_ptr_real3 (u),
2078                      ffebld_constant_complex1 (ffebld_conter (l)));
2079                   break;
2080 #endif
2081
2082 #if FFETARGET_okCOMPLEX2
2083                 case FFEINFO_kindtypeREAL2:
2084                   error = ffetarget_convert_real3_complex2
2085                     (ffebld_cu_ptr_real3 (u),
2086                      ffebld_constant_complex2 (ffebld_conter (l)));
2087                   break;
2088 #endif
2089
2090 #if FFETARGET_okCOMPLEX3
2091                 case FFEINFO_kindtypeREAL3:
2092                   error = ffetarget_convert_real3_complex3
2093                     (ffebld_cu_ptr_real3 (u),
2094                      ffebld_constant_complex3 (ffebld_conter (l)));
2095                   break;
2096 #endif
2097
2098 #if FFETARGET_okCOMPLEX4
2099                 case FFEINFO_kindtypeREAL4:
2100                   error = ffetarget_convert_real3_complex4
2101                     (ffebld_cu_ptr_real3 (u),
2102                      ffebld_constant_complex4 (ffebld_conter (l)));
2103                   break;
2104 #endif
2105
2106                 default:
2107                   assert ("REAL3/COMPLEX bad source kind type" == NULL);
2108                   break;
2109                 }
2110               break;
2111
2112             case FFEINFO_basictypeCHARACTER:
2113               error = ffetarget_convert_real3_character1
2114                 (ffebld_cu_ptr_real3 (u),
2115                  ffebld_constant_character1 (ffebld_conter (l)));
2116               break;
2117
2118             case FFEINFO_basictypeHOLLERITH:
2119               error = ffetarget_convert_real3_hollerith
2120                 (ffebld_cu_ptr_real3 (u),
2121                  ffebld_constant_hollerith (ffebld_conter (l)));
2122               break;
2123
2124             case FFEINFO_basictypeTYPELESS:
2125               error = ffetarget_convert_real3_typeless
2126                 (ffebld_cu_ptr_real3 (u),
2127                  ffebld_constant_typeless (ffebld_conter (l)));
2128               break;
2129
2130             default:
2131               assert ("REAL3 bad type" == NULL);
2132               break;
2133             }
2134
2135           /* If conversion operation is not implemented, return original expr.  */
2136           if (error == FFEBAD_NOCANDO)
2137             return expr;
2138
2139           expr = ffebld_new_conter_with_orig
2140             (ffebld_constant_new_real3_val
2141              (ffebld_cu_val_real3 (u)), expr);
2142           break;
2143 #endif
2144
2145 #if FFETARGET_okREAL4
2146         case FFEINFO_kindtypeREAL4:
2147           switch (ffeinfo_basictype (ffebld_info (l)))
2148             {
2149             case FFEINFO_basictypeINTEGER:
2150               switch (ffeinfo_kindtype (ffebld_info (l)))
2151                 {
2152 #if FFETARGET_okINTEGER1
2153                 case FFEINFO_kindtypeINTEGER1:
2154                   error = ffetarget_convert_real4_integer1
2155                     (ffebld_cu_ptr_real4 (u),
2156                      ffebld_constant_integer1 (ffebld_conter (l)));
2157                   break;
2158 #endif
2159
2160 #if FFETARGET_okINTEGER2
2161                 case FFEINFO_kindtypeINTEGER2:
2162                   error = ffetarget_convert_real4_integer2
2163                     (ffebld_cu_ptr_real4 (u),
2164                      ffebld_constant_integer2 (ffebld_conter (l)));
2165                   break;
2166 #endif
2167
2168 #if FFETARGET_okINTEGER3
2169                 case FFEINFO_kindtypeINTEGER3:
2170                   error = ffetarget_convert_real4_integer3
2171                     (ffebld_cu_ptr_real4 (u),
2172                      ffebld_constant_integer3 (ffebld_conter (l)));
2173                   break;
2174 #endif
2175
2176 #if FFETARGET_okINTEGER4
2177                 case FFEINFO_kindtypeINTEGER4:
2178                   error = ffetarget_convert_real4_integer4
2179                     (ffebld_cu_ptr_real4 (u),
2180                      ffebld_constant_integer4 (ffebld_conter (l)));
2181                   break;
2182 #endif
2183
2184                 default:
2185                   assert ("REAL4/INTEGER bad source kind type" == NULL);
2186                   break;
2187                 }
2188               break;
2189
2190             case FFEINFO_basictypeREAL:
2191               switch (ffeinfo_kindtype (ffebld_info (l)))
2192                 {
2193 #if FFETARGET_okREAL1
2194                 case FFEINFO_kindtypeREAL1:
2195                   error = ffetarget_convert_real4_real1
2196                     (ffebld_cu_ptr_real4 (u),
2197                      ffebld_constant_real1 (ffebld_conter (l)));
2198                   break;
2199 #endif
2200
2201 #if FFETARGET_okREAL2
2202                 case FFEINFO_kindtypeREAL2:
2203                   error = ffetarget_convert_real4_real2
2204                     (ffebld_cu_ptr_real4 (u),
2205                      ffebld_constant_real2 (ffebld_conter (l)));
2206                   break;
2207 #endif
2208
2209 #if FFETARGET_okREAL3
2210                 case FFEINFO_kindtypeREAL3:
2211                   error = ffetarget_convert_real4_real3
2212                     (ffebld_cu_ptr_real4 (u),
2213                      ffebld_constant_real3 (ffebld_conter (l)));
2214                   break;
2215 #endif
2216
2217                 default:
2218                   assert ("REAL4/REAL bad source kind type" == NULL);
2219                   break;
2220                 }
2221               break;
2222
2223             case FFEINFO_basictypeCOMPLEX:
2224               switch (ffeinfo_kindtype (ffebld_info (l)))
2225                 {
2226 #if FFETARGET_okCOMPLEX1
2227                 case FFEINFO_kindtypeREAL1:
2228                   error = ffetarget_convert_real4_complex1
2229                     (ffebld_cu_ptr_real4 (u),
2230                      ffebld_constant_complex1 (ffebld_conter (l)));
2231                   break;
2232 #endif
2233
2234 #if FFETARGET_okCOMPLEX2
2235                 case FFEINFO_kindtypeREAL2:
2236                   error = ffetarget_convert_real4_complex2
2237                     (ffebld_cu_ptr_real4 (u),
2238                      ffebld_constant_complex2 (ffebld_conter (l)));
2239                   break;
2240 #endif
2241
2242 #if FFETARGET_okCOMPLEX3
2243                 case FFEINFO_kindtypeREAL3:
2244                   error = ffetarget_convert_real4_complex3
2245                     (ffebld_cu_ptr_real4 (u),
2246                      ffebld_constant_complex3 (ffebld_conter (l)));
2247                   break;
2248 #endif
2249
2250 #if FFETARGET_okCOMPLEX4
2251                 case FFEINFO_kindtypeREAL4:
2252                   error = ffetarget_convert_real4_complex4
2253                     (ffebld_cu_ptr_real4 (u),
2254                      ffebld_constant_complex4 (ffebld_conter (l)));
2255                   break;
2256 #endif
2257
2258                 default:
2259                   assert ("REAL4/COMPLEX bad source kind type" == NULL);
2260                   break;
2261                 }
2262               break;
2263
2264             case FFEINFO_basictypeCHARACTER:
2265               error = ffetarget_convert_real4_character1
2266                 (ffebld_cu_ptr_real4 (u),
2267                  ffebld_constant_character1 (ffebld_conter (l)));
2268               break;
2269
2270             case FFEINFO_basictypeHOLLERITH:
2271               error = ffetarget_convert_real4_hollerith
2272                 (ffebld_cu_ptr_real4 (u),
2273                  ffebld_constant_hollerith (ffebld_conter (l)));
2274               break;
2275
2276             case FFEINFO_basictypeTYPELESS:
2277               error = ffetarget_convert_real4_typeless
2278                 (ffebld_cu_ptr_real4 (u),
2279                  ffebld_constant_typeless (ffebld_conter (l)));
2280               break;
2281
2282             default:
2283               assert ("REAL4 bad type" == NULL);
2284               break;
2285             }
2286
2287           /* If conversion operation is not implemented, return original expr.  */
2288           if (error == FFEBAD_NOCANDO)
2289             return expr;
2290
2291           expr = ffebld_new_conter_with_orig
2292             (ffebld_constant_new_real4_val
2293              (ffebld_cu_val_real4 (u)), expr);
2294           break;
2295 #endif
2296
2297         default:
2298           assert ("bad real kind type" == NULL);
2299           break;
2300         }
2301       break;
2302
2303     case FFEINFO_basictypeCOMPLEX:
2304       sz = FFETARGET_charactersizeNONE;
2305       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2306         {
2307 #if FFETARGET_okCOMPLEX1
2308         case FFEINFO_kindtypeREAL1:
2309           switch (ffeinfo_basictype (ffebld_info (l)))
2310             {
2311             case FFEINFO_basictypeINTEGER:
2312               switch (ffeinfo_kindtype (ffebld_info (l)))
2313                 {
2314 #if FFETARGET_okINTEGER1
2315                 case FFEINFO_kindtypeINTEGER1:
2316                   error = ffetarget_convert_complex1_integer1
2317                     (ffebld_cu_ptr_complex1 (u),
2318                      ffebld_constant_integer1 (ffebld_conter (l)));
2319                   break;
2320 #endif
2321
2322 #if FFETARGET_okINTEGER2
2323                 case FFEINFO_kindtypeINTEGER2:
2324                   error = ffetarget_convert_complex1_integer2
2325                     (ffebld_cu_ptr_complex1 (u),
2326                      ffebld_constant_integer2 (ffebld_conter (l)));
2327                   break;
2328 #endif
2329
2330 #if FFETARGET_okINTEGER3
2331                 case FFEINFO_kindtypeINTEGER3:
2332                   error = ffetarget_convert_complex1_integer3
2333                     (ffebld_cu_ptr_complex1 (u),
2334                      ffebld_constant_integer3 (ffebld_conter (l)));
2335                   break;
2336 #endif
2337
2338 #if FFETARGET_okINTEGER4
2339                 case FFEINFO_kindtypeINTEGER4:
2340                   error = ffetarget_convert_complex1_integer4
2341                     (ffebld_cu_ptr_complex1 (u),
2342                      ffebld_constant_integer4 (ffebld_conter (l)));
2343                   break;
2344 #endif
2345
2346                 default:
2347                   assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2348                   break;
2349                 }
2350               break;
2351
2352             case FFEINFO_basictypeREAL:
2353               switch (ffeinfo_kindtype (ffebld_info (l)))
2354                 {
2355 #if FFETARGET_okREAL1
2356                 case FFEINFO_kindtypeREAL1:
2357                   error = ffetarget_convert_complex1_real1
2358                     (ffebld_cu_ptr_complex1 (u),
2359                      ffebld_constant_real1 (ffebld_conter (l)));
2360                   break;
2361 #endif
2362
2363 #if FFETARGET_okREAL2
2364                 case FFEINFO_kindtypeREAL2:
2365                   error = ffetarget_convert_complex1_real2
2366                     (ffebld_cu_ptr_complex1 (u),
2367                      ffebld_constant_real2 (ffebld_conter (l)));
2368                   break;
2369 #endif
2370
2371 #if FFETARGET_okREAL3
2372                 case FFEINFO_kindtypeREAL3:
2373                   error = ffetarget_convert_complex1_real3
2374                     (ffebld_cu_ptr_complex1 (u),
2375                      ffebld_constant_real3 (ffebld_conter (l)));
2376                   break;
2377 #endif
2378
2379 #if FFETARGET_okREAL4
2380                 case FFEINFO_kindtypeREAL4:
2381                   error = ffetarget_convert_complex1_real4
2382                     (ffebld_cu_ptr_complex1 (u),
2383                      ffebld_constant_real4 (ffebld_conter (l)));
2384                   break;
2385 #endif
2386
2387                 default:
2388                   assert ("COMPLEX1/REAL bad source kind type" == NULL);
2389                   break;
2390                 }
2391               break;
2392
2393             case FFEINFO_basictypeCOMPLEX:
2394               switch (ffeinfo_kindtype (ffebld_info (l)))
2395                 {
2396 #if FFETARGET_okCOMPLEX2
2397                 case FFEINFO_kindtypeREAL2:
2398                   error = ffetarget_convert_complex1_complex2
2399                     (ffebld_cu_ptr_complex1 (u),
2400                      ffebld_constant_complex2 (ffebld_conter (l)));
2401                   break;
2402 #endif
2403
2404 #if FFETARGET_okCOMPLEX3
2405                 case FFEINFO_kindtypeREAL3:
2406                   error = ffetarget_convert_complex1_complex3
2407                     (ffebld_cu_ptr_complex1 (u),
2408                      ffebld_constant_complex3 (ffebld_conter (l)));
2409                   break;
2410 #endif
2411
2412 #if FFETARGET_okCOMPLEX4
2413                 case FFEINFO_kindtypeREAL4:
2414                   error = ffetarget_convert_complex1_complex4
2415                     (ffebld_cu_ptr_complex1 (u),
2416                      ffebld_constant_complex4 (ffebld_conter (l)));
2417                   break;
2418 #endif
2419
2420                 default:
2421                   assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2422                   break;
2423                 }
2424               break;
2425
2426             case FFEINFO_basictypeCHARACTER:
2427               error = ffetarget_convert_complex1_character1
2428                 (ffebld_cu_ptr_complex1 (u),
2429                  ffebld_constant_character1 (ffebld_conter (l)));
2430               break;
2431
2432             case FFEINFO_basictypeHOLLERITH:
2433               error = ffetarget_convert_complex1_hollerith
2434                 (ffebld_cu_ptr_complex1 (u),
2435                  ffebld_constant_hollerith (ffebld_conter (l)));
2436               break;
2437
2438             case FFEINFO_basictypeTYPELESS:
2439               error = ffetarget_convert_complex1_typeless
2440                 (ffebld_cu_ptr_complex1 (u),
2441                  ffebld_constant_typeless (ffebld_conter (l)));
2442               break;
2443
2444             default:
2445               assert ("COMPLEX1 bad type" == NULL);
2446               break;
2447             }
2448
2449           /* If conversion operation is not implemented, return original expr.  */
2450           if (error == FFEBAD_NOCANDO)
2451             return expr;
2452
2453           expr = ffebld_new_conter_with_orig
2454             (ffebld_constant_new_complex1_val
2455              (ffebld_cu_val_complex1 (u)), expr);
2456           break;
2457 #endif
2458
2459 #if FFETARGET_okCOMPLEX2
2460         case FFEINFO_kindtypeREAL2:
2461           switch (ffeinfo_basictype (ffebld_info (l)))
2462             {
2463             case FFEINFO_basictypeINTEGER:
2464               switch (ffeinfo_kindtype (ffebld_info (l)))
2465                 {
2466 #if FFETARGET_okINTEGER1
2467                 case FFEINFO_kindtypeINTEGER1:
2468                   error = ffetarget_convert_complex2_integer1
2469                     (ffebld_cu_ptr_complex2 (u),
2470                      ffebld_constant_integer1 (ffebld_conter (l)));
2471                   break;
2472 #endif
2473
2474 #if FFETARGET_okINTEGER2
2475                 case FFEINFO_kindtypeINTEGER2:
2476                   error = ffetarget_convert_complex2_integer2
2477                     (ffebld_cu_ptr_complex2 (u),
2478                      ffebld_constant_integer2 (ffebld_conter (l)));
2479                   break;
2480 #endif
2481
2482 #if FFETARGET_okINTEGER3
2483                 case FFEINFO_kindtypeINTEGER3:
2484                   error = ffetarget_convert_complex2_integer3
2485                     (ffebld_cu_ptr_complex2 (u),
2486                      ffebld_constant_integer3 (ffebld_conter (l)));
2487                   break;
2488 #endif
2489
2490 #if FFETARGET_okINTEGER4
2491                 case FFEINFO_kindtypeINTEGER4:
2492                   error = ffetarget_convert_complex2_integer4
2493                     (ffebld_cu_ptr_complex2 (u),
2494                      ffebld_constant_integer4 (ffebld_conter (l)));
2495                   break;
2496 #endif
2497
2498                 default:
2499                   assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2500                   break;
2501                 }
2502               break;
2503
2504             case FFEINFO_basictypeREAL:
2505               switch (ffeinfo_kindtype (ffebld_info (l)))
2506                 {
2507 #if FFETARGET_okREAL1
2508                 case FFEINFO_kindtypeREAL1:
2509                   error = ffetarget_convert_complex2_real1
2510                     (ffebld_cu_ptr_complex2 (u),
2511                      ffebld_constant_real1 (ffebld_conter (l)));
2512                   break;
2513 #endif
2514
2515 #if FFETARGET_okREAL2
2516                 case FFEINFO_kindtypeREAL2:
2517                   error = ffetarget_convert_complex2_real2
2518                     (ffebld_cu_ptr_complex2 (u),
2519                      ffebld_constant_real2 (ffebld_conter (l)));
2520                   break;
2521 #endif
2522
2523 #if FFETARGET_okREAL3
2524                 case FFEINFO_kindtypeREAL3:
2525                   error = ffetarget_convert_complex2_real3
2526                     (ffebld_cu_ptr_complex2 (u),
2527                      ffebld_constant_real3 (ffebld_conter (l)));
2528                   break;
2529 #endif
2530
2531 #if FFETARGET_okREAL4
2532                 case FFEINFO_kindtypeREAL4:
2533                   error = ffetarget_convert_complex2_real4
2534                     (ffebld_cu_ptr_complex2 (u),
2535                      ffebld_constant_real4 (ffebld_conter (l)));
2536                   break;
2537 #endif
2538
2539                 default:
2540                   assert ("COMPLEX2/REAL bad source kind type" == NULL);
2541                   break;
2542                 }
2543               break;
2544
2545             case FFEINFO_basictypeCOMPLEX:
2546               switch (ffeinfo_kindtype (ffebld_info (l)))
2547                 {
2548 #if FFETARGET_okCOMPLEX1
2549                 case FFEINFO_kindtypeREAL1:
2550                   error = ffetarget_convert_complex2_complex1
2551                     (ffebld_cu_ptr_complex2 (u),
2552                      ffebld_constant_complex1 (ffebld_conter (l)));
2553                   break;
2554 #endif
2555
2556 #if FFETARGET_okCOMPLEX3
2557                 case FFEINFO_kindtypeREAL3:
2558                   error = ffetarget_convert_complex2_complex3
2559                     (ffebld_cu_ptr_complex2 (u),
2560                      ffebld_constant_complex3 (ffebld_conter (l)));
2561                   break;
2562 #endif
2563
2564 #if FFETARGET_okCOMPLEX4
2565                 case FFEINFO_kindtypeREAL4:
2566                   error = ffetarget_convert_complex2_complex4
2567                     (ffebld_cu_ptr_complex2 (u),
2568                      ffebld_constant_complex4 (ffebld_conter (l)));
2569                   break;
2570 #endif
2571
2572                 default:
2573                   assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2574                   break;
2575                 }
2576               break;
2577
2578             case FFEINFO_basictypeCHARACTER:
2579               error = ffetarget_convert_complex2_character1
2580                 (ffebld_cu_ptr_complex2 (u),
2581                  ffebld_constant_character1 (ffebld_conter (l)));
2582               break;
2583
2584             case FFEINFO_basictypeHOLLERITH:
2585               error = ffetarget_convert_complex2_hollerith
2586                 (ffebld_cu_ptr_complex2 (u),
2587                  ffebld_constant_hollerith (ffebld_conter (l)));
2588               break;
2589
2590             case FFEINFO_basictypeTYPELESS:
2591               error = ffetarget_convert_complex2_typeless
2592                 (ffebld_cu_ptr_complex2 (u),
2593                  ffebld_constant_typeless (ffebld_conter (l)));
2594               break;
2595
2596             default:
2597               assert ("COMPLEX2 bad type" == NULL);
2598               break;
2599             }
2600
2601           /* If conversion operation is not implemented, return original expr.  */
2602           if (error == FFEBAD_NOCANDO)
2603             return expr;
2604
2605           expr = ffebld_new_conter_with_orig
2606             (ffebld_constant_new_complex2_val
2607              (ffebld_cu_val_complex2 (u)), expr);
2608           break;
2609 #endif
2610
2611 #if FFETARGET_okCOMPLEX3
2612         case FFEINFO_kindtypeREAL3:
2613           switch (ffeinfo_basictype (ffebld_info (l)))
2614             {
2615             case FFEINFO_basictypeINTEGER:
2616               switch (ffeinfo_kindtype (ffebld_info (l)))
2617                 {
2618 #if FFETARGET_okINTEGER1
2619                 case FFEINFO_kindtypeINTEGER1:
2620                   error = ffetarget_convert_complex3_integer1
2621                     (ffebld_cu_ptr_complex3 (u),
2622                      ffebld_constant_integer1 (ffebld_conter (l)));
2623                   break;
2624 #endif
2625
2626 #if FFETARGET_okINTEGER2
2627                 case FFEINFO_kindtypeINTEGER2:
2628                   error = ffetarget_convert_complex3_integer2
2629                     (ffebld_cu_ptr_complex3 (u),
2630                      ffebld_constant_integer2 (ffebld_conter (l)));
2631                   break;
2632 #endif
2633
2634 #if FFETARGET_okINTEGER3
2635                 case FFEINFO_kindtypeINTEGER3:
2636                   error = ffetarget_convert_complex3_integer3
2637                     (ffebld_cu_ptr_complex3 (u),
2638                      ffebld_constant_integer3 (ffebld_conter (l)));
2639                   break;
2640 #endif
2641
2642 #if FFETARGET_okINTEGER4
2643                 case FFEINFO_kindtypeINTEGER4:
2644                   error = ffetarget_convert_complex3_integer4
2645                     (ffebld_cu_ptr_complex3 (u),
2646                      ffebld_constant_integer4 (ffebld_conter (l)));
2647                   break;
2648 #endif
2649
2650                 default:
2651                   assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2652                   break;
2653                 }
2654               break;
2655
2656             case FFEINFO_basictypeREAL:
2657               switch (ffeinfo_kindtype (ffebld_info (l)))
2658                 {
2659 #if FFETARGET_okREAL1
2660                 case FFEINFO_kindtypeREAL1:
2661                   error = ffetarget_convert_complex3_real1
2662                     (ffebld_cu_ptr_complex3 (u),
2663                      ffebld_constant_real1 (ffebld_conter (l)));
2664                   break;
2665 #endif
2666
2667 #if FFETARGET_okREAL2
2668                 case FFEINFO_kindtypeREAL2:
2669                   error = ffetarget_convert_complex3_real2
2670                     (ffebld_cu_ptr_complex3 (u),
2671                      ffebld_constant_real2 (ffebld_conter (l)));
2672                   break;
2673 #endif
2674
2675 #if FFETARGET_okREAL3
2676                 case FFEINFO_kindtypeREAL3:
2677                   error = ffetarget_convert_complex3_real3
2678                     (ffebld_cu_ptr_complex3 (u),
2679                      ffebld_constant_real3 (ffebld_conter (l)));
2680                   break;
2681 #endif
2682
2683 #if FFETARGET_okREAL4
2684                 case FFEINFO_kindtypeREAL4:
2685                   error = ffetarget_convert_complex3_real4
2686                     (ffebld_cu_ptr_complex3 (u),
2687                      ffebld_constant_real4 (ffebld_conter (l)));
2688                   break;
2689 #endif
2690
2691                 default:
2692                   assert ("COMPLEX3/REAL bad source kind type" == NULL);
2693                   break;
2694                 }
2695               break;
2696
2697             case FFEINFO_basictypeCOMPLEX:
2698               switch (ffeinfo_kindtype (ffebld_info (l)))
2699                 {
2700 #if FFETARGET_okCOMPLEX1
2701                 case FFEINFO_kindtypeREAL1:
2702                   error = ffetarget_convert_complex3_complex1
2703                     (ffebld_cu_ptr_complex3 (u),
2704                      ffebld_constant_complex1 (ffebld_conter (l)));
2705                   break;
2706 #endif
2707
2708 #if FFETARGET_okCOMPLEX2
2709                 case FFEINFO_kindtypeREAL2:
2710                   error = ffetarget_convert_complex3_complex2
2711                     (ffebld_cu_ptr_complex3 (u),
2712                      ffebld_constant_complex2 (ffebld_conter (l)));
2713                   break;
2714 #endif
2715
2716 #if FFETARGET_okCOMPLEX4
2717                 case FFEINFO_kindtypeREAL4:
2718                   error = ffetarget_convert_complex3_complex4
2719                     (ffebld_cu_ptr_complex3 (u),
2720                      ffebld_constant_complex4 (ffebld_conter (l)));
2721                   break;
2722 #endif
2723
2724                 default:
2725                   assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2726                   break;
2727                 }
2728               break;
2729
2730             case FFEINFO_basictypeCHARACTER:
2731               error = ffetarget_convert_complex3_character1
2732                 (ffebld_cu_ptr_complex3 (u),
2733                  ffebld_constant_character1 (ffebld_conter (l)));
2734               break;
2735
2736             case FFEINFO_basictypeHOLLERITH:
2737               error = ffetarget_convert_complex3_hollerith
2738                 (ffebld_cu_ptr_complex3 (u),
2739                  ffebld_constant_hollerith (ffebld_conter (l)));
2740               break;
2741
2742             case FFEINFO_basictypeTYPELESS:
2743               error = ffetarget_convert_complex3_typeless
2744                 (ffebld_cu_ptr_complex3 (u),
2745                  ffebld_constant_typeless (ffebld_conter (l)));
2746               break;
2747
2748             default:
2749               assert ("COMPLEX3 bad type" == NULL);
2750               break;
2751             }
2752
2753           /* If conversion operation is not implemented, return original expr.  */
2754           if (error == FFEBAD_NOCANDO)
2755             return expr;
2756
2757           expr = ffebld_new_conter_with_orig
2758             (ffebld_constant_new_complex3_val
2759              (ffebld_cu_val_complex3 (u)), expr);
2760           break;
2761 #endif
2762
2763 #if FFETARGET_okCOMPLEX4
2764         case FFEINFO_kindtypeREAL4:
2765           switch (ffeinfo_basictype (ffebld_info (l)))
2766             {
2767             case FFEINFO_basictypeINTEGER:
2768               switch (ffeinfo_kindtype (ffebld_info (l)))
2769                 {
2770 #if FFETARGET_okINTEGER1
2771                 case FFEINFO_kindtypeINTEGER1:
2772                   error = ffetarget_convert_complex4_integer1
2773                     (ffebld_cu_ptr_complex4 (u),
2774                      ffebld_constant_integer1 (ffebld_conter (l)));
2775                   break;
2776 #endif
2777
2778 #if FFETARGET_okINTEGER2
2779                 case FFEINFO_kindtypeINTEGER2:
2780                   error = ffetarget_convert_complex4_integer2
2781                     (ffebld_cu_ptr_complex4 (u),
2782                      ffebld_constant_integer2 (ffebld_conter (l)));
2783                   break;
2784 #endif
2785
2786 #if FFETARGET_okINTEGER3
2787                 case FFEINFO_kindtypeINTEGER3:
2788                   error = ffetarget_convert_complex4_integer3
2789                     (ffebld_cu_ptr_complex4 (u),
2790                      ffebld_constant_integer3 (ffebld_conter (l)));
2791                   break;
2792 #endif
2793
2794 #if FFETARGET_okINTEGER4
2795                 case FFEINFO_kindtypeINTEGER4:
2796                   error = ffetarget_convert_complex4_integer4
2797                     (ffebld_cu_ptr_complex4 (u),
2798                      ffebld_constant_integer4 (ffebld_conter (l)));
2799                   break;
2800 #endif
2801
2802                 default:
2803                   assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2804                   break;
2805                 }
2806               break;
2807
2808             case FFEINFO_basictypeREAL:
2809               switch (ffeinfo_kindtype (ffebld_info (l)))
2810                 {
2811 #if FFETARGET_okREAL1
2812                 case FFEINFO_kindtypeREAL1:
2813                   error = ffetarget_convert_complex4_real1
2814                     (ffebld_cu_ptr_complex4 (u),
2815                      ffebld_constant_real1 (ffebld_conter (l)));
2816                   break;
2817 #endif
2818
2819 #if FFETARGET_okREAL2
2820                 case FFEINFO_kindtypeREAL2:
2821                   error = ffetarget_convert_complex4_real2
2822                     (ffebld_cu_ptr_complex4 (u),
2823                      ffebld_constant_real2 (ffebld_conter (l)));
2824                   break;
2825 #endif
2826
2827 #if FFETARGET_okREAL3
2828                 case FFEINFO_kindtypeREAL3:
2829                   error = ffetarget_convert_complex4_real3
2830                     (ffebld_cu_ptr_complex4 (u),
2831                      ffebld_constant_real3 (ffebld_conter (l)));
2832                   break;
2833 #endif
2834
2835 #if FFETARGET_okREAL4
2836                 case FFEINFO_kindtypeREAL4:
2837                   error = ffetarget_convert_complex4_real4
2838                     (ffebld_cu_ptr_complex4 (u),
2839                      ffebld_constant_real4 (ffebld_conter (l)));
2840                   break;
2841 #endif
2842
2843                 default:
2844                   assert ("COMPLEX4/REAL bad source kind type" == NULL);
2845                   break;
2846                 }
2847               break;
2848
2849             case FFEINFO_basictypeCOMPLEX:
2850               switch (ffeinfo_kindtype (ffebld_info (l)))
2851                 {
2852 #if FFETARGET_okCOMPLEX1
2853                 case FFEINFO_kindtypeREAL1:
2854                   error = ffetarget_convert_complex4_complex1
2855                     (ffebld_cu_ptr_complex4 (u),
2856                      ffebld_constant_complex1 (ffebld_conter (l)));
2857                   break;
2858 #endif
2859
2860 #if FFETARGET_okCOMPLEX2
2861                 case FFEINFO_kindtypeREAL2:
2862                   error = ffetarget_convert_complex4_complex2
2863                     (ffebld_cu_ptr_complex4 (u),
2864                      ffebld_constant_complex2 (ffebld_conter (l)));
2865                   break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX3
2869                 case FFEINFO_kindtypeREAL3:
2870                   error = ffetarget_convert_complex4_complex3
2871                     (ffebld_cu_ptr_complex4 (u),
2872                      ffebld_constant_complex3 (ffebld_conter (l)));
2873                   break;
2874 #endif
2875
2876                 default:
2877                   assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2878                   break;
2879                 }
2880               break;
2881
2882             case FFEINFO_basictypeCHARACTER:
2883               error = ffetarget_convert_complex4_character1
2884                 (ffebld_cu_ptr_complex4 (u),
2885                  ffebld_constant_character1 (ffebld_conter (l)));
2886               break;
2887
2888             case FFEINFO_basictypeHOLLERITH:
2889               error = ffetarget_convert_complex4_hollerith
2890                 (ffebld_cu_ptr_complex4 (u),
2891                  ffebld_constant_hollerith (ffebld_conter (l)));
2892               break;
2893
2894             case FFEINFO_basictypeTYPELESS:
2895               error = ffetarget_convert_complex4_typeless
2896                 (ffebld_cu_ptr_complex4 (u),
2897                  ffebld_constant_typeless (ffebld_conter (l)));
2898               break;
2899
2900             default:
2901               assert ("COMPLEX4 bad type" == NULL);
2902               break;
2903             }
2904
2905           /* If conversion operation is not implemented, return original expr.  */
2906           if (error == FFEBAD_NOCANDO)
2907             return expr;
2908
2909           expr = ffebld_new_conter_with_orig
2910             (ffebld_constant_new_complex4_val
2911              (ffebld_cu_val_complex4 (u)), expr);
2912           break;
2913 #endif
2914
2915         default:
2916           assert ("bad complex kind type" == NULL);
2917           break;
2918         }
2919       break;
2920
2921     case FFEINFO_basictypeCHARACTER:
2922       if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2923         return expr;
2924       kt = ffeinfo_kindtype (ffebld_info (expr));
2925       switch (kt)
2926         {
2927 #if FFETARGET_okCHARACTER1
2928         case FFEINFO_kindtypeCHARACTER1:
2929           switch (ffeinfo_basictype (ffebld_info (l)))
2930             {
2931             case FFEINFO_basictypeCHARACTER:
2932               if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2933                 return expr;
2934               assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2935               assert (sz2 == ffetarget_length_character1
2936                       (ffebld_constant_character1
2937                        (ffebld_conter (l))));
2938               error
2939                 = ffetarget_convert_character1_character1
2940                 (ffebld_cu_ptr_character1 (u), sz,
2941                  ffebld_constant_character1 (ffebld_conter (l)),
2942                  ffebld_constant_pool ());
2943               break;
2944
2945             case FFEINFO_basictypeINTEGER:
2946               switch (ffeinfo_kindtype (ffebld_info (l)))
2947                 {
2948 #if FFETARGET_okINTEGER1
2949                 case FFEINFO_kindtypeINTEGER1:
2950                   error
2951                     = ffetarget_convert_character1_integer1
2952                       (ffebld_cu_ptr_character1 (u),
2953                        sz,
2954                        ffebld_constant_integer1 (ffebld_conter (l)),
2955                        ffebld_constant_pool ());
2956                   break;
2957 #endif
2958
2959 #if FFETARGET_okINTEGER2
2960                 case FFEINFO_kindtypeINTEGER2:
2961                   error
2962                     = ffetarget_convert_character1_integer2
2963                       (ffebld_cu_ptr_character1 (u),
2964                        sz,
2965                        ffebld_constant_integer2 (ffebld_conter (l)),
2966                        ffebld_constant_pool ());
2967                   break;
2968 #endif
2969
2970 #if FFETARGET_okINTEGER3
2971                 case FFEINFO_kindtypeINTEGER3:
2972                   error
2973                     = ffetarget_convert_character1_integer3
2974                       (ffebld_cu_ptr_character1 (u),
2975                        sz,
2976                        ffebld_constant_integer3 (ffebld_conter (l)),
2977                        ffebld_constant_pool ());
2978                   break;
2979 #endif
2980
2981 #if FFETARGET_okINTEGER4
2982                 case FFEINFO_kindtypeINTEGER4:
2983                   error
2984                     = ffetarget_convert_character1_integer4
2985                       (ffebld_cu_ptr_character1 (u),
2986                        sz,
2987                        ffebld_constant_integer4 (ffebld_conter (l)),
2988                        ffebld_constant_pool ());
2989                   break;
2990 #endif
2991
2992                 default:
2993                   assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2994                   break;
2995                 }
2996               break;
2997
2998             case FFEINFO_basictypeLOGICAL:
2999               switch (ffeinfo_kindtype (ffebld_info (l)))
3000                 {
3001 #if FFETARGET_okLOGICAL1
3002                 case FFEINFO_kindtypeLOGICAL1:
3003                   error
3004                     = ffetarget_convert_character1_logical1
3005                       (ffebld_cu_ptr_character1 (u),
3006                        sz,
3007                        ffebld_constant_logical1 (ffebld_conter (l)),
3008                        ffebld_constant_pool ());
3009                   break;
3010 #endif
3011
3012 #if FFETARGET_okLOGICAL2
3013                 case FFEINFO_kindtypeLOGICAL2:
3014                   error
3015                     = ffetarget_convert_character1_logical2
3016                       (ffebld_cu_ptr_character1 (u),
3017                        sz,
3018                        ffebld_constant_logical2 (ffebld_conter (l)),
3019                        ffebld_constant_pool ());
3020                   break;
3021 #endif
3022
3023 #if FFETARGET_okLOGICAL3
3024                 case FFEINFO_kindtypeLOGICAL3:
3025                   error
3026                     = ffetarget_convert_character1_logical3
3027                       (ffebld_cu_ptr_character1 (u),
3028                        sz,
3029                        ffebld_constant_logical3 (ffebld_conter (l)),
3030                        ffebld_constant_pool ());
3031                   break;
3032 #endif
3033
3034 #if FFETARGET_okLOGICAL4
3035                 case FFEINFO_kindtypeLOGICAL4:
3036                   error
3037                     = ffetarget_convert_character1_logical4
3038                       (ffebld_cu_ptr_character1 (u),
3039                        sz,
3040                        ffebld_constant_logical4 (ffebld_conter (l)),
3041                        ffebld_constant_pool ());
3042                   break;
3043 #endif
3044
3045                 default:
3046                   assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3047                   break;
3048                 }
3049               break;
3050
3051             case FFEINFO_basictypeHOLLERITH:
3052               error
3053                 = ffetarget_convert_character1_hollerith
3054                 (ffebld_cu_ptr_character1 (u),
3055                  sz,
3056                  ffebld_constant_hollerith (ffebld_conter (l)),
3057                  ffebld_constant_pool ());
3058               break;
3059
3060             case FFEINFO_basictypeTYPELESS:
3061               error
3062                 = ffetarget_convert_character1_typeless
3063                 (ffebld_cu_ptr_character1 (u),
3064                  sz,
3065                  ffebld_constant_typeless (ffebld_conter (l)),
3066                  ffebld_constant_pool ());
3067               break;
3068
3069             default:
3070               assert ("CHARACTER1 bad type" == NULL);
3071             }
3072
3073           expr
3074             = ffebld_new_conter_with_orig
3075             (ffebld_constant_new_character1_val
3076              (ffebld_cu_val_character1 (u)),
3077              expr);
3078           break;
3079 #endif
3080
3081         default:
3082           assert ("bad character kind type" == NULL);
3083           break;
3084         }
3085       break;
3086
3087     default:
3088       assert ("bad type" == NULL);
3089       return expr;
3090     }
3091
3092   ffebld_set_info (expr, ffeinfo_new
3093                    (bt,
3094                     kt,
3095                     0,
3096                     FFEINFO_kindENTITY,
3097                     FFEINFO_whereCONSTANT,
3098                     sz));
3099
3100   if ((error != FFEBAD)
3101       && ffebad_start (error))
3102     {
3103       assert (t != NULL);
3104       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3105       ffebad_finish ();
3106     }
3107
3108   return expr;
3109 }
3110
3111 /* ffeexpr_collapse_paren -- Collapse paren expr
3112
3113    ffebld expr;
3114    ffelexToken token;
3115    expr = ffeexpr_collapse_paren(expr,token);
3116
3117    If the result of the expr is a constant, replaces the expr with the
3118    computed constant.  */
3119
3120 ffebld
3121 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3122 {
3123   ffebld r;
3124   ffeinfoBasictype bt;
3125   ffeinfoKindtype kt;
3126   ffetargetCharacterSize len;
3127
3128   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3129     return expr;
3130
3131   r = ffebld_left (expr);
3132
3133   if (ffebld_op (r) != FFEBLD_opCONTER)
3134     return expr;
3135
3136   bt = ffeinfo_basictype (ffebld_info (r));
3137   kt = ffeinfo_kindtype (ffebld_info (r));
3138   len = ffebld_size (r);
3139
3140   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3141                                       expr);
3142
3143   ffebld_set_info (expr, ffeinfo_new
3144                    (bt,
3145                     kt,
3146                     0,
3147                     FFEINFO_kindENTITY,
3148                     FFEINFO_whereCONSTANT,
3149                     len));
3150
3151   return expr;
3152 }
3153
3154 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3155
3156    ffebld expr;
3157    ffelexToken token;
3158    expr = ffeexpr_collapse_uplus(expr,token);
3159
3160    If the result of the expr is a constant, replaces the expr with the
3161    computed constant.  */
3162
3163 ffebld
3164 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3165 {
3166   ffebld r;
3167   ffeinfoBasictype bt;
3168   ffeinfoKindtype kt;
3169   ffetargetCharacterSize len;
3170
3171   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3172     return expr;
3173
3174   r = ffebld_left (expr);
3175
3176   if (ffebld_op (r) != FFEBLD_opCONTER)
3177     return expr;
3178
3179   bt = ffeinfo_basictype (ffebld_info (r));
3180   kt = ffeinfo_kindtype (ffebld_info (r));
3181   len = ffebld_size (r);
3182
3183   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3184                                       expr);
3185
3186   ffebld_set_info (expr, ffeinfo_new
3187                    (bt,
3188                     kt,
3189                     0,
3190                     FFEINFO_kindENTITY,
3191                     FFEINFO_whereCONSTANT,
3192                     len));
3193
3194   return expr;
3195 }
3196
3197 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3198
3199    ffebld expr;
3200    ffelexToken token;
3201    expr = ffeexpr_collapse_uminus(expr,token);
3202
3203    If the result of the expr is a constant, replaces the expr with the
3204    computed constant.  */
3205
3206 ffebld
3207 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3208 {
3209   ffebad error = FFEBAD;
3210   ffebld r;
3211   ffebldConstantUnion u;
3212   ffeinfoBasictype bt;
3213   ffeinfoKindtype kt;
3214
3215   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3216     return expr;
3217
3218   r = ffebld_left (expr);
3219
3220   if (ffebld_op (r) != FFEBLD_opCONTER)
3221     return expr;
3222
3223   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3224     {
3225     case FFEINFO_basictypeANY:
3226       return expr;
3227
3228     case FFEINFO_basictypeINTEGER:
3229       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3230         {
3231 #if FFETARGET_okINTEGER1
3232         case FFEINFO_kindtypeINTEGER1:
3233           error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3234                               ffebld_constant_integer1 (ffebld_conter (r)));
3235           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3236                                         (ffebld_cu_val_integer1 (u)), expr);
3237           break;
3238 #endif
3239
3240 #if FFETARGET_okINTEGER2
3241         case FFEINFO_kindtypeINTEGER2:
3242           error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3243                               ffebld_constant_integer2 (ffebld_conter (r)));
3244           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3245                                         (ffebld_cu_val_integer2 (u)), expr);
3246           break;
3247 #endif
3248
3249 #if FFETARGET_okINTEGER3
3250         case FFEINFO_kindtypeINTEGER3:
3251           error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3252                               ffebld_constant_integer3 (ffebld_conter (r)));
3253           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3254                                         (ffebld_cu_val_integer3 (u)), expr);
3255           break;
3256 #endif
3257
3258 #if FFETARGET_okINTEGER4
3259         case FFEINFO_kindtypeINTEGER4:
3260           error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3261                               ffebld_constant_integer4 (ffebld_conter (r)));
3262           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3263                                         (ffebld_cu_val_integer4 (u)), expr);
3264           break;
3265 #endif
3266
3267         default:
3268           assert ("bad integer kind type" == NULL);
3269           break;
3270         }
3271       break;
3272
3273     case FFEINFO_basictypeREAL:
3274       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3275         {
3276 #if FFETARGET_okREAL1
3277         case FFEINFO_kindtypeREAL1:
3278           error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3279                                  ffebld_constant_real1 (ffebld_conter (r)));
3280           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3281                                            (ffebld_cu_val_real1 (u)), expr);
3282           break;
3283 #endif
3284
3285 #if FFETARGET_okREAL2
3286         case FFEINFO_kindtypeREAL2:
3287           error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3288                                  ffebld_constant_real2 (ffebld_conter (r)));
3289           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3290                                            (ffebld_cu_val_real2 (u)), expr);
3291           break;
3292 #endif
3293
3294 #if FFETARGET_okREAL3
3295         case FFEINFO_kindtypeREAL3:
3296           error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3297                                  ffebld_constant_real3 (ffebld_conter (r)));
3298           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3299                                            (ffebld_cu_val_real3 (u)), expr);
3300           break;
3301 #endif
3302
3303 #if FFETARGET_okREAL4
3304         case FFEINFO_kindtypeREAL4:
3305           error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3306                                  ffebld_constant_real4 (ffebld_conter (r)));
3307           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3308                                            (ffebld_cu_val_real4 (u)), expr);
3309           break;
3310 #endif
3311
3312         default:
3313           assert ("bad real kind type" == NULL);
3314           break;
3315         }
3316       break;
3317
3318     case FFEINFO_basictypeCOMPLEX:
3319       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3320         {
3321 #if FFETARGET_okCOMPLEX1
3322         case FFEINFO_kindtypeREAL1:
3323           error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3324                               ffebld_constant_complex1 (ffebld_conter (r)));
3325           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3326                                         (ffebld_cu_val_complex1 (u)), expr);
3327           break;
3328 #endif
3329
3330 #if FFETARGET_okCOMPLEX2
3331         case FFEINFO_kindtypeREAL2:
3332           error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3333                               ffebld_constant_complex2 (ffebld_conter (r)));
3334           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3335                                         (ffebld_cu_val_complex2 (u)), expr);
3336           break;
3337 #endif
3338
3339 #if FFETARGET_okCOMPLEX3
3340         case FFEINFO_kindtypeREAL3:
3341           error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3342                               ffebld_constant_complex3 (ffebld_conter (r)));
3343           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3344                                         (ffebld_cu_val_complex3 (u)), expr);
3345           break;
3346 #endif
3347
3348 #if FFETARGET_okCOMPLEX4
3349         case FFEINFO_kindtypeREAL4:
3350           error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3351                               ffebld_constant_complex4 (ffebld_conter (r)));
3352           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3353                                         (ffebld_cu_val_complex4 (u)), expr);
3354           break;
3355 #endif
3356
3357         default:
3358           assert ("bad complex kind type" == NULL);
3359           break;
3360         }
3361       break;
3362
3363     default:
3364       assert ("bad type" == NULL);
3365       return expr;
3366     }
3367
3368   ffebld_set_info (expr, ffeinfo_new
3369                    (bt,
3370                     kt,
3371                     0,
3372                     FFEINFO_kindENTITY,
3373                     FFEINFO_whereCONSTANT,
3374                     FFETARGET_charactersizeNONE));
3375
3376   if ((error != FFEBAD)
3377       && ffebad_start (error))
3378     {
3379       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3380       ffebad_finish ();
3381     }
3382
3383   return expr;
3384 }
3385
3386 /* ffeexpr_collapse_not -- Collapse not expr
3387
3388    ffebld expr;
3389    ffelexToken token;
3390    expr = ffeexpr_collapse_not(expr,token);
3391
3392    If the result of the expr is a constant, replaces the expr with the
3393    computed constant.  */
3394
3395 ffebld
3396 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3397 {
3398   ffebad error = FFEBAD;
3399   ffebld r;
3400   ffebldConstantUnion u;
3401   ffeinfoBasictype bt;
3402   ffeinfoKindtype kt;
3403
3404   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3405     return expr;
3406
3407   r = ffebld_left (expr);
3408
3409   if (ffebld_op (r) != FFEBLD_opCONTER)
3410     return expr;
3411
3412   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3413     {
3414     case FFEINFO_basictypeANY:
3415       return expr;
3416
3417     case FFEINFO_basictypeINTEGER:
3418       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3419         {
3420 #if FFETARGET_okINTEGER1
3421         case FFEINFO_kindtypeINTEGER1:
3422           error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3423                               ffebld_constant_integer1 (ffebld_conter (r)));
3424           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3425                                         (ffebld_cu_val_integer1 (u)), expr);
3426           break;
3427 #endif
3428
3429 #if FFETARGET_okINTEGER2
3430         case FFEINFO_kindtypeINTEGER2:
3431           error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3432                               ffebld_constant_integer2 (ffebld_conter (r)));
3433           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3434                                         (ffebld_cu_val_integer2 (u)), expr);
3435           break;
3436 #endif
3437
3438 #if FFETARGET_okINTEGER3
3439         case FFEINFO_kindtypeINTEGER3:
3440           error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3441                               ffebld_constant_integer3 (ffebld_conter (r)));
3442           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3443                                         (ffebld_cu_val_integer3 (u)), expr);
3444           break;
3445 #endif
3446
3447 #if FFETARGET_okINTEGER4
3448         case FFEINFO_kindtypeINTEGER4:
3449           error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3450                               ffebld_constant_integer4 (ffebld_conter (r)));
3451           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3452                                         (ffebld_cu_val_integer4 (u)), expr);
3453           break;
3454 #endif
3455
3456         default:
3457           assert ("bad integer kind type" == NULL);
3458           break;
3459         }
3460       break;
3461
3462     case FFEINFO_basictypeLOGICAL:
3463       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3464         {
3465 #if FFETARGET_okLOGICAL1
3466         case FFEINFO_kindtypeLOGICAL1:
3467           error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3468                               ffebld_constant_logical1 (ffebld_conter (r)));
3469           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3470                                         (ffebld_cu_val_logical1 (u)), expr);
3471           break;
3472 #endif
3473
3474 #if FFETARGET_okLOGICAL2
3475         case FFEINFO_kindtypeLOGICAL2:
3476           error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3477                               ffebld_constant_logical2 (ffebld_conter (r)));
3478           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3479                                         (ffebld_cu_val_logical2 (u)), expr);
3480           break;
3481 #endif
3482
3483 #if FFETARGET_okLOGICAL3
3484         case FFEINFO_kindtypeLOGICAL3:
3485           error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3486                               ffebld_constant_logical3 (ffebld_conter (r)));
3487           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3488                                         (ffebld_cu_val_logical3 (u)), expr);
3489           break;
3490 #endif
3491
3492 #if FFETARGET_okLOGICAL4
3493         case FFEINFO_kindtypeLOGICAL4:
3494           error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3495                               ffebld_constant_logical4 (ffebld_conter (r)));
3496           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3497                                         (ffebld_cu_val_logical4 (u)), expr);
3498           break;
3499 #endif
3500
3501         default:
3502           assert ("bad logical kind type" == NULL);
3503           break;
3504         }
3505       break;
3506
3507     default:
3508       assert ("bad type" == NULL);
3509       return expr;
3510     }
3511
3512   ffebld_set_info (expr, ffeinfo_new
3513                    (bt,
3514                     kt,
3515                     0,
3516                     FFEINFO_kindENTITY,
3517                     FFEINFO_whereCONSTANT,
3518                     FFETARGET_charactersizeNONE));
3519
3520   if ((error != FFEBAD)
3521       && ffebad_start (error))
3522     {
3523       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3524       ffebad_finish ();
3525     }
3526
3527   return expr;
3528 }
3529
3530 /* ffeexpr_collapse_add -- Collapse add expr
3531
3532    ffebld expr;
3533    ffelexToken token;
3534    expr = ffeexpr_collapse_add(expr,token);
3535
3536    If the result of the expr is a constant, replaces the expr with the
3537    computed constant.  */
3538
3539 ffebld
3540 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3541 {
3542   ffebad error = FFEBAD;
3543   ffebld l;
3544   ffebld r;
3545   ffebldConstantUnion u;
3546   ffeinfoBasictype bt;
3547   ffeinfoKindtype kt;
3548
3549   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3550     return expr;
3551
3552   l = ffebld_left (expr);
3553   r = ffebld_right (expr);
3554
3555   if (ffebld_op (l) != FFEBLD_opCONTER)
3556     return expr;
3557   if (ffebld_op (r) != FFEBLD_opCONTER)
3558     return expr;
3559
3560   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3561     {
3562     case FFEINFO_basictypeANY:
3563       return expr;
3564
3565     case FFEINFO_basictypeINTEGER:
3566       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3567         {
3568 #if FFETARGET_okINTEGER1
3569         case FFEINFO_kindtypeINTEGER1:
3570           error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3571                                ffebld_constant_integer1 (ffebld_conter (l)),
3572                               ffebld_constant_integer1 (ffebld_conter (r)));
3573           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3574                                         (ffebld_cu_val_integer1 (u)), expr);
3575           break;
3576 #endif
3577
3578 #if FFETARGET_okINTEGER2
3579         case FFEINFO_kindtypeINTEGER2:
3580           error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3581                                ffebld_constant_integer2 (ffebld_conter (l)),
3582                               ffebld_constant_integer2 (ffebld_conter (r)));
3583           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3584                                         (ffebld_cu_val_integer2 (u)), expr);
3585           break;
3586 #endif
3587
3588 #if FFETARGET_okINTEGER3
3589         case FFEINFO_kindtypeINTEGER3:
3590           error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3591                                ffebld_constant_integer3 (ffebld_conter (l)),
3592                               ffebld_constant_integer3 (ffebld_conter (r)));
3593           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3594                                         (ffebld_cu_val_integer3 (u)), expr);
3595           break;
3596 #endif
3597
3598 #if FFETARGET_okINTEGER4
3599         case FFEINFO_kindtypeINTEGER4:
3600           error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3601                                ffebld_constant_integer4 (ffebld_conter (l)),
3602                               ffebld_constant_integer4 (ffebld_conter (r)));
3603           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3604                                         (ffebld_cu_val_integer4 (u)), expr);
3605           break;
3606 #endif
3607
3608         default:
3609           assert ("bad integer kind type" == NULL);
3610           break;
3611         }
3612       break;
3613
3614     case FFEINFO_basictypeREAL:
3615       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3616         {
3617 #if FFETARGET_okREAL1
3618         case FFEINFO_kindtypeREAL1:
3619           error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3620                                   ffebld_constant_real1 (ffebld_conter (l)),
3621                                  ffebld_constant_real1 (ffebld_conter (r)));
3622           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3623                                            (ffebld_cu_val_real1 (u)), expr);
3624           break;
3625 #endif
3626
3627 #if FFETARGET_okREAL2
3628         case FFEINFO_kindtypeREAL2:
3629           error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3630                                   ffebld_constant_real2 (ffebld_conter (l)),
3631                                  ffebld_constant_real2 (ffebld_conter (r)));
3632           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3633                                            (ffebld_cu_val_real2 (u)), expr);
3634           break;
3635 #endif
3636
3637 #if FFETARGET_okREAL3
3638         case FFEINFO_kindtypeREAL3:
3639           error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3640                                   ffebld_constant_real3 (ffebld_conter (l)),
3641                                  ffebld_constant_real3 (ffebld_conter (r)));
3642           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3643                                            (ffebld_cu_val_real3 (u)), expr);
3644           break;
3645 #endif
3646
3647 #if FFETARGET_okREAL4
3648         case FFEINFO_kindtypeREAL4:
3649           error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3650                                   ffebld_constant_real4 (ffebld_conter (l)),
3651                                  ffebld_constant_real4 (ffebld_conter (r)));
3652           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3653                                            (ffebld_cu_val_real4 (u)), expr);
3654           break;
3655 #endif
3656
3657         default:
3658           assert ("bad real kind type" == NULL);
3659           break;
3660         }
3661       break;
3662
3663     case FFEINFO_basictypeCOMPLEX:
3664       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3665         {
3666 #if FFETARGET_okCOMPLEX1
3667         case FFEINFO_kindtypeREAL1:
3668           error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3669                                ffebld_constant_complex1 (ffebld_conter (l)),
3670                               ffebld_constant_complex1 (ffebld_conter (r)));
3671           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3672                                         (ffebld_cu_val_complex1 (u)), expr);
3673           break;
3674 #endif
3675
3676 #if FFETARGET_okCOMPLEX2
3677         case FFEINFO_kindtypeREAL2:
3678           error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3679                                ffebld_constant_complex2 (ffebld_conter (l)),
3680                               ffebld_constant_complex2 (ffebld_conter (r)));
3681           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3682                                         (ffebld_cu_val_complex2 (u)), expr);
3683           break;
3684 #endif
3685
3686 #if FFETARGET_okCOMPLEX3
3687         case FFEINFO_kindtypeREAL3:
3688           error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3689                                ffebld_constant_complex3 (ffebld_conter (l)),
3690                               ffebld_constant_complex3 (ffebld_conter (r)));
3691           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3692                                         (ffebld_cu_val_complex3 (u)), expr);
3693           break;
3694 #endif
3695
3696 #if FFETARGET_okCOMPLEX4
3697         case FFEINFO_kindtypeREAL4:
3698           error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3699                                ffebld_constant_complex4 (ffebld_conter (l)),
3700                               ffebld_constant_complex4 (ffebld_conter (r)));
3701           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3702                                         (ffebld_cu_val_complex4 (u)), expr);
3703           break;
3704 #endif
3705
3706         default:
3707           assert ("bad complex kind type" == NULL);
3708           break;
3709         }
3710       break;
3711
3712     default:
3713       assert ("bad type" == NULL);
3714       return expr;
3715     }
3716
3717   ffebld_set_info (expr, ffeinfo_new
3718                    (bt,
3719                     kt,
3720                     0,
3721                     FFEINFO_kindENTITY,
3722                     FFEINFO_whereCONSTANT,
3723                     FFETARGET_charactersizeNONE));
3724
3725   if ((error != FFEBAD)
3726       && ffebad_start (error))
3727     {
3728       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3729       ffebad_finish ();
3730     }
3731
3732   return expr;
3733 }
3734
3735 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3736
3737    ffebld expr;
3738    ffelexToken token;
3739    expr = ffeexpr_collapse_subtract(expr,token);
3740
3741    If the result of the expr is a constant, replaces the expr with the
3742    computed constant.  */
3743
3744 ffebld
3745 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3746 {
3747   ffebad error = FFEBAD;
3748   ffebld l;
3749   ffebld r;
3750   ffebldConstantUnion u;
3751   ffeinfoBasictype bt;
3752   ffeinfoKindtype kt;
3753
3754   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3755     return expr;
3756
3757   l = ffebld_left (expr);
3758   r = ffebld_right (expr);
3759
3760   if (ffebld_op (l) != FFEBLD_opCONTER)
3761     return expr;
3762   if (ffebld_op (r) != FFEBLD_opCONTER)
3763     return expr;
3764
3765   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3766     {
3767     case FFEINFO_basictypeANY:
3768       return expr;
3769
3770     case FFEINFO_basictypeINTEGER:
3771       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3772         {
3773 #if FFETARGET_okINTEGER1
3774         case FFEINFO_kindtypeINTEGER1:
3775           error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3776                                ffebld_constant_integer1 (ffebld_conter (l)),
3777                               ffebld_constant_integer1 (ffebld_conter (r)));
3778           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3779                                         (ffebld_cu_val_integer1 (u)), expr);
3780           break;
3781 #endif
3782
3783 #if FFETARGET_okINTEGER2
3784         case FFEINFO_kindtypeINTEGER2:
3785           error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3786                                ffebld_constant_integer2 (ffebld_conter (l)),
3787                               ffebld_constant_integer2 (ffebld_conter (r)));
3788           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3789                                         (ffebld_cu_val_integer2 (u)), expr);
3790           break;
3791 #endif
3792
3793 #if FFETARGET_okINTEGER3
3794         case FFEINFO_kindtypeINTEGER3:
3795           error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3796                                ffebld_constant_integer3 (ffebld_conter (l)),
3797                               ffebld_constant_integer3 (ffebld_conter (r)));
3798           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3799                                         (ffebld_cu_val_integer3 (u)), expr);
3800           break;
3801 #endif
3802
3803 #if FFETARGET_okINTEGER4
3804         case FFEINFO_kindtypeINTEGER4:
3805           error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3806                                ffebld_constant_integer4 (ffebld_conter (l)),
3807                               ffebld_constant_integer4 (ffebld_conter (r)));
3808           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3809                                         (ffebld_cu_val_integer4 (u)), expr);
3810           break;
3811 #endif
3812
3813         default:
3814           assert ("bad integer kind type" == NULL);
3815           break;
3816         }
3817       break;
3818
3819     case FFEINFO_basictypeREAL:
3820       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3821         {
3822 #if FFETARGET_okREAL1
3823         case FFEINFO_kindtypeREAL1:
3824           error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3825                                   ffebld_constant_real1 (ffebld_conter (l)),
3826                                  ffebld_constant_real1 (ffebld_conter (r)));
3827           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3828                                            (ffebld_cu_val_real1 (u)), expr);
3829           break;
3830 #endif
3831
3832 #if FFETARGET_okREAL2
3833         case FFEINFO_kindtypeREAL2:
3834           error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3835                                   ffebld_constant_real2 (ffebld_conter (l)),
3836                                  ffebld_constant_real2 (ffebld_conter (r)));
3837           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3838                                            (ffebld_cu_val_real2 (u)), expr);
3839           break;
3840 #endif
3841
3842 #if FFETARGET_okREAL3
3843         case FFEINFO_kindtypeREAL3:
3844           error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3845                                   ffebld_constant_real3 (ffebld_conter (l)),
3846                                  ffebld_constant_real3 (ffebld_conter (r)));
3847           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3848                                            (ffebld_cu_val_real3 (u)), expr);
3849           break;
3850 #endif
3851
3852 #if FFETARGET_okREAL4
3853         case FFEINFO_kindtypeREAL4:
3854           error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3855                                   ffebld_constant_real4 (ffebld_conter (l)),
3856                                  ffebld_constant_real4 (ffebld_conter (r)));
3857           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3858                                            (ffebld_cu_val_real4 (u)), expr);
3859           break;
3860 #endif
3861
3862         default:
3863           assert ("bad real kind type" == NULL);
3864           break;
3865         }
3866       break;
3867
3868     case FFEINFO_basictypeCOMPLEX:
3869       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3870         {
3871 #if FFETARGET_okCOMPLEX1
3872         case FFEINFO_kindtypeREAL1:
3873           error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3874                                ffebld_constant_complex1 (ffebld_conter (l)),
3875                               ffebld_constant_complex1 (ffebld_conter (r)));
3876           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3877                                         (ffebld_cu_val_complex1 (u)), expr);
3878           break;
3879 #endif
3880
3881 #if FFETARGET_okCOMPLEX2
3882         case FFEINFO_kindtypeREAL2:
3883           error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3884                                ffebld_constant_complex2 (ffebld_conter (l)),
3885                               ffebld_constant_complex2 (ffebld_conter (r)));
3886           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3887                                         (ffebld_cu_val_complex2 (u)), expr);
3888           break;
3889 #endif
3890
3891 #if FFETARGET_okCOMPLEX3
3892         case FFEINFO_kindtypeREAL3:
3893           error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3894                                ffebld_constant_complex3 (ffebld_conter (l)),
3895                               ffebld_constant_complex3 (ffebld_conter (r)));
3896           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3897                                         (ffebld_cu_val_complex3 (u)), expr);
3898           break;
3899 #endif
3900
3901 #if FFETARGET_okCOMPLEX4
3902         case FFEINFO_kindtypeREAL4:
3903           error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3904                                ffebld_constant_complex4 (ffebld_conter (l)),
3905                               ffebld_constant_complex4 (ffebld_conter (r)));
3906           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3907                                         (ffebld_cu_val_complex4 (u)), expr);
3908           break;
3909 #endif
3910
3911         default:
3912           assert ("bad complex kind type" == NULL);
3913           break;
3914         }
3915       break;
3916
3917     default:
3918       assert ("bad type" == NULL);
3919       return expr;
3920     }
3921
3922   ffebld_set_info (expr, ffeinfo_new
3923                    (bt,
3924                     kt,
3925                     0,
3926                     FFEINFO_kindENTITY,
3927                     FFEINFO_whereCONSTANT,
3928                     FFETARGET_charactersizeNONE));
3929
3930   if ((error != FFEBAD)
3931       && ffebad_start (error))
3932     {
3933       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3934       ffebad_finish ();
3935     }
3936
3937   return expr;
3938 }
3939
3940 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3941
3942    ffebld expr;
3943    ffelexToken token;
3944    expr = ffeexpr_collapse_multiply(expr,token);
3945
3946    If the result of the expr is a constant, replaces the expr with the
3947    computed constant.  */
3948
3949 ffebld
3950 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3951 {
3952   ffebad error = FFEBAD;
3953   ffebld l;
3954   ffebld r;
3955   ffebldConstantUnion u;
3956   ffeinfoBasictype bt;
3957   ffeinfoKindtype kt;
3958
3959   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3960     return expr;
3961
3962   l = ffebld_left (expr);
3963   r = ffebld_right (expr);
3964
3965   if (ffebld_op (l) != FFEBLD_opCONTER)
3966     return expr;
3967   if (ffebld_op (r) != FFEBLD_opCONTER)
3968     return expr;
3969
3970   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3971     {
3972     case FFEINFO_basictypeANY:
3973       return expr;
3974
3975     case FFEINFO_basictypeINTEGER:
3976       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3977         {
3978 #if FFETARGET_okINTEGER1
3979         case FFEINFO_kindtypeINTEGER1:
3980           error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3981                                ffebld_constant_integer1 (ffebld_conter (l)),
3982                               ffebld_constant_integer1 (ffebld_conter (r)));
3983           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3984                                         (ffebld_cu_val_integer1 (u)), expr);
3985           break;
3986 #endif
3987
3988 #if FFETARGET_okINTEGER2
3989         case FFEINFO_kindtypeINTEGER2:
3990           error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3991                                ffebld_constant_integer2 (ffebld_conter (l)),
3992                               ffebld_constant_integer2 (ffebld_conter (r)));
3993           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3994                                         (ffebld_cu_val_integer2 (u)), expr);
3995           break;
3996 #endif
3997
3998 #if FFETARGET_okINTEGER3
3999         case FFEINFO_kindtypeINTEGER3:
4000           error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4001                                ffebld_constant_integer3 (ffebld_conter (l)),
4002                               ffebld_constant_integer3 (ffebld_conter (r)));
4003           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4004                                         (ffebld_cu_val_integer3 (u)), expr);
4005           break;
4006 #endif
4007
4008 #if FFETARGET_okINTEGER4
4009         case FFEINFO_kindtypeINTEGER4:
4010           error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4011                                ffebld_constant_integer4 (ffebld_conter (l)),
4012                               ffebld_constant_integer4 (ffebld_conter (r)));
4013           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4014                                         (ffebld_cu_val_integer4 (u)), expr);
4015           break;
4016 #endif
4017
4018         default:
4019           assert ("bad integer kind type" == NULL);
4020           break;
4021         }
4022       break;
4023
4024     case FFEINFO_basictypeREAL:
4025       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4026         {
4027 #if FFETARGET_okREAL1
4028         case FFEINFO_kindtypeREAL1:
4029           error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4030                                   ffebld_constant_real1 (ffebld_conter (l)),
4031                                  ffebld_constant_real1 (ffebld_conter (r)));
4032           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4033                                            (ffebld_cu_val_real1 (u)), expr);
4034           break;
4035 #endif
4036
4037 #if FFETARGET_okREAL2
4038         case FFEINFO_kindtypeREAL2:
4039           error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4040                                   ffebld_constant_real2 (ffebld_conter (l)),
4041                                  ffebld_constant_real2 (ffebld_conter (r)));
4042           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4043                                            (ffebld_cu_val_real2 (u)), expr);
4044           break;
4045 #endif
4046
4047 #if FFETARGET_okREAL3
4048         case FFEINFO_kindtypeREAL3:
4049           error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4050                                   ffebld_constant_real3 (ffebld_conter (l)),
4051                                  ffebld_constant_real3 (ffebld_conter (r)));
4052           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4053                                            (ffebld_cu_val_real3 (u)), expr);
4054           break;
4055 #endif
4056
4057 #if FFETARGET_okREAL4
4058         case FFEINFO_kindtypeREAL4:
4059           error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4060                                   ffebld_constant_real4 (ffebld_conter (l)),
4061                                  ffebld_constant_real4 (ffebld_conter (r)));
4062           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4063                                            (ffebld_cu_val_real4 (u)), expr);
4064           break;
4065 #endif
4066
4067         default:
4068           assert ("bad real kind type" == NULL);
4069           break;
4070         }
4071       break;
4072
4073     case FFEINFO_basictypeCOMPLEX:
4074       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4075         {
4076 #if FFETARGET_okCOMPLEX1
4077         case FFEINFO_kindtypeREAL1:
4078           error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4079                                ffebld_constant_complex1 (ffebld_conter (l)),
4080                               ffebld_constant_complex1 (ffebld_conter (r)));
4081           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4082                                         (ffebld_cu_val_complex1 (u)), expr);
4083           break;
4084 #endif
4085
4086 #if FFETARGET_okCOMPLEX2
4087         case FFEINFO_kindtypeREAL2:
4088           error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4089                                ffebld_constant_complex2 (ffebld_conter (l)),
4090                               ffebld_constant_complex2 (ffebld_conter (r)));
4091           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4092                                         (ffebld_cu_val_complex2 (u)), expr);
4093           break;
4094 #endif
4095
4096 #if FFETARGET_okCOMPLEX3
4097         case FFEINFO_kindtypeREAL3:
4098           error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4099                                ffebld_constant_complex3 (ffebld_conter (l)),
4100                               ffebld_constant_complex3 (ffebld_conter (r)));
4101           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4102                                         (ffebld_cu_val_complex3 (u)), expr);
4103           break;
4104 #endif
4105
4106 #if FFETARGET_okCOMPLEX4
4107         case FFEINFO_kindtypeREAL4:
4108           error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4109                                ffebld_constant_complex4 (ffebld_conter (l)),
4110                               ffebld_constant_complex4 (ffebld_conter (r)));
4111           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4112                                         (ffebld_cu_val_complex4 (u)), expr);
4113           break;
4114 #endif
4115
4116         default:
4117           assert ("bad complex kind type" == NULL);
4118           break;
4119         }
4120       break;
4121
4122     default:
4123       assert ("bad type" == NULL);
4124       return expr;
4125     }
4126
4127   ffebld_set_info (expr, ffeinfo_new
4128                    (bt,
4129                     kt,
4130                     0,
4131                     FFEINFO_kindENTITY,
4132                     FFEINFO_whereCONSTANT,
4133                     FFETARGET_charactersizeNONE));
4134
4135   if ((error != FFEBAD)
4136       && ffebad_start (error))
4137     {
4138       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4139       ffebad_finish ();
4140     }
4141
4142   return expr;
4143 }
4144
4145 /* ffeexpr_collapse_divide -- Collapse divide expr
4146
4147    ffebld expr;
4148    ffelexToken token;
4149    expr = ffeexpr_collapse_divide(expr,token);
4150
4151    If the result of the expr is a constant, replaces the expr with the
4152    computed constant.  */
4153
4154 ffebld
4155 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4156 {
4157   ffebad error = FFEBAD;
4158   ffebld l;
4159   ffebld r;
4160   ffebldConstantUnion u;
4161   ffeinfoBasictype bt;
4162   ffeinfoKindtype kt;
4163
4164   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4165     return expr;
4166
4167   l = ffebld_left (expr);
4168   r = ffebld_right (expr);
4169
4170   if (ffebld_op (l) != FFEBLD_opCONTER)
4171     return expr;
4172   if (ffebld_op (r) != FFEBLD_opCONTER)
4173     return expr;
4174
4175   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4176     {
4177     case FFEINFO_basictypeANY:
4178       return expr;
4179
4180     case FFEINFO_basictypeINTEGER:
4181       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4182         {
4183 #if FFETARGET_okINTEGER1
4184         case FFEINFO_kindtypeINTEGER1:
4185           error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4186                                ffebld_constant_integer1 (ffebld_conter (l)),
4187                               ffebld_constant_integer1 (ffebld_conter (r)));
4188           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4189                                         (ffebld_cu_val_integer1 (u)), expr);
4190           break;
4191 #endif
4192
4193 #if FFETARGET_okINTEGER2
4194         case FFEINFO_kindtypeINTEGER2:
4195           error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4196                                ffebld_constant_integer2 (ffebld_conter (l)),
4197                               ffebld_constant_integer2 (ffebld_conter (r)));
4198           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4199                                         (ffebld_cu_val_integer2 (u)), expr);
4200           break;
4201 #endif
4202
4203 #if FFETARGET_okINTEGER3
4204         case FFEINFO_kindtypeINTEGER3:
4205           error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4206                                ffebld_constant_integer3 (ffebld_conter (l)),
4207                               ffebld_constant_integer3 (ffebld_conter (r)));
4208           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4209                                         (ffebld_cu_val_integer3 (u)), expr);
4210           break;
4211 #endif
4212
4213 #if FFETARGET_okINTEGER4
4214         case FFEINFO_kindtypeINTEGER4:
4215           error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4216                                ffebld_constant_integer4 (ffebld_conter (l)),
4217                               ffebld_constant_integer4 (ffebld_conter (r)));
4218           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4219                                         (ffebld_cu_val_integer4 (u)), expr);
4220           break;
4221 #endif
4222
4223         default:
4224           assert ("bad integer kind type" == NULL);
4225           break;
4226         }
4227       break;
4228
4229     case FFEINFO_basictypeREAL:
4230       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4231         {
4232 #if FFETARGET_okREAL1
4233         case FFEINFO_kindtypeREAL1:
4234           error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4235                                   ffebld_constant_real1 (ffebld_conter (l)),
4236                                  ffebld_constant_real1 (ffebld_conter (r)));
4237           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4238                                            (ffebld_cu_val_real1 (u)), expr);
4239           break;
4240 #endif
4241
4242 #if FFETARGET_okREAL2
4243         case FFEINFO_kindtypeREAL2:
4244           error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4245                                   ffebld_constant_real2 (ffebld_conter (l)),
4246                                  ffebld_constant_real2 (ffebld_conter (r)));
4247           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4248                                            (ffebld_cu_val_real2 (u)), expr);
4249           break;
4250 #endif
4251
4252 #if FFETARGET_okREAL3
4253         case FFEINFO_kindtypeREAL3:
4254           error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4255                                   ffebld_constant_real3 (ffebld_conter (l)),
4256                                  ffebld_constant_real3 (ffebld_conter (r)));
4257           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4258                                            (ffebld_cu_val_real3 (u)), expr);
4259           break;
4260 #endif
4261
4262 #if FFETARGET_okREAL4
4263         case FFEINFO_kindtypeREAL4:
4264           error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4265                                   ffebld_constant_real4 (ffebld_conter (l)),
4266                                  ffebld_constant_real4 (ffebld_conter (r)));
4267           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4268                                            (ffebld_cu_val_real4 (u)), expr);
4269           break;
4270 #endif
4271
4272         default:
4273           assert ("bad real kind type" == NULL);
4274           break;
4275         }
4276       break;
4277
4278     case FFEINFO_basictypeCOMPLEX:
4279       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4280         {
4281 #if FFETARGET_okCOMPLEX1
4282         case FFEINFO_kindtypeREAL1:
4283           error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4284                                ffebld_constant_complex1 (ffebld_conter (l)),
4285                               ffebld_constant_complex1 (ffebld_conter (r)));
4286           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4287                                         (ffebld_cu_val_complex1 (u)), expr);
4288           break;
4289 #endif
4290
4291 #if FFETARGET_okCOMPLEX2
4292         case FFEINFO_kindtypeREAL2:
4293           error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4294                                ffebld_constant_complex2 (ffebld_conter (l)),
4295                               ffebld_constant_complex2 (ffebld_conter (r)));
4296           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4297                                         (ffebld_cu_val_complex2 (u)), expr);
4298           break;
4299 #endif
4300
4301 #if FFETARGET_okCOMPLEX3
4302         case FFEINFO_kindtypeREAL3:
4303           error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4304                                ffebld_constant_complex3 (ffebld_conter (l)),
4305                               ffebld_constant_complex3 (ffebld_conter (r)));
4306           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4307                                         (ffebld_cu_val_complex3 (u)), expr);
4308           break;
4309 #endif
4310
4311 #if FFETARGET_okCOMPLEX4
4312         case FFEINFO_kindtypeREAL4:
4313           error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4314                                ffebld_constant_complex4 (ffebld_conter (l)),
4315                               ffebld_constant_complex4 (ffebld_conter (r)));
4316           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4317                                         (ffebld_cu_val_complex4 (u)), expr);
4318           break;
4319 #endif
4320
4321         default:
4322           assert ("bad complex kind type" == NULL);
4323           break;
4324         }
4325       break;
4326
4327     default:
4328       assert ("bad type" == NULL);
4329       return expr;
4330     }
4331
4332   ffebld_set_info (expr, ffeinfo_new
4333                    (bt,
4334                     kt,
4335                     0,
4336                     FFEINFO_kindENTITY,
4337                     FFEINFO_whereCONSTANT,
4338                     FFETARGET_charactersizeNONE));
4339
4340   if ((error != FFEBAD)
4341       && ffebad_start (error))
4342     {
4343       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4344       ffebad_finish ();
4345     }
4346
4347   return expr;
4348 }
4349
4350 /* ffeexpr_collapse_power -- Collapse power expr
4351
4352    ffebld expr;
4353    ffelexToken token;
4354    expr = ffeexpr_collapse_power(expr,token);
4355
4356    If the result of the expr is a constant, replaces the expr with the
4357    computed constant.  */
4358
4359 ffebld
4360 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4361 {
4362   ffebad error = FFEBAD;
4363   ffebld l;
4364   ffebld r;
4365   ffebldConstantUnion u;
4366   ffeinfoBasictype bt;
4367   ffeinfoKindtype kt;
4368
4369   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4370     return expr;
4371
4372   l = ffebld_left (expr);
4373   r = ffebld_right (expr);
4374
4375   if (ffebld_op (l) != FFEBLD_opCONTER)
4376     return expr;
4377   if (ffebld_op (r) != FFEBLD_opCONTER)
4378     return expr;
4379
4380   if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4381   || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4382     return expr;
4383
4384   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4385     {
4386     case FFEINFO_basictypeANY:
4387       return expr;
4388
4389     case FFEINFO_basictypeINTEGER:
4390       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4391         {
4392         case FFEINFO_kindtypeINTEGERDEFAULT:
4393           error = ffetarget_power_integerdefault_integerdefault
4394             (ffebld_cu_ptr_integerdefault (u),
4395              ffebld_constant_integerdefault (ffebld_conter (l)),
4396              ffebld_constant_integerdefault (ffebld_conter (r)));
4397           expr = ffebld_new_conter_with_orig
4398             (ffebld_constant_new_integerdefault_val
4399              (ffebld_cu_val_integerdefault (u)), expr);
4400           break;
4401
4402         default:
4403           assert ("bad integer kind type" == NULL);
4404           break;
4405         }
4406       break;
4407
4408     case FFEINFO_basictypeREAL:
4409       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4410         {
4411         case FFEINFO_kindtypeREALDEFAULT:
4412           error = ffetarget_power_realdefault_integerdefault
4413             (ffebld_cu_ptr_realdefault (u),
4414              ffebld_constant_realdefault (ffebld_conter (l)),
4415              ffebld_constant_integerdefault (ffebld_conter (r)));
4416           expr = ffebld_new_conter_with_orig
4417             (ffebld_constant_new_realdefault_val
4418              (ffebld_cu_val_realdefault (u)), expr);
4419           break;
4420
4421         case FFEINFO_kindtypeREALDOUBLE:
4422           error = ffetarget_power_realdouble_integerdefault
4423             (ffebld_cu_ptr_realdouble (u),
4424              ffebld_constant_realdouble (ffebld_conter (l)),
4425              ffebld_constant_integerdefault (ffebld_conter (r)));
4426           expr = ffebld_new_conter_with_orig
4427             (ffebld_constant_new_realdouble_val
4428              (ffebld_cu_val_realdouble (u)), expr);
4429           break;
4430
4431 #if FFETARGET_okREALQUAD
4432         case FFEINFO_kindtypeREALQUAD:
4433           error = ffetarget_power_realquad_integerdefault
4434             (ffebld_cu_ptr_realquad (u),
4435              ffebld_constant_realquad (ffebld_conter (l)),
4436              ffebld_constant_integerdefault (ffebld_conter (r)));
4437           expr = ffebld_new_conter_with_orig
4438             (ffebld_constant_new_realquad_val
4439              (ffebld_cu_val_realquad (u)), expr);
4440           break;
4441 #endif
4442         default:
4443           assert ("bad real kind type" == NULL);
4444           break;
4445         }
4446       break;
4447
4448     case FFEINFO_basictypeCOMPLEX:
4449       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4450         {
4451         case FFEINFO_kindtypeREALDEFAULT:
4452           error = ffetarget_power_complexdefault_integerdefault
4453             (ffebld_cu_ptr_complexdefault (u),
4454              ffebld_constant_complexdefault (ffebld_conter (l)),
4455              ffebld_constant_integerdefault (ffebld_conter (r)));
4456           expr = ffebld_new_conter_with_orig
4457             (ffebld_constant_new_complexdefault_val
4458              (ffebld_cu_val_complexdefault (u)), expr);
4459           break;
4460
4461 #if FFETARGET_okCOMPLEXDOUBLE
4462         case FFEINFO_kindtypeREALDOUBLE:
4463           error = ffetarget_power_complexdouble_integerdefault
4464             (ffebld_cu_ptr_complexdouble (u),
4465              ffebld_constant_complexdouble (ffebld_conter (l)),
4466              ffebld_constant_integerdefault (ffebld_conter (r)));
4467           expr = ffebld_new_conter_with_orig
4468             (ffebld_constant_new_complexdouble_val
4469              (ffebld_cu_val_complexdouble (u)), expr);
4470           break;
4471 #endif
4472
4473 #if FFETARGET_okCOMPLEXQUAD
4474         case FFEINFO_kindtypeREALQUAD:
4475           error = ffetarget_power_complexquad_integerdefault
4476             (ffebld_cu_ptr_complexquad (u),
4477              ffebld_constant_complexquad (ffebld_conter (l)),
4478              ffebld_constant_integerdefault (ffebld_conter (r)));
4479           expr = ffebld_new_conter_with_orig
4480             (ffebld_constant_new_complexquad_val
4481              (ffebld_cu_val_complexquad (u)), expr);
4482           break;
4483 #endif
4484
4485         default:
4486           assert ("bad complex kind type" == NULL);
4487           break;
4488         }
4489       break;
4490
4491     default:
4492       assert ("bad type" == NULL);
4493       return expr;
4494     }
4495
4496   ffebld_set_info (expr, ffeinfo_new
4497                    (bt,
4498                     kt,
4499                     0,
4500                     FFEINFO_kindENTITY,
4501                     FFEINFO_whereCONSTANT,
4502                     FFETARGET_charactersizeNONE));
4503
4504   if ((error != FFEBAD)
4505       && ffebad_start (error))
4506     {
4507       ffebad_here (0, ffelex_token_where_line (t),
4508                    ffelex_token_where_column (t));
4509       ffebad_finish ();
4510     }
4511
4512   return expr;
4513 }
4514
4515 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4516
4517    ffebld expr;
4518    ffelexToken token;
4519    expr = ffeexpr_collapse_concatenate(expr,token);
4520
4521    If the result of the expr is a constant, replaces the expr with the
4522    computed constant.  */
4523
4524 ffebld
4525 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4526 {
4527   ffebad error = FFEBAD;
4528   ffebld l;
4529   ffebld r;
4530   ffebldConstantUnion u;
4531   ffeinfoKindtype kt;
4532   ffetargetCharacterSize len;
4533
4534   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4535     return expr;
4536
4537   l = ffebld_left (expr);
4538   r = ffebld_right (expr);
4539
4540   if (ffebld_op (l) != FFEBLD_opCONTER)
4541     return expr;
4542   if (ffebld_op (r) != FFEBLD_opCONTER)
4543     return expr;
4544
4545   switch (ffeinfo_basictype (ffebld_info (expr)))
4546     {
4547     case FFEINFO_basictypeANY:
4548       return expr;
4549
4550     case FFEINFO_basictypeCHARACTER:
4551       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4552         {
4553 #if FFETARGET_okCHARACTER1
4554         case FFEINFO_kindtypeCHARACTER1:
4555           error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4556                              ffebld_constant_character1 (ffebld_conter (l)),
4557                              ffebld_constant_character1 (ffebld_conter (r)),
4558                                    ffebld_constant_pool (), &len);
4559           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4560                                       (ffebld_cu_val_character1 (u)), expr);
4561           break;
4562 #endif
4563
4564 #if FFETARGET_okCHARACTER2
4565         case FFEINFO_kindtypeCHARACTER2:
4566           error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4567                              ffebld_constant_character2 (ffebld_conter (l)),
4568                              ffebld_constant_character2 (ffebld_conter (r)),
4569                                    ffebld_constant_pool (), &len);
4570           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4571                                       (ffebld_cu_val_character2 (u)), expr);
4572           break;
4573 #endif
4574
4575 #if FFETARGET_okCHARACTER3
4576         case FFEINFO_kindtypeCHARACTER3:
4577           error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4578                              ffebld_constant_character3 (ffebld_conter (l)),
4579                              ffebld_constant_character3 (ffebld_conter (r)),
4580                                    ffebld_constant_pool (), &len);
4581           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4582                                       (ffebld_cu_val_character3 (u)), expr);
4583           break;
4584 #endif
4585
4586 #if FFETARGET_okCHARACTER4
4587         case FFEINFO_kindtypeCHARACTER4:
4588           error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4589                              ffebld_constant_character4 (ffebld_conter (l)),
4590                              ffebld_constant_character4 (ffebld_conter (r)),
4591                                    ffebld_constant_pool (), &len);
4592           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4593                                       (ffebld_cu_val_character4 (u)), expr);
4594           break;
4595 #endif
4596
4597         default:
4598           assert ("bad character kind type" == NULL);
4599           break;
4600         }
4601       break;
4602
4603     default:
4604       assert ("bad type" == NULL);
4605       return expr;
4606     }
4607
4608   ffebld_set_info (expr, ffeinfo_new
4609                    (FFEINFO_basictypeCHARACTER,
4610                     kt,
4611                     0,
4612                     FFEINFO_kindENTITY,
4613                     FFEINFO_whereCONSTANT,
4614                     len));
4615
4616   if ((error != FFEBAD)
4617       && ffebad_start (error))
4618     {
4619       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4620       ffebad_finish ();
4621     }
4622
4623   return expr;
4624 }
4625
4626 /* ffeexpr_collapse_eq -- Collapse eq expr
4627
4628    ffebld expr;
4629    ffelexToken token;
4630    expr = ffeexpr_collapse_eq(expr,token);
4631
4632    If the result of the expr is a constant, replaces the expr with the
4633    computed constant.  */
4634
4635 ffebld
4636 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4637 {
4638   ffebad error = FFEBAD;
4639   ffebld l;
4640   ffebld r;
4641   bool val;
4642
4643   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4644     return expr;
4645
4646   l = ffebld_left (expr);
4647   r = ffebld_right (expr);
4648
4649   if (ffebld_op (l) != FFEBLD_opCONTER)
4650     return expr;
4651   if (ffebld_op (r) != FFEBLD_opCONTER)
4652     return expr;
4653
4654   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4655     {
4656     case FFEINFO_basictypeANY:
4657       return expr;
4658
4659     case FFEINFO_basictypeINTEGER:
4660       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4661         {
4662 #if FFETARGET_okINTEGER1
4663         case FFEINFO_kindtypeINTEGER1:
4664           error = ffetarget_eq_integer1 (&val,
4665                                ffebld_constant_integer1 (ffebld_conter (l)),
4666                               ffebld_constant_integer1 (ffebld_conter (r)));
4667           expr = ffebld_new_conter_with_orig
4668             (ffebld_constant_new_logicaldefault (val), expr);
4669           break;
4670 #endif
4671
4672 #if FFETARGET_okINTEGER2
4673         case FFEINFO_kindtypeINTEGER2:
4674           error = ffetarget_eq_integer2 (&val,
4675                                ffebld_constant_integer2 (ffebld_conter (l)),
4676                               ffebld_constant_integer2 (ffebld_conter (r)));
4677           expr = ffebld_new_conter_with_orig
4678             (ffebld_constant_new_logicaldefault (val), expr);
4679           break;
4680 #endif
4681
4682 #if FFETARGET_okINTEGER3
4683         case FFEINFO_kindtypeINTEGER3:
4684           error = ffetarget_eq_integer3 (&val,
4685                                ffebld_constant_integer3 (ffebld_conter (l)),
4686                               ffebld_constant_integer3 (ffebld_conter (r)));
4687           expr = ffebld_new_conter_with_orig
4688             (ffebld_constant_new_logicaldefault (val), expr);
4689           break;
4690 #endif
4691
4692 #if FFETARGET_okINTEGER4
4693         case FFEINFO_kindtypeINTEGER4:
4694           error = ffetarget_eq_integer4 (&val,
4695                                ffebld_constant_integer4 (ffebld_conter (l)),
4696                               ffebld_constant_integer4 (ffebld_conter (r)));
4697           expr = ffebld_new_conter_with_orig
4698             (ffebld_constant_new_logicaldefault (val), expr);
4699           break;
4700 #endif
4701
4702         default:
4703           assert ("bad integer kind type" == NULL);
4704           break;
4705         }
4706       break;
4707
4708     case FFEINFO_basictypeREAL:
4709       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4710         {
4711 #if FFETARGET_okREAL1
4712         case FFEINFO_kindtypeREAL1:
4713           error = ffetarget_eq_real1 (&val,
4714                                   ffebld_constant_real1 (ffebld_conter (l)),
4715                                  ffebld_constant_real1 (ffebld_conter (r)));
4716           expr = ffebld_new_conter_with_orig
4717             (ffebld_constant_new_logicaldefault (val), expr);
4718           break;
4719 #endif
4720
4721 #if FFETARGET_okREAL2
4722         case FFEINFO_kindtypeREAL2:
4723           error = ffetarget_eq_real2 (&val,
4724                                   ffebld_constant_real2 (ffebld_conter (l)),
4725                                  ffebld_constant_real2 (ffebld_conter (r)));
4726           expr = ffebld_new_conter_with_orig
4727             (ffebld_constant_new_logicaldefault (val), expr);
4728           break;
4729 #endif
4730
4731 #if FFETARGET_okREAL3
4732         case FFEINFO_kindtypeREAL3:
4733           error = ffetarget_eq_real3 (&val,
4734                                   ffebld_constant_real3 (ffebld_conter (l)),
4735                                  ffebld_constant_real3 (ffebld_conter (r)));
4736           expr = ffebld_new_conter_with_orig
4737             (ffebld_constant_new_logicaldefault (val), expr);
4738           break;
4739 #endif
4740
4741 #if FFETARGET_okREAL4
4742         case FFEINFO_kindtypeREAL4:
4743           error = ffetarget_eq_real4 (&val,
4744                                   ffebld_constant_real4 (ffebld_conter (l)),
4745                                  ffebld_constant_real4 (ffebld_conter (r)));
4746           expr = ffebld_new_conter_with_orig
4747             (ffebld_constant_new_logicaldefault (val), expr);
4748           break;
4749 #endif
4750
4751         default:
4752           assert ("bad real kind type" == NULL);
4753           break;
4754         }
4755       break;
4756
4757     case FFEINFO_basictypeCOMPLEX:
4758       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4759         {
4760 #if FFETARGET_okCOMPLEX1
4761         case FFEINFO_kindtypeREAL1:
4762           error = ffetarget_eq_complex1 (&val,
4763                                ffebld_constant_complex1 (ffebld_conter (l)),
4764                               ffebld_constant_complex1 (ffebld_conter (r)));
4765           expr = ffebld_new_conter_with_orig
4766             (ffebld_constant_new_logicaldefault (val), expr);
4767           break;
4768 #endif
4769
4770 #if FFETARGET_okCOMPLEX2
4771         case FFEINFO_kindtypeREAL2:
4772           error = ffetarget_eq_complex2 (&val,
4773                                ffebld_constant_complex2 (ffebld_conter (l)),
4774                               ffebld_constant_complex2 (ffebld_conter (r)));
4775           expr = ffebld_new_conter_with_orig
4776             (ffebld_constant_new_logicaldefault (val), expr);
4777           break;
4778 #endif
4779
4780 #if FFETARGET_okCOMPLEX3
4781         case FFEINFO_kindtypeREAL3:
4782           error = ffetarget_eq_complex3 (&val,
4783                                ffebld_constant_complex3 (ffebld_conter (l)),
4784                               ffebld_constant_complex3 (ffebld_conter (r)));
4785           expr = ffebld_new_conter_with_orig
4786             (ffebld_constant_new_logicaldefault (val), expr);
4787           break;
4788 #endif
4789
4790 #if FFETARGET_okCOMPLEX4
4791         case FFEINFO_kindtypeREAL4:
4792           error = ffetarget_eq_complex4 (&val,
4793                                ffebld_constant_complex4 (ffebld_conter (l)),
4794                               ffebld_constant_complex4 (ffebld_conter (r)));
4795           expr = ffebld_new_conter_with_orig
4796             (ffebld_constant_new_logicaldefault (val), expr);
4797           break;
4798 #endif
4799
4800         default:
4801           assert ("bad complex kind type" == NULL);
4802           break;
4803         }
4804       break;
4805
4806     case FFEINFO_basictypeCHARACTER:
4807       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4808         {
4809 #if FFETARGET_okCHARACTER1
4810         case FFEINFO_kindtypeCHARACTER1:
4811           error = ffetarget_eq_character1 (&val,
4812                              ffebld_constant_character1 (ffebld_conter (l)),
4813                             ffebld_constant_character1 (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_okCHARACTER2
4820         case FFEINFO_kindtypeCHARACTER2:
4821           error = ffetarget_eq_character2 (&val,
4822                              ffebld_constant_character2 (ffebld_conter (l)),
4823                             ffebld_constant_character2 (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_okCHARACTER3
4830         case FFEINFO_kindtypeCHARACTER3:
4831           error = ffetarget_eq_character3 (&val,
4832                              ffebld_constant_character3 (ffebld_conter (l)),
4833                             ffebld_constant_character3 (ffebld_conter (r)));
4834           expr = ffebld_new_conter_with_orig
4835             (ffebld_constant_new_logicaldefault (val), expr);
4836           break;
4837 #endif
4838
4839 #if FFETARGET_okCHARACTER4
4840         case FFEINFO_kindtypeCHARACTER4:
4841           error = ffetarget_eq_character4 (&val,
4842                              ffebld_constant_character4 (ffebld_conter (l)),
4843                             ffebld_constant_character4 (ffebld_conter (r)));
4844           expr = ffebld_new_conter_with_orig
4845             (ffebld_constant_new_logicaldefault (val), expr);
4846           break;
4847 #endif
4848
4849         default:
4850           assert ("bad character kind type" == NULL);
4851           break;
4852         }
4853       break;
4854
4855     default:
4856       assert ("bad type" == NULL);
4857       return expr;
4858     }
4859
4860   ffebld_set_info (expr, ffeinfo_new
4861                    (FFEINFO_basictypeLOGICAL,
4862                     FFEINFO_kindtypeLOGICALDEFAULT,
4863                     0,
4864                     FFEINFO_kindENTITY,
4865                     FFEINFO_whereCONSTANT,
4866                     FFETARGET_charactersizeNONE));
4867
4868   if ((error != FFEBAD)
4869       && ffebad_start (error))
4870     {
4871       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4872       ffebad_finish ();
4873     }
4874
4875   return expr;
4876 }
4877
4878 /* ffeexpr_collapse_ne -- Collapse ne expr
4879
4880    ffebld expr;
4881    ffelexToken token;
4882    expr = ffeexpr_collapse_ne(expr,token);
4883
4884    If the result of the expr is a constant, replaces the expr with the
4885    computed constant.  */
4886
4887 ffebld
4888 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4889 {
4890   ffebad error = FFEBAD;
4891   ffebld l;
4892   ffebld r;
4893   bool val;
4894
4895   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4896     return expr;
4897
4898   l = ffebld_left (expr);
4899   r = ffebld_right (expr);
4900
4901   if (ffebld_op (l) != FFEBLD_opCONTER)
4902     return expr;
4903   if (ffebld_op (r) != FFEBLD_opCONTER)
4904     return expr;
4905
4906   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4907     {
4908     case FFEINFO_basictypeANY:
4909       return expr;
4910
4911     case FFEINFO_basictypeINTEGER:
4912       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4913         {
4914 #if FFETARGET_okINTEGER1
4915         case FFEINFO_kindtypeINTEGER1:
4916           error = ffetarget_ne_integer1 (&val,
4917                                ffebld_constant_integer1 (ffebld_conter (l)),
4918                               ffebld_constant_integer1 (ffebld_conter (r)));
4919           expr = ffebld_new_conter_with_orig
4920             (ffebld_constant_new_logicaldefault (val), expr);
4921           break;
4922 #endif
4923
4924 #if FFETARGET_okINTEGER2
4925         case FFEINFO_kindtypeINTEGER2:
4926           error = ffetarget_ne_integer2 (&val,
4927                                ffebld_constant_integer2 (ffebld_conter (l)),
4928                               ffebld_constant_integer2 (ffebld_conter (r)));
4929           expr = ffebld_new_conter_with_orig
4930             (ffebld_constant_new_logicaldefault (val), expr);
4931           break;
4932 #endif
4933
4934 #if FFETARGET_okINTEGER3
4935         case FFEINFO_kindtypeINTEGER3:
4936           error = ffetarget_ne_integer3 (&val,
4937                                ffebld_constant_integer3 (ffebld_conter (l)),
4938                               ffebld_constant_integer3 (ffebld_conter (r)));
4939           expr = ffebld_new_conter_with_orig
4940             (ffebld_constant_new_logicaldefault (val), expr);
4941           break;
4942 #endif
4943
4944 #if FFETARGET_okINTEGER4
4945         case FFEINFO_kindtypeINTEGER4:
4946           error = ffetarget_ne_integer4 (&val,
4947                                ffebld_constant_integer4 (ffebld_conter (l)),
4948                               ffebld_constant_integer4 (ffebld_conter (r)));
4949           expr = ffebld_new_conter_with_orig
4950             (ffebld_constant_new_logicaldefault (val), expr);
4951           break;
4952 #endif
4953
4954         default:
4955           assert ("bad integer kind type" == NULL);
4956           break;
4957         }
4958       break;
4959
4960     case FFEINFO_basictypeREAL:
4961       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4962         {
4963 #if FFETARGET_okREAL1
4964         case FFEINFO_kindtypeREAL1:
4965           error = ffetarget_ne_real1 (&val,
4966                                   ffebld_constant_real1 (ffebld_conter (l)),
4967                                  ffebld_constant_real1 (ffebld_conter (r)));
4968           expr = ffebld_new_conter_with_orig
4969             (ffebld_constant_new_logicaldefault (val), expr);
4970           break;
4971 #endif
4972
4973 #if FFETARGET_okREAL2
4974         case FFEINFO_kindtypeREAL2:
4975           error = ffetarget_ne_real2 (&val,
4976                                   ffebld_constant_real2 (ffebld_conter (l)),
4977                                  ffebld_constant_real2 (ffebld_conter (r)));
4978           expr = ffebld_new_conter_with_orig
4979             (ffebld_constant_new_logicaldefault (val), expr);
4980           break;
4981 #endif
4982
4983 #if FFETARGET_okREAL3
4984         case FFEINFO_kindtypeREAL3:
4985           error = ffetarget_ne_real3 (&val,
4986                                   ffebld_constant_real3 (ffebld_conter (l)),
4987                                  ffebld_constant_real3 (ffebld_conter (r)));
4988           expr = ffebld_new_conter_with_orig
4989             (ffebld_constant_new_logicaldefault (val), expr);
4990           break;
4991 #endif
4992
4993 #if FFETARGET_okREAL4
4994         case FFEINFO_kindtypeREAL4:
4995           error = ffetarget_ne_real4 (&val,
4996                                   ffebld_constant_real4 (ffebld_conter (l)),
4997                                  ffebld_constant_real4 (ffebld_conter (r)));
4998           expr = ffebld_new_conter_with_orig
4999             (ffebld_constant_new_logicaldefault (val), expr);
5000           break;
5001 #endif
5002
5003         default:
5004           assert ("bad real kind type" == NULL);
5005           break;
5006         }
5007       break;
5008
5009     case FFEINFO_basictypeCOMPLEX:
5010       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5011         {
5012 #if FFETARGET_okCOMPLEX1
5013         case FFEINFO_kindtypeREAL1:
5014           error = ffetarget_ne_complex1 (&val,
5015                                ffebld_constant_complex1 (ffebld_conter (l)),
5016                               ffebld_constant_complex1 (ffebld_conter (r)));
5017           expr = ffebld_new_conter_with_orig
5018             (ffebld_constant_new_logicaldefault (val), expr);
5019           break;
5020 #endif
5021
5022 #if FFETARGET_okCOMPLEX2
5023         case FFEINFO_kindtypeREAL2:
5024           error = ffetarget_ne_complex2 (&val,
5025                                ffebld_constant_complex2 (ffebld_conter (l)),
5026                               ffebld_constant_complex2 (ffebld_conter (r)));
5027           expr = ffebld_new_conter_with_orig
5028             (ffebld_constant_new_logicaldefault (val), expr);
5029           break;
5030 #endif
5031
5032 #if FFETARGET_okCOMPLEX3
5033         case FFEINFO_kindtypeREAL3:
5034           error = ffetarget_ne_complex3 (&val,
5035                                ffebld_constant_complex3 (ffebld_conter (l)),
5036                               ffebld_constant_complex3 (ffebld_conter (r)));
5037           expr = ffebld_new_conter_with_orig
5038             (ffebld_constant_new_logicaldefault (val), expr);
5039           break;
5040 #endif
5041
5042 #if FFETARGET_okCOMPLEX4
5043         case FFEINFO_kindtypeREAL4:
5044           error = ffetarget_ne_complex4 (&val,
5045                                ffebld_constant_complex4 (ffebld_conter (l)),
5046                               ffebld_constant_complex4 (ffebld_conter (r)));
5047           expr = ffebld_new_conter_with_orig
5048             (ffebld_constant_new_logicaldefault (val), expr);
5049           break;
5050 #endif
5051
5052         default:
5053           assert ("bad complex kind type" == NULL);
5054           break;
5055         }
5056       break;
5057
5058     case FFEINFO_basictypeCHARACTER:
5059       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5060         {
5061 #if FFETARGET_okCHARACTER1
5062         case FFEINFO_kindtypeCHARACTER1:
5063           error = ffetarget_ne_character1 (&val,
5064                              ffebld_constant_character1 (ffebld_conter (l)),
5065                             ffebld_constant_character1 (ffebld_conter (r)));
5066           expr = ffebld_new_conter_with_orig
5067             (ffebld_constant_new_logicaldefault (val), expr);
5068           break;
5069 #endif
5070
5071 #if FFETARGET_okCHARACTER2
5072         case FFEINFO_kindtypeCHARACTER2:
5073           error = ffetarget_ne_character2 (&val,
5074                              ffebld_constant_character2 (ffebld_conter (l)),
5075                             ffebld_constant_character2 (ffebld_conter (r)));
5076           expr = ffebld_new_conter_with_orig
5077             (ffebld_constant_new_logicaldefault (val), expr);
5078           break;
5079 #endif
5080
5081 #if FFETARGET_okCHARACTER3
5082         case FFEINFO_kindtypeCHARACTER3:
5083           error = ffetarget_ne_character3 (&val,
5084                              ffebld_constant_character3 (ffebld_conter (l)),
5085                             ffebld_constant_character3 (ffebld_conter (r)));
5086           expr = ffebld_new_conter_with_orig
5087             (ffebld_constant_new_logicaldefault (val), expr);
5088           break;
5089 #endif
5090
5091 #if FFETARGET_okCHARACTER4
5092         case FFEINFO_kindtypeCHARACTER4:
5093           error = ffetarget_ne_character4 (&val,
5094                              ffebld_constant_character4 (ffebld_conter (l)),
5095                             ffebld_constant_character4 (ffebld_conter (r)));
5096           expr = ffebld_new_conter_with_orig
5097             (ffebld_constant_new_logicaldefault (val), expr);
5098           break;
5099 #endif
5100
5101         default:
5102           assert ("bad character kind type" == NULL);
5103           break;
5104         }
5105       break;
5106
5107     default:
5108       assert ("bad type" == NULL);
5109       return expr;
5110     }
5111
5112   ffebld_set_info (expr, ffeinfo_new
5113                    (FFEINFO_basictypeLOGICAL,
5114                     FFEINFO_kindtypeLOGICALDEFAULT,
5115                     0,
5116                     FFEINFO_kindENTITY,
5117                     FFEINFO_whereCONSTANT,
5118                     FFETARGET_charactersizeNONE));
5119
5120   if ((error != FFEBAD)
5121       && ffebad_start (error))
5122     {
5123       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5124       ffebad_finish ();
5125     }
5126
5127   return expr;
5128 }
5129
5130 /* ffeexpr_collapse_ge -- Collapse ge expr
5131
5132    ffebld expr;
5133    ffelexToken token;
5134    expr = ffeexpr_collapse_ge(expr,token);
5135
5136    If the result of the expr is a constant, replaces the expr with the
5137    computed constant.  */
5138
5139 ffebld
5140 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5141 {
5142   ffebad error = FFEBAD;
5143   ffebld l;
5144   ffebld r;
5145   bool val;
5146
5147   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5148     return expr;
5149
5150   l = ffebld_left (expr);
5151   r = ffebld_right (expr);
5152
5153   if (ffebld_op (l) != FFEBLD_opCONTER)
5154     return expr;
5155   if (ffebld_op (r) != FFEBLD_opCONTER)
5156     return expr;
5157
5158   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5159     {
5160     case FFEINFO_basictypeANY:
5161       return expr;
5162
5163     case FFEINFO_basictypeINTEGER:
5164       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5165         {
5166 #if FFETARGET_okINTEGER1
5167         case FFEINFO_kindtypeINTEGER1:
5168           error = ffetarget_ge_integer1 (&val,
5169                                ffebld_constant_integer1 (ffebld_conter (l)),
5170                               ffebld_constant_integer1 (ffebld_conter (r)));
5171           expr = ffebld_new_conter_with_orig
5172             (ffebld_constant_new_logicaldefault (val), expr);
5173           break;
5174 #endif
5175
5176 #if FFETARGET_okINTEGER2
5177         case FFEINFO_kindtypeINTEGER2:
5178           error = ffetarget_ge_integer2 (&val,
5179                                ffebld_constant_integer2 (ffebld_conter (l)),
5180                               ffebld_constant_integer2 (ffebld_conter (r)));
5181           expr = ffebld_new_conter_with_orig
5182             (ffebld_constant_new_logicaldefault (val), expr);
5183           break;
5184 #endif
5185
5186 #if FFETARGET_okINTEGER3
5187         case FFEINFO_kindtypeINTEGER3:
5188           error = ffetarget_ge_integer3 (&val,
5189                                ffebld_constant_integer3 (ffebld_conter (l)),
5190                               ffebld_constant_integer3 (ffebld_conter (r)));
5191           expr = ffebld_new_conter_with_orig
5192             (ffebld_constant_new_logicaldefault (val), expr);
5193           break;
5194 #endif
5195
5196 #if FFETARGET_okINTEGER4
5197         case FFEINFO_kindtypeINTEGER4:
5198           error = ffetarget_ge_integer4 (&val,
5199                                ffebld_constant_integer4 (ffebld_conter (l)),
5200                               ffebld_constant_integer4 (ffebld_conter (r)));
5201           expr = ffebld_new_conter_with_orig
5202             (ffebld_constant_new_logicaldefault (val), expr);
5203           break;
5204 #endif
5205
5206         default:
5207           assert ("bad integer kind type" == NULL);
5208           break;
5209         }
5210       break;
5211
5212     case FFEINFO_basictypeREAL:
5213       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5214         {
5215 #if FFETARGET_okREAL1
5216         case FFEINFO_kindtypeREAL1:
5217           error = ffetarget_ge_real1 (&val,
5218                                   ffebld_constant_real1 (ffebld_conter (l)),
5219                                  ffebld_constant_real1 (ffebld_conter (r)));
5220           expr = ffebld_new_conter_with_orig
5221             (ffebld_constant_new_logicaldefault (val), expr);
5222           break;
5223 #endif
5224
5225 #if FFETARGET_okREAL2
5226         case FFEINFO_kindtypeREAL2:
5227           error = ffetarget_ge_real2 (&val,
5228                                   ffebld_constant_real2 (ffebld_conter (l)),
5229                                  ffebld_constant_real2 (ffebld_conter (r)));
5230           expr = ffebld_new_conter_with_orig
5231             (ffebld_constant_new_logicaldefault (val), expr);
5232           break;
5233 #endif
5234
5235 #if FFETARGET_okREAL3
5236         case FFEINFO_kindtypeREAL3:
5237           error = ffetarget_ge_real3 (&val,
5238                                   ffebld_constant_real3 (ffebld_conter (l)),
5239                                  ffebld_constant_real3 (ffebld_conter (r)));
5240           expr = ffebld_new_conter_with_orig
5241             (ffebld_constant_new_logicaldefault (val), expr);
5242           break;
5243 #endif
5244
5245 #if FFETARGET_okREAL4
5246         case FFEINFO_kindtypeREAL4:
5247           error = ffetarget_ge_real4 (&val,
5248                                   ffebld_constant_real4 (ffebld_conter (l)),
5249                                  ffebld_constant_real4 (ffebld_conter (r)));
5250           expr = ffebld_new_conter_with_orig
5251             (ffebld_constant_new_logicaldefault (val), expr);
5252           break;
5253 #endif
5254
5255         default:
5256           assert ("bad real kind type" == NULL);
5257           break;
5258         }
5259       break;
5260
5261     case FFEINFO_basictypeCHARACTER:
5262       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5263         {
5264 #if FFETARGET_okCHARACTER1
5265         case FFEINFO_kindtypeCHARACTER1:
5266           error = ffetarget_ge_character1 (&val,
5267                              ffebld_constant_character1 (ffebld_conter (l)),
5268                             ffebld_constant_character1 (ffebld_conter (r)));
5269           expr = ffebld_new_conter_with_orig
5270             (ffebld_constant_new_logicaldefault (val), expr);
5271           break;
5272 #endif
5273
5274 #if FFETARGET_okCHARACTER2
5275         case FFEINFO_kindtypeCHARACTER2:
5276           error = ffetarget_ge_character2 (&val,
5277                              ffebld_constant_character2 (ffebld_conter (l)),
5278                             ffebld_constant_character2 (ffebld_conter (r)));
5279           expr = ffebld_new_conter_with_orig
5280             (ffebld_constant_new_logicaldefault (val), expr);
5281           break;
5282 #endif
5283
5284 #if FFETARGET_okCHARACTER3
5285         case FFEINFO_kindtypeCHARACTER3:
5286           error = ffetarget_ge_character3 (&val,
5287                              ffebld_constant_character3 (ffebld_conter (l)),
5288                             ffebld_constant_character3 (ffebld_conter (r)));
5289           expr = ffebld_new_conter_with_orig
5290             (ffebld_constant_new_logicaldefault (val), expr);
5291           break;
5292 #endif
5293
5294 #if FFETARGET_okCHARACTER4
5295         case FFEINFO_kindtypeCHARACTER4:
5296           error = ffetarget_ge_character4 (&val,
5297                              ffebld_constant_character4 (ffebld_conter (l)),
5298                             ffebld_constant_character4 (ffebld_conter (r)));
5299           expr = ffebld_new_conter_with_orig
5300             (ffebld_constant_new_logicaldefault (val), expr);
5301           break;
5302 #endif
5303
5304         default:
5305           assert ("bad character kind type" == NULL);
5306           break;
5307         }
5308       break;
5309
5310     default:
5311       assert ("bad type" == NULL);
5312       return expr;
5313     }
5314
5315   ffebld_set_info (expr, ffeinfo_new
5316                    (FFEINFO_basictypeLOGICAL,
5317                     FFEINFO_kindtypeLOGICALDEFAULT,
5318                     0,
5319                     FFEINFO_kindENTITY,
5320                     FFEINFO_whereCONSTANT,
5321                     FFETARGET_charactersizeNONE));
5322
5323   if ((error != FFEBAD)
5324       && ffebad_start (error))
5325     {
5326       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5327       ffebad_finish ();
5328     }
5329
5330   return expr;
5331 }
5332
5333 /* ffeexpr_collapse_gt -- Collapse gt expr
5334
5335    ffebld expr;
5336    ffelexToken token;
5337    expr = ffeexpr_collapse_gt(expr,token);
5338
5339    If the result of the expr is a constant, replaces the expr with the
5340    computed constant.  */
5341
5342 ffebld
5343 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5344 {
5345   ffebad error = FFEBAD;
5346   ffebld l;
5347   ffebld r;
5348   bool val;
5349
5350   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5351     return expr;
5352
5353   l = ffebld_left (expr);
5354   r = ffebld_right (expr);
5355
5356   if (ffebld_op (l) != FFEBLD_opCONTER)
5357     return expr;
5358   if (ffebld_op (r) != FFEBLD_opCONTER)
5359     return expr;
5360
5361   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5362     {
5363     case FFEINFO_basictypeANY:
5364       return expr;
5365
5366     case FFEINFO_basictypeINTEGER:
5367       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5368         {
5369 #if FFETARGET_okINTEGER1
5370         case FFEINFO_kindtypeINTEGER1:
5371           error = ffetarget_gt_integer1 (&val,
5372                                ffebld_constant_integer1 (ffebld_conter (l)),
5373                               ffebld_constant_integer1 (ffebld_conter (r)));
5374           expr = ffebld_new_conter_with_orig
5375             (ffebld_constant_new_logicaldefault (val), expr);
5376           break;
5377 #endif
5378
5379 #if FFETARGET_okINTEGER2
5380         case FFEINFO_kindtypeINTEGER2:
5381           error = ffetarget_gt_integer2 (&val,
5382                                ffebld_constant_integer2 (ffebld_conter (l)),
5383                               ffebld_constant_integer2 (ffebld_conter (r)));
5384           expr = ffebld_new_conter_with_orig
5385             (ffebld_constant_new_logicaldefault (val), expr);
5386           break;
5387 #endif
5388
5389 #if FFETARGET_okINTEGER3
5390         case FFEINFO_kindtypeINTEGER3:
5391           error = ffetarget_gt_integer3 (&val,
5392                                ffebld_constant_integer3 (ffebld_conter (l)),
5393                               ffebld_constant_integer3 (ffebld_conter (r)));
5394           expr = ffebld_new_conter_with_orig
5395             (ffebld_constant_new_logicaldefault (val), expr);
5396           break;
5397 #endif
5398
5399 #if FFETARGET_okINTEGER4
5400         case FFEINFO_kindtypeINTEGER4:
5401           error = ffetarget_gt_integer4 (&val,
5402                                ffebld_constant_integer4 (ffebld_conter (l)),
5403                               ffebld_constant_integer4 (ffebld_conter (r)));
5404           expr = ffebld_new_conter_with_orig
5405             (ffebld_constant_new_logicaldefault (val), expr);
5406           break;
5407 #endif
5408
5409         default:
5410           assert ("bad integer kind type" == NULL);
5411           break;
5412         }
5413       break;
5414
5415     case FFEINFO_basictypeREAL:
5416       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5417         {
5418 #if FFETARGET_okREAL1
5419         case FFEINFO_kindtypeREAL1:
5420           error = ffetarget_gt_real1 (&val,
5421                                   ffebld_constant_real1 (ffebld_conter (l)),
5422                                  ffebld_constant_real1 (ffebld_conter (r)));
5423           expr = ffebld_new_conter_with_orig
5424             (ffebld_constant_new_logicaldefault (val), expr);
5425           break;
5426 #endif
5427
5428 #if FFETARGET_okREAL2
5429         case FFEINFO_kindtypeREAL2:
5430           error = ffetarget_gt_real2 (&val,
5431                                   ffebld_constant_real2 (ffebld_conter (l)),
5432                                  ffebld_constant_real2 (ffebld_conter (r)));
5433           expr = ffebld_new_conter_with_orig
5434             (ffebld_constant_new_logicaldefault (val), expr);
5435           break;
5436 #endif
5437
5438 #if FFETARGET_okREAL3
5439         case FFEINFO_kindtypeREAL3:
5440           error = ffetarget_gt_real3 (&val,
5441                                   ffebld_constant_real3 (ffebld_conter (l)),
5442                                  ffebld_constant_real3 (ffebld_conter (r)));
5443           expr = ffebld_new_conter_with_orig
5444             (ffebld_constant_new_logicaldefault (val), expr);
5445           break;
5446 #endif
5447
5448 #if FFETARGET_okREAL4
5449         case FFEINFO_kindtypeREAL4:
5450           error = ffetarget_gt_real4 (&val,
5451                                   ffebld_constant_real4 (ffebld_conter (l)),
5452                                  ffebld_constant_real4 (ffebld_conter (r)));
5453           expr = ffebld_new_conter_with_orig
5454             (ffebld_constant_new_logicaldefault (val), expr);
5455           break;
5456 #endif
5457
5458         default:
5459           assert ("bad real kind type" == NULL);
5460           break;
5461         }
5462       break;
5463
5464     case FFEINFO_basictypeCHARACTER:
5465       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5466         {
5467 #if FFETARGET_okCHARACTER1
5468         case FFEINFO_kindtypeCHARACTER1:
5469           error = ffetarget_gt_character1 (&val,
5470                              ffebld_constant_character1 (ffebld_conter (l)),
5471                             ffebld_constant_character1 (ffebld_conter (r)));
5472           expr = ffebld_new_conter_with_orig
5473             (ffebld_constant_new_logicaldefault (val), expr);
5474           break;
5475 #endif
5476
5477 #if FFETARGET_okCHARACTER2
5478         case FFEINFO_kindtypeCHARACTER2:
5479           error = ffetarget_gt_character2 (&val,
5480                              ffebld_constant_character2 (ffebld_conter (l)),
5481                             ffebld_constant_character2 (ffebld_conter (r)));
5482           expr = ffebld_new_conter_with_orig
5483             (ffebld_constant_new_logicaldefault (val), expr);
5484           break;
5485 #endif
5486
5487 #if FFETARGET_okCHARACTER3
5488         case FFEINFO_kindtypeCHARACTER3:
5489           error = ffetarget_gt_character3 (&val,
5490                              ffebld_constant_character3 (ffebld_conter (l)),
5491                             ffebld_constant_character3 (ffebld_conter (r)));
5492           expr = ffebld_new_conter_with_orig
5493             (ffebld_constant_new_logicaldefault (val), expr);
5494           break;
5495 #endif
5496
5497 #if FFETARGET_okCHARACTER4
5498         case FFEINFO_kindtypeCHARACTER4:
5499           error = ffetarget_gt_character4 (&val,
5500                              ffebld_constant_character4 (ffebld_conter (l)),
5501                             ffebld_constant_character4 (ffebld_conter (r)));
5502           expr = ffebld_new_conter_with_orig
5503             (ffebld_constant_new_logicaldefault (val), expr);
5504           break;
5505 #endif
5506
5507         default:
5508           assert ("bad character kind type" == NULL);
5509           break;
5510         }
5511       break;
5512
5513     default:
5514       assert ("bad type" == NULL);
5515       return expr;
5516     }
5517
5518   ffebld_set_info (expr, ffeinfo_new
5519                    (FFEINFO_basictypeLOGICAL,
5520                     FFEINFO_kindtypeLOGICALDEFAULT,
5521                     0,
5522                     FFEINFO_kindENTITY,
5523                     FFEINFO_whereCONSTANT,
5524                     FFETARGET_charactersizeNONE));
5525
5526   if ((error != FFEBAD)
5527       && ffebad_start (error))
5528     {
5529       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5530       ffebad_finish ();
5531     }
5532
5533   return expr;
5534 }
5535
5536 /* ffeexpr_collapse_le -- Collapse le expr
5537
5538    ffebld expr;
5539    ffelexToken token;
5540    expr = ffeexpr_collapse_le(expr,token);
5541
5542    If the result of the expr is a constant, replaces the expr with the
5543    computed constant.  */
5544
5545 ffebld
5546 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5547 {
5548   ffebad error = FFEBAD;
5549   ffebld l;
5550   ffebld r;
5551   bool val;
5552
5553   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5554     return expr;
5555
5556   l = ffebld_left (expr);
5557   r = ffebld_right (expr);
5558
5559   if (ffebld_op (l) != FFEBLD_opCONTER)
5560     return expr;
5561   if (ffebld_op (r) != FFEBLD_opCONTER)
5562     return expr;
5563
5564   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5565     {
5566     case FFEINFO_basictypeANY:
5567       return expr;
5568
5569     case FFEINFO_basictypeINTEGER:
5570       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5571         {
5572 #if FFETARGET_okINTEGER1
5573         case FFEINFO_kindtypeINTEGER1:
5574           error = ffetarget_le_integer1 (&val,
5575                                ffebld_constant_integer1 (ffebld_conter (l)),
5576                               ffebld_constant_integer1 (ffebld_conter (r)));
5577           expr = ffebld_new_conter_with_orig
5578             (ffebld_constant_new_logicaldefault (val), expr);
5579           break;
5580 #endif
5581
5582 #if FFETARGET_okINTEGER2
5583         case FFEINFO_kindtypeINTEGER2:
5584           error = ffetarget_le_integer2 (&val,
5585                                ffebld_constant_integer2 (ffebld_conter (l)),
5586                               ffebld_constant_integer2 (ffebld_conter (r)));
5587           expr = ffebld_new_conter_with_orig
5588             (ffebld_constant_new_logicaldefault (val), expr);
5589           break;
5590 #endif
5591
5592 #if FFETARGET_okINTEGER3
5593         case FFEINFO_kindtypeINTEGER3:
5594           error = ffetarget_le_integer3 (&val,
5595                                ffebld_constant_integer3 (ffebld_conter (l)),
5596                               ffebld_constant_integer3 (ffebld_conter (r)));
5597           expr = ffebld_new_conter_with_orig
5598             (ffebld_constant_new_logicaldefault (val), expr);
5599           break;
5600 #endif
5601
5602 #if FFETARGET_okINTEGER4
5603         case FFEINFO_kindtypeINTEGER4:
5604           error = ffetarget_le_integer4 (&val,
5605                                ffebld_constant_integer4 (ffebld_conter (l)),
5606                               ffebld_constant_integer4 (ffebld_conter (r)));
5607           expr = ffebld_new_conter_with_orig
5608             (ffebld_constant_new_logicaldefault (val), expr);
5609           break;
5610 #endif
5611
5612         default:
5613           assert ("bad integer kind type" == NULL);
5614           break;
5615         }
5616       break;
5617
5618     case FFEINFO_basictypeREAL:
5619       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5620         {
5621 #if FFETARGET_okREAL1
5622         case FFEINFO_kindtypeREAL1:
5623           error = ffetarget_le_real1 (&val,
5624                                   ffebld_constant_real1 (ffebld_conter (l)),
5625                                  ffebld_constant_real1 (ffebld_conter (r)));
5626           expr = ffebld_new_conter_with_orig
5627             (ffebld_constant_new_logicaldefault (val), expr);
5628           break;
5629 #endif
5630
5631 #if FFETARGET_okREAL2
5632         case FFEINFO_kindtypeREAL2:
5633           error = ffetarget_le_real2 (&val,
5634                                   ffebld_constant_real2 (ffebld_conter (l)),
5635                                  ffebld_constant_real2 (ffebld_conter (r)));
5636           expr = ffebld_new_conter_with_orig
5637             (ffebld_constant_new_logicaldefault (val), expr);
5638           break;
5639 #endif
5640
5641 #if FFETARGET_okREAL3
5642         case FFEINFO_kindtypeREAL3:
5643           error = ffetarget_le_real3 (&val,
5644                                   ffebld_constant_real3 (ffebld_conter (l)),
5645                                  ffebld_constant_real3 (ffebld_conter (r)));
5646           expr = ffebld_new_conter_with_orig
5647             (ffebld_constant_new_logicaldefault (val), expr);
5648           break;
5649 #endif
5650
5651 #if FFETARGET_okREAL4
5652         case FFEINFO_kindtypeREAL4:
5653           error = ffetarget_le_real4 (&val,
5654                                   ffebld_constant_real4 (ffebld_conter (l)),
5655                                  ffebld_constant_real4 (ffebld_conter (r)));
5656           expr = ffebld_new_conter_with_orig
5657             (ffebld_constant_new_logicaldefault (val), expr);
5658           break;
5659 #endif
5660
5661         default:
5662           assert ("bad real kind type" == NULL);
5663           break;
5664         }
5665       break;
5666
5667     case FFEINFO_basictypeCHARACTER:
5668       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5669         {
5670 #if FFETARGET_okCHARACTER1
5671         case FFEINFO_kindtypeCHARACTER1:
5672           error = ffetarget_le_character1 (&val,
5673                              ffebld_constant_character1 (ffebld_conter (l)),
5674                             ffebld_constant_character1 (ffebld_conter (r)));
5675           expr = ffebld_new_conter_with_orig
5676             (ffebld_constant_new_logicaldefault (val), expr);
5677           break;
5678 #endif
5679
5680 #if FFETARGET_okCHARACTER2
5681         case FFEINFO_kindtypeCHARACTER2:
5682           error = ffetarget_le_character2 (&val,
5683                              ffebld_constant_character2 (ffebld_conter (l)),
5684                             ffebld_constant_character2 (ffebld_conter (r)));
5685           expr = ffebld_new_conter_with_orig
5686             (ffebld_constant_new_logicaldefault (val), expr);
5687           break;
5688 #endif
5689
5690 #if FFETARGET_okCHARACTER3
5691         case FFEINFO_kindtypeCHARACTER3:
5692           error = ffetarget_le_character3 (&val,
5693                              ffebld_constant_character3 (ffebld_conter (l)),
5694                             ffebld_constant_character3 (ffebld_conter (r)));
5695           expr = ffebld_new_conter_with_orig
5696             (ffebld_constant_new_logicaldefault (val), expr);
5697           break;
5698 #endif
5699
5700 #if FFETARGET_okCHARACTER4
5701         case FFEINFO_kindtypeCHARACTER4:
5702           error = ffetarget_le_character4 (&val,
5703                              ffebld_constant_character4 (ffebld_conter (l)),
5704                             ffebld_constant_character4 (ffebld_conter (r)));
5705           expr = ffebld_new_conter_with_orig
5706             (ffebld_constant_new_logicaldefault (val), expr);
5707           break;
5708 #endif
5709
5710         default:
5711           assert ("bad character kind type" == NULL);
5712           break;
5713         }
5714       break;
5715
5716     default:
5717       assert ("bad type" == NULL);
5718       return expr;
5719     }
5720
5721   ffebld_set_info (expr, ffeinfo_new
5722                    (FFEINFO_basictypeLOGICAL,
5723                     FFEINFO_kindtypeLOGICALDEFAULT,
5724                     0,
5725                     FFEINFO_kindENTITY,
5726                     FFEINFO_whereCONSTANT,
5727                     FFETARGET_charactersizeNONE));
5728
5729   if ((error != FFEBAD)
5730       && ffebad_start (error))
5731     {
5732       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5733       ffebad_finish ();
5734     }
5735
5736   return expr;
5737 }
5738
5739 /* ffeexpr_collapse_lt -- Collapse lt expr
5740
5741    ffebld expr;
5742    ffelexToken token;
5743    expr = ffeexpr_collapse_lt(expr,token);
5744
5745    If the result of the expr is a constant, replaces the expr with the
5746    computed constant.  */
5747
5748 ffebld
5749 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5750 {
5751   ffebad error = FFEBAD;
5752   ffebld l;
5753   ffebld r;
5754   bool val;
5755
5756   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5757     return expr;
5758
5759   l = ffebld_left (expr);
5760   r = ffebld_right (expr);
5761
5762   if (ffebld_op (l) != FFEBLD_opCONTER)
5763     return expr;
5764   if (ffebld_op (r) != FFEBLD_opCONTER)
5765     return expr;
5766
5767   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5768     {
5769     case FFEINFO_basictypeANY:
5770       return expr;
5771
5772     case FFEINFO_basictypeINTEGER:
5773       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5774         {
5775 #if FFETARGET_okINTEGER1
5776         case FFEINFO_kindtypeINTEGER1:
5777           error = ffetarget_lt_integer1 (&val,
5778                                ffebld_constant_integer1 (ffebld_conter (l)),
5779                               ffebld_constant_integer1 (ffebld_conter (r)));
5780           expr = ffebld_new_conter_with_orig
5781             (ffebld_constant_new_logicaldefault (val), expr);
5782           break;
5783 #endif
5784
5785 #if FFETARGET_okINTEGER2
5786         case FFEINFO_kindtypeINTEGER2:
5787           error = ffetarget_lt_integer2 (&val,
5788                                ffebld_constant_integer2 (ffebld_conter (l)),
5789                               ffebld_constant_integer2 (ffebld_conter (r)));
5790           expr = ffebld_new_conter_with_orig
5791             (ffebld_constant_new_logicaldefault (val), expr);
5792           break;
5793 #endif
5794
5795 #if FFETARGET_okINTEGER3
5796         case FFEINFO_kindtypeINTEGER3:
5797           error = ffetarget_lt_integer3 (&val,
5798                                ffebld_constant_integer3 (ffebld_conter (l)),
5799                               ffebld_constant_integer3 (ffebld_conter (r)));
5800           expr = ffebld_new_conter_with_orig
5801             (ffebld_constant_new_logicaldefault (val), expr);
5802           break;
5803 #endif
5804
5805 #if FFETARGET_okINTEGER4
5806         case FFEINFO_kindtypeINTEGER4:
5807           error = ffetarget_lt_integer4 (&val,
5808                                ffebld_constant_integer4 (ffebld_conter (l)),
5809                               ffebld_constant_integer4 (ffebld_conter (r)));
5810           expr = ffebld_new_conter_with_orig
5811             (ffebld_constant_new_logicaldefault (val), expr);
5812           break;
5813 #endif
5814
5815         default:
5816           assert ("bad integer kind type" == NULL);
5817           break;
5818         }
5819       break;
5820
5821     case FFEINFO_basictypeREAL:
5822       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5823         {
5824 #if FFETARGET_okREAL1
5825         case FFEINFO_kindtypeREAL1:
5826           error = ffetarget_lt_real1 (&val,
5827                                   ffebld_constant_real1 (ffebld_conter (l)),
5828                                  ffebld_constant_real1 (ffebld_conter (r)));
5829           expr = ffebld_new_conter_with_orig
5830             (ffebld_constant_new_logicaldefault (val), expr);
5831           break;
5832 #endif
5833
5834 #if FFETARGET_okREAL2
5835         case FFEINFO_kindtypeREAL2:
5836           error = ffetarget_lt_real2 (&val,
5837                                   ffebld_constant_real2 (ffebld_conter (l)),
5838                                  ffebld_constant_real2 (ffebld_conter (r)));
5839           expr = ffebld_new_conter_with_orig
5840             (ffebld_constant_new_logicaldefault (val), expr);
5841           break;
5842 #endif
5843
5844 #if FFETARGET_okREAL3
5845         case FFEINFO_kindtypeREAL3:
5846           error = ffetarget_lt_real3 (&val,
5847                                   ffebld_constant_real3 (ffebld_conter (l)),
5848                                  ffebld_constant_real3 (ffebld_conter (r)));
5849           expr = ffebld_new_conter_with_orig
5850             (ffebld_constant_new_logicaldefault (val), expr);
5851           break;
5852 #endif
5853
5854 #if FFETARGET_okREAL4
5855         case FFEINFO_kindtypeREAL4:
5856           error = ffetarget_lt_real4 (&val,
5857                                   ffebld_constant_real4 (ffebld_conter (l)),
5858                                  ffebld_constant_real4 (ffebld_conter (r)));
5859           expr = ffebld_new_conter_with_orig
5860             (ffebld_constant_new_logicaldefault (val), expr);
5861           break;
5862 #endif
5863
5864         default:
5865           assert ("bad real kind type" == NULL);
5866           break;
5867         }
5868       break;
5869
5870     case FFEINFO_basictypeCHARACTER:
5871       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5872         {
5873 #if FFETARGET_okCHARACTER1
5874         case FFEINFO_kindtypeCHARACTER1:
5875           error = ffetarget_lt_character1 (&val,
5876                              ffebld_constant_character1 (ffebld_conter (l)),
5877                             ffebld_constant_character1 (ffebld_conter (r)));
5878           expr = ffebld_new_conter_with_orig
5879             (ffebld_constant_new_logicaldefault (val), expr);
5880           break;
5881 #endif
5882
5883 #if FFETARGET_okCHARACTER2
5884         case FFEINFO_kindtypeCHARACTER2:
5885           error = ffetarget_lt_character2 (&val,
5886                              ffebld_constant_character2 (ffebld_conter (l)),
5887                             ffebld_constant_character2 (ffebld_conter (r)));
5888           expr = ffebld_new_conter_with_orig
5889             (ffebld_constant_new_logicaldefault (val), expr);
5890           break;
5891 #endif
5892
5893 #if FFETARGET_okCHARACTER3
5894         case FFEINFO_kindtypeCHARACTER3:
5895           error = ffetarget_lt_character3 (&val,
5896                              ffebld_constant_character3 (ffebld_conter (l)),
5897                             ffebld_constant_character3 (ffebld_conter (r)));
5898           expr = ffebld_new_conter_with_orig
5899             (ffebld_constant_new_logicaldefault (val), expr);
5900           break;
5901 #endif
5902
5903 #if FFETARGET_okCHARACTER4
5904         case FFEINFO_kindtypeCHARACTER4:
5905           error = ffetarget_lt_character4 (&val,
5906                              ffebld_constant_character4 (ffebld_conter (l)),
5907                             ffebld_constant_character4 (ffebld_conter (r)));
5908           expr = ffebld_new_conter_with_orig
5909             (ffebld_constant_new_logicaldefault (val), expr);
5910           break;
5911 #endif
5912
5913         default:
5914           assert ("bad character kind type" == NULL);
5915           break;
5916         }
5917       break;
5918
5919     default:
5920       assert ("bad type" == NULL);
5921       return expr;
5922     }
5923
5924   ffebld_set_info (expr, ffeinfo_new
5925                    (FFEINFO_basictypeLOGICAL,
5926                     FFEINFO_kindtypeLOGICALDEFAULT,
5927                     0,
5928                     FFEINFO_kindENTITY,
5929                     FFEINFO_whereCONSTANT,
5930                     FFETARGET_charactersizeNONE));
5931
5932   if ((error != FFEBAD)
5933       && ffebad_start (error))
5934     {
5935       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5936       ffebad_finish ();
5937     }
5938
5939   return expr;
5940 }
5941
5942 /* ffeexpr_collapse_and -- Collapse and expr
5943
5944    ffebld expr;
5945    ffelexToken token;
5946    expr = ffeexpr_collapse_and(expr,token);
5947
5948    If the result of the expr is a constant, replaces the expr with the
5949    computed constant.  */
5950
5951 ffebld
5952 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5953 {
5954   ffebad error = FFEBAD;
5955   ffebld l;
5956   ffebld r;
5957   ffebldConstantUnion u;
5958   ffeinfoBasictype bt;
5959   ffeinfoKindtype kt;
5960
5961   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5962     return expr;
5963
5964   l = ffebld_left (expr);
5965   r = ffebld_right (expr);
5966
5967   if (ffebld_op (l) != FFEBLD_opCONTER)
5968     return expr;
5969   if (ffebld_op (r) != FFEBLD_opCONTER)
5970     return expr;
5971
5972   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5973     {
5974     case FFEINFO_basictypeANY:
5975       return expr;
5976
5977     case FFEINFO_basictypeINTEGER:
5978       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5979         {
5980 #if FFETARGET_okINTEGER1
5981         case FFEINFO_kindtypeINTEGER1:
5982           error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5983                                ffebld_constant_integer1 (ffebld_conter (l)),
5984                               ffebld_constant_integer1 (ffebld_conter (r)));
5985           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5986                                         (ffebld_cu_val_integer1 (u)), expr);
5987           break;
5988 #endif
5989
5990 #if FFETARGET_okINTEGER2
5991         case FFEINFO_kindtypeINTEGER2:
5992           error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5993                                ffebld_constant_integer2 (ffebld_conter (l)),
5994                               ffebld_constant_integer2 (ffebld_conter (r)));
5995           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5996                                         (ffebld_cu_val_integer2 (u)), expr);
5997           break;
5998 #endif
5999
6000 #if FFETARGET_okINTEGER3
6001         case FFEINFO_kindtypeINTEGER3:
6002           error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6003                                ffebld_constant_integer3 (ffebld_conter (l)),
6004                               ffebld_constant_integer3 (ffebld_conter (r)));
6005           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6006                                         (ffebld_cu_val_integer3 (u)), expr);
6007           break;
6008 #endif
6009
6010 #if FFETARGET_okINTEGER4
6011         case FFEINFO_kindtypeINTEGER4:
6012           error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6013                                ffebld_constant_integer4 (ffebld_conter (l)),
6014                               ffebld_constant_integer4 (ffebld_conter (r)));
6015           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6016                                         (ffebld_cu_val_integer4 (u)), expr);
6017           break;
6018 #endif
6019
6020         default:
6021           assert ("bad integer kind type" == NULL);
6022           break;
6023         }
6024       break;
6025
6026     case FFEINFO_basictypeLOGICAL:
6027       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6028         {
6029 #if FFETARGET_okLOGICAL1
6030         case FFEINFO_kindtypeLOGICAL1:
6031           error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6032                                ffebld_constant_logical1 (ffebld_conter (l)),
6033                               ffebld_constant_logical1 (ffebld_conter (r)));
6034           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6035                                         (ffebld_cu_val_logical1 (u)), expr);
6036           break;
6037 #endif
6038
6039 #if FFETARGET_okLOGICAL2
6040         case FFEINFO_kindtypeLOGICAL2:
6041           error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6042                                ffebld_constant_logical2 (ffebld_conter (l)),
6043                               ffebld_constant_logical2 (ffebld_conter (r)));
6044           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6045                                         (ffebld_cu_val_logical2 (u)), expr);
6046           break;
6047 #endif
6048
6049 #if FFETARGET_okLOGICAL3
6050         case FFEINFO_kindtypeLOGICAL3:
6051           error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6052                                ffebld_constant_logical3 (ffebld_conter (l)),
6053                               ffebld_constant_logical3 (ffebld_conter (r)));
6054           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6055                                         (ffebld_cu_val_logical3 (u)), expr);
6056           break;
6057 #endif
6058
6059 #if FFETARGET_okLOGICAL4
6060         case FFEINFO_kindtypeLOGICAL4:
6061           error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6062                                ffebld_constant_logical4 (ffebld_conter (l)),
6063                               ffebld_constant_logical4 (ffebld_conter (r)));
6064           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6065                                         (ffebld_cu_val_logical4 (u)), expr);
6066           break;
6067 #endif
6068
6069         default:
6070           assert ("bad logical kind type" == NULL);
6071           break;
6072         }
6073       break;
6074
6075     default:
6076       assert ("bad type" == NULL);
6077       return expr;
6078     }
6079
6080   ffebld_set_info (expr, ffeinfo_new
6081                    (bt,
6082                     kt,
6083                     0,
6084                     FFEINFO_kindENTITY,
6085                     FFEINFO_whereCONSTANT,
6086                     FFETARGET_charactersizeNONE));
6087
6088   if ((error != FFEBAD)
6089       && ffebad_start (error))
6090     {
6091       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6092       ffebad_finish ();
6093     }
6094
6095   return expr;
6096 }
6097
6098 /* ffeexpr_collapse_or -- Collapse or expr
6099
6100    ffebld expr;
6101    ffelexToken token;
6102    expr = ffeexpr_collapse_or(expr,token);
6103
6104    If the result of the expr is a constant, replaces the expr with the
6105    computed constant.  */
6106
6107 ffebld
6108 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6109 {
6110   ffebad error = FFEBAD;
6111   ffebld l;
6112   ffebld r;
6113   ffebldConstantUnion u;
6114   ffeinfoBasictype bt;
6115   ffeinfoKindtype kt;
6116
6117   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6118     return expr;
6119
6120   l = ffebld_left (expr);
6121   r = ffebld_right (expr);
6122
6123   if (ffebld_op (l) != FFEBLD_opCONTER)
6124     return expr;
6125   if (ffebld_op (r) != FFEBLD_opCONTER)
6126     return expr;
6127
6128   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6129     {
6130     case FFEINFO_basictypeANY:
6131       return expr;
6132
6133     case FFEINFO_basictypeINTEGER:
6134       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6135         {
6136 #if FFETARGET_okINTEGER1
6137         case FFEINFO_kindtypeINTEGER1:
6138           error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6139                                ffebld_constant_integer1 (ffebld_conter (l)),
6140                               ffebld_constant_integer1 (ffebld_conter (r)));
6141           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6142                                         (ffebld_cu_val_integer1 (u)), expr);
6143           break;
6144 #endif
6145
6146 #if FFETARGET_okINTEGER2
6147         case FFEINFO_kindtypeINTEGER2:
6148           error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6149                                ffebld_constant_integer2 (ffebld_conter (l)),
6150                               ffebld_constant_integer2 (ffebld_conter (r)));
6151           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6152                                         (ffebld_cu_val_integer2 (u)), expr);
6153           break;
6154 #endif
6155
6156 #if FFETARGET_okINTEGER3
6157         case FFEINFO_kindtypeINTEGER3:
6158           error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6159                                ffebld_constant_integer3 (ffebld_conter (l)),
6160                               ffebld_constant_integer3 (ffebld_conter (r)));
6161           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6162                                         (ffebld_cu_val_integer3 (u)), expr);
6163           break;
6164 #endif
6165
6166 #if FFETARGET_okINTEGER4
6167         case FFEINFO_kindtypeINTEGER4:
6168           error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6169                                ffebld_constant_integer4 (ffebld_conter (l)),
6170                               ffebld_constant_integer4 (ffebld_conter (r)));
6171           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6172                                         (ffebld_cu_val_integer4 (u)), expr);
6173           break;
6174 #endif
6175
6176         default:
6177           assert ("bad integer kind type" == NULL);
6178           break;
6179         }
6180       break;
6181
6182     case FFEINFO_basictypeLOGICAL:
6183       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6184         {
6185 #if FFETARGET_okLOGICAL1
6186         case FFEINFO_kindtypeLOGICAL1:
6187           error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6188                                ffebld_constant_logical1 (ffebld_conter (l)),
6189                               ffebld_constant_logical1 (ffebld_conter (r)));
6190           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6191                                         (ffebld_cu_val_logical1 (u)), expr);
6192           break;
6193 #endif
6194
6195 #if FFETARGET_okLOGICAL2
6196         case FFEINFO_kindtypeLOGICAL2:
6197           error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6198                                ffebld_constant_logical2 (ffebld_conter (l)),
6199                               ffebld_constant_logical2 (ffebld_conter (r)));
6200           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6201                                         (ffebld_cu_val_logical2 (u)), expr);
6202           break;
6203 #endif
6204
6205 #if FFETARGET_okLOGICAL3
6206         case FFEINFO_kindtypeLOGICAL3:
6207           error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6208                                ffebld_constant_logical3 (ffebld_conter (l)),
6209                               ffebld_constant_logical3 (ffebld_conter (r)));
6210           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6211                                         (ffebld_cu_val_logical3 (u)), expr);
6212           break;
6213 #endif
6214
6215 #if FFETARGET_okLOGICAL4
6216         case FFEINFO_kindtypeLOGICAL4:
6217           error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6218                                ffebld_constant_logical4 (ffebld_conter (l)),
6219                               ffebld_constant_logical4 (ffebld_conter (r)));
6220           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6221                                         (ffebld_cu_val_logical4 (u)), expr);
6222           break;
6223 #endif
6224
6225         default:
6226           assert ("bad logical kind type" == NULL);
6227           break;
6228         }
6229       break;
6230
6231     default:
6232       assert ("bad type" == NULL);
6233       return expr;
6234     }
6235
6236   ffebld_set_info (expr, ffeinfo_new
6237                    (bt,
6238                     kt,
6239                     0,
6240                     FFEINFO_kindENTITY,
6241                     FFEINFO_whereCONSTANT,
6242                     FFETARGET_charactersizeNONE));
6243
6244   if ((error != FFEBAD)
6245       && ffebad_start (error))
6246     {
6247       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6248       ffebad_finish ();
6249     }
6250
6251   return expr;
6252 }
6253
6254 /* ffeexpr_collapse_xor -- Collapse xor expr
6255
6256    ffebld expr;
6257    ffelexToken token;
6258    expr = ffeexpr_collapse_xor(expr,token);
6259
6260    If the result of the expr is a constant, replaces the expr with the
6261    computed constant.  */
6262
6263 ffebld
6264 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6265 {
6266   ffebad error = FFEBAD;
6267   ffebld l;
6268   ffebld r;
6269   ffebldConstantUnion u;
6270   ffeinfoBasictype bt;
6271   ffeinfoKindtype kt;
6272
6273   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6274     return expr;
6275
6276   l = ffebld_left (expr);
6277   r = ffebld_right (expr);
6278
6279   if (ffebld_op (l) != FFEBLD_opCONTER)
6280     return expr;
6281   if (ffebld_op (r) != FFEBLD_opCONTER)
6282     return expr;
6283
6284   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6285     {
6286     case FFEINFO_basictypeANY:
6287       return expr;
6288
6289     case FFEINFO_basictypeINTEGER:
6290       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6291         {
6292 #if FFETARGET_okINTEGER1
6293         case FFEINFO_kindtypeINTEGER1:
6294           error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6295                                ffebld_constant_integer1 (ffebld_conter (l)),
6296                               ffebld_constant_integer1 (ffebld_conter (r)));
6297           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6298                                         (ffebld_cu_val_integer1 (u)), expr);
6299           break;
6300 #endif
6301
6302 #if FFETARGET_okINTEGER2
6303         case FFEINFO_kindtypeINTEGER2:
6304           error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6305                                ffebld_constant_integer2 (ffebld_conter (l)),
6306                               ffebld_constant_integer2 (ffebld_conter (r)));
6307           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6308                                         (ffebld_cu_val_integer2 (u)), expr);
6309           break;
6310 #endif
6311
6312 #if FFETARGET_okINTEGER3
6313         case FFEINFO_kindtypeINTEGER3:
6314           error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6315                                ffebld_constant_integer3 (ffebld_conter (l)),
6316                               ffebld_constant_integer3 (ffebld_conter (r)));
6317           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6318                                         (ffebld_cu_val_integer3 (u)), expr);
6319           break;
6320 #endif
6321
6322 #if FFETARGET_okINTEGER4
6323         case FFEINFO_kindtypeINTEGER4:
6324           error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6325                                ffebld_constant_integer4 (ffebld_conter (l)),
6326                               ffebld_constant_integer4 (ffebld_conter (r)));
6327           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6328                                         (ffebld_cu_val_integer4 (u)), expr);
6329           break;
6330 #endif
6331
6332         default:
6333           assert ("bad integer kind type" == NULL);
6334           break;
6335         }
6336       break;
6337
6338     case FFEINFO_basictypeLOGICAL:
6339       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6340         {
6341 #if FFETARGET_okLOGICAL1
6342         case FFEINFO_kindtypeLOGICAL1:
6343           error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6344                                ffebld_constant_logical1 (ffebld_conter (l)),
6345                               ffebld_constant_logical1 (ffebld_conter (r)));
6346           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6347                                         (ffebld_cu_val_logical1 (u)), expr);
6348           break;
6349 #endif
6350
6351 #if FFETARGET_okLOGICAL2
6352         case FFEINFO_kindtypeLOGICAL2:
6353           error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6354                                ffebld_constant_logical2 (ffebld_conter (l)),
6355                               ffebld_constant_logical2 (ffebld_conter (r)));
6356           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6357                                         (ffebld_cu_val_logical2 (u)), expr);
6358           break;
6359 #endif
6360
6361 #if FFETARGET_okLOGICAL3
6362         case FFEINFO_kindtypeLOGICAL3:
6363           error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6364                                ffebld_constant_logical3 (ffebld_conter (l)),
6365                               ffebld_constant_logical3 (ffebld_conter (r)));
6366           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6367                                         (ffebld_cu_val_logical3 (u)), expr);
6368           break;
6369 #endif
6370
6371 #if FFETARGET_okLOGICAL4
6372         case FFEINFO_kindtypeLOGICAL4:
6373           error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6374                                ffebld_constant_logical4 (ffebld_conter (l)),
6375                               ffebld_constant_logical4 (ffebld_conter (r)));
6376           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6377                                         (ffebld_cu_val_logical4 (u)), expr);
6378           break;
6379 #endif
6380
6381         default:
6382           assert ("bad logical kind type" == NULL);
6383           break;
6384         }
6385       break;
6386
6387     default:
6388       assert ("bad type" == NULL);
6389       return expr;
6390     }
6391
6392   ffebld_set_info (expr, ffeinfo_new
6393                    (bt,
6394                     kt,
6395                     0,
6396                     FFEINFO_kindENTITY,
6397                     FFEINFO_whereCONSTANT,
6398                     FFETARGET_charactersizeNONE));
6399
6400   if ((error != FFEBAD)
6401       && ffebad_start (error))
6402     {
6403       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6404       ffebad_finish ();
6405     }
6406
6407   return expr;
6408 }
6409
6410 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6411
6412    ffebld expr;
6413    ffelexToken token;
6414    expr = ffeexpr_collapse_eqv(expr,token);
6415
6416    If the result of the expr is a constant, replaces the expr with the
6417    computed constant.  */
6418
6419 ffebld
6420 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6421 {
6422   ffebad error = FFEBAD;
6423   ffebld l;
6424   ffebld r;
6425   ffebldConstantUnion u;
6426   ffeinfoBasictype bt;
6427   ffeinfoKindtype kt;
6428
6429   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6430     return expr;
6431
6432   l = ffebld_left (expr);
6433   r = ffebld_right (expr);
6434
6435   if (ffebld_op (l) != FFEBLD_opCONTER)
6436     return expr;
6437   if (ffebld_op (r) != FFEBLD_opCONTER)
6438     return expr;
6439
6440   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6441     {
6442     case FFEINFO_basictypeANY:
6443       return expr;
6444
6445     case FFEINFO_basictypeINTEGER:
6446       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6447         {
6448 #if FFETARGET_okINTEGER1
6449         case FFEINFO_kindtypeINTEGER1:
6450           error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6451                                ffebld_constant_integer1 (ffebld_conter (l)),
6452                               ffebld_constant_integer1 (ffebld_conter (r)));
6453           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6454                                         (ffebld_cu_val_integer1 (u)), expr);
6455           break;
6456 #endif
6457
6458 #if FFETARGET_okINTEGER2
6459         case FFEINFO_kindtypeINTEGER2:
6460           error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6461                                ffebld_constant_integer2 (ffebld_conter (l)),
6462                               ffebld_constant_integer2 (ffebld_conter (r)));
6463           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6464                                         (ffebld_cu_val_integer2 (u)), expr);
6465           break;
6466 #endif
6467
6468 #if FFETARGET_okINTEGER3
6469         case FFEINFO_kindtypeINTEGER3:
6470           error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6471                                ffebld_constant_integer3 (ffebld_conter (l)),
6472                               ffebld_constant_integer3 (ffebld_conter (r)));
6473           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6474                                         (ffebld_cu_val_integer3 (u)), expr);
6475           break;
6476 #endif
6477
6478 #if FFETARGET_okINTEGER4
6479         case FFEINFO_kindtypeINTEGER4:
6480           error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6481                                ffebld_constant_integer4 (ffebld_conter (l)),
6482                               ffebld_constant_integer4 (ffebld_conter (r)));
6483           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6484                                         (ffebld_cu_val_integer4 (u)), expr);
6485           break;
6486 #endif
6487
6488         default:
6489           assert ("bad integer kind type" == NULL);
6490           break;
6491         }
6492       break;
6493
6494     case FFEINFO_basictypeLOGICAL:
6495       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6496         {
6497 #if FFETARGET_okLOGICAL1
6498         case FFEINFO_kindtypeLOGICAL1:
6499           error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6500                                ffebld_constant_logical1 (ffebld_conter (l)),
6501                               ffebld_constant_logical1 (ffebld_conter (r)));
6502           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6503                                         (ffebld_cu_val_logical1 (u)), expr);
6504           break;
6505 #endif
6506
6507 #if FFETARGET_okLOGICAL2
6508         case FFEINFO_kindtypeLOGICAL2:
6509           error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6510                                ffebld_constant_logical2 (ffebld_conter (l)),
6511                               ffebld_constant_logical2 (ffebld_conter (r)));
6512           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6513                                         (ffebld_cu_val_logical2 (u)), expr);
6514           break;
6515 #endif
6516
6517 #if FFETARGET_okLOGICAL3
6518         case FFEINFO_kindtypeLOGICAL3:
6519           error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6520                                ffebld_constant_logical3 (ffebld_conter (l)),
6521                               ffebld_constant_logical3 (ffebld_conter (r)));
6522           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6523                                         (ffebld_cu_val_logical3 (u)), expr);
6524           break;
6525 #endif
6526
6527 #if FFETARGET_okLOGICAL4
6528         case FFEINFO_kindtypeLOGICAL4:
6529           error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6530                                ffebld_constant_logical4 (ffebld_conter (l)),
6531                               ffebld_constant_logical4 (ffebld_conter (r)));
6532           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6533                                         (ffebld_cu_val_logical4 (u)), expr);
6534           break;
6535 #endif
6536
6537         default:
6538           assert ("bad logical kind type" == NULL);
6539           break;
6540         }
6541       break;
6542
6543     default:
6544       assert ("bad type" == NULL);
6545       return expr;
6546     }
6547
6548   ffebld_set_info (expr, ffeinfo_new
6549                    (bt,
6550                     kt,
6551                     0,
6552                     FFEINFO_kindENTITY,
6553                     FFEINFO_whereCONSTANT,
6554                     FFETARGET_charactersizeNONE));
6555
6556   if ((error != FFEBAD)
6557       && ffebad_start (error))
6558     {
6559       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6560       ffebad_finish ();
6561     }
6562
6563   return expr;
6564 }
6565
6566 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6567
6568    ffebld expr;
6569    ffelexToken token;
6570    expr = ffeexpr_collapse_neqv(expr,token);
6571
6572    If the result of the expr is a constant, replaces the expr with the
6573    computed constant.  */
6574
6575 ffebld
6576 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6577 {
6578   ffebad error = FFEBAD;
6579   ffebld l;
6580   ffebld r;
6581   ffebldConstantUnion u;
6582   ffeinfoBasictype bt;
6583   ffeinfoKindtype kt;
6584
6585   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6586     return expr;
6587
6588   l = ffebld_left (expr);
6589   r = ffebld_right (expr);
6590
6591   if (ffebld_op (l) != FFEBLD_opCONTER)
6592     return expr;
6593   if (ffebld_op (r) != FFEBLD_opCONTER)
6594     return expr;
6595
6596   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6597     {
6598     case FFEINFO_basictypeANY:
6599       return expr;
6600
6601     case FFEINFO_basictypeINTEGER:
6602       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6603         {
6604 #if FFETARGET_okINTEGER1
6605         case FFEINFO_kindtypeINTEGER1:
6606           error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6607                                ffebld_constant_integer1 (ffebld_conter (l)),
6608                               ffebld_constant_integer1 (ffebld_conter (r)));
6609           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6610                                         (ffebld_cu_val_integer1 (u)), expr);
6611           break;
6612 #endif
6613
6614 #if FFETARGET_okINTEGER2
6615         case FFEINFO_kindtypeINTEGER2:
6616           error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6617                                ffebld_constant_integer2 (ffebld_conter (l)),
6618                               ffebld_constant_integer2 (ffebld_conter (r)));
6619           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6620                                         (ffebld_cu_val_integer2 (u)), expr);
6621           break;
6622 #endif
6623
6624 #if FFETARGET_okINTEGER3
6625         case FFEINFO_kindtypeINTEGER3:
6626           error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6627                                ffebld_constant_integer3 (ffebld_conter (l)),
6628                               ffebld_constant_integer3 (ffebld_conter (r)));
6629           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6630                                         (ffebld_cu_val_integer3 (u)), expr);
6631           break;
6632 #endif
6633
6634 #if FFETARGET_okINTEGER4
6635         case FFEINFO_kindtypeINTEGER4:
6636           error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6637                                ffebld_constant_integer4 (ffebld_conter (l)),
6638                               ffebld_constant_integer4 (ffebld_conter (r)));
6639           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6640                                         (ffebld_cu_val_integer4 (u)), expr);
6641           break;
6642 #endif
6643
6644         default:
6645           assert ("bad integer kind type" == NULL);
6646           break;
6647         }
6648       break;
6649
6650     case FFEINFO_basictypeLOGICAL:
6651       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6652         {
6653 #if FFETARGET_okLOGICAL1
6654         case FFEINFO_kindtypeLOGICAL1:
6655           error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6656                                ffebld_constant_logical1 (ffebld_conter (l)),
6657                               ffebld_constant_logical1 (ffebld_conter (r)));
6658           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6659                                         (ffebld_cu_val_logical1 (u)), expr);
6660           break;
6661 #endif
6662
6663 #if FFETARGET_okLOGICAL2
6664         case FFEINFO_kindtypeLOGICAL2:
6665           error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6666                                ffebld_constant_logical2 (ffebld_conter (l)),
6667                               ffebld_constant_logical2 (ffebld_conter (r)));
6668           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6669                                         (ffebld_cu_val_logical2 (u)), expr);
6670           break;
6671 #endif
6672
6673 #if FFETARGET_okLOGICAL3
6674         case FFEINFO_kindtypeLOGICAL3:
6675           error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6676                                ffebld_constant_logical3 (ffebld_conter (l)),
6677                               ffebld_constant_logical3 (ffebld_conter (r)));
6678           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6679                                         (ffebld_cu_val_logical3 (u)), expr);
6680           break;
6681 #endif
6682
6683 #if FFETARGET_okLOGICAL4
6684         case FFEINFO_kindtypeLOGICAL4:
6685           error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6686                                ffebld_constant_logical4 (ffebld_conter (l)),
6687                               ffebld_constant_logical4 (ffebld_conter (r)));
6688           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6689                                         (ffebld_cu_val_logical4 (u)), expr);
6690           break;
6691 #endif
6692
6693         default:
6694           assert ("bad logical kind type" == NULL);
6695           break;
6696         }
6697       break;
6698
6699     default:
6700       assert ("bad type" == NULL);
6701       return expr;
6702     }
6703
6704   ffebld_set_info (expr, ffeinfo_new
6705                    (bt,
6706                     kt,
6707                     0,
6708                     FFEINFO_kindENTITY,
6709                     FFEINFO_whereCONSTANT,
6710                     FFETARGET_charactersizeNONE));
6711
6712   if ((error != FFEBAD)
6713       && ffebad_start (error))
6714     {
6715       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6716       ffebad_finish ();
6717     }
6718
6719   return expr;
6720 }
6721
6722 /* ffeexpr_collapse_symter -- Collapse symter expr
6723
6724    ffebld expr;
6725    ffelexToken token;
6726    expr = ffeexpr_collapse_symter(expr,token);
6727
6728    If the result of the expr is a constant, replaces the expr with the
6729    computed constant.  */
6730
6731 ffebld
6732 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6733 {
6734   ffebld r;
6735   ffeinfoBasictype bt;
6736   ffeinfoKindtype kt;
6737   ffetargetCharacterSize len;
6738
6739   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6740     return expr;
6741
6742   if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6743     return expr;                /* A PARAMETER lhs in progress. */
6744
6745   switch (ffebld_op (r))
6746     {
6747     case FFEBLD_opCONTER:
6748       break;
6749
6750     case FFEBLD_opANY:
6751       return r;
6752
6753     default:
6754       return expr;
6755     }
6756
6757   bt = ffeinfo_basictype (ffebld_info (r));
6758   kt = ffeinfo_kindtype (ffebld_info (r));
6759   len = ffebld_size (r);
6760
6761   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6762                                       expr);
6763
6764   ffebld_set_info (expr, ffeinfo_new
6765                    (bt,
6766                     kt,
6767                     0,
6768                     FFEINFO_kindENTITY,
6769                     FFEINFO_whereCONSTANT,
6770                     len));
6771
6772   return expr;
6773 }
6774
6775 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6776
6777    ffebld expr;
6778    ffelexToken token;
6779    expr = ffeexpr_collapse_funcref(expr,token);
6780
6781    If the result of the expr is a constant, replaces the expr with the
6782    computed constant.  */
6783
6784 ffebld
6785 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6786 {
6787   return expr;                  /* ~~someday go ahead and collapse these,
6788                                    though not required */
6789 }
6790
6791 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6792
6793    ffebld expr;
6794    ffelexToken token;
6795    expr = ffeexpr_collapse_arrayref(expr,token);
6796
6797    If the result of the expr is a constant, replaces the expr with the
6798    computed constant.  */
6799
6800 ffebld
6801 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6802 {
6803   return expr;
6804 }
6805
6806 /* ffeexpr_collapse_substr -- Collapse substr expr
6807
6808    ffebld expr;
6809    ffelexToken token;
6810    expr = ffeexpr_collapse_substr(expr,token);
6811
6812    If the result of the expr is a constant, replaces the expr with the
6813    computed constant.  */
6814
6815 ffebld
6816 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6817 {
6818   ffebad error = FFEBAD;
6819   ffebld l;
6820   ffebld r;
6821   ffebld start;
6822   ffebld stop;
6823   ffebldConstantUnion u;
6824   ffeinfoKindtype kt;
6825   ffetargetCharacterSize len;
6826   ffetargetIntegerDefault first;
6827   ffetargetIntegerDefault last;
6828
6829   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6830     return expr;
6831
6832   l = ffebld_left (expr);
6833   r = ffebld_right (expr);      /* opITEM. */
6834
6835   if (ffebld_op (l) != FFEBLD_opCONTER)
6836     return expr;
6837
6838   kt = ffeinfo_kindtype (ffebld_info (l));
6839   len = ffebld_size (l);
6840
6841   start = ffebld_head (r);
6842   stop = ffebld_head (ffebld_trail (r));
6843   if (start == NULL)
6844     first = 1;
6845   else
6846     {
6847       if ((ffebld_op (start) != FFEBLD_opCONTER)
6848           || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6849           || (ffeinfo_kindtype (ffebld_info (start))
6850               != FFEINFO_kindtypeINTEGERDEFAULT))
6851         return expr;
6852       first = ffebld_constant_integerdefault (ffebld_conter (start));
6853     }
6854   if (stop == NULL)
6855     last = len;
6856   else
6857     {
6858       if ((ffebld_op (stop) != FFEBLD_opCONTER)
6859       || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6860           || (ffeinfo_kindtype (ffebld_info (stop))
6861               != FFEINFO_kindtypeINTEGERDEFAULT))
6862         return expr;
6863       last = ffebld_constant_integerdefault (ffebld_conter (stop));
6864     }
6865
6866   /* Handle problems that should have already been diagnosed, but
6867      left in the expression tree.  */
6868
6869   if (first <= 0)
6870     first = 1;
6871   if (last < first)
6872     last = first + len - 1;
6873
6874   if ((first == 1) && (last == len))
6875     {                           /* Same as original. */
6876       expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6877                                           (ffebld_conter (l)), expr);
6878       ffebld_set_info (expr, ffeinfo_new
6879                        (FFEINFO_basictypeCHARACTER,
6880                         kt,
6881                         0,
6882                         FFEINFO_kindENTITY,
6883                         FFEINFO_whereCONSTANT,
6884                         len));
6885
6886       return expr;
6887     }
6888
6889   switch (ffeinfo_basictype (ffebld_info (expr)))
6890     {
6891     case FFEINFO_basictypeANY:
6892       return expr;
6893
6894     case FFEINFO_basictypeCHARACTER:
6895       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6896         {
6897 #if FFETARGET_okCHARACTER1
6898         case FFEINFO_kindtypeCHARACTER1:
6899           error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6900                 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6901                                    ffebld_constant_pool (), &len);
6902           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6903                                       (ffebld_cu_val_character1 (u)), expr);
6904           break;
6905 #endif
6906
6907 #if FFETARGET_okCHARACTER2
6908         case FFEINFO_kindtypeCHARACTER2:
6909           error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6910                 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6911                                    ffebld_constant_pool (), &len);
6912           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6913                                       (ffebld_cu_val_character2 (u)), expr);
6914           break;
6915 #endif
6916
6917 #if FFETARGET_okCHARACTER3
6918         case FFEINFO_kindtypeCHARACTER3:
6919           error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6920                 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6921                                    ffebld_constant_pool (), &len);
6922           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6923                                       (ffebld_cu_val_character3 (u)), expr);
6924           break;
6925 #endif
6926
6927 #if FFETARGET_okCHARACTER4
6928         case FFEINFO_kindtypeCHARACTER4:
6929           error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6930                 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6931                                    ffebld_constant_pool (), &len);
6932           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6933                                       (ffebld_cu_val_character4 (u)), expr);
6934           break;
6935 #endif
6936
6937         default:
6938           assert ("bad character kind type" == NULL);
6939           break;
6940         }
6941       break;
6942
6943     default:
6944       assert ("bad type" == NULL);
6945       return expr;
6946     }
6947
6948   ffebld_set_info (expr, ffeinfo_new
6949                    (FFEINFO_basictypeCHARACTER,
6950                     kt,
6951                     0,
6952                     FFEINFO_kindENTITY,
6953                     FFEINFO_whereCONSTANT,
6954                     len));
6955
6956   if ((error != FFEBAD)
6957       && ffebad_start (error))
6958     {
6959       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6960       ffebad_finish ();
6961     }
6962
6963   return expr;
6964 }
6965
6966 /* ffeexpr_convert -- Convert source expression to given type
6967
6968    ffebld source;
6969    ffelexToken source_token;
6970    ffelexToken dest_token;  // Any appropriate token for "destination".
6971    ffeinfoBasictype bt;
6972    ffeinfoKindtype kt;
6973    ffetargetCharactersize sz;
6974    ffeexprContext context;  // Mainly LET or DATA.
6975    source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6976
6977    If the expression conforms, returns the source expression.  Otherwise
6978    returns source wrapped in a convert node doing the conversion, or
6979    ANY wrapped in convert if there is a conversion error (and issues an
6980    error message).  Be sensitive to the context for certain aspects of
6981    the conversion.  */
6982
6983 ffebld
6984 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6985                  ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6986                  ffetargetCharacterSize sz, ffeexprContext context)
6987 {
6988   bool bad;
6989   ffeinfo info;
6990   ffeinfoWhere wh;
6991
6992   info = ffebld_info (source);
6993   if ((bt != ffeinfo_basictype (info))
6994       || (kt != ffeinfo_kindtype (info))
6995       || (rk != 0)              /* Can't convert from or to arrays yet. */
6996       || (ffeinfo_rank (info) != 0)
6997       || (sz != ffebld_size_known (source)))
6998 #if 0   /* Nobody seems to need this spurious CONVERT node. */
6999       || ((context != FFEEXPR_contextLET)
7000           && (bt == FFEINFO_basictypeCHARACTER)
7001           && (sz == FFETARGET_charactersizeNONE)))
7002 #endif
7003     {
7004       switch (ffeinfo_basictype (info))
7005         {
7006         case FFEINFO_basictypeLOGICAL:
7007           switch (bt)
7008             {
7009             case FFEINFO_basictypeLOGICAL:
7010               bad = FALSE;
7011               break;
7012
7013             case FFEINFO_basictypeINTEGER:
7014               bad = !ffe_is_ugly_logint ();
7015               break;
7016
7017             case FFEINFO_basictypeCHARACTER:
7018               bad = ffe_is_pedantic ()
7019                 || !(ffe_is_ugly_init ()
7020                      && (context == FFEEXPR_contextDATA));
7021               break;
7022
7023             default:
7024               bad = TRUE;
7025               break;
7026             }
7027           break;
7028
7029         case FFEINFO_basictypeINTEGER:
7030           switch (bt)
7031             {
7032             case FFEINFO_basictypeINTEGER:
7033             case FFEINFO_basictypeREAL:
7034             case FFEINFO_basictypeCOMPLEX:
7035               bad = FALSE;
7036               break;
7037
7038             case FFEINFO_basictypeLOGICAL:
7039               bad = !ffe_is_ugly_logint ();
7040               break;
7041
7042             case FFEINFO_basictypeCHARACTER:
7043               bad = ffe_is_pedantic ()
7044                 || !(ffe_is_ugly_init ()
7045                      && (context == FFEEXPR_contextDATA));
7046               break;
7047
7048             default:
7049               bad = TRUE;
7050               break;
7051             }
7052           break;
7053
7054         case FFEINFO_basictypeREAL:
7055         case FFEINFO_basictypeCOMPLEX:
7056           switch (bt)
7057             {
7058             case FFEINFO_basictypeINTEGER:
7059             case FFEINFO_basictypeREAL:
7060             case FFEINFO_basictypeCOMPLEX:
7061               bad = FALSE;
7062               break;
7063
7064             case FFEINFO_basictypeCHARACTER:
7065               bad = TRUE;
7066               break;
7067
7068             default:
7069               bad = TRUE;
7070               break;
7071             }
7072           break;
7073
7074         case FFEINFO_basictypeCHARACTER:
7075           bad = (bt != FFEINFO_basictypeCHARACTER)
7076             && (ffe_is_pedantic ()
7077                 || (bt != FFEINFO_basictypeINTEGER)
7078                 || !(ffe_is_ugly_init ()
7079                      && (context == FFEEXPR_contextDATA)));
7080           break;
7081
7082         case FFEINFO_basictypeTYPELESS:
7083         case FFEINFO_basictypeHOLLERITH:
7084           bad = ffe_is_pedantic ()
7085             || !(ffe_is_ugly_init ()
7086                  && ((context == FFEEXPR_contextDATA)
7087                      || (context == FFEEXPR_contextLET)));
7088           break;
7089
7090         default:
7091           bad = TRUE;
7092           break;
7093         }
7094
7095       if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7096         bad = TRUE;
7097
7098       if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7099           && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7100           && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7101           && (ffeinfo_where (info) != FFEINFO_whereANY))
7102         {
7103           if (ffebad_start (FFEBAD_BAD_TYPES))
7104             {
7105               if (dest_token == NULL)
7106                 ffebad_here (0, ffewhere_line_unknown (),
7107                              ffewhere_column_unknown ());
7108               else
7109                 ffebad_here (0, ffelex_token_where_line (dest_token),
7110                              ffelex_token_where_column (dest_token));
7111               assert (source_token != NULL);
7112               ffebad_here (1, ffelex_token_where_line (source_token),
7113                            ffelex_token_where_column (source_token));
7114               ffebad_finish ();
7115             }
7116
7117           source = ffebld_new_any ();
7118           ffebld_set_info (source, ffeinfo_new_any ());
7119         }
7120       else
7121         {
7122           switch (ffeinfo_where (info))
7123             {
7124             case FFEINFO_whereCONSTANT:
7125               wh = FFEINFO_whereCONSTANT;
7126               break;
7127
7128             case FFEINFO_whereIMMEDIATE:
7129               wh = FFEINFO_whereIMMEDIATE;
7130               break;
7131
7132             default:
7133               wh = FFEINFO_whereFLEETING;
7134               break;
7135             }
7136           source = ffebld_new_convert (source);
7137           ffebld_set_info (source, ffeinfo_new
7138                            (bt,
7139                             kt,
7140                             0,
7141                             FFEINFO_kindENTITY,
7142                             wh,
7143                             sz));
7144           source = ffeexpr_collapse_convert (source, source_token);
7145         }
7146     }
7147
7148   return source;
7149 }
7150
7151 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7152
7153    ffebld source;
7154    ffebld dest;
7155    ffelexToken source_token;
7156    ffelexToken dest_token;
7157    ffeexprContext context;
7158    source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7159
7160    If the expressions conform, returns the source expression.  Otherwise
7161    returns source wrapped in a convert node doing the conversion, or
7162    ANY wrapped in convert if there is a conversion error (and issues an
7163    error message).  Be sensitive to the context, such as LET or DATA.  */
7164
7165 ffebld
7166 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7167                       ffelexToken dest_token, ffeexprContext context)
7168 {
7169   ffeinfo info;
7170
7171   info = ffebld_info (dest);
7172   return ffeexpr_convert (source, source_token, dest_token,
7173                           ffeinfo_basictype (info),
7174                           ffeinfo_kindtype (info),
7175                           ffeinfo_rank (info),
7176                           ffebld_size_known (dest),
7177                           context);
7178 }
7179
7180 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7181
7182    ffebld source;
7183    ffesymbol dest;
7184    ffelexToken source_token;
7185    ffelexToken dest_token;
7186    source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7187
7188    If the expressions conform, returns the source expression.  Otherwise
7189    returns source wrapped in a convert node doing the conversion, or
7190    ANY wrapped in convert if there is a conversion error (and issues an
7191    error message).  */
7192
7193 ffebld
7194 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7195                         ffesymbol dest, ffelexToken dest_token)
7196 {
7197   return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7198     ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7199                           FFEEXPR_contextLET);
7200 }
7201
7202 /* Initializes the module.  */
7203
7204 void
7205 ffeexpr_init_2 ()
7206 {
7207   ffeexpr_stack_ = NULL;
7208   ffeexpr_level_ = 0;
7209 }
7210
7211 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7212
7213    Prepares cluster for delivery of lexer tokens representing an expression
7214    in a left-hand-side context (A in A=B, for example).  ffebld is used
7215    to build expressions in the given pool.  The appropriate lexer-token
7216    handling routine within ffeexpr is returned.  When the end of the
7217    expression is detected, mycallbackroutine is called with the resulting
7218    single ffebld object specifying the entire expression and the first
7219    lexer token that is not considered part of the expression.  This caller-
7220    supplied routine itself returns a lexer-token handling routine.  Thus,
7221    if necessary, ffeexpr can return several tokens as end-of-expression
7222    tokens if it needs to scan forward more than one in any instance.  */
7223
7224 ffelexHandler
7225 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7226 {
7227   ffeexprStack_ s;
7228
7229   ffebld_pool_push (pool);
7230   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7231   s->previous = ffeexpr_stack_;
7232   s->pool = pool;
7233   s->context = context;
7234   s->callback = callback;
7235   s->first_token = NULL;
7236   s->exprstack = NULL;
7237   s->is_rhs = FALSE;
7238   ffeexpr_stack_ = s;
7239   return (ffelexHandler) ffeexpr_token_first_lhs_;
7240 }
7241
7242 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7243
7244    return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
7245
7246    Prepares cluster for delivery of lexer tokens representing an expression
7247    in a right-hand-side context (B in A=B, for example).  ffebld is used
7248    to build expressions in the given pool.  The appropriate lexer-token
7249    handling routine within ffeexpr is returned.  When the end of the
7250    expression is detected, mycallbackroutine is called with the resulting
7251    single ffebld object specifying the entire expression and the first
7252    lexer token that is not considered part of the expression.  This caller-
7253    supplied routine itself returns a lexer-token handling routine.  Thus,
7254    if necessary, ffeexpr can return several tokens as end-of-expression
7255    tokens if it needs to scan forward more than one in any instance.  */
7256
7257 ffelexHandler
7258 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7259 {
7260   ffeexprStack_ s;
7261
7262   ffebld_pool_push (pool);
7263   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7264   s->previous = ffeexpr_stack_;
7265   s->pool = pool;
7266   s->context = context;
7267   s->callback = callback;
7268   s->first_token = NULL;
7269   s->exprstack = NULL;
7270   s->is_rhs = TRUE;
7271   ffeexpr_stack_ = s;
7272   return (ffelexHandler) ffeexpr_token_first_rhs_;
7273 }
7274
7275 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7276
7277    Pass it to ffeexpr_rhs as the callback routine.
7278
7279    Makes sure the end token is close-paren and swallows it, else issues
7280    an error message and doesn't swallow the token (passing it along instead).
7281    In either case wraps up subexpression construction by enclosing the
7282    ffebld expression in a paren.  */
7283
7284 static ffelexHandler
7285 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7286 {
7287   ffeexprExpr_ e;
7288
7289   if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7290     {
7291       /* Oops, naughty user didn't specify the close paren! */
7292
7293       if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7294         {
7295           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7296           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7297                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7298           ffebad_finish ();
7299         }
7300
7301       e = ffeexpr_expr_new_ ();
7302       e->type = FFEEXPR_exprtypeOPERAND_;
7303       e->u.operand = ffebld_new_any ();
7304       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7305       ffeexpr_exprstack_push_operand_ (e);
7306
7307       return
7308         (ffelexHandler) ffeexpr_find_close_paren_ (t,
7309                                                    (ffelexHandler)
7310                                                    ffeexpr_token_binary_);
7311     }
7312
7313   if (expr->op == FFEBLD_opIMPDO)
7314     {
7315       if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7316         {
7317           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7318                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7319           ffebad_finish ();
7320         }
7321     }
7322   else
7323     {
7324       expr = ffebld_new_paren (expr);
7325       ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7326     }
7327
7328   /* Now push the (parenthesized) expression as an operand onto the
7329      expression stack. */
7330
7331   e = ffeexpr_expr_new_ ();
7332   e->type = FFEEXPR_exprtypeOPERAND_;
7333   e->u.operand = expr;
7334   e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7335   e->token = ffeexpr_stack_->tokens[0];
7336   ffeexpr_exprstack_push_operand_ (e);
7337
7338   return (ffelexHandler) ffeexpr_token_binary_;
7339 }
7340
7341 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7342
7343    Pass it to ffeexpr_rhs as the callback routine.
7344
7345    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7346    with the next token in t.  If the next token is possibly a binary
7347    operator, continue processing the outer expression.  If the next
7348    token is COMMA, then the expression is a unit specifier, and
7349    parentheses should not be added to it because it surrounds the
7350    I/O control list that starts with the unit specifier (and continues
7351    on from here -- we haven't seen the CLOSE_PAREN that matches the
7352    OPEN_PAREN, it is up to the callback function to expect to see it
7353    at some point).  In this case, we notify the callback function that
7354    the COMMA is inside, not outside, the parens by wrapping the expression
7355    in an opITEM (with a NULL trail) -- the callback function presumably
7356    unwraps it after seeing this kludgey indicator.
7357
7358    If the next token is CLOSE_PAREN, then we go to the _1_ state to
7359    decide what to do with the token after that.
7360
7361    15-Feb-91  JCB  1.1
7362       Use an extra state for the CLOSE_PAREN case to make READ &co really
7363       work right.  */
7364
7365 static ffelexHandler
7366 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7367 {
7368   ffeexprCallback callback;
7369   ffeexprStack_ s;
7370
7371   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7372     {                           /* Need to see the next token before we
7373                                    decide anything. */
7374       ffeexpr_stack_->expr = expr;
7375       ffeexpr_tokens_[0] = ffelex_token_use (ft);
7376       ffeexpr_tokens_[1] = ffelex_token_use (t);
7377       return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7378     }
7379
7380   expr = ffeexpr_finished_ambig_ (ft, expr);
7381
7382   /* Let the callback function handle the case where t isn't COMMA. */
7383
7384   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7385      that preceded the expression starts a list of expressions, and the expr
7386      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7387      node.  The callback function should extract the real expr from the head
7388      of this opITEM node after testing it. */
7389
7390   expr = ffebld_new_item (expr, NULL);
7391
7392   ffebld_pool_pop ();
7393   callback = ffeexpr_stack_->callback;
7394   ffelex_token_kill (ffeexpr_stack_->first_token);
7395   s = ffeexpr_stack_->previous;
7396   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7397   ffeexpr_stack_ = s;
7398   return (ffelexHandler) (*callback) (ft, expr, t);
7399 }
7400
7401 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7402
7403    See ffeexpr_cb_close_paren_ambig_.
7404
7405    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7406    with the next token in t.  If the next token is possibly a binary
7407    operator, continue processing the outer expression.  If the next
7408    token is COMMA, the expression is a parenthesized format specifier.
7409    If the next token is not EOS or SEMICOLON, then because it is not a
7410    binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7411    a unit specifier, and parentheses should not be added to it because
7412    they surround the I/O control list that consists of only the unit
7413    specifier.  If the next token is EOS or SEMICOLON, the statement
7414    must be disambiguated by looking at the type of the expression -- a
7415    character expression is a parenthesized format specifier, while a
7416    non-character expression is a unit specifier.
7417
7418    Another issue is how to do the callback so the recipient of the
7419    next token knows how to handle it if it is a COMMA.  In all other
7420    cases, disambiguation is straightforward: the same approach as the
7421    above is used.
7422
7423    EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7424    as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7425    and apparently other compilers do, as well, and some code out there
7426    uses this "feature".
7427
7428    19-Feb-91  JCB  1.1
7429       Extend to allow COMMA as nondisambiguating by itself.  Remember
7430       to not try and check info field for opSTAR, since that expr doesn't
7431       have a valid info field.  */
7432
7433 static ffelexHandler
7434 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7435 {
7436   ffeexprCallback callback;
7437   ffeexprStack_ s;
7438   ffelexHandler next;
7439   ffelexToken orig_ft = ffeexpr_tokens_[0];     /* In case callback clobbers
7440                                                    these. */
7441   ffelexToken orig_t = ffeexpr_tokens_[1];
7442   ffebld expr = ffeexpr_stack_->expr;
7443
7444   switch (ffelex_token_type (t))
7445     {
7446     case FFELEX_typeCOMMA:      /* Subexpr is parenthesized format specifier. */
7447       if (ffe_is_pedantic ())
7448         goto pedantic_comma;    /* :::::::::::::::::::: */
7449       /* Fall through. */
7450     case FFELEX_typeEOS:        /* Ambiguous; use type of expr to
7451                                    disambiguate. */
7452     case FFELEX_typeSEMICOLON:
7453       if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7454           || (ffebld_op (expr) == FFEBLD_opSTAR)
7455           || (ffeinfo_basictype (ffebld_info (expr))
7456               != FFEINFO_basictypeCHARACTER))
7457         break;                  /* Not a valid CHARACTER entity, can't be a
7458                                    format spec. */
7459       /* Fall through. */
7460     default:                    /* Binary op (we assume; error otherwise);
7461                                    format specifier. */
7462
7463     pedantic_comma:             /* :::::::::::::::::::: */
7464
7465       switch (ffeexpr_stack_->context)
7466         {
7467         case FFEEXPR_contextFILENUMAMBIG:
7468           ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7469           break;
7470
7471         case FFEEXPR_contextFILEUNITAMBIG:
7472           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7473           break;
7474
7475         default:
7476           assert ("bad context" == NULL);
7477           break;
7478         }
7479
7480       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7481       next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7482       ffelex_token_kill (orig_ft);
7483       ffelex_token_kill (orig_t);
7484       return (ffelexHandler) (*next) (t);
7485
7486     case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7487     case FFELEX_typeNAME:
7488       break;
7489     }
7490
7491   expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7492
7493   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7494      that preceded the expression starts a list of expressions, and the expr
7495      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7496      node.  The callback function should extract the real expr from the head
7497      of this opITEM node after testing it. */
7498
7499   expr = ffebld_new_item (expr, NULL);
7500
7501   ffebld_pool_pop ();
7502   callback = ffeexpr_stack_->callback;
7503   ffelex_token_kill (ffeexpr_stack_->first_token);
7504   s = ffeexpr_stack_->previous;
7505   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7506   ffeexpr_stack_ = s;
7507   next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7508   ffelex_token_kill (orig_ft);
7509   ffelex_token_kill (orig_t);
7510   return (ffelexHandler) (*next) (t);
7511 }
7512
7513 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7514
7515    Pass it to ffeexpr_rhs as the callback routine.
7516
7517    Makes sure the end token is close-paren and swallows it, or a comma
7518    and handles complex/implied-do possibilities, else issues
7519    an error message and doesn't swallow the token (passing it along instead).  */
7520
7521 static ffelexHandler
7522 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7523 {
7524   /* First check to see if this is a possible complex entity.  It is if the
7525      token is a comma. */
7526
7527   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7528     {
7529       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7530       ffeexpr_stack_->expr = expr;
7531       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7532                                 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7533     }
7534
7535   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7536 }
7537
7538 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7539
7540    Pass it to ffeexpr_rhs as the callback routine.
7541
7542    If this token is not a comma, we have a complex constant (or an attempt
7543    at one), so handle it accordingly, displaying error messages if the token
7544    is not a close-paren.  */
7545
7546 static ffelexHandler
7547 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7548 {
7549   ffeexprExpr_ e;
7550   ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7551     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7552   ffeinfoBasictype rty = (expr == NULL)
7553     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7554   ffeinfoKindtype lkt;
7555   ffeinfoKindtype rkt;
7556   ffeinfoKindtype nkt;
7557   bool ok = TRUE;
7558   ffebld orig;
7559
7560   if ((ffeexpr_stack_->expr == NULL)
7561       || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7562       || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7563           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7564                && (ffebld_op (orig) != FFEBLD_opUPLUS))
7565               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7566       || ((lty != FFEINFO_basictypeINTEGER)
7567           && (lty != FFEINFO_basictypeREAL)))
7568     {
7569       if ((lty != FFEINFO_basictypeANY)
7570           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7571         {
7572           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7573                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7574           ffebad_string ("Real");
7575           ffebad_finish ();
7576         }
7577       ok = FALSE;
7578     }
7579   if ((expr == NULL)
7580       || (ffebld_op (expr) != FFEBLD_opCONTER)
7581       || (((orig = ffebld_conter_orig (expr)) != NULL)
7582           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7583                && (ffebld_op (orig) != FFEBLD_opUPLUS))
7584               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7585       || ((rty != FFEINFO_basictypeINTEGER)
7586           && (rty != FFEINFO_basictypeREAL)))
7587     {
7588       if ((rty != FFEINFO_basictypeANY)
7589           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7590         {
7591           ffebad_here (0, ffelex_token_where_line (ft),
7592                        ffelex_token_where_column (ft));
7593           ffebad_string ("Imaginary");
7594           ffebad_finish ();
7595         }
7596       ok = FALSE;
7597     }
7598
7599   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7600
7601   /* Push the (parenthesized) expression as an operand onto the expression
7602      stack. */
7603
7604   e = ffeexpr_expr_new_ ();
7605   e->type = FFEEXPR_exprtypeOPERAND_;
7606   e->token = ffeexpr_stack_->tokens[0];
7607
7608   if (ok)
7609     {
7610       if (lty == FFEINFO_basictypeINTEGER)
7611         lkt = FFEINFO_kindtypeREALDEFAULT;
7612       else
7613         lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7614       if (rty == FFEINFO_basictypeINTEGER)
7615         rkt = FFEINFO_kindtypeREALDEFAULT;
7616       else
7617         rkt = ffeinfo_kindtype (ffebld_info (expr));
7618
7619       nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7620       ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7621                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7622                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7623                                               FFEEXPR_contextLET);
7624       expr = ffeexpr_convert (expr,
7625                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7626                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7627                               FFEEXPR_contextLET);
7628     }
7629   else
7630     nkt = FFEINFO_kindtypeANY;
7631
7632   switch (nkt)
7633     {
7634 #if FFETARGET_okCOMPLEX1
7635     case FFEINFO_kindtypeREAL1:
7636       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7637               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7638       ffebld_set_info (e->u.operand,
7639                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7640                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7641                                     FFETARGET_charactersizeNONE));
7642       break;
7643 #endif
7644
7645 #if FFETARGET_okCOMPLEX2
7646     case FFEINFO_kindtypeREAL2:
7647       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7648               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7649       ffebld_set_info (e->u.operand,
7650                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7651                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7652                                     FFETARGET_charactersizeNONE));
7653       break;
7654 #endif
7655
7656 #if FFETARGET_okCOMPLEX3
7657     case FFEINFO_kindtypeREAL3:
7658       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7659               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7660       ffebld_set_info (e->u.operand,
7661                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7662                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7663                                     FFETARGET_charactersizeNONE));
7664       break;
7665 #endif
7666
7667 #if FFETARGET_okCOMPLEX4
7668     case FFEINFO_kindtypeREAL4:
7669       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7670               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7671       ffebld_set_info (e->u.operand,
7672                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7673                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7674                                     FFETARGET_charactersizeNONE));
7675       break;
7676 #endif
7677
7678     default:
7679       if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7680                         ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7681         {
7682           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7683                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7684           ffebad_finish ();
7685         }
7686       /* Fall through. */
7687     case FFEINFO_kindtypeANY:
7688       e->u.operand = ffebld_new_any ();
7689       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7690       break;
7691     }
7692   ffeexpr_exprstack_push_operand_ (e);
7693
7694   /* Now, if the token is a close parenthese, we're in great shape so return
7695      the next handler. */
7696
7697   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7698     return (ffelexHandler) ffeexpr_token_binary_;
7699
7700   /* Oops, naughty user didn't specify the close paren! */
7701
7702   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7703     {
7704       ffebad_here (0, ffelex_token_where_line (t),
7705                    ffelex_token_where_column (t));
7706       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7707                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7708       ffebad_finish ();
7709     }
7710
7711   return
7712     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7713                                                (ffelexHandler)
7714                                                ffeexpr_token_binary_);
7715 }
7716
7717 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7718                                     implied-DO construct)
7719
7720    Pass it to ffeexpr_rhs as the callback routine.
7721
7722    Makes sure the end token is close-paren and swallows it, or a comma
7723    and handles complex/implied-do possibilities, else issues
7724    an error message and doesn't swallow the token (passing it along instead).  */
7725
7726 static ffelexHandler
7727 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7728 {
7729   ffeexprContext ctx;
7730
7731   /* First check to see if this is a possible complex or implied-DO entity.
7732      It is if the token is a comma. */
7733
7734   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7735     {
7736       switch (ffeexpr_stack_->context)
7737         {
7738         case FFEEXPR_contextIOLIST:
7739         case FFEEXPR_contextIMPDOITEM_:
7740           ctx = FFEEXPR_contextIMPDOITEM_;
7741           break;
7742
7743         case FFEEXPR_contextIOLISTDF:
7744         case FFEEXPR_contextIMPDOITEMDF_:
7745           ctx = FFEEXPR_contextIMPDOITEMDF_;
7746           break;
7747
7748         default:
7749           assert ("bad context" == NULL);
7750           ctx = FFEEXPR_contextIMPDOITEM_;
7751           break;
7752         }
7753
7754       ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7755       ffeexpr_stack_->expr = expr;
7756       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7757                                           ctx, ffeexpr_cb_comma_ci_);
7758     }
7759
7760   ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7761   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7762 }
7763
7764 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7765
7766    Pass it to ffeexpr_rhs as the callback routine.
7767
7768    If this token is not a comma, we have a complex constant (or an attempt
7769    at one), so handle it accordingly, displaying error messages if the token
7770    is not a close-paren.  If we have a comma here, it is an attempt at an
7771    implied-DO, so start making a list accordingly.  Oh, it might be an
7772    equal sign also, meaning an implied-DO with only one item in its list.  */
7773
7774 static ffelexHandler
7775 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7776 {
7777   ffebld fexpr;
7778
7779   /* First check to see if this is a possible complex constant.  It is if the
7780      token is not a comma or an equals sign, in which case it should be a
7781      close-paren. */
7782
7783   if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7784       && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7785     {
7786       ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7787       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7788       return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7789     }
7790
7791   /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7792      construct.  Make a list and handle accordingly. */
7793
7794   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7795   fexpr = ffeexpr_stack_->expr;
7796   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7797   ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7798   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7799 }
7800
7801 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7802
7803    Pass it to ffeexpr_rhs as the callback routine.
7804
7805    Handle first item in an implied-DO construct.  */
7806
7807 static ffelexHandler
7808 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7809 {
7810   if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7811     {
7812       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7813         {
7814           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7815           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7816                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7817           ffebad_finish ();
7818         }
7819       ffebld_end_list (&ffeexpr_stack_->bottom);
7820       ffeexpr_stack_->expr = ffebld_new_any ();
7821       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7822       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7823         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7824       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7825     }
7826
7827   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7828 }
7829
7830 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7831
7832    Pass it to ffeexpr_rhs as the callback routine.
7833
7834    Handle first item in an implied-DO construct.  */
7835
7836 static ffelexHandler
7837 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7838 {
7839   ffeexprContext ctxi;
7840   ffeexprContext ctxc;
7841
7842   switch (ffeexpr_stack_->context)
7843     {
7844     case FFEEXPR_contextDATA:
7845     case FFEEXPR_contextDATAIMPDOITEM_:
7846       ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7847       ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7848       break;
7849
7850     case FFEEXPR_contextIOLIST:
7851     case FFEEXPR_contextIMPDOITEM_:
7852       ctxi = FFEEXPR_contextIMPDOITEM_;
7853       ctxc = FFEEXPR_contextIMPDOCTRL_;
7854       break;
7855
7856     case FFEEXPR_contextIOLISTDF:
7857     case FFEEXPR_contextIMPDOITEMDF_:
7858       ctxi = FFEEXPR_contextIMPDOITEMDF_;
7859       ctxc = FFEEXPR_contextIMPDOCTRL_;
7860       break;
7861
7862     default:
7863       assert ("bad context" == NULL);
7864       ctxi = FFEEXPR_context;
7865       ctxc = FFEEXPR_context;
7866       break;
7867     }
7868
7869   switch (ffelex_token_type (t))
7870     {
7871     case FFELEX_typeCOMMA:
7872       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7873       if (ffeexpr_stack_->is_rhs)
7874         return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7875                                             ctxi, ffeexpr_cb_comma_i_1_);
7876       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7877                                           ctxi, ffeexpr_cb_comma_i_1_);
7878
7879     case FFELEX_typeEQUALS:
7880       ffebld_end_list (&ffeexpr_stack_->bottom);
7881
7882       /* Complain if implied-DO variable in list of items to be read.  */
7883
7884       if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7885         ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7886                               ffeexpr_stack_->first_token, expr, ft);
7887
7888       /* Set doiter flag for all appropriate SYMTERs.  */
7889
7890       ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7891
7892       ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7893       ffebld_set_info (ffeexpr_stack_->expr,
7894                        ffeinfo_new (FFEINFO_basictypeNONE,
7895                                     FFEINFO_kindtypeNONE,
7896                                     0,
7897                                     FFEINFO_kindNONE,
7898                                     FFEINFO_whereNONE,
7899                                     FFETARGET_charactersizeNONE));
7900       ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7901                         &ffeexpr_stack_->bottom);
7902       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7903       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7904                                           ctxc, ffeexpr_cb_comma_i_2_);
7905
7906     default:
7907       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7908         {
7909           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7910           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7911                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7912           ffebad_finish ();
7913         }
7914       ffebld_end_list (&ffeexpr_stack_->bottom);
7915       ffeexpr_stack_->expr = ffebld_new_any ();
7916       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7917       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7918         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7919       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7920     }
7921 }
7922
7923 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7924
7925    Pass it to ffeexpr_rhs as the callback routine.
7926
7927    Handle start-value in an implied-DO construct.  */
7928
7929 static ffelexHandler
7930 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7931 {
7932   ffeexprContext ctx;
7933
7934   switch (ffeexpr_stack_->context)
7935     {
7936     case FFEEXPR_contextDATA:
7937     case FFEEXPR_contextDATAIMPDOITEM_:
7938       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7939       break;
7940
7941     case FFEEXPR_contextIOLIST:
7942     case FFEEXPR_contextIOLISTDF:
7943     case FFEEXPR_contextIMPDOITEM_:
7944     case FFEEXPR_contextIMPDOITEMDF_:
7945       ctx = FFEEXPR_contextIMPDOCTRL_;
7946       break;
7947
7948     default:
7949       assert ("bad context" == NULL);
7950       ctx = FFEEXPR_context;
7951       break;
7952     }
7953
7954   switch (ffelex_token_type (t))
7955     {
7956     case FFELEX_typeCOMMA:
7957       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7958       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7959                                           ctx, ffeexpr_cb_comma_i_3_);
7960       break;
7961
7962     default:
7963       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7964         {
7965           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7966           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7967                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7968           ffebad_finish ();
7969         }
7970       ffebld_end_list (&ffeexpr_stack_->bottom);
7971       ffeexpr_stack_->expr = ffebld_new_any ();
7972       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7973       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7974         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7975       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7976     }
7977 }
7978
7979 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7980
7981    Pass it to ffeexpr_rhs as the callback routine.
7982
7983    Handle end-value in an implied-DO construct.  */
7984
7985 static ffelexHandler
7986 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7987 {
7988   ffeexprContext ctx;
7989
7990   switch (ffeexpr_stack_->context)
7991     {
7992     case FFEEXPR_contextDATA:
7993     case FFEEXPR_contextDATAIMPDOITEM_:
7994       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7995       break;
7996
7997     case FFEEXPR_contextIOLIST:
7998     case FFEEXPR_contextIOLISTDF:
7999     case FFEEXPR_contextIMPDOITEM_:
8000     case FFEEXPR_contextIMPDOITEMDF_:
8001       ctx = FFEEXPR_contextIMPDOCTRL_;
8002       break;
8003
8004     default:
8005       assert ("bad context" == NULL);
8006       ctx = FFEEXPR_context;
8007       break;
8008     }
8009
8010   switch (ffelex_token_type (t))
8011     {
8012     case FFELEX_typeCOMMA:
8013       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8014       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8015                                           ctx, ffeexpr_cb_comma_i_4_);
8016       break;
8017
8018     case FFELEX_typeCLOSE_PAREN:
8019       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8020       return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8021       break;
8022
8023     default:
8024       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8025         {
8026           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8027           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8028                    ffelex_token_where_column (ffeexpr_stack_->first_token));
8029           ffebad_finish ();
8030         }
8031       ffebld_end_list (&ffeexpr_stack_->bottom);
8032       ffeexpr_stack_->expr = ffebld_new_any ();
8033       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8034       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8035         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8036       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8037     }
8038 }
8039
8040 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8041                                [COMMA expr]
8042
8043    Pass it to ffeexpr_rhs as the callback routine.
8044
8045    Handle incr-value in an implied-DO construct.  */
8046
8047 static ffelexHandler
8048 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8049 {
8050   switch (ffelex_token_type (t))
8051     {
8052     case FFELEX_typeCLOSE_PAREN:
8053       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8054       ffebld_end_list (&ffeexpr_stack_->bottom);
8055       {
8056         ffebld item;
8057
8058         for (item = ffebld_left (ffeexpr_stack_->expr);
8059              item != NULL;
8060              item = ffebld_trail (item))
8061           if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8062             goto replace_with_any;      /* :::::::::::::::::::: */
8063
8064         for (item = ffebld_right (ffeexpr_stack_->expr);
8065              item != NULL;
8066              item = ffebld_trail (item))
8067           if ((ffebld_head (item) != NULL)      /* Increment may be NULL. */
8068               && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8069             goto replace_with_any;      /* :::::::::::::::::::: */
8070       }
8071       break;
8072
8073     default:
8074       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8075         {
8076           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8077           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8078                    ffelex_token_where_column (ffeexpr_stack_->first_token));
8079           ffebad_finish ();
8080         }
8081       ffebld_end_list (&ffeexpr_stack_->bottom);
8082
8083     replace_with_any:           /* :::::::::::::::::::: */
8084
8085       ffeexpr_stack_->expr = ffebld_new_any ();
8086       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8087       break;
8088     }
8089
8090   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8091     return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8092   return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8093 }
8094
8095 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8096                                [COMMA expr] CLOSE_PAREN
8097
8098    Pass it to ffeexpr_rhs as the callback routine.
8099
8100    Collects token following implied-DO construct for callback function.  */
8101
8102 static ffelexHandler
8103 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8104 {
8105   ffeexprCallback callback;
8106   ffeexprStack_ s;
8107   ffelexHandler next;
8108   ffelexToken ft;
8109   ffebld expr;
8110   bool terminate;
8111
8112   switch (ffeexpr_stack_->context)
8113     {
8114     case FFEEXPR_contextDATA:
8115     case FFEEXPR_contextDATAIMPDOITEM_:
8116       terminate = TRUE;
8117       break;
8118
8119     case FFEEXPR_contextIOLIST:
8120     case FFEEXPR_contextIOLISTDF:
8121     case FFEEXPR_contextIMPDOITEM_:
8122     case FFEEXPR_contextIMPDOITEMDF_:
8123       terminate = FALSE;
8124       break;
8125
8126     default:
8127       assert ("bad context" == NULL);
8128       terminate = FALSE;
8129       break;
8130     }
8131
8132   ffebld_pool_pop ();
8133   callback = ffeexpr_stack_->callback;
8134   ft = ffeexpr_stack_->first_token;
8135   expr = ffeexpr_stack_->expr;
8136   s = ffeexpr_stack_->previous;
8137   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8138                   sizeof (*ffeexpr_stack_));
8139   ffeexpr_stack_ = s;
8140   next = (ffelexHandler) (*callback) (ft, expr, t);
8141   ffelex_token_kill (ft);
8142   if (terminate)
8143     {
8144       ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8145       --ffeexpr_level_;
8146       if (ffeexpr_level_ == 0)
8147         ffe_terminate_4 ();
8148     }
8149   return (ffelexHandler) next;
8150 }
8151
8152 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8153
8154    Makes sure the end token is close-paren and swallows it, else issues
8155    an error message and doesn't swallow the token (passing it along instead).
8156    In either case wraps up subexpression construction by enclosing the
8157    ffebld expression in a %LOC.  */
8158
8159 static ffelexHandler
8160 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8161 {
8162   ffeexprExpr_ e;
8163
8164   /* First push the (%LOC) expression as an operand onto the expression
8165      stack. */
8166
8167   e = ffeexpr_expr_new_ ();
8168   e->type = FFEEXPR_exprtypeOPERAND_;
8169   e->token = ffeexpr_stack_->tokens[0];
8170   e->u.operand = ffebld_new_percent_loc (expr);
8171   ffebld_set_info (e->u.operand,
8172                    ffeinfo_new (FFEINFO_basictypeINTEGER,
8173                                 ffecom_pointer_kind (),
8174                                 0,
8175                                 FFEINFO_kindENTITY,
8176                                 FFEINFO_whereFLEETING,
8177                                 FFETARGET_charactersizeNONE));
8178 #if 0                           /* ~~ */
8179   e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8180 #endif
8181   ffeexpr_exprstack_push_operand_ (e);
8182
8183   /* Now, if the token is a close parenthese, we're in great shape so return
8184      the next handler. */
8185
8186   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8187     {
8188       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8189       return (ffelexHandler) ffeexpr_token_binary_;
8190     }
8191
8192   /* Oops, naughty user didn't specify the close paren! */
8193
8194   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8195     {
8196       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8197       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8198                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8199       ffebad_finish ();
8200     }
8201
8202   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8203   return
8204     (ffelexHandler) ffeexpr_find_close_paren_ (t,
8205                                                (ffelexHandler)
8206                                                ffeexpr_token_binary_);
8207 }
8208
8209 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8210
8211    Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
8212
8213 static ffelexHandler
8214 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8215 {
8216   ffeexprExpr_ e;
8217   ffebldOp op;
8218
8219   /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8220      such things until the lowest-level expression is reached.  */
8221
8222   op = ffebld_op (expr);
8223   if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8224       || (op == FFEBLD_opPERCENT_DESCR))
8225     {
8226       if (ffebad_start (FFEBAD_NESTED_PERCENT))
8227         {
8228           ffebad_here (0, ffelex_token_where_line (ft),
8229                        ffelex_token_where_column (ft));
8230           ffebad_finish ();
8231         }
8232
8233       do
8234         {
8235           expr = ffebld_left (expr);
8236           op = ffebld_op (expr);
8237         }
8238       while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8239              || (op == FFEBLD_opPERCENT_DESCR));
8240     }
8241
8242   /* Push the expression as an operand onto the expression stack. */
8243
8244   e = ffeexpr_expr_new_ ();
8245   e->type = FFEEXPR_exprtypeOPERAND_;
8246   e->token = ffeexpr_stack_->tokens[0];
8247   switch (ffeexpr_stack_->percent)
8248     {
8249     case FFEEXPR_percentVAL_:
8250       e->u.operand = ffebld_new_percent_val (expr);
8251       break;
8252
8253     case FFEEXPR_percentREF_:
8254       e->u.operand = ffebld_new_percent_ref (expr);
8255       break;
8256
8257     case FFEEXPR_percentDESCR_:
8258       e->u.operand = ffebld_new_percent_descr (expr);
8259       break;
8260
8261     default:
8262       assert ("%lossage" == NULL);
8263       e->u.operand = expr;
8264       break;
8265     }
8266   ffebld_set_info (e->u.operand, ffebld_info (expr));
8267 #if 0                           /* ~~ */
8268   e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8269 #endif
8270   ffeexpr_exprstack_push_operand_ (e);
8271
8272   /* Now, if the token is a close parenthese, we're in great shape so return
8273      the next handler. */
8274
8275   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8276     return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8277
8278   /* Oops, naughty user didn't specify the close paren! */
8279
8280   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8281     {
8282       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8283       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8284                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8285       ffebad_finish ();
8286     }
8287
8288   ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8289
8290   switch (ffeexpr_stack_->context)
8291     {
8292     case FFEEXPR_contextACTUALARG_:
8293       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8294       break;
8295
8296     case FFEEXPR_contextINDEXORACTUALARG_:
8297       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8298       break;
8299
8300     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8301       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8302       break;
8303
8304     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8305       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8306       break;
8307
8308     default:
8309       assert ("bad context?!?!" == NULL);
8310       break;
8311     }
8312
8313   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8314   return
8315     (ffelexHandler) ffeexpr_find_close_paren_ (t,
8316                                                (ffelexHandler)
8317                                                ffeexpr_cb_end_notloc_1_);
8318 }
8319
8320 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8321    CLOSE_PAREN
8322
8323    Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
8324
8325 static ffelexHandler
8326 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8327 {
8328   switch (ffelex_token_type (t))
8329     {
8330     case FFELEX_typeCOMMA:
8331     case FFELEX_typeCLOSE_PAREN:
8332       switch (ffeexpr_stack_->context)
8333         {
8334         case FFEEXPR_contextACTUALARG_:
8335         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8336           break;
8337
8338         case FFEEXPR_contextINDEXORACTUALARG_:
8339           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8340           break;
8341
8342         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8343           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8344           break;
8345
8346         default:
8347           assert ("bad context?!?!" == NULL);
8348           break;
8349         }
8350       break;
8351
8352     default:
8353       if (ffebad_start (FFEBAD_INVALID_PERCENT))
8354         {
8355           ffebad_here (0,
8356                        ffelex_token_where_line (ffeexpr_stack_->first_token),
8357                    ffelex_token_where_column (ffeexpr_stack_->first_token));
8358           ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8359           ffebad_finish ();
8360         }
8361
8362       ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8363                      FFEBLD_opPERCENT_LOC);
8364
8365       switch (ffeexpr_stack_->context)
8366         {
8367         case FFEEXPR_contextACTUALARG_:
8368           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8369           break;
8370
8371         case FFEEXPR_contextINDEXORACTUALARG_:
8372           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8373           break;
8374
8375         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8376           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8377           break;
8378
8379         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8380           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8381           break;
8382
8383         default:
8384           assert ("bad context?!?!" == NULL);
8385           break;
8386         }
8387     }
8388
8389   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8390   return
8391     (ffelexHandler) ffeexpr_token_binary_ (t);
8392 }
8393
8394 /* Process DATA implied-DO iterator variables as this implied-DO level
8395    terminates.  At this point, ffeexpr_level_ == 1 when we see the
8396    last right-paren in "DATA (A(I),I=1,10)/.../".  */
8397
8398 static ffesymbol
8399 ffeexpr_check_impctrl_ (ffesymbol s)
8400 {
8401   assert (s != NULL);
8402   assert (ffesymbol_sfdummyparent (s) != NULL);
8403
8404   switch (ffesymbol_state (s))
8405     {
8406     case FFESYMBOL_stateNONE:   /* Used as iterator already. Now let symbol
8407                                    be used as iterator at any level at or
8408                                    innermore than the outermost of the
8409                                    current level and the symbol's current
8410                                    level. */
8411       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8412         {
8413           ffesymbol_signal_change (s);
8414           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8415           ffesymbol_signal_unreported (s);
8416         }
8417       break;
8418
8419     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
8420                                    Error if at outermost level, else it can
8421                                    still become an iterator. */
8422       if ((ffeexpr_level_ == 1)
8423           && ffebad_start (FFEBAD_BAD_IMPDCL))
8424         {
8425           ffebad_string (ffesymbol_text (s));
8426           ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8427           ffebad_finish ();
8428         }
8429       break;
8430
8431     case FFESYMBOL_stateUNCERTAIN:      /* Iterator. */
8432       assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8433       ffesymbol_signal_change (s);
8434       ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8435       ffesymbol_signal_unreported (s);
8436       break;
8437
8438     case FFESYMBOL_stateUNDERSTOOD:
8439       break;                    /* ANY. */
8440
8441     default:
8442       assert ("Sasha Foo!!" == NULL);
8443       break;
8444     }
8445
8446   return s;
8447 }
8448
8449 /* Issue diagnostic if implied-DO variable appears in list of lhs
8450    expressions (as in "READ *, (I,I=1,10)").  */
8451
8452 static void
8453 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8454                       ffebld dovar, ffelexToken dovar_t)
8455 {
8456   ffebld item;
8457   ffesymbol dovar_sym;
8458   int itemnum;
8459
8460   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8461     return;                     /* Presumably opANY. */
8462
8463   dovar_sym = ffebld_symter (dovar);
8464
8465   for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8466     {
8467       if (((item = ffebld_head (list)) != NULL)
8468           && (ffebld_op (item) == FFEBLD_opSYMTER)
8469           && (ffebld_symter (item) == dovar_sym))
8470         {
8471           char itemno[20];
8472
8473           sprintf (&itemno[0], "%d", itemnum);
8474           if (ffebad_start (FFEBAD_DOITER_IMPDO))
8475             {
8476               ffebad_here (0, ffelex_token_where_line (list_t),
8477                            ffelex_token_where_column (list_t));
8478               ffebad_here (1, ffelex_token_where_line (dovar_t),
8479                            ffelex_token_where_column (dovar_t));
8480               ffebad_string (ffesymbol_text (dovar_sym));
8481               ffebad_string (itemno);
8482               ffebad_finish ();
8483             }
8484         }
8485     }
8486 }
8487
8488 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8489    flag.  */
8490
8491 static void
8492 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8493 {
8494   ffesymbol dovar_sym;
8495
8496   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8497     return;                     /* Presumably opANY. */
8498
8499   dovar_sym = ffebld_symter (dovar);
8500
8501   ffeexpr_update_impdo_sym_ (list, dovar_sym);  /* Recurse! */
8502 }
8503
8504 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8505    if they refer to the given variable.  */
8506
8507 static void
8508 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8509 {
8510   tail_recurse:                 /* :::::::::::::::::::: */
8511
8512   if (expr == NULL)
8513     return;
8514
8515   switch (ffebld_op (expr))
8516     {
8517     case FFEBLD_opSYMTER:
8518       if (ffebld_symter (expr) == dovar)
8519         ffebld_symter_set_is_doiter (expr, TRUE);
8520       break;
8521
8522     case FFEBLD_opITEM:
8523       ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8524       expr = ffebld_trail (expr);
8525       goto tail_recurse;        /* :::::::::::::::::::: */
8526
8527     default:
8528       break;
8529     }
8530
8531   switch (ffebld_arity (expr))
8532     {
8533     case 2:
8534       ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8535       expr = ffebld_right (expr);
8536       goto tail_recurse;        /* :::::::::::::::::::: */
8537
8538     case 1:
8539       expr = ffebld_left (expr);
8540       goto tail_recurse;        /* :::::::::::::::::::: */
8541
8542     default:
8543       break;
8544     }
8545
8546   return;
8547 }
8548
8549 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8550
8551    if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8552        // After zero or more PAREN_ contexts, an IF context exists  */
8553
8554 static ffeexprContext
8555 ffeexpr_context_outer_ (ffeexprStack_ s)
8556 {
8557   assert (s != NULL);
8558
8559   for (;;)
8560     {
8561       switch (s->context)
8562         {
8563         case FFEEXPR_contextPAREN_:
8564         case FFEEXPR_contextPARENFILENUM_:
8565         case FFEEXPR_contextPARENFILEUNIT_:
8566           break;
8567
8568         default:
8569           return s->context;
8570         }
8571       s = s->previous;
8572       assert (s != NULL);
8573     }
8574 }
8575
8576 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8577
8578    ffeexprPercent_ p;
8579    ffelexToken t;
8580    p = ffeexpr_percent_(t);
8581
8582    Returns the identifier for the name, or the NONE identifier.  */
8583
8584 static ffeexprPercent_
8585 ffeexpr_percent_ (ffelexToken t)
8586 {
8587   const char *p;
8588
8589   switch (ffelex_token_length (t))
8590     {
8591     case 3:
8592       switch (*(p = ffelex_token_text (t)))
8593         {
8594         case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8595           if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8596               && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8597             return FFEEXPR_percentLOC_;
8598           return FFEEXPR_percentNONE_;
8599
8600         case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8601           if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8602               && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8603             return FFEEXPR_percentREF_;
8604           return FFEEXPR_percentNONE_;
8605
8606         case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8607           if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8608               && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8609             return FFEEXPR_percentVAL_;
8610           return FFEEXPR_percentNONE_;
8611
8612         default:
8613         no_match_3:             /* :::::::::::::::::::: */
8614           return FFEEXPR_percentNONE_;
8615         }
8616
8617     case 5:
8618       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8619                             "descr", "Descr") == 0)
8620         return FFEEXPR_percentDESCR_;
8621       return FFEEXPR_percentNONE_;
8622
8623     default:
8624       return FFEEXPR_percentNONE_;
8625     }
8626 }
8627
8628 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8629
8630    See prototype.
8631
8632    If combining the two basictype/kindtype pairs produces a COMPLEX with an
8633    unsupported kind type, complain and use the default kind type for
8634    COMPLEX.  */
8635
8636 void
8637 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8638                       ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8639                       ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8640                       ffelexToken t)
8641 {
8642   ffeinfoBasictype nbt;
8643   ffeinfoKindtype nkt;
8644
8645   nbt = ffeinfo_basictype_combine (lbt, rbt);
8646   if ((nbt == FFEINFO_basictypeCOMPLEX)
8647       && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8648       && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8649     {
8650       nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8651       if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8652         nkt = FFEINFO_kindtypeNONE;     /* Force error. */
8653       switch (nkt)
8654         {
8655 #if FFETARGET_okCOMPLEX1
8656         case FFEINFO_kindtypeREAL1:
8657 #endif
8658 #if FFETARGET_okCOMPLEX2
8659         case FFEINFO_kindtypeREAL2:
8660 #endif
8661 #if FFETARGET_okCOMPLEX3
8662         case FFEINFO_kindtypeREAL3:
8663 #endif
8664 #if FFETARGET_okCOMPLEX4
8665         case FFEINFO_kindtypeREAL4:
8666 #endif
8667           break;                /* Fine and dandy. */
8668
8669         default:
8670           if (t != NULL)
8671             {
8672               ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8673                             ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8674               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8675               ffebad_finish ();
8676             }
8677           nbt = FFEINFO_basictypeNONE;
8678           nkt = FFEINFO_kindtypeNONE;
8679           break;
8680
8681         case FFEINFO_kindtypeANY:
8682           nkt = FFEINFO_kindtypeREALDEFAULT;
8683           break;
8684         }
8685     }
8686   else
8687     {                           /* The normal stuff. */
8688       if (nbt == lbt)
8689         {
8690           if (nbt == rbt)
8691             nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8692           else
8693             nkt = lkt;
8694         }
8695       else if (nbt == rbt)
8696         nkt = rkt;
8697       else
8698         {                       /* Let the caller do the complaining. */
8699           nbt = FFEINFO_basictypeNONE;
8700           nkt = FFEINFO_kindtypeNONE;
8701         }
8702     }
8703
8704   /* Always a good idea to avoid aliasing problems.  */
8705
8706   *xnbt = nbt;
8707   *xnkt = nkt;
8708 }
8709
8710 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8711
8712    Return a pointer to this function to the lexer (ffelex), which will
8713    invoke it for the next token.
8714
8715    Record line and column of first token in expression, then invoke the
8716    initial-state lhs handler.  */
8717
8718 static ffelexHandler
8719 ffeexpr_token_first_lhs_ (ffelexToken t)
8720 {
8721   ffeexpr_stack_->first_token = ffelex_token_use (t);
8722
8723   /* When changing the list of valid initial lhs tokens, check whether to
8724      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8725      READ (expr) <token> case -- it assumes it knows which tokens <token> can
8726      be to indicate an lhs (or implied DO), which right now is the set
8727      {NAME,OPEN_PAREN}.
8728
8729      This comment also appears in ffeexpr_token_lhs_. */
8730
8731   switch (ffelex_token_type (t))
8732     {
8733     case FFELEX_typeOPEN_PAREN:
8734       switch (ffeexpr_stack_->context)
8735         {
8736         case FFEEXPR_contextDATA:
8737           ffe_init_4 ();
8738           ffeexpr_level_ = 1;   /* Level of DATA implied-DO construct. */
8739           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8740           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8741                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8742
8743         case FFEEXPR_contextDATAIMPDOITEM_:
8744           ++ffeexpr_level_;     /* Level of DATA implied-DO construct. */
8745           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8746           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8747                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8748
8749         case FFEEXPR_contextIOLIST:
8750         case FFEEXPR_contextIMPDOITEM_:
8751           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8752           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8753                             FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8754
8755         case FFEEXPR_contextIOLISTDF:
8756         case FFEEXPR_contextIMPDOITEMDF_:
8757           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8758           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8759                           FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8760
8761         case FFEEXPR_contextFILEEXTFUNC:
8762           assert (ffeexpr_stack_->exprstack == NULL);
8763           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8764
8765         default:
8766           break;
8767         }
8768       break;
8769
8770     case FFELEX_typeNAME:
8771       switch (ffeexpr_stack_->context)
8772         {
8773         case FFEEXPR_contextFILENAMELIST:
8774           assert (ffeexpr_stack_->exprstack == NULL);
8775           return (ffelexHandler) ffeexpr_token_namelist_;
8776
8777         case FFEEXPR_contextFILEEXTFUNC:
8778           assert (ffeexpr_stack_->exprstack == NULL);
8779           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8780
8781         default:
8782           break;
8783         }
8784       break;
8785
8786     default:
8787       switch (ffeexpr_stack_->context)
8788         {
8789         case FFEEXPR_contextFILEEXTFUNC:
8790           assert (ffeexpr_stack_->exprstack == NULL);
8791           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8792
8793         default:
8794           break;
8795         }
8796       break;
8797     }
8798
8799   return (ffelexHandler) ffeexpr_token_lhs_ (t);
8800 }
8801
8802 /* ffeexpr_token_first_lhs_1_ -- NAME
8803
8804    return ffeexpr_token_first_lhs_1_;  // to lexer
8805
8806    Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8807    statement).  */
8808
8809 static ffelexHandler
8810 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8811 {
8812   ffeexprCallback callback;
8813   ffeexprStack_ s;
8814   ffelexHandler next;
8815   ffelexToken ft;
8816   ffesymbol sy = NULL;
8817   ffebld expr;
8818
8819   ffebld_pool_pop ();
8820   callback = ffeexpr_stack_->callback;
8821   ft = ffeexpr_stack_->first_token;
8822   s = ffeexpr_stack_->previous;
8823
8824   if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8825       || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8826           & FFESYMBOL_attrANY))
8827     {
8828       if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8829           || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8830         {
8831           ffebad_start (FFEBAD_EXPR_WRONG);
8832           ffebad_here (0, ffelex_token_where_line (ft),
8833                        ffelex_token_where_column (ft));
8834           ffebad_finish ();
8835         }
8836       expr = ffebld_new_any ();
8837       ffebld_set_info (expr, ffeinfo_new_any ());
8838     }
8839   else
8840     {
8841       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8842                                 FFEINTRIN_impNONE);
8843       ffebld_set_info (expr, ffesymbol_info (sy));
8844     }
8845
8846   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8847                   sizeof (*ffeexpr_stack_));
8848   ffeexpr_stack_ = s;
8849
8850   next = (ffelexHandler) (*callback) (ft, expr, t);
8851   ffelex_token_kill (ft);
8852   return (ffelexHandler) next;
8853 }
8854
8855 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8856
8857    Record line and column of first token in expression, then invoke the
8858    initial-state rhs handler.
8859
8860    19-Feb-91  JCB  1.1
8861       Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8862       (i.e. only as in READ(*), not READ((*))).  */
8863
8864 static ffelexHandler
8865 ffeexpr_token_first_rhs_ (ffelexToken t)
8866 {
8867   ffesymbol s;
8868
8869   ffeexpr_stack_->first_token = ffelex_token_use (t);
8870
8871   switch (ffelex_token_type (t))
8872     {
8873     case FFELEX_typeASTERISK:
8874       switch (ffeexpr_stack_->context)
8875         {
8876         case FFEEXPR_contextFILEFORMATNML:
8877           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8878           /* Fall through.  */
8879         case FFEEXPR_contextFILEUNIT:
8880         case FFEEXPR_contextDIMLIST:
8881         case FFEEXPR_contextFILEFORMAT:
8882         case FFEEXPR_contextCHARACTERSIZE:
8883           if (ffeexpr_stack_->previous != NULL)
8884             break;              /* Valid only on first level. */
8885           assert (ffeexpr_stack_->exprstack == NULL);
8886           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8887
8888         case FFEEXPR_contextPARENFILEUNIT_:
8889           if (ffeexpr_stack_->previous->previous != NULL)
8890             break;              /* Valid only on second level. */
8891           assert (ffeexpr_stack_->exprstack == NULL);
8892           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8893
8894         case FFEEXPR_contextACTUALARG_:
8895           if (ffeexpr_stack_->previous->context
8896               != FFEEXPR_contextSUBROUTINEREF)
8897             {
8898               ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8899               break;
8900             }
8901           assert (ffeexpr_stack_->exprstack == NULL);
8902           return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8903
8904         case FFEEXPR_contextINDEXORACTUALARG_:
8905           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8906           break;
8907
8908         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8909           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8910           break;
8911
8912         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8913           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8914           break;
8915
8916         default:
8917           break;
8918         }
8919       break;
8920
8921     case FFELEX_typeOPEN_PAREN:
8922       switch (ffeexpr_stack_->context)
8923         {
8924         case FFEEXPR_contextFILENUMAMBIG:
8925           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8926                                               FFEEXPR_contextPARENFILENUM_,
8927                                               ffeexpr_cb_close_paren_ambig_);
8928
8929         case FFEEXPR_contextFILEUNITAMBIG:
8930           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8931                                               FFEEXPR_contextPARENFILEUNIT_,
8932                                               ffeexpr_cb_close_paren_ambig_);
8933
8934         case FFEEXPR_contextIOLIST:
8935         case FFEEXPR_contextIMPDOITEM_:
8936           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8937                                               FFEEXPR_contextIMPDOITEM_,
8938                                               ffeexpr_cb_close_paren_ci_);
8939
8940         case FFEEXPR_contextIOLISTDF:
8941         case FFEEXPR_contextIMPDOITEMDF_:
8942           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8943                                               FFEEXPR_contextIMPDOITEMDF_,
8944                                               ffeexpr_cb_close_paren_ci_);
8945
8946         case FFEEXPR_contextFILEFORMATNML:
8947           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8948           break;
8949
8950         case FFEEXPR_contextACTUALARG_:
8951           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8952           break;
8953
8954         case FFEEXPR_contextINDEXORACTUALARG_:
8955           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8956           break;
8957
8958         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8959           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8960           break;
8961
8962         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8963           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8964           break;
8965
8966         default:
8967           break;
8968         }
8969       break;
8970
8971     case FFELEX_typeNUMBER:
8972       switch (ffeexpr_stack_->context)
8973         {
8974         case FFEEXPR_contextFILEFORMATNML:
8975           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8976           /* Fall through.  */
8977         case FFEEXPR_contextFILEFORMAT:
8978           if (ffeexpr_stack_->previous != NULL)
8979             break;              /* Valid only on first level. */
8980           assert (ffeexpr_stack_->exprstack == NULL);
8981           return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8982
8983         case FFEEXPR_contextACTUALARG_:
8984           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8985           break;
8986
8987         case FFEEXPR_contextINDEXORACTUALARG_:
8988           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8989           break;
8990
8991         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8992           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8993           break;
8994
8995         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8996           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8997           break;
8998
8999         default:
9000           break;
9001         }
9002       break;
9003
9004     case FFELEX_typeNAME:
9005       switch (ffeexpr_stack_->context)
9006         {
9007         case FFEEXPR_contextFILEFORMATNML:
9008           assert (ffeexpr_stack_->exprstack == NULL);
9009           s = ffesymbol_lookup_local (t);
9010           if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9011             return (ffelexHandler) ffeexpr_token_namelist_;
9012           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9013           break;
9014
9015         default:
9016           break;
9017         }
9018       break;
9019
9020     case FFELEX_typePERCENT:
9021       switch (ffeexpr_stack_->context)
9022         {
9023         case FFEEXPR_contextACTUALARG_:
9024         case FFEEXPR_contextINDEXORACTUALARG_:
9025         case FFEEXPR_contextSFUNCDEFACTUALARG_:
9026         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9027           return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9028
9029         case FFEEXPR_contextFILEFORMATNML:
9030           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9031           break;
9032
9033         default:
9034           break;
9035         }
9036
9037     default:
9038       switch (ffeexpr_stack_->context)
9039         {
9040         case FFEEXPR_contextACTUALARG_:
9041           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9042           break;
9043
9044         case FFEEXPR_contextINDEXORACTUALARG_:
9045           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9046           break;
9047
9048         case FFEEXPR_contextSFUNCDEFACTUALARG_:
9049           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9050           break;
9051
9052         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9053           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9054           break;
9055
9056         case FFEEXPR_contextFILEFORMATNML:
9057           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9058           break;
9059
9060         default:
9061           break;
9062         }
9063       break;
9064     }
9065
9066   return (ffelexHandler) ffeexpr_token_rhs_ (t);
9067 }
9068
9069 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9070
9071    return ffeexpr_token_first_rhs_1_;  // to lexer
9072
9073    Return STAR as expression.  */
9074
9075 static ffelexHandler
9076 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9077 {
9078   ffebld expr;
9079   ffeexprCallback callback;
9080   ffeexprStack_ s;
9081   ffelexHandler next;
9082   ffelexToken ft;
9083
9084   expr = ffebld_new_star ();
9085   ffebld_pool_pop ();
9086   callback = ffeexpr_stack_->callback;
9087   ft = ffeexpr_stack_->first_token;
9088   s = ffeexpr_stack_->previous;
9089   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9090   ffeexpr_stack_ = s;
9091   next = (ffelexHandler) (*callback) (ft, expr, t);
9092   ffelex_token_kill (ft);
9093   return (ffelexHandler) next;
9094 }
9095
9096 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9097
9098    return ffeexpr_token_first_rhs_2_;  // to lexer
9099
9100    Return NULL as expression; NUMBER as first (and only) token, unless the
9101    current token is not a terminating token, in which case run normal
9102    expression handling.  */
9103
9104 static ffelexHandler
9105 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9106 {
9107   ffeexprCallback callback;
9108   ffeexprStack_ s;
9109   ffelexHandler next;
9110   ffelexToken ft;
9111
9112   switch (ffelex_token_type (t))
9113     {
9114     case FFELEX_typeCLOSE_PAREN:
9115     case FFELEX_typeCOMMA:
9116     case FFELEX_typeEOS:
9117     case FFELEX_typeSEMICOLON:
9118       break;
9119
9120     default:
9121       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9122       return (ffelexHandler) (*next) (t);
9123     }
9124
9125   ffebld_pool_pop ();
9126   callback = ffeexpr_stack_->callback;
9127   ft = ffeexpr_stack_->first_token;
9128   s = ffeexpr_stack_->previous;
9129   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9130                   sizeof (*ffeexpr_stack_));
9131   ffeexpr_stack_ = s;
9132   next = (ffelexHandler) (*callback) (ft, NULL, t);
9133   ffelex_token_kill (ft);
9134   return (ffelexHandler) next;
9135 }
9136
9137 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9138
9139    return ffeexpr_token_first_rhs_3_;  // to lexer
9140
9141    Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9142    confirming, else NULL).  */
9143
9144 static ffelexHandler
9145 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9146 {
9147   ffelexHandler next;
9148
9149   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9150     {                           /* An error, but let normal processing handle
9151                                    it. */
9152       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9153       return (ffelexHandler) (*next) (t);
9154     }
9155
9156   /* Special case: when we see "*10" as an argument to a subroutine
9157      reference, we confirm the current statement and, if not inhibited at
9158      this point, put a copy of the token into a LABTOK node.  We do this
9159      instead of just resolving the label directly via ffelab and putting it
9160      into a LABTER simply to improve error reporting and consistency in
9161      ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
9162      doesn't have to worry about killing off any tokens when retracting. */
9163
9164   ffest_confirmed ();
9165   if (ffest_is_inhibited ())
9166     ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9167   else
9168     ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9169   ffebld_set_info (ffeexpr_stack_->expr,
9170                    ffeinfo_new (FFEINFO_basictypeNONE,
9171                                 FFEINFO_kindtypeNONE,
9172                                 0,
9173                                 FFEINFO_kindNONE,
9174                                 FFEINFO_whereNONE,
9175                                 FFETARGET_charactersizeNONE));
9176
9177   return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9178 }
9179
9180 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9181
9182    return ffeexpr_token_first_rhs_4_;  // to lexer
9183
9184    Collect/flush appropriate stuff, send token to callback function.  */
9185
9186 static ffelexHandler
9187 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9188 {
9189   ffebld expr;
9190   ffeexprCallback callback;
9191   ffeexprStack_ s;
9192   ffelexHandler next;
9193   ffelexToken ft;
9194
9195   expr = ffeexpr_stack_->expr;
9196   ffebld_pool_pop ();
9197   callback = ffeexpr_stack_->callback;
9198   ft = ffeexpr_stack_->first_token;
9199   s = ffeexpr_stack_->previous;
9200   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9201   ffeexpr_stack_ = s;
9202   next = (ffelexHandler) (*callback) (ft, expr, t);
9203   ffelex_token_kill (ft);
9204   return (ffelexHandler) next;
9205 }
9206
9207 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9208
9209    Should be NAME, or pass through original mechanism.  If NAME is LOC,
9210    pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9211    in which case handle the argument (in parentheses), etc.  */
9212
9213 static ffelexHandler
9214 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9215 {
9216   ffelexHandler next;
9217
9218   if (ffelex_token_type (t) == FFELEX_typeNAME)
9219     {
9220       ffeexprPercent_ p = ffeexpr_percent_ (t);
9221
9222       switch (p)
9223         {
9224         case FFEEXPR_percentNONE_:
9225         case FFEEXPR_percentLOC_:
9226           break;                /* Treat %LOC as any other expression. */
9227
9228         case FFEEXPR_percentVAL_:
9229         case FFEEXPR_percentREF_:
9230         case FFEEXPR_percentDESCR_:
9231           ffeexpr_stack_->percent = p;
9232           ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9233           return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9234
9235         default:
9236           assert ("bad percent?!?" == NULL);
9237           break;
9238         }
9239     }
9240
9241   switch (ffeexpr_stack_->context)
9242     {
9243     case FFEEXPR_contextACTUALARG_:
9244       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9245       break;
9246
9247     case FFEEXPR_contextINDEXORACTUALARG_:
9248       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9249       break;
9250
9251     case FFEEXPR_contextSFUNCDEFACTUALARG_:
9252       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9253       break;
9254
9255     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9256       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9257       break;
9258
9259     default:
9260       assert ("bad context?!?!" == NULL);
9261       break;
9262     }
9263
9264   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9265   return (ffelexHandler) (*next) (t);
9266 }
9267
9268 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9269
9270    Should be OPEN_PAREN, or pass through original mechanism.  */
9271
9272 static ffelexHandler
9273 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9274 {
9275   ffelexHandler next;
9276   ffelexToken ft;
9277
9278   if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9279     {
9280       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9281       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9282                                           ffeexpr_stack_->context,
9283                                           ffeexpr_cb_end_notloc_);
9284     }
9285
9286   switch (ffeexpr_stack_->context)
9287     {
9288     case FFEEXPR_contextACTUALARG_:
9289       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9290       break;
9291
9292     case FFEEXPR_contextINDEXORACTUALARG_:
9293       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9294       break;
9295
9296     case FFEEXPR_contextSFUNCDEFACTUALARG_:
9297       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9298       break;
9299
9300     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9301       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9302       break;
9303
9304     default:
9305       assert ("bad context?!?!" == NULL);
9306       break;
9307     }
9308
9309   ft = ffeexpr_stack_->tokens[0];
9310   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9311   next = (ffelexHandler) (*next) (ft);
9312   ffelex_token_kill (ft);
9313   return (ffelexHandler) (*next) (t);
9314 }
9315
9316 /* ffeexpr_token_namelist_ -- NAME
9317
9318    return ffeexpr_token_namelist_;  // to lexer
9319
9320    Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9321    return.  */
9322
9323 static ffelexHandler
9324 ffeexpr_token_namelist_ (ffelexToken t)
9325 {
9326   ffeexprCallback callback;
9327   ffeexprStack_ s;
9328   ffelexHandler next;
9329   ffelexToken ft;
9330   ffesymbol sy;
9331   ffebld expr;
9332
9333   ffebld_pool_pop ();
9334   callback = ffeexpr_stack_->callback;
9335   ft = ffeexpr_stack_->first_token;
9336   s = ffeexpr_stack_->previous;
9337   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9338   ffeexpr_stack_ = s;
9339
9340   sy = ffesymbol_lookup_local (ft);
9341   if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9342     {
9343       ffebad_start (FFEBAD_EXPR_WRONG);
9344       ffebad_here (0, ffelex_token_where_line (ft),
9345                    ffelex_token_where_column (ft));
9346       ffebad_finish ();
9347       expr = ffebld_new_any ();
9348       ffebld_set_info (expr, ffeinfo_new_any ());
9349     }
9350   else
9351     {
9352       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9353                                 FFEINTRIN_impNONE);
9354       ffebld_set_info (expr, ffesymbol_info (sy));
9355     }
9356   next = (ffelexHandler) (*callback) (ft, expr, t);
9357   ffelex_token_kill (ft);
9358   return (ffelexHandler) next;
9359 }
9360
9361 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9362
9363    ffeexprExpr_ e;
9364    ffeexpr_expr_kill_(e);
9365
9366    Kills the ffewhere info, if necessary, then kills the object.  */
9367
9368 static void
9369 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9370 {
9371   if (e->token != NULL)
9372     ffelex_token_kill (e->token);
9373   malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9374 }
9375
9376 /* ffeexpr_expr_new_ -- Make a new internal expression object
9377
9378    ffeexprExpr_ e;
9379    e = ffeexpr_expr_new_();
9380
9381    Allocates and initializes a new expression object, returns it.  */
9382
9383 static ffeexprExpr_
9384 ffeexpr_expr_new_ ()
9385 {
9386   ffeexprExpr_ e;
9387
9388   e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9389                                     sizeof (*e));
9390   e->previous = NULL;
9391   e->type = FFEEXPR_exprtypeUNKNOWN_;
9392   e->token = NULL;
9393   return e;
9394 }
9395
9396 /* Verify that call to global is valid, and register whatever
9397    new information about a global might be discoverable by looking
9398    at the call.  */
9399
9400 static void
9401 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9402 {
9403   int n_args;
9404   ffebld list;
9405   ffebld item;
9406   ffesymbol s;
9407
9408   assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9409           || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9410
9411   if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9412     return;
9413
9414   if (ffesymbol_retractable ())
9415     return;
9416
9417   s = ffebld_symter (ffebld_left (*expr));
9418   if (ffesymbol_global (s) == NULL)
9419     return;
9420
9421   for (n_args = 0, list = ffebld_right (*expr);
9422        list != NULL;
9423        list = ffebld_trail (list), ++n_args)
9424     ;
9425
9426   if (ffeglobal_proc_ref_nargs (s, n_args, t))
9427     {
9428       ffeglobalArgSummary as;
9429       ffeinfoBasictype bt;
9430       ffeinfoKindtype kt;
9431       bool array;
9432       bool fail = FALSE;
9433
9434       for (n_args = 0, list = ffebld_right (*expr);
9435            list != NULL;
9436            list = ffebld_trail (list), ++n_args)
9437         {
9438           item = ffebld_head (list);
9439           if (item != NULL)
9440             {
9441               bt = ffeinfo_basictype (ffebld_info (item));
9442               kt = ffeinfo_kindtype (ffebld_info (item));
9443               array = (ffeinfo_rank (ffebld_info (item)) > 0);
9444               switch (ffebld_op (item))
9445                 {
9446                 case FFEBLD_opLABTOK:
9447                 case FFEBLD_opLABTER:
9448                   as = FFEGLOBAL_argsummaryALTRTN;
9449                   break;
9450
9451 #if 0
9452                   /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9453                      expression, so don't treat it specially.  */
9454                 case FFEBLD_opPERCENT_LOC:
9455                   as = FFEGLOBAL_argsummaryPTR;
9456                   break;
9457 #endif
9458
9459                 case FFEBLD_opPERCENT_VAL:
9460                   as = FFEGLOBAL_argsummaryVAL;
9461                   break;
9462
9463                 case FFEBLD_opPERCENT_REF:
9464                   as = FFEGLOBAL_argsummaryREF;
9465                   break;
9466
9467                 case FFEBLD_opPERCENT_DESCR:
9468                   as = FFEGLOBAL_argsummaryDESCR;
9469                   break;
9470
9471                 case FFEBLD_opFUNCREF:
9472 #if 0
9473                   /* No, LOC(foo) is just like any INTEGER(KIND=7)
9474                      expression, so don't treat it specially.  */
9475                   if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9476                       && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9477                           == FFEINTRIN_specLOC))
9478                     {
9479                       as = FFEGLOBAL_argsummaryPTR;
9480                       break;
9481                     }
9482 #endif
9483                   /* Fall through.  */
9484                 default:
9485                   if (ffebld_op (item) == FFEBLD_opSYMTER)
9486                     {
9487                       as = FFEGLOBAL_argsummaryNONE;
9488
9489                       switch (ffeinfo_kind (ffebld_info (item)))
9490                         {
9491                         case FFEINFO_kindFUNCTION:
9492                           as = FFEGLOBAL_argsummaryFUNC;
9493                           break;
9494
9495                         case FFEINFO_kindSUBROUTINE:
9496                           as = FFEGLOBAL_argsummarySUBR;
9497                           break;
9498
9499                         case FFEINFO_kindNONE:
9500                           as = FFEGLOBAL_argsummaryPROC;
9501                           break;
9502
9503                         default:
9504                           break;
9505                         }
9506
9507                       if (as != FFEGLOBAL_argsummaryNONE)
9508                         break;
9509                     }
9510
9511                   if (bt == FFEINFO_basictypeCHARACTER)
9512                     as = FFEGLOBAL_argsummaryDESCR;
9513                   else
9514                     as = FFEGLOBAL_argsummaryREF;
9515                   break;
9516                 }
9517             }
9518           else
9519             {
9520               array = FALSE;
9521               as = FFEGLOBAL_argsummaryNONE;
9522               bt = FFEINFO_basictypeNONE;
9523               kt = FFEINFO_kindtypeNONE;
9524             }
9525
9526           if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9527             fail = TRUE;
9528         }
9529       if (! fail)
9530         return;
9531     }
9532
9533   *expr = ffebld_new_any ();
9534   ffebld_set_info (*expr, ffeinfo_new_any ());
9535 }
9536
9537 /* Check whether rest of string is all decimal digits.  */
9538
9539 static bool
9540 ffeexpr_isdigits_ (const char *p)
9541 {
9542   for (; *p != '\0'; ++p)
9543     if (! ISDIGIT (*p))
9544       return FALSE;
9545   return TRUE;
9546 }
9547
9548 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9549
9550    ffeexprExpr_ e;
9551    ffeexpr_exprstack_push_(e);
9552
9553    Pushes the expression onto the stack without any analysis of the existing
9554    contents of the stack.  */
9555
9556 static void
9557 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9558 {
9559   e->previous = ffeexpr_stack_->exprstack;
9560   ffeexpr_stack_->exprstack = e;
9561 }
9562
9563 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9564
9565    ffeexprExpr_ e;
9566    ffeexpr_exprstack_push_operand_(e);
9567
9568    Pushes the expression already containing an operand (a constant, variable,
9569    or more complicated expression that has already been fully resolved) after
9570    analyzing the stack and checking for possible reduction (which will never
9571    happen here since the highest precedence operator is ** and it has right-
9572    to-left associativity).  */
9573
9574 static void
9575 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9576 {
9577   ffeexpr_exprstack_push_ (e);
9578 #ifdef WEIRD_NONFORTRAN_RULES
9579   if ((ffeexpr_stack_->exprstack != NULL)
9580       && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9581       && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9582           == FFEEXPR_operatorprecedenceHIGHEST_)
9583       && (ffeexpr_stack_->exprstack->expr->u.operator.as
9584           == FFEEXPR_operatorassociativityL2R_))
9585     ffeexpr_reduce_ ();
9586 #endif
9587 }
9588
9589 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9590
9591    ffeexprExpr_ e;
9592    ffeexpr_exprstack_push_unary_(e);
9593
9594    Pushes the expression already containing a unary operator.  Reduction can
9595    never happen since unary operators are themselves always R-L; that is, the
9596    top of the expression stack is not an operand, in that it is either empty,
9597    has a binary operator at the top, or a unary operator at the top.  In any
9598    of these cases, reduction is impossible.  */
9599
9600 static void
9601 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9602 {
9603   if ((ffe_is_pedantic ()
9604        || ffe_is_warn_surprising ())
9605       && (ffeexpr_stack_->exprstack != NULL)
9606       && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9607       && (ffeexpr_stack_->exprstack->u.operator.prec
9608           <= FFEEXPR_operatorprecedenceLOWARITH_)
9609       && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9610     {
9611       ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9612                         ffe_is_pedantic ()
9613                         ? FFEBAD_severityPEDANTIC
9614                         : FFEBAD_severityWARNING);
9615       ffebad_here (0,
9616                   ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9617                ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9618       ffebad_here (1,
9619                    ffelex_token_where_line (e->token),
9620                    ffelex_token_where_column (e->token));
9621       ffebad_finish ();
9622     }
9623
9624   ffeexpr_exprstack_push_ (e);
9625 }
9626
9627 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9628
9629    ffeexprExpr_ e;
9630    ffeexpr_exprstack_push_binary_(e);
9631
9632    Pushes the expression already containing a binary operator after checking
9633    whether reduction is possible.  If the stack is not empty, the top of the
9634    stack must be an operand or syntactic analysis has failed somehow.  If
9635    the operand is preceded by a unary operator of higher (or equal and L-R
9636    associativity) precedence than the new binary operator, then reduce that
9637    preceding operator and its operand(s) before pushing the new binary
9638    operator.  */
9639
9640 static void
9641 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9642 {
9643   ffeexprExpr_ ce;
9644
9645   if (ffe_is_warn_surprising ()
9646       /* These next two are always true (see assertions below).  */
9647       && (ffeexpr_stack_->exprstack != NULL)
9648       && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9649       /* If the previous operator is a unary minus, and the binary op
9650          is of higher precedence, might not do what user expects,
9651          e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9652          yield "4".  */
9653       && (ffeexpr_stack_->exprstack->previous != NULL)
9654       && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9655       && (ffeexpr_stack_->exprstack->previous->u.operator.op
9656           == FFEEXPR_operatorSUBTRACT_)
9657       && (e->u.operator.prec
9658           < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9659     {
9660       ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9661       ffebad_here (0,
9662          ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9663       ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9664       ffebad_here (1,
9665                    ffelex_token_where_line (e->token),
9666                    ffelex_token_where_column (e->token));
9667       ffebad_finish ();
9668     }
9669
9670 again:
9671   assert (ffeexpr_stack_->exprstack != NULL);
9672   assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9673   if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9674     {
9675       assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9676       if ((ce->u.operator.prec < e->u.operator.prec)
9677           || ((ce->u.operator.prec == e->u.operator.prec)
9678               && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9679         {
9680           ffeexpr_reduce_ ();
9681           goto again;   /* :::::::::::::::::::: */
9682         }
9683     }
9684
9685   ffeexpr_exprstack_push_ (e);
9686 }
9687
9688 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9689
9690    ffeexpr_reduce_();
9691
9692    Converts operand binop operand or unop operand at top of stack to a
9693    single operand having the appropriate ffebld expression, and makes
9694    sure that the expression is proper (like not trying to add two character
9695    variables, not trying to concatenate two numbers).  Also does the
9696    requisite type-assignment.  */
9697
9698 static void
9699 ffeexpr_reduce_ ()
9700 {
9701   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
9702   ffeexprExpr_ left_operand;    /* When operator is binary, this is A in A+B. */
9703   ffeexprExpr_ operator;        /* This is + in A+B. */
9704   ffebld reduced;               /* This is +(A,B) in A+B or u-(B) in -B. */
9705   ffebldConstant constnode;     /* For checking magical numbers (where mag ==
9706                                    -mag). */
9707   ffebld expr;
9708   ffebld left_expr;
9709   bool submag = FALSE;
9710
9711   operand = ffeexpr_stack_->exprstack;
9712   assert (operand != NULL);
9713   assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9714   operator = operand->previous;
9715   assert (operator != NULL);
9716   assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9717   if (operator->type == FFEEXPR_exprtypeUNARY_)
9718     {
9719       expr = operand->u.operand;
9720       switch (operator->u.operator.op)
9721         {
9722         case FFEEXPR_operatorADD_:
9723           reduced = ffebld_new_uplus (expr);
9724           if (ffe_is_ugly_logint ())
9725             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9726           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9727           reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9728           break;
9729
9730         case FFEEXPR_operatorSUBTRACT_:
9731           submag = TRUE;        /* Ok to negate a magic number. */
9732           reduced = ffebld_new_uminus (expr);
9733           if (ffe_is_ugly_logint ())
9734             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9735           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9736           reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9737           break;
9738
9739         case FFEEXPR_operatorNOT_:
9740           reduced = ffebld_new_not (expr);
9741           if (ffe_is_ugly_logint ())
9742             reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9743           reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9744           reduced = ffeexpr_collapse_not (reduced, operator->token);
9745           break;
9746
9747         default:
9748           assert ("unexpected unary op" != NULL);
9749           reduced = NULL;
9750           break;
9751         }
9752       if (!submag
9753           && (ffebld_op (expr) == FFEBLD_opCONTER)
9754           && (ffebld_conter_orig (expr) == NULL)
9755           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9756         {
9757           ffetarget_integer_bad_magical (operand->token);
9758         }
9759       ffeexpr_stack_->exprstack = operator->previous;   /* Pops unary-op operand
9760                                                            off stack. */
9761       ffeexpr_expr_kill_ (operand);
9762       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
9763                                                            save */
9764       operator->u.operand = reduced;    /* the line/column ffewhere info. */
9765       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
9766                                                            stack. */
9767     }
9768   else
9769     {
9770       assert (operator->type == FFEEXPR_exprtypeBINARY_);
9771       left_operand = operator->previous;
9772       assert (left_operand != NULL);
9773       assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9774       expr = operand->u.operand;
9775       left_expr = left_operand->u.operand;
9776       switch (operator->u.operator.op)
9777         {
9778         case FFEEXPR_operatorADD_:
9779           reduced = ffebld_new_add (left_expr, expr);
9780           if (ffe_is_ugly_logint ())
9781             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9782                                               operand);
9783           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9784                                             operand);
9785           reduced = ffeexpr_collapse_add (reduced, operator->token);
9786           break;
9787
9788         case FFEEXPR_operatorSUBTRACT_:
9789           submag = TRUE;        /* Just to pick the right error if magic
9790                                    number. */
9791           reduced = ffebld_new_subtract (left_expr, expr);
9792           if (ffe_is_ugly_logint ())
9793             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9794                                               operand);
9795           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9796                                             operand);
9797           reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9798           break;
9799
9800         case FFEEXPR_operatorMULTIPLY_:
9801           reduced = ffebld_new_multiply (left_expr, expr);
9802           if (ffe_is_ugly_logint ())
9803             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9804                                               operand);
9805           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9806                                             operand);
9807           reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9808           break;
9809
9810         case FFEEXPR_operatorDIVIDE_:
9811           reduced = ffebld_new_divide (left_expr, expr);
9812           if (ffe_is_ugly_logint ())
9813             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9814                                               operand);
9815           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9816                                             operand);
9817           reduced = ffeexpr_collapse_divide (reduced, operator->token);
9818           break;
9819
9820         case FFEEXPR_operatorPOWER_:
9821           reduced = ffebld_new_power (left_expr, expr);
9822           if (ffe_is_ugly_logint ())
9823             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9824                                               operand);
9825           reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9826                                             operand);
9827           reduced = ffeexpr_collapse_power (reduced, operator->token);
9828           break;
9829
9830         case FFEEXPR_operatorCONCATENATE_:
9831           reduced = ffebld_new_concatenate (left_expr, expr);
9832           reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9833                                                   operand);
9834           reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9835           break;
9836
9837         case FFEEXPR_operatorLT_:
9838           reduced = ffebld_new_lt (left_expr, expr);
9839           if (ffe_is_ugly_logint ())
9840             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9841                                               operand);
9842           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9843                                              operand);
9844           reduced = ffeexpr_collapse_lt (reduced, operator->token);
9845           break;
9846
9847         case FFEEXPR_operatorLE_:
9848           reduced = ffebld_new_le (left_expr, expr);
9849           if (ffe_is_ugly_logint ())
9850             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9851                                               operand);
9852           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9853                                              operand);
9854           reduced = ffeexpr_collapse_le (reduced, operator->token);
9855           break;
9856
9857         case FFEEXPR_operatorEQ_:
9858           reduced = ffebld_new_eq (left_expr, expr);
9859           if (ffe_is_ugly_logint ())
9860             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9861                                               operand);
9862           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9863                                             operand);
9864           reduced = ffeexpr_collapse_eq (reduced, operator->token);
9865           break;
9866
9867         case FFEEXPR_operatorNE_:
9868           reduced = ffebld_new_ne (left_expr, expr);
9869           if (ffe_is_ugly_logint ())
9870             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9871                                               operand);
9872           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9873                                             operand);
9874           reduced = ffeexpr_collapse_ne (reduced, operator->token);
9875           break;
9876
9877         case FFEEXPR_operatorGT_:
9878           reduced = ffebld_new_gt (left_expr, expr);
9879           if (ffe_is_ugly_logint ())
9880             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9881                                               operand);
9882           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9883                                              operand);
9884           reduced = ffeexpr_collapse_gt (reduced, operator->token);
9885           break;
9886
9887         case FFEEXPR_operatorGE_:
9888           reduced = ffebld_new_ge (left_expr, expr);
9889           if (ffe_is_ugly_logint ())
9890             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9891                                               operand);
9892           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9893                                              operand);
9894           reduced = ffeexpr_collapse_ge (reduced, operator->token);
9895           break;
9896
9897         case FFEEXPR_operatorAND_:
9898           reduced = ffebld_new_and (left_expr, expr);
9899           if (ffe_is_ugly_logint ())
9900             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9901                                                  operand);
9902           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9903                                             operand);
9904           reduced = ffeexpr_collapse_and (reduced, operator->token);
9905           break;
9906
9907         case FFEEXPR_operatorOR_:
9908           reduced = ffebld_new_or (left_expr, expr);
9909           if (ffe_is_ugly_logint ())
9910             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9911                                                  operand);
9912           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9913                                             operand);
9914           reduced = ffeexpr_collapse_or (reduced, operator->token);
9915           break;
9916
9917         case FFEEXPR_operatorXOR_:
9918           reduced = ffebld_new_xor (left_expr, expr);
9919           if (ffe_is_ugly_logint ())
9920             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9921                                                  operand);
9922           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9923                                             operand);
9924           reduced = ffeexpr_collapse_xor (reduced, operator->token);
9925           break;
9926
9927         case FFEEXPR_operatorEQV_:
9928           reduced = ffebld_new_eqv (left_expr, expr);
9929           if (ffe_is_ugly_logint ())
9930             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9931                                                  operand);
9932           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9933                                             operand);
9934           reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9935           break;
9936
9937         case FFEEXPR_operatorNEQV_:
9938           reduced = ffebld_new_neqv (left_expr, expr);
9939           if (ffe_is_ugly_logint ())
9940             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9941                                                  operand);
9942           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9943                                             operand);
9944           reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9945           break;
9946
9947         default:
9948           assert ("bad bin op" == NULL);
9949           reduced = expr;
9950           break;
9951         }
9952       if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9953           && (ffebld_conter_orig (expr) == NULL)
9954       && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9955         {
9956           if ((left_operand->previous != NULL)
9957               && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9958               && (left_operand->previous->u.operator.op
9959                   == FFEEXPR_operatorSUBTRACT_))
9960             {
9961               if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9962                 ffetarget_integer_bad_magical_precedence (left_operand->token,
9963                                                           left_operand->previous->token,
9964                                                           operator->token);
9965               else
9966                 ffetarget_integer_bad_magical_precedence_binary
9967                   (left_operand->token,
9968                    left_operand->previous->token,
9969                    operator->token);
9970             }
9971           else
9972             ffetarget_integer_bad_magical (left_operand->token);
9973         }
9974       if ((ffebld_op (expr) == FFEBLD_opCONTER)
9975           && (ffebld_conter_orig (expr) == NULL)
9976           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9977         {
9978           if (submag)
9979             ffetarget_integer_bad_magical_binary (operand->token,
9980                                                   operator->token);
9981           else
9982             ffetarget_integer_bad_magical (operand->token);
9983         }
9984       ffeexpr_stack_->exprstack = left_operand->previous;       /* Pops binary-op
9985                                                                    operands off stack. */
9986       ffeexpr_expr_kill_ (left_operand);
9987       ffeexpr_expr_kill_ (operand);
9988       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
9989                                                            save */
9990       operator->u.operand = reduced;    /* the line/column ffewhere info. */
9991       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
9992                                                            stack. */
9993     }
9994 }
9995
9996 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9997
9998    reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9999
10000    Makes sure the argument for reduced has basictype of
10001    LOGICAL or (ugly) INTEGER.  If
10002    argument has where of CONSTANT, assign where CONSTANT to
10003    reduced, else assign where FLEETING.
10004
10005    If these requirements cannot be met, generate error message.  */
10006
10007 static ffebld
10008 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10009 {
10010   ffeinfo rinfo, ninfo;
10011   ffeinfoBasictype rbt;
10012   ffeinfoKindtype rkt;
10013   ffeinfoRank rrk;
10014   ffeinfoKind rkd;
10015   ffeinfoWhere rwh, nwh;
10016
10017   rinfo = ffebld_info (ffebld_left (reduced));
10018   rbt = ffeinfo_basictype (rinfo);
10019   rkt = ffeinfo_kindtype (rinfo);
10020   rrk = ffeinfo_rank (rinfo);
10021   rkd = ffeinfo_kind (rinfo);
10022   rwh = ffeinfo_where (rinfo);
10023
10024   if (((rbt == FFEINFO_basictypeLOGICAL)
10025        || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10026       && (rrk == 0))
10027     {
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
10043       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10044                            FFETARGET_charactersizeNONE);
10045       ffebld_set_info (reduced, ninfo);
10046       return reduced;
10047     }
10048
10049   if ((rbt != FFEINFO_basictypeLOGICAL)
10050       && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10051     {
10052       if ((rbt != FFEINFO_basictypeANY)
10053           && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10054         {
10055           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10056           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10057           ffebad_finish ();
10058         }
10059     }
10060   else
10061     {
10062       if ((rkd != FFEINFO_kindANY)
10063           && ffebad_start (FFEBAD_NOT_ARG_KIND))
10064         {
10065           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10066           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10067           ffebad_string ("an array");
10068           ffebad_finish ();
10069         }
10070     }
10071
10072   reduced = ffebld_new_any ();
10073   ffebld_set_info (reduced, ffeinfo_new_any ());
10074   return reduced;
10075 }
10076
10077 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10078
10079    reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10080
10081    Makes sure the left and right arguments for reduced have basictype of
10082    LOGICAL or (ugly) INTEGER.  Determine common basictype and
10083    size for reduction (flag expression for combined hollerith/typeless
10084    situations for later determination of effective basictype).  If both left
10085    and right arguments have where of CONSTANT, assign where CONSTANT to
10086    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10087    needed.  Convert typeless
10088    constants to the desired type/size explicitly.
10089
10090    If these requirements cannot be met, generate error message.  */
10091
10092 static ffebld
10093 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10094                         ffeexprExpr_ r)
10095 {
10096   ffeinfo linfo, rinfo, ninfo;
10097   ffeinfoBasictype lbt, rbt, nbt;
10098   ffeinfoKindtype lkt, rkt, nkt;
10099   ffeinfoRank lrk, rrk;
10100   ffeinfoKind lkd, rkd;
10101   ffeinfoWhere lwh, rwh, nwh;
10102
10103   linfo = ffebld_info (ffebld_left (reduced));
10104   lbt = ffeinfo_basictype (linfo);
10105   lkt = ffeinfo_kindtype (linfo);
10106   lrk = ffeinfo_rank (linfo);
10107   lkd = ffeinfo_kind (linfo);
10108   lwh = ffeinfo_where (linfo);
10109
10110   rinfo = ffebld_info (ffebld_right (reduced));
10111   rbt = ffeinfo_basictype (rinfo);
10112   rkt = ffeinfo_kindtype (rinfo);
10113   rrk = ffeinfo_rank (rinfo);
10114   rkd = ffeinfo_kind (rinfo);
10115   rwh = ffeinfo_where (rinfo);
10116
10117   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10118
10119   if (((nbt == FFEINFO_basictypeLOGICAL)
10120        || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10121       && (lrk == 0) && (rrk == 0))
10122     {
10123       switch (lwh)
10124         {
10125         case FFEINFO_whereCONSTANT:
10126           switch (rwh)
10127             {
10128             case FFEINFO_whereCONSTANT:
10129               nwh = FFEINFO_whereCONSTANT;
10130               break;
10131
10132             case FFEINFO_whereIMMEDIATE:
10133               nwh = FFEINFO_whereIMMEDIATE;
10134               break;
10135
10136             default:
10137               nwh = FFEINFO_whereFLEETING;
10138               break;
10139             }
10140           break;
10141
10142         case FFEINFO_whereIMMEDIATE:
10143           switch (rwh)
10144             {
10145             case FFEINFO_whereCONSTANT:
10146             case FFEINFO_whereIMMEDIATE:
10147               nwh = FFEINFO_whereIMMEDIATE;
10148               break;
10149
10150             default:
10151               nwh = FFEINFO_whereFLEETING;
10152               break;
10153             }
10154           break;
10155
10156         default:
10157           nwh = FFEINFO_whereFLEETING;
10158           break;
10159         }
10160
10161       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10162                            FFETARGET_charactersizeNONE);
10163       ffebld_set_info (reduced, ninfo);
10164       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10165               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10166                                                  FFEEXPR_contextLET));
10167       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10168               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10169                                                   FFEEXPR_contextLET));
10170       return reduced;
10171     }
10172
10173   if ((lbt != FFEINFO_basictypeLOGICAL)
10174       && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10175     {
10176       if ((rbt != FFEINFO_basictypeLOGICAL)
10177           && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10178         {
10179           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10180               && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10181             {
10182               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10183               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10184               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10185               ffebad_finish ();
10186             }
10187         }
10188       else
10189         {
10190           if ((lbt != FFEINFO_basictypeANY)
10191               && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10192             {
10193               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10194               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10195               ffebad_finish ();
10196             }
10197         }
10198     }
10199   else if ((rbt != FFEINFO_basictypeLOGICAL)
10200            && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10201     {
10202       if ((rbt != FFEINFO_basictypeANY)
10203           && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10204         {
10205           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10206           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10207           ffebad_finish ();
10208         }
10209     }
10210   else if (lrk != 0)
10211     {
10212       if ((lkd != FFEINFO_kindANY)
10213           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10214         {
10215           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10216           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10217           ffebad_string ("an array");
10218           ffebad_finish ();
10219         }
10220     }
10221   else
10222     {
10223       if ((rkd != FFEINFO_kindANY)
10224           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10225         {
10226           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10227           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10228           ffebad_string ("an array");
10229           ffebad_finish ();
10230         }
10231     }
10232
10233   reduced = ffebld_new_any ();
10234   ffebld_set_info (reduced, ffeinfo_new_any ());
10235   return reduced;
10236 }
10237
10238 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10239
10240    reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10241
10242    Makes sure the left and right arguments for reduced have basictype of
10243    CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
10244    basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
10245    size of concatenation and assign that size to reduced.  If both left and
10246    right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10247    else assign where FLEETING.
10248
10249    If these requirements cannot be met, generate error message using the
10250    info in l, op, and r arguments and assign basictype, size, kind, and where
10251    of ANY.  */
10252
10253 static ffebld
10254 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10255                               ffeexprExpr_ r)
10256 {
10257   ffeinfo linfo, rinfo, ninfo;
10258   ffeinfoBasictype lbt, rbt, nbt;
10259   ffeinfoKindtype lkt, rkt, nkt;
10260   ffeinfoRank lrk, rrk;
10261   ffeinfoKind lkd, rkd, nkd;
10262   ffeinfoWhere lwh, rwh, nwh;
10263   ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10264
10265   linfo = ffebld_info (ffebld_left (reduced));
10266   lbt = ffeinfo_basictype (linfo);
10267   lkt = ffeinfo_kindtype (linfo);
10268   lrk = ffeinfo_rank (linfo);
10269   lkd = ffeinfo_kind (linfo);
10270   lwh = ffeinfo_where (linfo);
10271   lszk = ffeinfo_size (linfo);  /* Known size. */
10272   lszm = ffebld_size_max (ffebld_left (reduced));
10273
10274   rinfo = ffebld_info (ffebld_right (reduced));
10275   rbt = ffeinfo_basictype (rinfo);
10276   rkt = ffeinfo_kindtype (rinfo);
10277   rrk = ffeinfo_rank (rinfo);
10278   rkd = ffeinfo_kind (rinfo);
10279   rwh = ffeinfo_where (rinfo);
10280   rszk = ffeinfo_size (rinfo);  /* Known size. */
10281   rszm = ffebld_size_max (ffebld_right (reduced));
10282
10283   if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10284       && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10285       && (((lszm != FFETARGET_charactersizeNONE)
10286            && (rszm != FFETARGET_charactersizeNONE))
10287           || (ffeexpr_context_outer_ (ffeexpr_stack_)
10288               == FFEEXPR_contextLET)
10289           || (ffeexpr_context_outer_ (ffeexpr_stack_)
10290               == FFEEXPR_contextSFUNCDEF)))
10291     {
10292       nbt = FFEINFO_basictypeCHARACTER;
10293       nkd = FFEINFO_kindENTITY;
10294       if ((lszk == FFETARGET_charactersizeNONE)
10295           || (rszk == FFETARGET_charactersizeNONE))
10296         nszk = FFETARGET_charactersizeNONE;     /* Ok only in rhs of LET
10297                                                    stmt. */
10298       else
10299         nszk = lszk + rszk;
10300
10301       switch (lwh)
10302         {
10303         case FFEINFO_whereCONSTANT:
10304           switch (rwh)
10305             {
10306             case FFEINFO_whereCONSTANT:
10307               nwh = FFEINFO_whereCONSTANT;
10308               break;
10309
10310             case FFEINFO_whereIMMEDIATE:
10311               nwh = FFEINFO_whereIMMEDIATE;
10312               break;
10313
10314             default:
10315               nwh = FFEINFO_whereFLEETING;
10316               break;
10317             }
10318           break;
10319
10320         case FFEINFO_whereIMMEDIATE:
10321           switch (rwh)
10322             {
10323             case FFEINFO_whereCONSTANT:
10324             case FFEINFO_whereIMMEDIATE:
10325               nwh = FFEINFO_whereIMMEDIATE;
10326               break;
10327
10328             default:
10329               nwh = FFEINFO_whereFLEETING;
10330               break;
10331             }
10332           break;
10333
10334         default:
10335           nwh = FFEINFO_whereFLEETING;
10336           break;
10337         }
10338
10339       nkt = lkt;
10340       ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10341       ffebld_set_info (reduced, ninfo);
10342       return reduced;
10343     }
10344
10345   if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10346     {
10347       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10348           && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10349         {
10350           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10351           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10352           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10353           ffebad_finish ();
10354         }
10355     }
10356   else if (lbt != FFEINFO_basictypeCHARACTER)
10357     {
10358       if ((lbt != FFEINFO_basictypeANY)
10359           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10360         {
10361           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10362           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10363           ffebad_finish ();
10364         }
10365     }
10366   else if (rbt != FFEINFO_basictypeCHARACTER)
10367     {
10368       if ((rbt != FFEINFO_basictypeANY)
10369           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10370         {
10371           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10372           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10373           ffebad_finish ();
10374         }
10375     }
10376   else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10377     {
10378       if ((lkd != FFEINFO_kindANY)
10379           && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10380         {
10381           const char *what;
10382
10383           if (lrk != 0)
10384             what = "an array";
10385           else
10386             what = "of indeterminate length";
10387           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10388           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10389           ffebad_string (what);
10390           ffebad_finish ();
10391         }
10392     }
10393   else
10394     {
10395       if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10396         {
10397           const char *what;
10398
10399           if (rrk != 0)
10400             what = "an array";
10401           else
10402             what = "of indeterminate length";
10403           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10404           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10405           ffebad_string (what);
10406           ffebad_finish ();
10407         }
10408     }
10409
10410   reduced = ffebld_new_any ();
10411   ffebld_set_info (reduced, ffeinfo_new_any ());
10412   return reduced;
10413 }
10414
10415 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10416
10417    reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10418
10419    Makes sure the left and right arguments for reduced have basictype of
10420    INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
10421    size for reduction.  If both left
10422    and right arguments have where of CONSTANT, assign where CONSTANT to
10423    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10424    needed.  Convert typeless
10425    constants to the desired type/size explicitly.
10426
10427    If these requirements cannot be met, generate error message.  */
10428
10429 static ffebld
10430 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10431                         ffeexprExpr_ r)
10432 {
10433   ffeinfo linfo, rinfo, ninfo;
10434   ffeinfoBasictype lbt, rbt, nbt;
10435   ffeinfoKindtype lkt, rkt, nkt;
10436   ffeinfoRank lrk, rrk;
10437   ffeinfoKind lkd, rkd;
10438   ffeinfoWhere lwh, rwh, nwh;
10439   ffetargetCharacterSize lsz, rsz;
10440
10441   linfo = ffebld_info (ffebld_left (reduced));
10442   lbt = ffeinfo_basictype (linfo);
10443   lkt = ffeinfo_kindtype (linfo);
10444   lrk = ffeinfo_rank (linfo);
10445   lkd = ffeinfo_kind (linfo);
10446   lwh = ffeinfo_where (linfo);
10447   lsz = ffebld_size_known (ffebld_left (reduced));
10448
10449   rinfo = ffebld_info (ffebld_right (reduced));
10450   rbt = ffeinfo_basictype (rinfo);
10451   rkt = ffeinfo_kindtype (rinfo);
10452   rrk = ffeinfo_rank (rinfo);
10453   rkd = ffeinfo_kind (rinfo);
10454   rwh = ffeinfo_where (rinfo);
10455   rsz = ffebld_size_known (ffebld_right (reduced));
10456
10457   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10458
10459   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10460        || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10461       && (lrk == 0) && (rrk == 0))
10462     {
10463       switch (lwh)
10464         {
10465         case FFEINFO_whereCONSTANT:
10466           switch (rwh)
10467             {
10468             case FFEINFO_whereCONSTANT:
10469               nwh = FFEINFO_whereCONSTANT;
10470               break;
10471
10472             case FFEINFO_whereIMMEDIATE:
10473               nwh = FFEINFO_whereIMMEDIATE;
10474               break;
10475
10476             default:
10477               nwh = FFEINFO_whereFLEETING;
10478               break;
10479             }
10480           break;
10481
10482         case FFEINFO_whereIMMEDIATE:
10483           switch (rwh)
10484             {
10485             case FFEINFO_whereCONSTANT:
10486             case FFEINFO_whereIMMEDIATE:
10487               nwh = FFEINFO_whereIMMEDIATE;
10488               break;
10489
10490             default:
10491               nwh = FFEINFO_whereFLEETING;
10492               break;
10493             }
10494           break;
10495
10496         default:
10497           nwh = FFEINFO_whereFLEETING;
10498           break;
10499         }
10500
10501       if ((lsz != FFETARGET_charactersizeNONE)
10502           && (rsz != FFETARGET_charactersizeNONE))
10503         lsz = rsz = (lsz > rsz) ? lsz : rsz;
10504
10505       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10506                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10507       ffebld_set_info (reduced, ninfo);
10508       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10509                                       l->token, op->token, nbt, nkt, 0, lsz,
10510                                                  FFEEXPR_contextLET));
10511       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10512                                       r->token, op->token, nbt, nkt, 0, rsz,
10513                                                   FFEEXPR_contextLET));
10514       return reduced;
10515     }
10516
10517   if ((lbt == FFEINFO_basictypeLOGICAL)
10518       && (rbt == FFEINFO_basictypeLOGICAL))
10519     {
10520       if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10521                             FFEBAD_severityFATAL))
10522         {
10523           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10524           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10525           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10526           ffebad_finish ();
10527         }
10528     }
10529   else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10530       && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10531     {
10532       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10533           && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10534         {
10535           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10536               && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10537             {
10538               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10539               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10540               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10541               ffebad_finish ();
10542             }
10543         }
10544       else
10545         {
10546           if ((lbt != FFEINFO_basictypeANY)
10547               && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10548             {
10549               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10550               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10551               ffebad_finish ();
10552             }
10553         }
10554     }
10555   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10556            && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10557     {
10558       if ((rbt != FFEINFO_basictypeANY)
10559           && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10560         {
10561           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10562           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10563           ffebad_finish ();
10564         }
10565     }
10566   else if (lrk != 0)
10567     {
10568       if ((lkd != FFEINFO_kindANY)
10569           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10570         {
10571           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10572           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10573           ffebad_string ("an array");
10574           ffebad_finish ();
10575         }
10576     }
10577   else
10578     {
10579       if ((rkd != FFEINFO_kindANY)
10580           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10581         {
10582           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10583           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10584           ffebad_string ("an array");
10585           ffebad_finish ();
10586         }
10587     }
10588
10589   reduced = ffebld_new_any ();
10590   ffebld_set_info (reduced, ffeinfo_new_any ());
10591   return reduced;
10592 }
10593
10594 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10595
10596    reduced = ffeexpr_reduced_math1_(reduced,op,r);
10597
10598    Makes sure the argument for reduced has basictype of
10599    INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
10600    assign where CONSTANT to
10601    reduced, else assign where FLEETING.
10602
10603    If these requirements cannot be met, generate error message.  */
10604
10605 static ffebld
10606 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10607 {
10608   ffeinfo rinfo, ninfo;
10609   ffeinfoBasictype rbt;
10610   ffeinfoKindtype rkt;
10611   ffeinfoRank rrk;
10612   ffeinfoKind rkd;
10613   ffeinfoWhere rwh, nwh;
10614
10615   rinfo = ffebld_info (ffebld_left (reduced));
10616   rbt = ffeinfo_basictype (rinfo);
10617   rkt = ffeinfo_kindtype (rinfo);
10618   rrk = ffeinfo_rank (rinfo);
10619   rkd = ffeinfo_kind (rinfo);
10620   rwh = ffeinfo_where (rinfo);
10621
10622   if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10623        || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10624     {
10625       switch (rwh)
10626         {
10627         case FFEINFO_whereCONSTANT:
10628           nwh = FFEINFO_whereCONSTANT;
10629           break;
10630
10631         case FFEINFO_whereIMMEDIATE:
10632           nwh = FFEINFO_whereIMMEDIATE;
10633           break;
10634
10635         default:
10636           nwh = FFEINFO_whereFLEETING;
10637           break;
10638         }
10639
10640       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10641                            FFETARGET_charactersizeNONE);
10642       ffebld_set_info (reduced, ninfo);
10643       return reduced;
10644     }
10645
10646   if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10647       && (rbt != FFEINFO_basictypeCOMPLEX))
10648     {
10649       if ((rbt != FFEINFO_basictypeANY)
10650           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10651         {
10652           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10653           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10654           ffebad_finish ();
10655         }
10656     }
10657   else
10658     {
10659       if ((rkd != FFEINFO_kindANY)
10660           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10661         {
10662           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10663           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10664           ffebad_string ("an array");
10665           ffebad_finish ();
10666         }
10667     }
10668
10669   reduced = ffebld_new_any ();
10670   ffebld_set_info (reduced, ffeinfo_new_any ());
10671   return reduced;
10672 }
10673
10674 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10675
10676    reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10677
10678    Makes sure the left and right arguments for reduced have basictype of
10679    INTEGER, REAL, or COMPLEX.  Determine common basictype and
10680    size for reduction (flag expression for combined hollerith/typeless
10681    situations for later determination of effective basictype).  If both left
10682    and right arguments have where of CONSTANT, assign where CONSTANT to
10683    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10684    needed.  Convert typeless
10685    constants to the desired type/size explicitly.
10686
10687    If these requirements cannot be met, generate error message.  */
10688
10689 static ffebld
10690 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10691                         ffeexprExpr_ r)
10692 {
10693   ffeinfo linfo, rinfo, ninfo;
10694   ffeinfoBasictype lbt, rbt, nbt;
10695   ffeinfoKindtype lkt, rkt, nkt;
10696   ffeinfoRank lrk, rrk;
10697   ffeinfoKind lkd, rkd;
10698   ffeinfoWhere lwh, rwh, nwh;
10699
10700   linfo = ffebld_info (ffebld_left (reduced));
10701   lbt = ffeinfo_basictype (linfo);
10702   lkt = ffeinfo_kindtype (linfo);
10703   lrk = ffeinfo_rank (linfo);
10704   lkd = ffeinfo_kind (linfo);
10705   lwh = ffeinfo_where (linfo);
10706
10707   rinfo = ffebld_info (ffebld_right (reduced));
10708   rbt = ffeinfo_basictype (rinfo);
10709   rkt = ffeinfo_kindtype (rinfo);
10710   rrk = ffeinfo_rank (rinfo);
10711   rkd = ffeinfo_kind (rinfo);
10712   rwh = ffeinfo_where (rinfo);
10713
10714   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10715
10716   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10717        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10718     {
10719       switch (lwh)
10720         {
10721         case FFEINFO_whereCONSTANT:
10722           switch (rwh)
10723             {
10724             case FFEINFO_whereCONSTANT:
10725               nwh = FFEINFO_whereCONSTANT;
10726               break;
10727
10728             case FFEINFO_whereIMMEDIATE:
10729               nwh = FFEINFO_whereIMMEDIATE;
10730               break;
10731
10732             default:
10733               nwh = FFEINFO_whereFLEETING;
10734               break;
10735             }
10736           break;
10737
10738         case FFEINFO_whereIMMEDIATE:
10739           switch (rwh)
10740             {
10741             case FFEINFO_whereCONSTANT:
10742             case FFEINFO_whereIMMEDIATE:
10743               nwh = FFEINFO_whereIMMEDIATE;
10744               break;
10745
10746             default:
10747               nwh = FFEINFO_whereFLEETING;
10748               break;
10749             }
10750           break;
10751
10752         default:
10753           nwh = FFEINFO_whereFLEETING;
10754           break;
10755         }
10756
10757       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10758                            FFETARGET_charactersizeNONE);
10759       ffebld_set_info (reduced, ninfo);
10760       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10761               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10762                                                  FFEEXPR_contextLET));
10763       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10764               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10765                                                   FFEEXPR_contextLET));
10766       return reduced;
10767     }
10768
10769   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10770       && (lbt != FFEINFO_basictypeCOMPLEX))
10771     {
10772       if ((rbt != FFEINFO_basictypeINTEGER)
10773       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10774         {
10775           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10776               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10777             {
10778               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10779               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10780               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10781               ffebad_finish ();
10782             }
10783         }
10784       else
10785         {
10786           if ((lbt != FFEINFO_basictypeANY)
10787               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10788             {
10789               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10790               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10791               ffebad_finish ();
10792             }
10793         }
10794     }
10795   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10796            && (rbt != FFEINFO_basictypeCOMPLEX))
10797     {
10798       if ((rbt != FFEINFO_basictypeANY)
10799           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10800         {
10801           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10802           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10803           ffebad_finish ();
10804         }
10805     }
10806   else if (lrk != 0)
10807     {
10808       if ((lkd != FFEINFO_kindANY)
10809           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10810         {
10811           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10812           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10813           ffebad_string ("an array");
10814           ffebad_finish ();
10815         }
10816     }
10817   else
10818     {
10819       if ((rkd != FFEINFO_kindANY)
10820           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10821         {
10822           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10823           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10824           ffebad_string ("an array");
10825           ffebad_finish ();
10826         }
10827     }
10828
10829   reduced = ffebld_new_any ();
10830   ffebld_set_info (reduced, ffeinfo_new_any ());
10831   return reduced;
10832 }
10833
10834 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10835
10836    reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10837
10838    Makes sure the left and right arguments for reduced have basictype of
10839    INTEGER, REAL, or COMPLEX.  Determine common basictype and
10840    size for reduction (flag expression for combined hollerith/typeless
10841    situations for later determination of effective basictype).  If both left
10842    and right arguments have where of CONSTANT, assign where CONSTANT to
10843    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10844    needed.  Note that real**int or complex**int
10845    comes out as int = real**int etc with no conversions.
10846
10847    If these requirements cannot be met, generate error message using the
10848    info in l, op, and r arguments and assign basictype, size, kind, and where
10849    of ANY.  */
10850
10851 static ffebld
10852 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10853                         ffeexprExpr_ r)
10854 {
10855   ffeinfo linfo, rinfo, ninfo;
10856   ffeinfoBasictype lbt, rbt, nbt;
10857   ffeinfoKindtype lkt, rkt, nkt;
10858   ffeinfoRank lrk, rrk;
10859   ffeinfoKind lkd, rkd;
10860   ffeinfoWhere lwh, rwh, nwh;
10861
10862   linfo = ffebld_info (ffebld_left (reduced));
10863   lbt = ffeinfo_basictype (linfo);
10864   lkt = ffeinfo_kindtype (linfo);
10865   lrk = ffeinfo_rank (linfo);
10866   lkd = ffeinfo_kind (linfo);
10867   lwh = ffeinfo_where (linfo);
10868
10869   rinfo = ffebld_info (ffebld_right (reduced));
10870   rbt = ffeinfo_basictype (rinfo);
10871   rkt = ffeinfo_kindtype (rinfo);
10872   rrk = ffeinfo_rank (rinfo);
10873   rkd = ffeinfo_kind (rinfo);
10874   rwh = ffeinfo_where (rinfo);
10875
10876   if ((rbt == FFEINFO_basictypeINTEGER)
10877       && ((lbt == FFEINFO_basictypeREAL)
10878           || (lbt == FFEINFO_basictypeCOMPLEX)))
10879     {
10880       nbt = lbt;
10881       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10882       if (nkt != FFEINFO_kindtypeREALDEFAULT)
10883         {
10884           nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10885           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10886             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10887         }
10888       if (rkt == FFEINFO_kindtypeINTEGER4)
10889         {
10890           ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10891                             FFEBAD_severityWARNING);
10892           ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10893           ffebad_finish ();
10894         }
10895       if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10896         {
10897           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10898                                                       r->token, op->token,
10899                 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10900                                                 FFETARGET_charactersizeNONE,
10901                                                       FFEEXPR_contextLET));
10902           rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10903         }
10904     }
10905   else
10906     {
10907       ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10908
10909 #if 0   /* INTEGER4**INTEGER4 works now. */
10910       if ((nbt == FFEINFO_basictypeINTEGER)
10911           && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10912         nkt = FFEINFO_kindtypeINTEGERDEFAULT;   /* Highest kt we can power! */
10913 #endif
10914       if (((nbt == FFEINFO_basictypeREAL)
10915            || (nbt == FFEINFO_basictypeCOMPLEX))
10916           && (nkt != FFEINFO_kindtypeREALDEFAULT))
10917         {
10918           nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10919           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10920             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10921         }
10922       /* else Gonna turn into an error below. */
10923     }
10924
10925   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10926        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10927     {
10928       switch (lwh)
10929         {
10930         case FFEINFO_whereCONSTANT:
10931           switch (rwh)
10932             {
10933             case FFEINFO_whereCONSTANT:
10934               nwh = FFEINFO_whereCONSTANT;
10935               break;
10936
10937             case FFEINFO_whereIMMEDIATE:
10938               nwh = FFEINFO_whereIMMEDIATE;
10939               break;
10940
10941             default:
10942               nwh = FFEINFO_whereFLEETING;
10943               break;
10944             }
10945           break;
10946
10947         case FFEINFO_whereIMMEDIATE:
10948           switch (rwh)
10949             {
10950             case FFEINFO_whereCONSTANT:
10951             case FFEINFO_whereIMMEDIATE:
10952               nwh = FFEINFO_whereIMMEDIATE;
10953               break;
10954
10955             default:
10956               nwh = FFEINFO_whereFLEETING;
10957               break;
10958             }
10959           break;
10960
10961         default:
10962           nwh = FFEINFO_whereFLEETING;
10963           break;
10964         }
10965
10966       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10967                            FFETARGET_charactersizeNONE);
10968       ffebld_set_info (reduced, ninfo);
10969       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10970               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10971                                                  FFEEXPR_contextLET));
10972       if (rbt != FFEINFO_basictypeINTEGER)
10973         ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10974               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10975                                                     FFEEXPR_contextLET));
10976       return reduced;
10977     }
10978
10979   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10980       && (lbt != FFEINFO_basictypeCOMPLEX))
10981     {
10982       if ((rbt != FFEINFO_basictypeINTEGER)
10983       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10984         {
10985           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10986               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10987             {
10988               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10989               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10990               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10991               ffebad_finish ();
10992             }
10993         }
10994       else
10995         {
10996           if ((lbt != FFEINFO_basictypeANY)
10997               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10998             {
10999               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11000               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11001               ffebad_finish ();
11002             }
11003         }
11004     }
11005   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11006            && (rbt != FFEINFO_basictypeCOMPLEX))
11007     {
11008       if ((rbt != FFEINFO_basictypeANY)
11009           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11010         {
11011           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11012           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11013           ffebad_finish ();
11014         }
11015     }
11016   else if (lrk != 0)
11017     {
11018       if ((lkd != FFEINFO_kindANY)
11019           && ffebad_start (FFEBAD_MATH_ARG_KIND))
11020         {
11021           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11022           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11023           ffebad_string ("an array");
11024           ffebad_finish ();
11025         }
11026     }
11027   else
11028     {
11029       if ((rkd != FFEINFO_kindANY)
11030           && ffebad_start (FFEBAD_MATH_ARG_KIND))
11031         {
11032           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11033           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11034           ffebad_string ("an array");
11035           ffebad_finish ();
11036         }
11037     }
11038
11039   reduced = ffebld_new_any ();
11040   ffebld_set_info (reduced, ffeinfo_new_any ());
11041   return reduced;
11042 }
11043
11044 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11045
11046    reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11047
11048    Makes sure the left and right arguments for reduced have basictype of
11049    INTEGER, REAL, or CHARACTER.  Determine common basictype and
11050    size for reduction.  If both left
11051    and right arguments have where of CONSTANT, assign where CONSTANT to
11052    reduced, else assign where FLEETING.  Create CONVERT ops for args where
11053    needed.  Convert typeless
11054    constants to the desired type/size explicitly.
11055
11056    If these requirements cannot be met, generate error message.  */
11057
11058 static ffebld
11059 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11060                          ffeexprExpr_ r)
11061 {
11062   ffeinfo linfo, rinfo, ninfo;
11063   ffeinfoBasictype lbt, rbt, nbt;
11064   ffeinfoKindtype lkt, rkt, nkt;
11065   ffeinfoRank lrk, rrk;
11066   ffeinfoKind lkd, rkd;
11067   ffeinfoWhere lwh, rwh, nwh;
11068   ffetargetCharacterSize lsz, rsz;
11069
11070   linfo = ffebld_info (ffebld_left (reduced));
11071   lbt = ffeinfo_basictype (linfo);
11072   lkt = ffeinfo_kindtype (linfo);
11073   lrk = ffeinfo_rank (linfo);
11074   lkd = ffeinfo_kind (linfo);
11075   lwh = ffeinfo_where (linfo);
11076   lsz = ffebld_size_known (ffebld_left (reduced));
11077
11078   rinfo = ffebld_info (ffebld_right (reduced));
11079   rbt = ffeinfo_basictype (rinfo);
11080   rkt = ffeinfo_kindtype (rinfo);
11081   rrk = ffeinfo_rank (rinfo);
11082   rkd = ffeinfo_kind (rinfo);
11083   rwh = ffeinfo_where (rinfo);
11084   rsz = ffebld_size_known (ffebld_right (reduced));
11085
11086   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11087
11088   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11089        || (nbt == FFEINFO_basictypeCHARACTER))
11090       && (lrk == 0) && (rrk == 0))
11091     {
11092       switch (lwh)
11093         {
11094         case FFEINFO_whereCONSTANT:
11095           switch (rwh)
11096             {
11097             case FFEINFO_whereCONSTANT:
11098               nwh = FFEINFO_whereCONSTANT;
11099               break;
11100
11101             case FFEINFO_whereIMMEDIATE:
11102               nwh = FFEINFO_whereIMMEDIATE;
11103               break;
11104
11105             default:
11106               nwh = FFEINFO_whereFLEETING;
11107               break;
11108             }
11109           break;
11110
11111         case FFEINFO_whereIMMEDIATE:
11112           switch (rwh)
11113             {
11114             case FFEINFO_whereCONSTANT:
11115             case FFEINFO_whereIMMEDIATE:
11116               nwh = FFEINFO_whereIMMEDIATE;
11117               break;
11118
11119             default:
11120               nwh = FFEINFO_whereFLEETING;
11121               break;
11122             }
11123           break;
11124
11125         default:
11126           nwh = FFEINFO_whereFLEETING;
11127           break;
11128         }
11129
11130       if ((lsz != FFETARGET_charactersizeNONE)
11131           && (rsz != FFETARGET_charactersizeNONE))
11132         lsz = rsz = (lsz > rsz) ? lsz : rsz;
11133
11134       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11135                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11136       ffebld_set_info (reduced, ninfo);
11137       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11138                                       l->token, op->token, nbt, nkt, 0, lsz,
11139                                                  FFEEXPR_contextLET));
11140       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11141                                       r->token, op->token, nbt, nkt, 0, rsz,
11142                                                   FFEEXPR_contextLET));
11143       return reduced;
11144     }
11145
11146   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11147       && (lbt != FFEINFO_basictypeCHARACTER))
11148     {
11149       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11150           && (rbt != FFEINFO_basictypeCHARACTER))
11151         {
11152           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11153               && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11154             {
11155               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11156               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11157               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11158               ffebad_finish ();
11159             }
11160         }
11161       else
11162         {
11163           if ((lbt != FFEINFO_basictypeANY)
11164               && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11165             {
11166               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11167               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11168               ffebad_finish ();
11169             }
11170         }
11171     }
11172   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11173            && (rbt != FFEINFO_basictypeCHARACTER))
11174     {
11175       if ((rbt != FFEINFO_basictypeANY)
11176           && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11177         {
11178           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11179           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11180           ffebad_finish ();
11181         }
11182     }
11183   else if (lrk != 0)
11184     {
11185       if ((lkd != FFEINFO_kindANY)
11186           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11187         {
11188           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11189           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11190           ffebad_string ("an array");
11191           ffebad_finish ();
11192         }
11193     }
11194   else
11195     {
11196       if ((rkd != FFEINFO_kindANY)
11197           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11198         {
11199           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11200           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11201           ffebad_string ("an array");
11202           ffebad_finish ();
11203         }
11204     }
11205
11206   reduced = ffebld_new_any ();
11207   ffebld_set_info (reduced, ffeinfo_new_any ());
11208   return reduced;
11209 }
11210
11211 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11212
11213    reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11214
11215    Sigh.  */
11216
11217 static ffebld
11218 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11219 {
11220   ffeinfo rinfo;
11221   ffeinfoBasictype rbt;
11222   ffeinfoKindtype rkt;
11223   ffeinfoRank rrk;
11224   ffeinfoKind rkd;
11225   ffeinfoWhere rwh;
11226
11227   rinfo = ffebld_info (ffebld_left (reduced));
11228   rbt = ffeinfo_basictype (rinfo);
11229   rkt = ffeinfo_kindtype (rinfo);
11230   rrk = ffeinfo_rank (rinfo);
11231   rkd = ffeinfo_kind (rinfo);
11232   rwh = ffeinfo_where (rinfo);
11233
11234   if ((rbt == FFEINFO_basictypeTYPELESS)
11235       || (rbt == FFEINFO_basictypeHOLLERITH))
11236     {
11237       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11238                               r->token, op->token, FFEINFO_basictypeINTEGER,
11239                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11240                                                  FFETARGET_charactersizeNONE,
11241                                                  FFEEXPR_contextLET));
11242       rinfo = ffebld_info (ffebld_left (reduced));
11243       rbt = FFEINFO_basictypeINTEGER;
11244       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11245       rrk = 0;
11246       rkd = FFEINFO_kindENTITY;
11247       rwh = ffeinfo_where (rinfo);
11248     }
11249
11250   if (rbt == FFEINFO_basictypeLOGICAL)
11251     {
11252       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11253                               r->token, op->token, FFEINFO_basictypeINTEGER,
11254                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11255                                                  FFETARGET_charactersizeNONE,
11256                                                  FFEEXPR_contextLET));
11257     }
11258
11259   return reduced;
11260 }
11261
11262 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11263
11264    reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11265
11266    Sigh.  */
11267
11268 static ffebld
11269 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11270 {
11271   ffeinfo rinfo;
11272   ffeinfoBasictype rbt;
11273   ffeinfoKindtype rkt;
11274   ffeinfoRank rrk;
11275   ffeinfoKind rkd;
11276   ffeinfoWhere rwh;
11277
11278   rinfo = ffebld_info (ffebld_left (reduced));
11279   rbt = ffeinfo_basictype (rinfo);
11280   rkt = ffeinfo_kindtype (rinfo);
11281   rrk = ffeinfo_rank (rinfo);
11282   rkd = ffeinfo_kind (rinfo);
11283   rwh = ffeinfo_where (rinfo);
11284
11285   if ((rbt == FFEINFO_basictypeTYPELESS)
11286       || (rbt == FFEINFO_basictypeHOLLERITH))
11287     {
11288       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11289                            r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11290                                              FFEINFO_kindtypeLOGICALDEFAULT,
11291                                                  FFETARGET_charactersizeNONE,
11292                                                  FFEEXPR_contextLET));
11293       rinfo = ffebld_info (ffebld_left (reduced));
11294       rbt = FFEINFO_basictypeLOGICAL;
11295       rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11296       rrk = 0;
11297       rkd = FFEINFO_kindENTITY;
11298       rwh = ffeinfo_where (rinfo);
11299     }
11300
11301   return reduced;
11302 }
11303
11304 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11305
11306    reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11307
11308    Sigh.  */
11309
11310 static ffebld
11311 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11312                         ffeexprExpr_ r)
11313 {
11314   ffeinfo linfo, rinfo;
11315   ffeinfoBasictype lbt, rbt;
11316   ffeinfoKindtype lkt, rkt;
11317   ffeinfoRank lrk, rrk;
11318   ffeinfoKind lkd, rkd;
11319   ffeinfoWhere lwh, rwh;
11320
11321   linfo = ffebld_info (ffebld_left (reduced));
11322   lbt = ffeinfo_basictype (linfo);
11323   lkt = ffeinfo_kindtype (linfo);
11324   lrk = ffeinfo_rank (linfo);
11325   lkd = ffeinfo_kind (linfo);
11326   lwh = ffeinfo_where (linfo);
11327
11328   rinfo = ffebld_info (ffebld_right (reduced));
11329   rbt = ffeinfo_basictype (rinfo);
11330   rkt = ffeinfo_kindtype (rinfo);
11331   rrk = ffeinfo_rank (rinfo);
11332   rkd = ffeinfo_kind (rinfo);
11333   rwh = ffeinfo_where (rinfo);
11334
11335   if ((lbt == FFEINFO_basictypeTYPELESS)
11336       || (lbt == FFEINFO_basictypeHOLLERITH))
11337     {
11338       if ((rbt == FFEINFO_basictypeTYPELESS)
11339           || (rbt == FFEINFO_basictypeHOLLERITH))
11340         {
11341           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11342                               l->token, op->token, FFEINFO_basictypeINTEGER,
11343                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11344                                                 FFETARGET_charactersizeNONE,
11345                                                      FFEEXPR_contextLET));
11346           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11347                            r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11348                                              FFEINFO_kindtypeINTEGERDEFAULT,
11349                                                 FFETARGET_charactersizeNONE,
11350                                                       FFEEXPR_contextLET));
11351           linfo = ffebld_info (ffebld_left (reduced));
11352           rinfo = ffebld_info (ffebld_right (reduced));
11353           lbt = rbt = FFEINFO_basictypeINTEGER;
11354           lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11355           lrk = rrk = 0;
11356           lkd = rkd = FFEINFO_kindENTITY;
11357           lwh = ffeinfo_where (linfo);
11358           rwh = ffeinfo_where (rinfo);
11359         }
11360       else
11361         {
11362           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11363                                  l->token, ffebld_right (reduced), r->token,
11364                                                        FFEEXPR_contextLET));
11365           linfo = ffebld_info (ffebld_left (reduced));
11366           lbt = ffeinfo_basictype (linfo);
11367           lkt = ffeinfo_kindtype (linfo);
11368           lrk = ffeinfo_rank (linfo);
11369           lkd = ffeinfo_kind (linfo);
11370           lwh = ffeinfo_where (linfo);
11371         }
11372     }
11373   else
11374     {
11375       if ((rbt == FFEINFO_basictypeTYPELESS)
11376           || (rbt == FFEINFO_basictypeHOLLERITH))
11377         {
11378           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11379                                   r->token, ffebld_left (reduced), l->token,
11380                                                        FFEEXPR_contextLET));
11381           rinfo = ffebld_info (ffebld_right (reduced));
11382           rbt = ffeinfo_basictype (rinfo);
11383           rkt = ffeinfo_kindtype (rinfo);
11384           rrk = ffeinfo_rank (rinfo);
11385           rkd = ffeinfo_kind (rinfo);
11386           rwh = ffeinfo_where (rinfo);
11387         }
11388       /* else Leave it alone. */
11389     }
11390
11391   if (lbt == FFEINFO_basictypeLOGICAL)
11392     {
11393       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11394                               l->token, op->token, FFEINFO_basictypeINTEGER,
11395                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11396                                                  FFETARGET_charactersizeNONE,
11397                                                  FFEEXPR_contextLET));
11398     }
11399
11400   if (rbt == FFEINFO_basictypeLOGICAL)
11401     {
11402       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11403                               r->token, op->token, FFEINFO_basictypeINTEGER,
11404                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11405                                                 FFETARGET_charactersizeNONE,
11406                                                   FFEEXPR_contextLET));
11407     }
11408
11409   return reduced;
11410 }
11411
11412 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11413
11414    reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11415
11416    Sigh.  */
11417
11418 static ffebld
11419 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11420                            ffeexprExpr_ r)
11421 {
11422   ffeinfo linfo, rinfo;
11423   ffeinfoBasictype lbt, rbt;
11424   ffeinfoKindtype lkt, rkt;
11425   ffeinfoRank lrk, rrk;
11426   ffeinfoKind lkd, rkd;
11427   ffeinfoWhere lwh, rwh;
11428
11429   linfo = ffebld_info (ffebld_left (reduced));
11430   lbt = ffeinfo_basictype (linfo);
11431   lkt = ffeinfo_kindtype (linfo);
11432   lrk = ffeinfo_rank (linfo);
11433   lkd = ffeinfo_kind (linfo);
11434   lwh = ffeinfo_where (linfo);
11435
11436   rinfo = ffebld_info (ffebld_right (reduced));
11437   rbt = ffeinfo_basictype (rinfo);
11438   rkt = ffeinfo_kindtype (rinfo);
11439   rrk = ffeinfo_rank (rinfo);
11440   rkd = ffeinfo_kind (rinfo);
11441   rwh = ffeinfo_where (rinfo);
11442
11443   if ((lbt == FFEINFO_basictypeTYPELESS)
11444       || (lbt == FFEINFO_basictypeHOLLERITH))
11445     {
11446       if ((rbt == FFEINFO_basictypeTYPELESS)
11447           || (rbt == FFEINFO_basictypeHOLLERITH))
11448         {
11449           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11450                               l->token, op->token, FFEINFO_basictypeLOGICAL,
11451                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
11452                                                 FFETARGET_charactersizeNONE,
11453                                                      FFEEXPR_contextLET));
11454           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11455                               r->token, op->token, FFEINFO_basictypeLOGICAL,
11456                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
11457                                                 FFETARGET_charactersizeNONE,
11458                                                       FFEEXPR_contextLET));
11459           linfo = ffebld_info (ffebld_left (reduced));
11460           rinfo = ffebld_info (ffebld_right (reduced));
11461           lbt = rbt = FFEINFO_basictypeLOGICAL;
11462           lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11463           lrk = rrk = 0;
11464           lkd = rkd = FFEINFO_kindENTITY;
11465           lwh = ffeinfo_where (linfo);
11466           rwh = ffeinfo_where (rinfo);
11467         }
11468       else
11469         {
11470           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11471                                  l->token, ffebld_right (reduced), r->token,
11472                                                        FFEEXPR_contextLET));
11473           linfo = ffebld_info (ffebld_left (reduced));
11474           lbt = ffeinfo_basictype (linfo);
11475           lkt = ffeinfo_kindtype (linfo);
11476           lrk = ffeinfo_rank (linfo);
11477           lkd = ffeinfo_kind (linfo);
11478           lwh = ffeinfo_where (linfo);
11479         }
11480     }
11481   else
11482     {
11483       if ((rbt == FFEINFO_basictypeTYPELESS)
11484           || (rbt == FFEINFO_basictypeHOLLERITH))
11485         {
11486           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11487                                   r->token, ffebld_left (reduced), l->token,
11488                                                        FFEEXPR_contextLET));
11489           rinfo = ffebld_info (ffebld_right (reduced));
11490           rbt = ffeinfo_basictype (rinfo);
11491           rkt = ffeinfo_kindtype (rinfo);
11492           rrk = ffeinfo_rank (rinfo);
11493           rkd = ffeinfo_kind (rinfo);
11494           rwh = ffeinfo_where (rinfo);
11495         }
11496       /* else Leave it alone. */
11497     }
11498
11499   return reduced;
11500 }
11501
11502 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11503    is found.
11504
11505    The idea is to process the tokens as they would be done by normal
11506    expression processing, with the key things being telling the lexer
11507    when hollerith/character constants are about to happen, until the
11508    true closing token is found.  */
11509
11510 static ffelexHandler
11511 ffeexpr_find_close_paren_ (ffelexToken t,
11512                            ffelexHandler after)
11513 {
11514   ffeexpr_find_.after = after;
11515   ffeexpr_find_.level = 1;
11516   return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11517 }
11518
11519 static ffelexHandler
11520 ffeexpr_nil_finished_ (ffelexToken t)
11521 {
11522   switch (ffelex_token_type (t))
11523     {
11524     case FFELEX_typeCLOSE_PAREN:
11525       if (--ffeexpr_find_.level == 0)
11526         return (ffelexHandler) ffeexpr_find_.after;
11527       return (ffelexHandler) ffeexpr_nil_binary_;
11528
11529     case FFELEX_typeCOMMA:
11530     case FFELEX_typeCOLON:
11531     case FFELEX_typeEQUALS:
11532     case FFELEX_typePOINTS:
11533       return (ffelexHandler) ffeexpr_nil_rhs_;
11534
11535     default:
11536       if (--ffeexpr_find_.level == 0)
11537         return (ffelexHandler) ffeexpr_find_.after (t);
11538       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11539     }
11540 }
11541
11542 static ffelexHandler
11543 ffeexpr_nil_rhs_ (ffelexToken t)
11544 {
11545   switch (ffelex_token_type (t))
11546     {
11547     case FFELEX_typeQUOTE:
11548       if (ffe_is_vxt ())
11549         return (ffelexHandler) ffeexpr_nil_quote_;
11550       ffelex_set_expecting_hollerith (-1, '\"',
11551                                       ffelex_token_where_line (t),
11552                                       ffelex_token_where_column (t));
11553       return (ffelexHandler) ffeexpr_nil_apostrophe_;
11554
11555     case FFELEX_typeAPOSTROPHE:
11556       ffelex_set_expecting_hollerith (-1, '\'',
11557                                       ffelex_token_where_line (t),
11558                                       ffelex_token_where_column (t));
11559       return (ffelexHandler) ffeexpr_nil_apostrophe_;
11560
11561     case FFELEX_typePERCENT:
11562       return (ffelexHandler) ffeexpr_nil_percent_;
11563
11564     case FFELEX_typeOPEN_PAREN:
11565       ++ffeexpr_find_.level;
11566       return (ffelexHandler) ffeexpr_nil_rhs_;
11567
11568     case FFELEX_typePLUS:
11569     case FFELEX_typeMINUS:
11570       return (ffelexHandler) ffeexpr_nil_rhs_;
11571
11572     case FFELEX_typePERIOD:
11573       return (ffelexHandler) ffeexpr_nil_period_;
11574
11575     case FFELEX_typeNUMBER:
11576       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11577       if (ffeexpr_hollerith_count_ > 0)
11578         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11579                                         '\0',
11580                                         ffelex_token_where_line (t),
11581                                         ffelex_token_where_column (t));
11582       return (ffelexHandler) ffeexpr_nil_number_;
11583
11584     case FFELEX_typeNAME:
11585     case FFELEX_typeNAMES:
11586       return (ffelexHandler) ffeexpr_nil_name_rhs_;
11587
11588     case FFELEX_typeASTERISK:
11589     case FFELEX_typeSLASH:
11590     case FFELEX_typePOWER:
11591     case FFELEX_typeCONCAT:
11592     case FFELEX_typeREL_EQ:
11593     case FFELEX_typeREL_NE:
11594     case FFELEX_typeREL_LE:
11595     case FFELEX_typeREL_GE:
11596       return (ffelexHandler) ffeexpr_nil_rhs_;
11597
11598     default:
11599       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11600     }
11601 }
11602
11603 static ffelexHandler
11604 ffeexpr_nil_period_ (ffelexToken t)
11605 {
11606   switch (ffelex_token_type (t))
11607     {
11608     case FFELEX_typeNAME:
11609     case FFELEX_typeNAMES:
11610       ffeexpr_current_dotdot_ = ffestr_other (t);
11611       switch (ffeexpr_current_dotdot_)
11612         {
11613         case FFESTR_otherNone:
11614           return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11615
11616         case FFESTR_otherTRUE:
11617         case FFESTR_otherFALSE:
11618         case FFESTR_otherNOT:
11619           return (ffelexHandler) ffeexpr_nil_end_period_;
11620
11621         default:
11622           return (ffelexHandler) ffeexpr_nil_swallow_period_;
11623         }
11624       break;                    /* Nothing really reaches here. */
11625
11626     case FFELEX_typeNUMBER:
11627       return (ffelexHandler) ffeexpr_nil_real_;
11628
11629     default:
11630       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11631     }
11632 }
11633
11634 static ffelexHandler
11635 ffeexpr_nil_end_period_ (ffelexToken t)
11636 {
11637   switch (ffeexpr_current_dotdot_)
11638     {
11639     case FFESTR_otherNOT:
11640       if (ffelex_token_type (t) != FFELEX_typePERIOD)
11641         return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11642       return (ffelexHandler) ffeexpr_nil_rhs_;
11643
11644     case FFESTR_otherTRUE:
11645     case FFESTR_otherFALSE:
11646       if (ffelex_token_type (t) != FFELEX_typePERIOD)
11647         return (ffelexHandler) ffeexpr_nil_binary_ (t);
11648       return (ffelexHandler) ffeexpr_nil_binary_;
11649
11650     default:
11651       assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11652       exit (0);
11653       return NULL;
11654     }
11655 }
11656
11657 static ffelexHandler
11658 ffeexpr_nil_swallow_period_ (ffelexToken t)
11659 {
11660   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11661     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11662   return (ffelexHandler) ffeexpr_nil_rhs_;
11663 }
11664
11665 static ffelexHandler
11666 ffeexpr_nil_real_ (ffelexToken t)
11667 {
11668   char d;
11669   const char *p;
11670
11671   if (((ffelex_token_type (t) != FFELEX_typeNAME)
11672        && (ffelex_token_type (t) != FFELEX_typeNAMES))
11673       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11674                                      'D', 'd')
11675              || ffesrc_char_match_init (d, 'E', 'e')
11676              || ffesrc_char_match_init (d, 'Q', 'q')))
11677            && ffeexpr_isdigits_ (++p)))
11678     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11679
11680   if (*p == '\0')
11681     return (ffelexHandler) ffeexpr_nil_real_exponent_;
11682   return (ffelexHandler) ffeexpr_nil_binary_;
11683 }
11684
11685 static ffelexHandler
11686 ffeexpr_nil_real_exponent_ (ffelexToken t)
11687 {
11688   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11689       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11690     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11691
11692   return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11693 }
11694
11695 static ffelexHandler
11696 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11697 {
11698   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11699     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11700   return (ffelexHandler) ffeexpr_nil_binary_;
11701 }
11702
11703 static ffelexHandler
11704 ffeexpr_nil_number_ (ffelexToken t)
11705 {
11706   char d;
11707   const char *p;
11708
11709   if (ffeexpr_hollerith_count_ > 0)
11710     ffelex_set_expecting_hollerith (0, '\0',
11711                                     ffewhere_line_unknown (),
11712                                     ffewhere_column_unknown ());
11713
11714   switch (ffelex_token_type (t))
11715     {
11716     case FFELEX_typeNAME:
11717     case FFELEX_typeNAMES:
11718       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11719                                    'D', 'd')
11720            || ffesrc_char_match_init (d, 'E', 'e')
11721            || ffesrc_char_match_init (d, 'Q', 'q'))
11722           && ffeexpr_isdigits_ (++p))
11723         {
11724           if (*p == '\0')
11725             {
11726               ffeexpr_find_.t = ffelex_token_use (t);
11727               return (ffelexHandler) ffeexpr_nil_number_exponent_;
11728             }
11729           return (ffelexHandler) ffeexpr_nil_binary_;
11730         }
11731       break;
11732
11733     case FFELEX_typePERIOD:
11734       ffeexpr_find_.t = ffelex_token_use (t);
11735       return (ffelexHandler) ffeexpr_nil_number_period_;
11736
11737     case FFELEX_typeHOLLERITH:
11738       return (ffelexHandler) ffeexpr_nil_binary_;
11739
11740     default:
11741       break;
11742     }
11743   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11744 }
11745
11746 /* Expects ffeexpr_find_.t.  */
11747
11748 static ffelexHandler
11749 ffeexpr_nil_number_exponent_ (ffelexToken t)
11750 {
11751   ffelexHandler nexthandler;
11752
11753   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11754       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11755     {
11756       nexthandler
11757         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11758       ffelex_token_kill (ffeexpr_find_.t);
11759       return (ffelexHandler) (*nexthandler) (t);
11760     }
11761
11762   ffelex_token_kill (ffeexpr_find_.t);
11763   return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11764 }
11765
11766 static ffelexHandler
11767 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11768 {
11769   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11770     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11771
11772   return (ffelexHandler) ffeexpr_nil_binary_;
11773 }
11774
11775 /* Expects ffeexpr_find_.t.  */
11776
11777 static ffelexHandler
11778 ffeexpr_nil_number_period_ (ffelexToken t)
11779 {
11780   ffelexHandler nexthandler;
11781   char d;
11782   const char *p;
11783
11784   switch (ffelex_token_type (t))
11785     {
11786     case FFELEX_typeNAME:
11787     case FFELEX_typeNAMES:
11788       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11789                                    'D', 'd')
11790            || ffesrc_char_match_init (d, 'E', 'e')
11791            || ffesrc_char_match_init (d, 'Q', 'q'))
11792           && ffeexpr_isdigits_ (++p))
11793         {
11794           if (*p == '\0')
11795             return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11796           ffelex_token_kill (ffeexpr_find_.t);
11797           return (ffelexHandler) ffeexpr_nil_binary_;
11798         }
11799       nexthandler
11800         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11801       ffelex_token_kill (ffeexpr_find_.t);
11802       return (ffelexHandler) (*nexthandler) (t);
11803
11804     case FFELEX_typeNUMBER:
11805       ffelex_token_kill (ffeexpr_find_.t);
11806       return (ffelexHandler) ffeexpr_nil_number_real_;
11807
11808     default:
11809       break;
11810     }
11811   ffelex_token_kill (ffeexpr_find_.t);
11812   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11813 }
11814
11815 /* Expects ffeexpr_find_.t.  */
11816
11817 static ffelexHandler
11818 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11819 {
11820   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11821       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11822     {
11823       ffelexHandler nexthandler;
11824
11825       nexthandler
11826         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11827       ffelex_token_kill (ffeexpr_find_.t);
11828       return (ffelexHandler) (*nexthandler) (t);
11829     }
11830
11831   ffelex_token_kill (ffeexpr_find_.t);
11832   return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11833 }
11834
11835 static ffelexHandler
11836 ffeexpr_nil_number_real_ (ffelexToken t)
11837 {
11838   char d;
11839   const char *p;
11840
11841   if (((ffelex_token_type (t) != FFELEX_typeNAME)
11842        && (ffelex_token_type (t) != FFELEX_typeNAMES))
11843       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11844                                      'D', 'd')
11845              || ffesrc_char_match_init (d, 'E', 'e')
11846              || ffesrc_char_match_init (d, 'Q', 'q')))
11847            && ffeexpr_isdigits_ (++p)))
11848     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11849
11850   if (*p == '\0')
11851     return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11852
11853   return (ffelexHandler) ffeexpr_nil_binary_;
11854 }
11855
11856 static ffelexHandler
11857 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11858 {
11859   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11860     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11861   return (ffelexHandler) ffeexpr_nil_binary_;
11862 }
11863
11864 static ffelexHandler
11865 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11866 {
11867   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11868       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11869     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11870   return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11871 }
11872
11873 static ffelexHandler
11874 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11875 {
11876   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11877     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11878   return (ffelexHandler) ffeexpr_nil_binary_;
11879 }
11880
11881 static ffelexHandler
11882 ffeexpr_nil_binary_ (ffelexToken t)
11883 {
11884   switch (ffelex_token_type (t))
11885     {
11886     case FFELEX_typePLUS:
11887     case FFELEX_typeMINUS:
11888     case FFELEX_typeASTERISK:
11889     case FFELEX_typeSLASH:
11890     case FFELEX_typePOWER:
11891     case FFELEX_typeCONCAT:
11892     case FFELEX_typeOPEN_ANGLE:
11893     case FFELEX_typeCLOSE_ANGLE:
11894     case FFELEX_typeREL_EQ:
11895     case FFELEX_typeREL_NE:
11896     case FFELEX_typeREL_GE:
11897     case FFELEX_typeREL_LE:
11898       return (ffelexHandler) ffeexpr_nil_rhs_;
11899
11900     case FFELEX_typePERIOD:
11901       return (ffelexHandler) ffeexpr_nil_binary_period_;
11902
11903     default:
11904       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11905     }
11906 }
11907
11908 static ffelexHandler
11909 ffeexpr_nil_binary_period_ (ffelexToken t)
11910 {
11911   switch (ffelex_token_type (t))
11912     {
11913     case FFELEX_typeNAME:
11914     case FFELEX_typeNAMES:
11915       ffeexpr_current_dotdot_ = ffestr_other (t);
11916       switch (ffeexpr_current_dotdot_)
11917         {
11918         case FFESTR_otherTRUE:
11919         case FFESTR_otherFALSE:
11920         case FFESTR_otherNOT:
11921           return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11922
11923         default:
11924           return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11925         }
11926       break;                    /* Nothing really reaches here. */
11927
11928     default:
11929       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11930     }
11931 }
11932
11933 static ffelexHandler
11934 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11935 {
11936   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11937     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11938   return (ffelexHandler) ffeexpr_nil_rhs_;
11939 }
11940
11941 static ffelexHandler
11942 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11943 {
11944   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11945     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11946   return (ffelexHandler) ffeexpr_nil_binary_;
11947 }
11948
11949 static ffelexHandler
11950 ffeexpr_nil_quote_ (ffelexToken t)
11951 {
11952   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11953     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11954   return (ffelexHandler) ffeexpr_nil_binary_;
11955 }
11956
11957 static ffelexHandler
11958 ffeexpr_nil_apostrophe_ (ffelexToken t)
11959 {
11960   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11961   return (ffelexHandler) ffeexpr_nil_apos_char_;
11962 }
11963
11964 static ffelexHandler
11965 ffeexpr_nil_apos_char_ (ffelexToken t)
11966 {
11967   char c;
11968
11969   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11970       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11971     {
11972       if ((ffelex_token_length (t) == 1)
11973           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11974                                       'B', 'b')
11975               || ffesrc_char_match_init (c, 'O', 'o')
11976               || ffesrc_char_match_init (c, 'X', 'x')
11977               || ffesrc_char_match_init (c, 'Z', 'z')))
11978         return (ffelexHandler) ffeexpr_nil_binary_;
11979     }
11980   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11981       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11982     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11983   return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11984 }
11985
11986 static ffelexHandler
11987 ffeexpr_nil_name_rhs_ (ffelexToken t)
11988 {
11989   switch (ffelex_token_type (t))
11990     {
11991     case FFELEX_typeQUOTE:
11992     case FFELEX_typeAPOSTROPHE:
11993       ffelex_set_hexnum (TRUE);
11994       return (ffelexHandler) ffeexpr_nil_name_apos_;
11995
11996     case FFELEX_typeOPEN_PAREN:
11997       ++ffeexpr_find_.level;
11998       return (ffelexHandler) ffeexpr_nil_rhs_;
11999
12000     default:
12001       return (ffelexHandler) ffeexpr_nil_binary_ (t);
12002     }
12003 }
12004
12005 static ffelexHandler
12006 ffeexpr_nil_name_apos_ (ffelexToken t)
12007 {
12008   if (ffelex_token_type (t) == FFELEX_typeNAME)
12009     return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12010   return (ffelexHandler) ffeexpr_nil_binary_ (t);
12011 }
12012
12013 static ffelexHandler
12014 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12015 {
12016   switch (ffelex_token_type (t))
12017     {
12018     case FFELEX_typeAPOSTROPHE:
12019     case FFELEX_typeQUOTE:
12020       return (ffelexHandler) ffeexpr_nil_finished_;
12021
12022     default:
12023       return (ffelexHandler) ffeexpr_nil_finished_ (t);
12024     }
12025 }
12026
12027 static ffelexHandler
12028 ffeexpr_nil_percent_ (ffelexToken t)
12029 {
12030   switch (ffelex_token_type (t))
12031     {
12032     case FFELEX_typeNAME:
12033     case FFELEX_typeNAMES:
12034       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12035       ffeexpr_find_.t = ffelex_token_use (t);
12036       return (ffelexHandler) ffeexpr_nil_percent_name_;
12037
12038     default:
12039       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12040     }
12041 }
12042
12043 /* Expects ffeexpr_find_.t.  */
12044
12045 static ffelexHandler
12046 ffeexpr_nil_percent_name_ (ffelexToken t)
12047 {
12048   ffelexHandler nexthandler;
12049
12050   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12051     {
12052       nexthandler
12053         = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12054       ffelex_token_kill (ffeexpr_find_.t);
12055       return (ffelexHandler) (*nexthandler) (t);
12056     }
12057
12058   ffelex_token_kill (ffeexpr_find_.t);
12059   ++ffeexpr_find_.level;
12060   return (ffelexHandler) ffeexpr_nil_rhs_;
12061 }
12062
12063 static ffelexHandler
12064 ffeexpr_nil_substrp_ (ffelexToken t)
12065 {
12066   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12067     return (ffelexHandler) ffeexpr_nil_binary_ (t);
12068
12069   ++ffeexpr_find_.level;
12070   return (ffelexHandler) ffeexpr_nil_rhs_;
12071 }
12072
12073 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12074
12075    ffelexToken t;
12076    return ffeexpr_finished_(t);
12077
12078    Reduces expression stack to one (or zero) elements by repeatedly reducing
12079    the top operator on the stack (or, if the top element on the stack is
12080    itself an operator, issuing an error message and discarding it).  Calls
12081    finishing routine with the expression, returning the ffelexHandler it
12082    returns to the caller.  */
12083
12084 static ffelexHandler
12085 ffeexpr_finished_ (ffelexToken t)
12086 {
12087   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
12088   ffebld expr;
12089   ffeexprCallback callback;
12090   ffeexprStack_ s;
12091   ffebldConstant constnode;     /* For detecting magical number. */
12092   ffelexToken ft;               /* Temporary copy of first token in
12093                                    expression. */
12094   ffelexHandler next;
12095   ffeinfo info;
12096   bool error = FALSE;
12097
12098   while (((operand = ffeexpr_stack_->exprstack) != NULL)
12099          && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12100     {
12101       if (operand->type == FFEEXPR_exprtypeOPERAND_)
12102         ffeexpr_reduce_ ();
12103       else
12104         {
12105           if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12106             {
12107               ffebad_here (0, ffelex_token_where_line (t),
12108                            ffelex_token_where_column (t));
12109               ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12110               ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12111               ffebad_finish ();
12112             }
12113           ffeexpr_stack_->exprstack = operand->previous;        /* Pop the useless
12114                                                                    operator. */
12115           ffeexpr_expr_kill_ (operand);
12116         }
12117     }
12118
12119   assert ((operand == NULL) || (operand->previous == NULL));
12120
12121   ffebld_pool_pop ();
12122   if (operand == NULL)
12123     expr = NULL;
12124   else
12125     {
12126       expr = operand->u.operand;
12127       info = ffebld_info (expr);
12128       if ((ffebld_op (expr) == FFEBLD_opCONTER)
12129           && (ffebld_conter_orig (expr) == NULL)
12130           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12131         {
12132           ffetarget_integer_bad_magical (operand->token);
12133         }
12134       ffeexpr_expr_kill_ (operand);
12135       ffeexpr_stack_->exprstack = NULL;
12136     }
12137
12138   ft = ffeexpr_stack_->first_token;
12139
12140 again:                          /* :::::::::::::::::::: */
12141   switch (ffeexpr_stack_->context)
12142     {
12143     case FFEEXPR_contextLET:
12144     case FFEEXPR_contextSFUNCDEF:
12145       error = (expr == NULL)
12146         || (ffeinfo_rank (info) != 0);
12147       break;
12148
12149     case FFEEXPR_contextPAREN_:
12150       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12151         break;
12152       switch (ffeinfo_basictype (info))
12153         {
12154         case FFEINFO_basictypeHOLLERITH:
12155         case FFEINFO_basictypeTYPELESS:
12156           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12157              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12158                                   FFEEXPR_contextLET);
12159           break;
12160
12161         default:
12162           break;
12163         }
12164       break;
12165
12166     case FFEEXPR_contextPARENFILENUM_:
12167       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12168         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12169       else
12170         ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12171       goto again;               /* :::::::::::::::::::: */
12172
12173     case FFEEXPR_contextPARENFILEUNIT_:
12174       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12175         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12176       else
12177         ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12178       goto again;               /* :::::::::::::::::::: */
12179
12180     case FFEEXPR_contextACTUALARGEXPR_:
12181     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12182       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12183               : ffeinfo_basictype (info))
12184         {
12185         case FFEINFO_basictypeHOLLERITH:
12186         case FFEINFO_basictypeTYPELESS:
12187           if (!ffe_is_ugly_args ()
12188               && ffebad_start (FFEBAD_ACTUALARG))
12189             {
12190               ffebad_here (0, ffelex_token_where_line (ft),
12191                            ffelex_token_where_column (ft));
12192               ffebad_finish ();
12193             }
12194           break;
12195
12196         default:
12197           break;
12198         }
12199       error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12200       break;
12201
12202     case FFEEXPR_contextACTUALARG_:
12203     case FFEEXPR_contextSFUNCDEFACTUALARG_:
12204       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12205               : ffeinfo_basictype (info))
12206         {
12207         case FFEINFO_basictypeHOLLERITH:
12208         case FFEINFO_basictypeTYPELESS:
12209 #if 0                           /* Should never get here. */
12210           expr = ffeexpr_convert (expr, ft, ft,
12211                                   FFEINFO_basictypeINTEGER,
12212                                   FFEINFO_kindtypeINTEGERDEFAULT,
12213                                   0,
12214                                   FFETARGET_charactersizeNONE,
12215                                   FFEEXPR_contextLET);
12216 #else
12217           assert ("why hollerith/typeless in actualarg_?" == NULL);
12218 #endif
12219           break;
12220
12221         default:
12222           break;
12223         }
12224       switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12225         {
12226         case FFEBLD_opSYMTER:
12227         case FFEBLD_opPERCENT_LOC:
12228         case FFEBLD_opPERCENT_VAL:
12229         case FFEBLD_opPERCENT_REF:
12230         case FFEBLD_opPERCENT_DESCR:
12231           error = FALSE;
12232           break;
12233
12234         default:
12235           error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12236           break;
12237         }
12238       {
12239         ffesymbol s;
12240         ffeinfoWhere where;
12241         ffeinfoKind kind;
12242
12243         if (!error
12244             && (expr != NULL)
12245             && (ffebld_op (expr) == FFEBLD_opSYMTER)
12246             && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12247                 (where == FFEINFO_whereINTRINSIC)
12248                 || (where == FFEINFO_whereGLOBAL)
12249                 || ((where == FFEINFO_whereDUMMY)
12250                     && ((kind = ffesymbol_kind (s)),
12251                         (kind == FFEINFO_kindFUNCTION)
12252                         || (kind == FFEINFO_kindSUBROUTINE))))
12253             && !ffesymbol_explicitwhere (s))
12254           {
12255             ffebad_start (where == FFEINFO_whereINTRINSIC
12256                           ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12257             ffebad_here (0, ffelex_token_where_line (ft),
12258                          ffelex_token_where_column (ft));
12259             ffebad_string (ffesymbol_text (s));
12260             ffebad_finish ();
12261             ffesymbol_signal_change (s);
12262             ffesymbol_set_explicitwhere (s, TRUE);
12263             ffesymbol_signal_unreported (s);
12264           }
12265       }
12266       break;
12267
12268     case FFEEXPR_contextINDEX_:
12269     case FFEEXPR_contextSFUNCDEFINDEX_:
12270       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12271         break;
12272       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12273               : ffeinfo_basictype (info))
12274         {
12275         case FFEINFO_basictypeNONE:
12276           error = FALSE;
12277           break;
12278
12279         case FFEINFO_basictypeLOGICAL:
12280           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12281              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12282                                   FFEEXPR_contextLET);
12283           /* Fall through. */
12284         case FFEINFO_basictypeREAL:
12285         case FFEINFO_basictypeCOMPLEX:
12286           if (ffe_is_pedantic ())
12287             {
12288               error = TRUE;
12289               break;
12290             }
12291           /* Fall through. */
12292         case FFEINFO_basictypeHOLLERITH:
12293         case FFEINFO_basictypeTYPELESS:
12294           error = FALSE;
12295           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12296              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12297                                   FFEEXPR_contextLET);
12298           break;
12299
12300         case FFEINFO_basictypeINTEGER:
12301           /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12302              unmolested.  Leave it to downstream to handle kinds.  */
12303           break;
12304
12305         default:
12306           error = TRUE;
12307           break;
12308         }
12309       break;                    /* expr==NULL ok for substring; element case
12310                                    caught by callback. */
12311
12312     case FFEEXPR_contextRETURN:
12313       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12314         break;
12315       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12316               : ffeinfo_basictype (info))
12317         {
12318         case FFEINFO_basictypeNONE:
12319           error = FALSE;
12320           break;
12321
12322         case FFEINFO_basictypeLOGICAL:
12323           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12324              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12325                                   FFEEXPR_contextLET);
12326           /* Fall through. */
12327         case FFEINFO_basictypeREAL:
12328         case FFEINFO_basictypeCOMPLEX:
12329           if (ffe_is_pedantic ())
12330             {
12331               error = TRUE;
12332               break;
12333             }
12334           /* Fall through. */
12335         case FFEINFO_basictypeINTEGER:
12336         case FFEINFO_basictypeHOLLERITH:
12337         case FFEINFO_basictypeTYPELESS:
12338           error = FALSE;
12339           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12340              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12341                                   FFEEXPR_contextLET);
12342           break;
12343
12344         default:
12345           error = TRUE;
12346           break;
12347         }
12348       break;
12349
12350     case FFEEXPR_contextDO:
12351       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12352         break;
12353       switch (ffeinfo_basictype (info))
12354         {
12355         case FFEINFO_basictypeLOGICAL:
12356           error = !ffe_is_ugly_logint ();
12357           if (!ffeexpr_stack_->is_rhs)
12358             break;              /* Don't convert lhs variable. */
12359           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12360                                   ffeinfo_kindtype (ffebld_info (expr)), 0,
12361                                   FFETARGET_charactersizeNONE,
12362                                   FFEEXPR_contextLET);
12363           break;
12364
12365         case FFEINFO_basictypeHOLLERITH:
12366         case FFEINFO_basictypeTYPELESS:
12367           if (!ffeexpr_stack_->is_rhs)
12368             {
12369               error = TRUE;
12370               break;            /* Don't convert lhs variable. */
12371             }
12372           break;
12373
12374         case FFEINFO_basictypeINTEGER:
12375         case FFEINFO_basictypeREAL:
12376           break;
12377
12378         default:
12379           error = TRUE;
12380           break;
12381         }
12382       if (!ffeexpr_stack_->is_rhs
12383           && (ffebld_op (expr) != FFEBLD_opSYMTER))
12384         error = TRUE;
12385       break;
12386
12387     case FFEEXPR_contextDOWHILE:
12388     case FFEEXPR_contextIF:
12389       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12390         break;
12391       switch (ffeinfo_basictype (info))
12392         {
12393         case FFEINFO_basictypeINTEGER:
12394           error = FALSE;
12395           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12396              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12397                                   FFEEXPR_contextLET);
12398           /* Fall through. */
12399         case FFEINFO_basictypeLOGICAL:
12400         case FFEINFO_basictypeHOLLERITH:
12401         case FFEINFO_basictypeTYPELESS:
12402           error = FALSE;
12403           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12404              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12405                                   FFEEXPR_contextLET);
12406           break;
12407
12408         default:
12409           error = TRUE;
12410           break;
12411         }
12412       break;
12413
12414     case FFEEXPR_contextASSIGN:
12415     case FFEEXPR_contextAGOTO:
12416       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12417               : ffeinfo_basictype (info))
12418         {
12419         case FFEINFO_basictypeINTEGER:
12420           error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12421           break;
12422
12423         case FFEINFO_basictypeLOGICAL:
12424           error = !ffe_is_ugly_logint ()
12425             || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12426           break;
12427
12428         default:
12429           error = TRUE;
12430           break;
12431         }
12432       if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12433           || (ffebld_op (expr) != FFEBLD_opSYMTER))
12434         error = TRUE;
12435       break;
12436
12437     case FFEEXPR_contextCGOTO:
12438     case FFEEXPR_contextFORMAT:
12439     case FFEEXPR_contextDIMLIST:
12440     case FFEEXPR_contextFILENUM:        /* See equiv code in _ambig_. */
12441       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12442         break;
12443       switch (ffeinfo_basictype (info))
12444         {
12445         case FFEINFO_basictypeLOGICAL:
12446           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12447              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12448                                   FFEEXPR_contextLET);
12449           /* Fall through. */
12450         case FFEINFO_basictypeREAL:
12451         case FFEINFO_basictypeCOMPLEX:
12452           if (ffe_is_pedantic ())
12453             {
12454               error = TRUE;
12455               break;
12456             }
12457           /* Fall through. */
12458         case FFEINFO_basictypeINTEGER:
12459         case FFEINFO_basictypeHOLLERITH:
12460         case FFEINFO_basictypeTYPELESS:
12461           error = FALSE;
12462           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12463              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12464                                   FFEEXPR_contextLET);
12465           break;
12466
12467         default:
12468           error = TRUE;
12469           break;
12470         }
12471       break;
12472
12473     case FFEEXPR_contextARITHIF:
12474       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12475         break;
12476       switch (ffeinfo_basictype (info))
12477         {
12478         case FFEINFO_basictypeLOGICAL:
12479           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12480              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12481                                   FFEEXPR_contextLET);
12482           if (ffe_is_pedantic ())
12483             {
12484               error = TRUE;
12485               break;
12486             }
12487           /* Fall through. */
12488         case FFEINFO_basictypeHOLLERITH:
12489         case FFEINFO_basictypeTYPELESS:
12490           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12491              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12492                                   FFEEXPR_contextLET);
12493           /* Fall through. */
12494         case FFEINFO_basictypeINTEGER:
12495         case FFEINFO_basictypeREAL:
12496           error = FALSE;
12497           break;
12498
12499         default:
12500           error = TRUE;
12501           break;
12502         }
12503       break;
12504
12505     case FFEEXPR_contextSTOP:
12506       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12507         break;
12508       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12509               : ffeinfo_basictype (info))
12510         {
12511         case FFEINFO_basictypeINTEGER:
12512           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12513           break;
12514
12515         case FFEINFO_basictypeCHARACTER:
12516           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12517           break;
12518
12519         case FFEINFO_basictypeHOLLERITH:
12520         case FFEINFO_basictypeTYPELESS:
12521           error = FALSE;
12522           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12523              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12524                                   FFEEXPR_contextLET);
12525           break;
12526
12527         case FFEINFO_basictypeNONE:
12528           error = FALSE;
12529           break;
12530
12531         default:
12532           error = TRUE;
12533           break;
12534         }
12535       if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12536                              || (ffebld_conter_orig (expr) != NULL)))
12537         error = TRUE;
12538       break;
12539
12540     case FFEEXPR_contextINCLUDE:
12541       error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12542         || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12543         || (ffebld_op (expr) != FFEBLD_opCONTER)
12544         || (ffebld_conter_orig (expr) != NULL);
12545       break;
12546
12547     case FFEEXPR_contextSELECTCASE:
12548       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12549         break;
12550       switch (ffeinfo_basictype (info))
12551         {
12552         case FFEINFO_basictypeINTEGER:
12553         case FFEINFO_basictypeCHARACTER:
12554         case FFEINFO_basictypeLOGICAL:
12555           error = FALSE;
12556           break;
12557
12558         case FFEINFO_basictypeHOLLERITH:
12559         case FFEINFO_basictypeTYPELESS:
12560           error = FALSE;
12561           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12562              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12563                                   FFEEXPR_contextLET);
12564           break;
12565
12566         default:
12567           error = TRUE;
12568           break;
12569         }
12570       break;
12571
12572     case FFEEXPR_contextCASE:
12573       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12574         break;
12575       switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12576               : ffeinfo_basictype (info))
12577         {
12578         case FFEINFO_basictypeINTEGER:
12579         case FFEINFO_basictypeCHARACTER:
12580         case FFEINFO_basictypeLOGICAL:
12581           error = FALSE;
12582           break;
12583
12584         case FFEINFO_basictypeHOLLERITH:
12585         case FFEINFO_basictypeTYPELESS:
12586           error = FALSE;
12587           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12588              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12589                                   FFEEXPR_contextLET);
12590           break;
12591
12592         default:
12593           error = TRUE;
12594           break;
12595         }
12596       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12597         error = TRUE;
12598       break;
12599
12600     case FFEEXPR_contextCHARACTERSIZE:
12601     case FFEEXPR_contextKINDTYPE:
12602     case FFEEXPR_contextDIMLISTCOMMON:
12603       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12604         break;
12605       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12606               : ffeinfo_basictype (info))
12607         {
12608         case FFEINFO_basictypeLOGICAL:
12609           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12610              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12611                                   FFEEXPR_contextLET);
12612           /* Fall through. */
12613         case FFEINFO_basictypeREAL:
12614         case FFEINFO_basictypeCOMPLEX:
12615           if (ffe_is_pedantic ())
12616             {
12617               error = TRUE;
12618               break;
12619             }
12620           /* Fall through. */
12621         case FFEINFO_basictypeINTEGER:
12622         case FFEINFO_basictypeHOLLERITH:
12623         case FFEINFO_basictypeTYPELESS:
12624           error = FALSE;
12625           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12626              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12627                                   FFEEXPR_contextLET);
12628           break;
12629
12630         default:
12631           error = TRUE;
12632           break;
12633         }
12634       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12635         error = TRUE;
12636       break;
12637
12638     case FFEEXPR_contextEQVINDEX_:
12639       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12640         break;
12641       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12642               : ffeinfo_basictype (info))
12643         {
12644         case FFEINFO_basictypeNONE:
12645           error = FALSE;
12646           break;
12647
12648         case FFEINFO_basictypeLOGICAL:
12649           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12650              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12651                                   FFEEXPR_contextLET);
12652           /* Fall through. */
12653         case FFEINFO_basictypeREAL:
12654         case FFEINFO_basictypeCOMPLEX:
12655           if (ffe_is_pedantic ())
12656             {
12657               error = TRUE;
12658               break;
12659             }
12660           /* Fall through. */
12661         case FFEINFO_basictypeINTEGER:
12662         case FFEINFO_basictypeHOLLERITH:
12663         case FFEINFO_basictypeTYPELESS:
12664           error = FALSE;
12665           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12666              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12667                                   FFEEXPR_contextLET);
12668           break;
12669
12670         default:
12671           error = TRUE;
12672           break;
12673         }
12674       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12675         error = TRUE;
12676       break;
12677
12678     case FFEEXPR_contextPARAMETER:
12679       if (ffeexpr_stack_->is_rhs)
12680         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12681           || (ffebld_op (expr) != FFEBLD_opCONTER);
12682       else
12683         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12684           || (ffebld_op (expr) != FFEBLD_opSYMTER);
12685       break;
12686
12687     case FFEEXPR_contextINDEXORACTUALARG_:
12688       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12689         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12690       else
12691         ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12692       goto again;               /* :::::::::::::::::::: */
12693
12694     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12695       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12696         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12697       else
12698         ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12699       goto again;               /* :::::::::::::::::::: */
12700
12701     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12702       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12703         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12704       else
12705         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12706       goto again;               /* :::::::::::::::::::: */
12707
12708     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12709       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12710         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12711       else
12712         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12713       goto again;               /* :::::::::::::::::::: */
12714
12715     case FFEEXPR_contextIMPDOCTRL_:
12716       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12717         break;
12718       if (!ffeexpr_stack_->is_rhs
12719           && (ffebld_op (expr) != FFEBLD_opSYMTER))
12720         error = TRUE;
12721       switch (ffeinfo_basictype (info))
12722         {
12723         case FFEINFO_basictypeLOGICAL:
12724           if (! ffe_is_ugly_logint ())
12725             error = TRUE;
12726           if (! ffeexpr_stack_->is_rhs)
12727             break;
12728           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12729                                   ffeinfo_kindtype (info), 0,
12730                                   FFETARGET_charactersizeNONE,
12731                                   FFEEXPR_contextLET);
12732           break;
12733
12734         case FFEINFO_basictypeINTEGER:
12735         case FFEINFO_basictypeHOLLERITH:
12736         case FFEINFO_basictypeTYPELESS:
12737           break;
12738
12739         case FFEINFO_basictypeREAL:
12740           if (!ffeexpr_stack_->is_rhs
12741               && ffe_is_warn_surprising ()
12742               && !error)
12743             {
12744               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
12745               ffebad_here (0, ffelex_token_where_line (ft),
12746                            ffelex_token_where_column (ft));
12747               ffebad_string (ffelex_token_text (ft));
12748               ffebad_finish ();
12749             }
12750           break;
12751
12752         default:
12753           error = TRUE;
12754           break;
12755         }
12756       break;
12757
12758     case FFEEXPR_contextDATAIMPDOCTRL_:
12759       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12760         break;
12761       if (ffeexpr_stack_->is_rhs)
12762         {
12763           if ((ffebld_op (expr) != FFEBLD_opCONTER)
12764               && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12765             error = TRUE;
12766         }
12767       else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12768                || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12769         error = TRUE;
12770       switch (ffeinfo_basictype (info))
12771         {
12772         case FFEINFO_basictypeLOGICAL:
12773           if (! ffeexpr_stack_->is_rhs)
12774             break;
12775           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12776                                   ffeinfo_kindtype (info), 0,
12777                                   FFETARGET_charactersizeNONE,
12778                                   FFEEXPR_contextLET);
12779           /* Fall through.  */
12780         case FFEINFO_basictypeINTEGER:
12781           if (ffeexpr_stack_->is_rhs
12782               && (ffeinfo_kindtype (ffebld_info (expr))
12783                   != FFEINFO_kindtypeINTEGERDEFAULT))
12784             expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12785                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
12786                                     FFETARGET_charactersizeNONE,
12787                                     FFEEXPR_contextLET);
12788           break;
12789
12790         case FFEINFO_basictypeHOLLERITH:
12791         case FFEINFO_basictypeTYPELESS:
12792           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12793              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12794                                   FFEEXPR_contextLET);
12795           break;
12796
12797         case FFEINFO_basictypeREAL:
12798           if (!ffeexpr_stack_->is_rhs
12799               && ffe_is_warn_surprising ()
12800               && !error)
12801             {
12802               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
12803               ffebad_here (0, ffelex_token_where_line (ft),
12804                            ffelex_token_where_column (ft));
12805               ffebad_string (ffelex_token_text (ft));
12806               ffebad_finish ();
12807             }
12808           break;
12809
12810         default:
12811           error = TRUE;
12812           break;
12813         }
12814       break;
12815
12816     case FFEEXPR_contextIMPDOITEM_:
12817       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12818         {
12819           ffeexpr_stack_->is_rhs = FALSE;
12820           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12821           goto again;           /* :::::::::::::::::::: */
12822         }
12823       /* Fall through. */
12824     case FFEEXPR_contextIOLIST:
12825     case FFEEXPR_contextFILEVXTCODE:
12826       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12827               : ffeinfo_basictype (info))
12828         {
12829         case FFEINFO_basictypeHOLLERITH:
12830         case FFEINFO_basictypeTYPELESS:
12831           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12832              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12833                                   FFEEXPR_contextLET);
12834           break;
12835
12836         default:
12837           break;
12838         }
12839       error = (expr == NULL)
12840         || ((ffeinfo_rank (info) != 0)
12841             && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12842                 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12843                 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12844                     == FFEBLD_opSTAR)));        /* Bad if null expr, or if
12845                                                    array that is not a SYMTER
12846                                                    (can't happen yet, I
12847                                                    think) or has a NULL or
12848                                                    STAR (assumed) array
12849                                                    size. */
12850       break;
12851
12852     case FFEEXPR_contextIMPDOITEMDF_:
12853       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12854         {
12855           ffeexpr_stack_->is_rhs = FALSE;
12856           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12857           goto again;           /* :::::::::::::::::::: */
12858         }
12859       /* Fall through. */
12860     case FFEEXPR_contextIOLISTDF:
12861       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12862               : ffeinfo_basictype (info))
12863         {
12864         case FFEINFO_basictypeHOLLERITH:
12865         case FFEINFO_basictypeTYPELESS:
12866           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12867              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12868                                   FFEEXPR_contextLET);
12869           break;
12870
12871         default:
12872           break;
12873         }
12874       error
12875         = (expr == NULL)
12876           || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12877               && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12878             || ((ffeinfo_rank (info) != 0)
12879                 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12880                     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12881                     || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12882                         == FFEBLD_opSTAR)));    /* Bad if null expr,
12883                                                    non-default-kindtype
12884                                                    character expr, or if
12885                                                    array that is not a SYMTER
12886                                                    (can't happen yet, I
12887                                                    think) or has a NULL or
12888                                                    STAR (assumed) array
12889                                                    size. */
12890       break;
12891
12892     case FFEEXPR_contextDATAIMPDOITEM_:
12893       error = (expr == NULL)
12894         || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12895         || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12896             && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12897       break;
12898
12899     case FFEEXPR_contextDATAIMPDOINDEX_:
12900       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12901         break;
12902       switch (ffeinfo_basictype (info))
12903         {
12904         case FFEINFO_basictypeLOGICAL:
12905           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12906              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12907                                   FFEEXPR_contextLET);
12908           /* Fall through. */
12909         case FFEINFO_basictypeREAL:
12910         case FFEINFO_basictypeCOMPLEX:
12911           if (ffe_is_pedantic ())
12912             {
12913               error = TRUE;
12914               break;
12915             }
12916           /* Fall through. */
12917         case FFEINFO_basictypeINTEGER:
12918         case FFEINFO_basictypeHOLLERITH:
12919         case FFEINFO_basictypeTYPELESS:
12920           error = FALSE;
12921           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12922              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12923                                   FFEEXPR_contextLET);
12924           break;
12925
12926         default:
12927           error = TRUE;
12928           break;
12929         }
12930       if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12931           && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12932         error = TRUE;
12933       break;
12934
12935     case FFEEXPR_contextDATA:
12936       if (expr == NULL)
12937         error = TRUE;
12938       else if (ffeexpr_stack_->is_rhs)
12939         error = (ffebld_op (expr) != FFEBLD_opCONTER);
12940       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12941         error = FALSE;
12942       else
12943         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12944       break;
12945
12946     case FFEEXPR_contextINITVAL:
12947       error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12948       break;
12949
12950     case FFEEXPR_contextEQUIVALENCE:
12951       if (expr == NULL)
12952         error = TRUE;
12953       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12954         error = FALSE;
12955       else
12956         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12957       break;
12958
12959     case FFEEXPR_contextFILEASSOC:
12960     case FFEEXPR_contextFILEINT:
12961       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12962               : ffeinfo_basictype (info))
12963         {
12964         case FFEINFO_basictypeINTEGER:
12965           /* Maybe this should be supported someday, but, right now,
12966              g77 can't generate a call to libf2c to write to an
12967              integer other than the default size.  */
12968           error = ((! ffeexpr_stack_->is_rhs)
12969                    && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12970           break;
12971
12972         default:
12973           error = TRUE;
12974           break;
12975         }
12976       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12977         error = TRUE;
12978       break;
12979
12980     case FFEEXPR_contextFILEDFINT:
12981       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12982               : ffeinfo_basictype (info))
12983         {
12984         case FFEINFO_basictypeINTEGER:
12985           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12986           break;
12987
12988         default:
12989           error = TRUE;
12990           break;
12991         }
12992       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12993         error = TRUE;
12994       break;
12995
12996     case FFEEXPR_contextFILELOG:
12997       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12998               : ffeinfo_basictype (info))
12999         {
13000         case FFEINFO_basictypeLOGICAL:
13001           error = FALSE;
13002           break;
13003
13004         default:
13005           error = TRUE;
13006           break;
13007         }
13008       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13009         error = TRUE;
13010       break;
13011
13012     case FFEEXPR_contextFILECHAR:
13013       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13014               : ffeinfo_basictype (info))
13015         {
13016         case FFEINFO_basictypeCHARACTER:
13017           error = FALSE;
13018           break;
13019
13020         default:
13021           error = TRUE;
13022           break;
13023         }
13024       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13025         error = TRUE;
13026       break;
13027
13028     case FFEEXPR_contextFILENUMCHAR:
13029       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13030         break;
13031       switch (ffeinfo_basictype (info))
13032         {
13033         case FFEINFO_basictypeLOGICAL:
13034           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13035              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13036                                   FFEEXPR_contextLET);
13037           /* Fall through. */
13038         case FFEINFO_basictypeREAL:
13039         case FFEINFO_basictypeCOMPLEX:
13040           if (ffe_is_pedantic ())
13041             {
13042               error = TRUE;
13043               break;
13044             }
13045           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13046              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13047                                   FFEEXPR_contextLET);
13048           break;
13049
13050         case FFEINFO_basictypeINTEGER:
13051         case FFEINFO_basictypeCHARACTER:
13052           error = FALSE;
13053           break;
13054
13055         default:
13056           error = TRUE;
13057           break;
13058         }
13059       break;
13060
13061     case FFEEXPR_contextFILEDFCHAR:
13062       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13063         break;
13064       switch (ffeinfo_basictype (info))
13065         {
13066         case FFEINFO_basictypeCHARACTER:
13067           error
13068             = (ffeinfo_kindtype (info)
13069                != FFEINFO_kindtypeCHARACTERDEFAULT);
13070           break;
13071
13072         default:
13073           error = TRUE;
13074           break;
13075         }
13076       if (!ffeexpr_stack_->is_rhs
13077           && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13078         error = TRUE;
13079       break;
13080
13081     case FFEEXPR_contextFILEUNIT:       /* See equiv code in _ambig_. */
13082       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13083               : ffeinfo_basictype (info))
13084         {
13085         case FFEINFO_basictypeLOGICAL:
13086           if ((error = (ffeinfo_rank (info) != 0)))
13087             break;
13088           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13089              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13090                                   FFEEXPR_contextLET);
13091           /* Fall through. */
13092         case FFEINFO_basictypeREAL:
13093         case FFEINFO_basictypeCOMPLEX:
13094           if ((error = (ffeinfo_rank (info) != 0)))
13095             break;
13096           if (ffe_is_pedantic ())
13097             {
13098               error = TRUE;
13099               break;
13100             }
13101           /* Fall through. */
13102         case FFEINFO_basictypeINTEGER:
13103         case FFEINFO_basictypeHOLLERITH:
13104         case FFEINFO_basictypeTYPELESS:
13105           if ((error = (ffeinfo_rank (info) != 0)))
13106             break;
13107           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13108              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13109                                   FFEEXPR_contextLET);
13110           break;
13111
13112         case FFEINFO_basictypeCHARACTER:
13113           switch (ffebld_op (expr))
13114             {                   /* As if _lhs had been called instead of
13115                                    _rhs. */
13116             case FFEBLD_opSYMTER:
13117               error
13118                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13119               break;
13120
13121             case FFEBLD_opSUBSTR:
13122               error = (ffeinfo_where (ffebld_info (expr))
13123                        == FFEINFO_whereCONSTANT_SUBOBJECT);
13124               break;
13125
13126             case FFEBLD_opARRAYREF:
13127               error = FALSE;
13128               break;
13129
13130             default:
13131               error = TRUE;
13132               break;
13133             }
13134           if (!error
13135            && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13136                || ((ffeinfo_rank (info) != 0)
13137                    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13138                      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13139                   || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13140                       == FFEBLD_opSTAR)))))     /* Bad if
13141                                                    non-default-kindtype
13142                                                    character expr, or if
13143                                                    array that is not a SYMTER
13144                                                    (can't happen yet, I
13145                                                    think), or has a NULL or
13146                                                    STAR (assumed) array
13147                                                    size. */
13148             error = TRUE;
13149           break;
13150
13151         default:
13152           error = TRUE;
13153           break;
13154         }
13155       break;
13156
13157     case FFEEXPR_contextFILEFORMAT:
13158       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13159               : ffeinfo_basictype (info))
13160         {
13161         case FFEINFO_basictypeINTEGER:
13162           error = (expr == NULL)
13163             || ((ffeinfo_rank (info) != 0) ?
13164                 ffe_is_pedantic ()      /* F77 C5. */
13165                 : (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13166             || (ffebld_op (expr) != FFEBLD_opSYMTER);
13167           break;
13168
13169         case FFEINFO_basictypeLOGICAL:
13170         case FFEINFO_basictypeREAL:
13171         case FFEINFO_basictypeCOMPLEX:
13172           /* F77 C5 -- must be an array of hollerith.  */
13173           error
13174             = ffe_is_pedantic ()
13175               || (ffeinfo_rank (info) == 0);
13176           break;
13177
13178         case FFEINFO_basictypeCHARACTER:
13179           if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13180               || ((ffeinfo_rank (info) != 0)
13181                   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13182                       || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13183                       || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13184                           == FFEBLD_opSTAR))))  /* Bad if
13185                                                    non-default-kindtype
13186                                                    character expr, or if
13187                                                    array that is not a SYMTER
13188                                                    (can't happen yet, I
13189                                                    think), or has a NULL or
13190                                                    STAR (assumed) array
13191                                                    size. */
13192             error = TRUE;
13193           else
13194             error = FALSE;
13195           break;
13196
13197         default:
13198           error = TRUE;
13199           break;
13200         }
13201       break;
13202
13203     case FFEEXPR_contextLOC_:
13204       /* See also ffeintrin_check_loc_.  */
13205       if ((expr == NULL)
13206           || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13207           || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13208               && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13209               && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13210         error = TRUE;
13211       break;
13212
13213     default:
13214       error = FALSE;
13215       break;
13216     }
13217
13218   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13219     {
13220       ffebad_start (FFEBAD_EXPR_WRONG);
13221       ffebad_here (0, ffelex_token_where_line (ft),
13222                    ffelex_token_where_column (ft));
13223       ffebad_finish ();
13224       expr = ffebld_new_any ();
13225       ffebld_set_info (expr, ffeinfo_new_any ());
13226     }
13227
13228   callback = ffeexpr_stack_->callback;
13229   s = ffeexpr_stack_->previous;
13230   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13231                   sizeof (*ffeexpr_stack_));
13232   ffeexpr_stack_ = s;
13233   next = (ffelexHandler) (*callback) (ft, expr, t);
13234   ffelex_token_kill (ft);
13235   return (ffelexHandler) next;
13236 }
13237
13238 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13239
13240    ffebld expr;
13241    expr = ffeexpr_finished_ambig_(expr);
13242
13243    Replicates a bit of ffeexpr_finished_'s task when in a context
13244    of UNIT or FORMAT.  */
13245
13246 static ffebld
13247 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13248 {
13249   ffeinfo info = ffebld_info (expr);
13250   bool error;
13251
13252   switch (ffeexpr_stack_->context)
13253     {
13254     case FFEEXPR_contextFILENUMAMBIG:   /* Same as FILENUM in _finished_. */
13255       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13256               : ffeinfo_basictype (info))
13257         {
13258         case FFEINFO_basictypeLOGICAL:
13259           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13260              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13261                                   FFEEXPR_contextLET);
13262           /* Fall through. */
13263         case FFEINFO_basictypeREAL:
13264         case FFEINFO_basictypeCOMPLEX:
13265           if (ffe_is_pedantic ())
13266             {
13267               error = TRUE;
13268               break;
13269             }
13270           /* Fall through. */
13271         case FFEINFO_basictypeINTEGER:
13272         case FFEINFO_basictypeHOLLERITH:
13273         case FFEINFO_basictypeTYPELESS:
13274           error = FALSE;
13275           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13276              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13277                                   FFEEXPR_contextLET);
13278           break;
13279
13280         default:
13281           error = TRUE;
13282           break;
13283         }
13284       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13285         error = TRUE;
13286       break;
13287
13288     case FFEEXPR_contextFILEUNITAMBIG:  /* Same as FILEUNIT in _finished_. */
13289       if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13290         {
13291           error = FALSE;
13292           break;
13293         }
13294       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13295               : ffeinfo_basictype (info))
13296         {
13297         case FFEINFO_basictypeLOGICAL:
13298           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13299              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13300                                   FFEEXPR_contextLET);
13301           /* Fall through. */
13302         case FFEINFO_basictypeREAL:
13303         case FFEINFO_basictypeCOMPLEX:
13304           if (ffe_is_pedantic ())
13305             {
13306               error = TRUE;
13307               break;
13308             }
13309           /* Fall through. */
13310         case FFEINFO_basictypeINTEGER:
13311         case FFEINFO_basictypeHOLLERITH:
13312         case FFEINFO_basictypeTYPELESS:
13313           error = (ffeinfo_rank (info) != 0);
13314           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13315              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13316                                   FFEEXPR_contextLET);
13317           break;
13318
13319         case FFEINFO_basictypeCHARACTER:
13320           switch (ffebld_op (expr))
13321             {                   /* As if _lhs had been called instead of
13322                                    _rhs. */
13323             case FFEBLD_opSYMTER:
13324               error
13325                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13326               break;
13327
13328             case FFEBLD_opSUBSTR:
13329               error = (ffeinfo_where (ffebld_info (expr))
13330                        == FFEINFO_whereCONSTANT_SUBOBJECT);
13331               break;
13332
13333             case FFEBLD_opARRAYREF:
13334               error = FALSE;
13335               break;
13336
13337             default:
13338               error = TRUE;
13339               break;
13340             }
13341           break;
13342
13343         default:
13344           error = TRUE;
13345           break;
13346         }
13347       break;
13348
13349     default:
13350       assert ("bad context" == NULL);
13351       error = TRUE;
13352       break;
13353     }
13354
13355   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13356     {
13357       ffebad_start (FFEBAD_EXPR_WRONG);
13358       ffebad_here (0, ffelex_token_where_line (ft),
13359                    ffelex_token_where_column (ft));
13360       ffebad_finish ();
13361       expr = ffebld_new_any ();
13362       ffebld_set_info (expr, ffeinfo_new_any ());
13363     }
13364
13365   return expr;
13366 }
13367
13368 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13369
13370    Return a pointer to this function to the lexer (ffelex), which will
13371    invoke it for the next token.
13372
13373    Basically a smaller version of _rhs_; keep them both in sync, of course.  */
13374
13375 static ffelexHandler
13376 ffeexpr_token_lhs_ (ffelexToken t)
13377 {
13378
13379   /* When changing the list of valid initial lhs tokens, check whether to
13380      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13381      READ (expr) <token> case -- it assumes it knows which tokens <token> can
13382      be to indicate an lhs (or implied DO), which right now is the set
13383      {NAME,OPEN_PAREN}.
13384
13385      This comment also appears in ffeexpr_token_first_lhs_. */
13386
13387   switch (ffelex_token_type (t))
13388     {
13389     case FFELEX_typeNAME:
13390     case FFELEX_typeNAMES:
13391       ffeexpr_tokens_[0] = ffelex_token_use (t);
13392       return (ffelexHandler) ffeexpr_token_name_lhs_;
13393
13394     default:
13395       return (ffelexHandler) ffeexpr_finished_ (t);
13396     }
13397 }
13398
13399 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13400
13401    Return a pointer to this function to the lexer (ffelex), which will
13402    invoke it for the next token.
13403
13404    The initial state and the post-binary-operator state are the same and
13405    both handled here, with the expression stack used to distinguish
13406    between them.  Binary operators are invalid here; unary operators,
13407    constants, subexpressions, and name references are valid.  */
13408
13409 static ffelexHandler
13410 ffeexpr_token_rhs_ (ffelexToken t)
13411 {
13412   ffeexprExpr_ e;
13413
13414   switch (ffelex_token_type (t))
13415     {
13416     case FFELEX_typeQUOTE:
13417       if (ffe_is_vxt ())
13418         {
13419           ffeexpr_tokens_[0] = ffelex_token_use (t);
13420           return (ffelexHandler) ffeexpr_token_quote_;
13421         }
13422       ffeexpr_tokens_[0] = ffelex_token_use (t);
13423       ffelex_set_expecting_hollerith (-1, '\"',
13424                                       ffelex_token_where_line (t),
13425                                       ffelex_token_where_column (t));
13426       /* Don't have to unset this one. */
13427       return (ffelexHandler) ffeexpr_token_apostrophe_;
13428
13429     case FFELEX_typeAPOSTROPHE:
13430       ffeexpr_tokens_[0] = ffelex_token_use (t);
13431       ffelex_set_expecting_hollerith (-1, '\'',
13432                                       ffelex_token_where_line (t),
13433                                       ffelex_token_where_column (t));
13434       /* Don't have to unset this one. */
13435       return (ffelexHandler) ffeexpr_token_apostrophe_;
13436
13437     case FFELEX_typePERCENT:
13438       ffeexpr_tokens_[0] = ffelex_token_use (t);
13439       return (ffelexHandler) ffeexpr_token_percent_;
13440
13441     case FFELEX_typeOPEN_PAREN:
13442       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13443       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13444                                           FFEEXPR_contextPAREN_,
13445                                           ffeexpr_cb_close_paren_c_);
13446
13447     case FFELEX_typePLUS:
13448       e = ffeexpr_expr_new_ ();
13449       e->type = FFEEXPR_exprtypeUNARY_;
13450       e->token = ffelex_token_use (t);
13451       e->u.operator.op = FFEEXPR_operatorADD_;
13452       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13453       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13454       ffeexpr_exprstack_push_unary_ (e);
13455       return (ffelexHandler) ffeexpr_token_rhs_;
13456
13457     case FFELEX_typeMINUS:
13458       e = ffeexpr_expr_new_ ();
13459       e->type = FFEEXPR_exprtypeUNARY_;
13460       e->token = ffelex_token_use (t);
13461       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13462       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13463       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13464       ffeexpr_exprstack_push_unary_ (e);
13465       return (ffelexHandler) ffeexpr_token_rhs_;
13466
13467     case FFELEX_typePERIOD:
13468       ffeexpr_tokens_[0] = ffelex_token_use (t);
13469       return (ffelexHandler) ffeexpr_token_period_;
13470
13471     case FFELEX_typeNUMBER:
13472       ffeexpr_tokens_[0] = ffelex_token_use (t);
13473       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13474       if (ffeexpr_hollerith_count_ > 0)
13475         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13476                                         '\0',
13477                                         ffelex_token_where_line (t),
13478                                         ffelex_token_where_column (t));
13479       return (ffelexHandler) ffeexpr_token_number_;
13480
13481     case FFELEX_typeNAME:
13482     case FFELEX_typeNAMES:
13483       ffeexpr_tokens_[0] = ffelex_token_use (t);
13484       switch (ffeexpr_stack_->context)
13485         {
13486         case FFEEXPR_contextACTUALARG_:
13487         case FFEEXPR_contextINDEXORACTUALARG_:
13488         case FFEEXPR_contextSFUNCDEFACTUALARG_:
13489         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13490           return (ffelexHandler) ffeexpr_token_name_arg_;
13491
13492         default:
13493           return (ffelexHandler) ffeexpr_token_name_rhs_;
13494         }
13495
13496     case FFELEX_typeASTERISK:
13497     case FFELEX_typeSLASH:
13498     case FFELEX_typePOWER:
13499     case FFELEX_typeCONCAT:
13500     case FFELEX_typeREL_EQ:
13501     case FFELEX_typeREL_NE:
13502     case FFELEX_typeREL_LE:
13503     case FFELEX_typeREL_GE:
13504       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13505         {
13506           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13507           ffebad_finish ();
13508         }
13509       return (ffelexHandler) ffeexpr_token_rhs_;
13510
13511 #if 0
13512     case FFELEX_typeEQUALS:
13513     case FFELEX_typePOINTS:
13514     case FFELEX_typeCLOSE_ANGLE:
13515     case FFELEX_typeCLOSE_PAREN:
13516     case FFELEX_typeCOMMA:
13517     case FFELEX_typeCOLON:
13518     case FFELEX_typeEOS:
13519     case FFELEX_typeSEMICOLON:
13520 #endif
13521     default:
13522       return (ffelexHandler) ffeexpr_finished_ (t);
13523     }
13524 }
13525
13526 /* ffeexpr_token_period_ -- Rhs PERIOD
13527
13528    Return a pointer to this function to the lexer (ffelex), which will
13529    invoke it for the next token.
13530
13531    Handle a period detected at rhs (expecting unary op or operand) state.
13532    Must begin a floating-point value (as in .12) or a dot-dot name, of
13533    which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
13534    valid names represent binary operators, which are invalid here because
13535    there isn't an operand at the top of the stack.  */
13536
13537 static ffelexHandler
13538 ffeexpr_token_period_ (ffelexToken t)
13539 {
13540   switch (ffelex_token_type (t))
13541     {
13542     case FFELEX_typeNAME:
13543     case FFELEX_typeNAMES:
13544       ffeexpr_current_dotdot_ = ffestr_other (t);
13545       switch (ffeexpr_current_dotdot_)
13546         {
13547         case FFESTR_otherNone:
13548           if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13549             {
13550               ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13551                            ffelex_token_where_column (ffeexpr_tokens_[0]));
13552               ffebad_finish ();
13553             }
13554           ffelex_token_kill (ffeexpr_tokens_[0]);
13555           return (ffelexHandler) ffeexpr_token_rhs_ (t);
13556
13557         case FFESTR_otherTRUE:
13558         case FFESTR_otherFALSE:
13559         case FFESTR_otherNOT:
13560           ffeexpr_tokens_[1] = ffelex_token_use (t);
13561           return (ffelexHandler) ffeexpr_token_end_period_;
13562
13563         default:
13564           if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13565             {
13566               ffebad_here (0, ffelex_token_where_line (t),
13567                            ffelex_token_where_column (t));
13568               ffebad_finish ();
13569             }
13570           ffelex_token_kill (ffeexpr_tokens_[0]);
13571           return (ffelexHandler) ffeexpr_token_swallow_period_;
13572         }
13573       break;                    /* Nothing really reaches here. */
13574
13575     case FFELEX_typeNUMBER:
13576       ffeexpr_tokens_[1] = ffelex_token_use (t);
13577       return (ffelexHandler) ffeexpr_token_real_;
13578
13579     default:
13580       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13581         {
13582           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13583                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13584           ffebad_finish ();
13585         }
13586       ffelex_token_kill (ffeexpr_tokens_[0]);
13587       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13588     }
13589 }
13590
13591 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13592
13593    Return a pointer to this function to the lexer (ffelex), which will
13594    invoke it for the next token.
13595
13596    Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13597    or operator) state.  If period isn't found, issue a diagnostic but
13598    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
13599    dotdot representation of the name in between the two PERIOD tokens.  */
13600
13601 static ffelexHandler
13602 ffeexpr_token_end_period_ (ffelexToken t)
13603 {
13604   ffeexprExpr_ e;
13605
13606   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13607     {
13608       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13609         {
13610           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13611                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13612           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13613           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13614           ffebad_finish ();
13615         }
13616     }
13617
13618   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill "NOT"/"TRUE"/"FALSE"
13619                                                    token. */
13620
13621   e = ffeexpr_expr_new_ ();
13622   e->token = ffeexpr_tokens_[0];
13623
13624   switch (ffeexpr_current_dotdot_)
13625     {
13626     case FFESTR_otherNOT:
13627       e->type = FFEEXPR_exprtypeUNARY_;
13628       e->u.operator.op = FFEEXPR_operatorNOT_;
13629       e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13630       e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13631       ffeexpr_exprstack_push_unary_ (e);
13632       if (ffelex_token_type (t) != FFELEX_typePERIOD)
13633         return (ffelexHandler) ffeexpr_token_rhs_ (t);
13634       return (ffelexHandler) ffeexpr_token_rhs_;
13635
13636     case FFESTR_otherTRUE:
13637       e->type = FFEEXPR_exprtypeOPERAND_;
13638       e->u.operand
13639         = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13640       ffebld_set_info (e->u.operand,
13641       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13642                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13643       ffeexpr_exprstack_push_operand_ (e);
13644       if (ffelex_token_type (t) != FFELEX_typePERIOD)
13645         return (ffelexHandler) ffeexpr_token_binary_ (t);
13646       return (ffelexHandler) ffeexpr_token_binary_;
13647
13648     case FFESTR_otherFALSE:
13649       e->type = FFEEXPR_exprtypeOPERAND_;
13650       e->u.operand
13651         = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13652       ffebld_set_info (e->u.operand,
13653       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13654                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13655       ffeexpr_exprstack_push_operand_ (e);
13656       if (ffelex_token_type (t) != FFELEX_typePERIOD)
13657         return (ffelexHandler) ffeexpr_token_binary_ (t);
13658       return (ffelexHandler) ffeexpr_token_binary_;
13659
13660     default:
13661       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13662       exit (0);
13663       return NULL;
13664     }
13665 }
13666
13667 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13668
13669    Return a pointer to this function to the lexer (ffelex), which will
13670    invoke it for the next token.
13671
13672    A diagnostic has already been issued; just swallow a period if there is
13673    one, then continue with ffeexpr_token_rhs_.  */
13674
13675 static ffelexHandler
13676 ffeexpr_token_swallow_period_ (ffelexToken t)
13677 {
13678   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13679     return (ffelexHandler) ffeexpr_token_rhs_ (t);
13680
13681   return (ffelexHandler) ffeexpr_token_rhs_;
13682 }
13683
13684 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13685
13686    Return a pointer to this function to the lexer (ffelex), which will
13687    invoke it for the next token.
13688
13689    After a period and a string of digits, check next token for possible
13690    exponent designation (D, E, or Q as first/only character) and continue
13691    real-number handling accordingly.  Else form basic real constant, push
13692    onto expression stack, and enter binary state using current token (which,
13693    if it is a name not beginning with D, E, or Q, will certainly result
13694    in an error, but that's not for this routine to deal with).  */
13695
13696 static ffelexHandler
13697 ffeexpr_token_real_ (ffelexToken t)
13698 {
13699   char d;
13700   const char *p;
13701
13702   if (((ffelex_token_type (t) != FFELEX_typeNAME)
13703        && (ffelex_token_type (t) != FFELEX_typeNAMES))
13704       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13705                                      'D', 'd')
13706              || ffesrc_char_match_init (d, 'E', 'e')
13707              || ffesrc_char_match_init (d, 'Q', 'q')))
13708            && ffeexpr_isdigits_ (++p)))
13709     {
13710 #if 0
13711       /* This code has been removed because it seems inconsistent to
13712          produce a diagnostic in this case, but not all of the other
13713          ones that look for an exponent and cannot recognize one.  */
13714       if (((ffelex_token_type (t) == FFELEX_typeNAME)
13715            || (ffelex_token_type (t) == FFELEX_typeNAMES))
13716           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13717         {
13718           char bad[2];
13719
13720           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13721           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13722                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13723           bad[0] = *(p - 1);
13724           bad[1] = '\0';
13725           ffebad_string (bad);
13726           ffebad_finish ();
13727         }
13728 #endif
13729       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13730                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13731                                  NULL, NULL, NULL);
13732
13733       ffelex_token_kill (ffeexpr_tokens_[0]);
13734       ffelex_token_kill (ffeexpr_tokens_[1]);
13735       return (ffelexHandler) ffeexpr_token_binary_ (t);
13736     }
13737
13738   /* Just exponent character by itself?  In which case, PLUS or MINUS must
13739      surely be next, followed by a NUMBER token. */
13740
13741   if (*p == '\0')
13742     {
13743       ffeexpr_tokens_[2] = ffelex_token_use (t);
13744       return (ffelexHandler) ffeexpr_token_real_exponent_;
13745     }
13746
13747   ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13748                              t, NULL, NULL);
13749
13750   ffelex_token_kill (ffeexpr_tokens_[0]);
13751   ffelex_token_kill (ffeexpr_tokens_[1]);
13752   return (ffelexHandler) ffeexpr_token_binary_;
13753 }
13754
13755 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13756
13757    Return a pointer to this function to the lexer (ffelex), which will
13758    invoke it for the next token.
13759
13760    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13761    for real number (exponent digits).  Else issues diagnostic, assumes a
13762    zero exponent field for number, passes token on to binary state as if
13763    previous token had been "E0" instead of "E", for example.  */
13764
13765 static ffelexHandler
13766 ffeexpr_token_real_exponent_ (ffelexToken t)
13767 {
13768   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13769       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13770     {
13771       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13772         {
13773           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13774                        ffelex_token_where_column (ffeexpr_tokens_[2]));
13775           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13776           ffebad_finish ();
13777         }
13778
13779       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13780                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13781                                  NULL, NULL, NULL);
13782
13783       ffelex_token_kill (ffeexpr_tokens_[0]);
13784       ffelex_token_kill (ffeexpr_tokens_[1]);
13785       ffelex_token_kill (ffeexpr_tokens_[2]);
13786       return (ffelexHandler) ffeexpr_token_binary_ (t);
13787     }
13788
13789   ffeexpr_tokens_[3] = ffelex_token_use (t);
13790   return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13791 }
13792
13793 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13794
13795    Return a pointer to this function to the lexer (ffelex), which will
13796    invoke it for the next token.
13797
13798    Make sure token is a NUMBER, make a real constant out of all we have and
13799    push it onto the expression stack.  Else issue diagnostic and pretend
13800    exponent field was a zero.  */
13801
13802 static ffelexHandler
13803 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13804 {
13805   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13806     {
13807       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13808         {
13809           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13810                        ffelex_token_where_column (ffeexpr_tokens_[2]));
13811           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13812           ffebad_finish ();
13813         }
13814
13815       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13816                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13817                                  NULL, NULL, NULL);
13818
13819       ffelex_token_kill (ffeexpr_tokens_[0]);
13820       ffelex_token_kill (ffeexpr_tokens_[1]);
13821       ffelex_token_kill (ffeexpr_tokens_[2]);
13822       ffelex_token_kill (ffeexpr_tokens_[3]);
13823       return (ffelexHandler) ffeexpr_token_binary_ (t);
13824     }
13825
13826   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13827                  ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13828                              ffeexpr_tokens_[3], t);
13829
13830   ffelex_token_kill (ffeexpr_tokens_[0]);
13831   ffelex_token_kill (ffeexpr_tokens_[1]);
13832   ffelex_token_kill (ffeexpr_tokens_[2]);
13833   ffelex_token_kill (ffeexpr_tokens_[3]);
13834   return (ffelexHandler) ffeexpr_token_binary_;
13835 }
13836
13837 /* ffeexpr_token_number_ -- Rhs NUMBER
13838
13839    Return a pointer to this function to the lexer (ffelex), which will
13840    invoke it for the next token.
13841
13842    If the token is a period, we may have a floating-point number, or an
13843    integer followed by a dotdot binary operator.  If the token is a name
13844    beginning with D, E, or Q, we definitely have a floating-point number.
13845    If the token is a hollerith constant, that's what we've got, so push
13846    it onto the expression stack and continue with the binary state.
13847
13848    Otherwise, we have an integer followed by something the binary state
13849    should be able to swallow.  */
13850
13851 static ffelexHandler
13852 ffeexpr_token_number_ (ffelexToken t)
13853 {
13854   ffeexprExpr_ e;
13855   ffeinfo ni;
13856   char d;
13857   const char *p;
13858
13859   if (ffeexpr_hollerith_count_ > 0)
13860     ffelex_set_expecting_hollerith (0, '\0',
13861                                     ffewhere_line_unknown (),
13862                                     ffewhere_column_unknown ());
13863
13864   /* See if we've got a floating-point number here. */
13865
13866   switch (ffelex_token_type (t))
13867     {
13868     case FFELEX_typeNAME:
13869     case FFELEX_typeNAMES:
13870       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13871                                    'D', 'd')
13872            || ffesrc_char_match_init (d, 'E', 'e')
13873            || ffesrc_char_match_init (d, 'Q', 'q'))
13874           && ffeexpr_isdigits_ (++p))
13875         {
13876
13877           /* Just exponent character by itself?  In which case, PLUS or MINUS
13878              must surely be next, followed by a NUMBER token. */
13879
13880           if (*p == '\0')
13881             {
13882               ffeexpr_tokens_[1] = ffelex_token_use (t);
13883               return (ffelexHandler) ffeexpr_token_number_exponent_;
13884             }
13885           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13886                                      NULL, NULL);
13887
13888           ffelex_token_kill (ffeexpr_tokens_[0]);
13889           return (ffelexHandler) ffeexpr_token_binary_;
13890         }
13891       break;
13892
13893     case FFELEX_typePERIOD:
13894       ffeexpr_tokens_[1] = ffelex_token_use (t);
13895       return (ffelexHandler) ffeexpr_token_number_period_;
13896
13897     case FFELEX_typeHOLLERITH:
13898       e = ffeexpr_expr_new_ ();
13899       e->type = FFEEXPR_exprtypeOPERAND_;
13900       e->token = ffeexpr_tokens_[0];
13901       e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13902       ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13903                         0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13904                         ffelex_token_length (t));
13905       ffebld_set_info (e->u.operand, ni);
13906       ffeexpr_exprstack_push_operand_ (e);
13907       return (ffelexHandler) ffeexpr_token_binary_;
13908
13909     default:
13910       break;
13911     }
13912
13913   /* Nothing specific we were looking for, so make an integer and pass the
13914      current token to the binary state. */
13915
13916   ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13917                              NULL, NULL, NULL);
13918   return (ffelexHandler) ffeexpr_token_binary_ (t);
13919 }
13920
13921 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13922
13923    Return a pointer to this function to the lexer (ffelex), which will
13924    invoke it for the next token.
13925
13926    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13927    for real number (exponent digits).  Else treats number as integer, passes
13928    name to binary, passes current token to subsequent handler.  */
13929
13930 static ffelexHandler
13931 ffeexpr_token_number_exponent_ (ffelexToken t)
13932 {
13933   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13934       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13935     {
13936       ffeexprExpr_ e;
13937       ffelexHandler nexthandler;
13938
13939       e = ffeexpr_expr_new_ ();
13940       e->type = FFEEXPR_exprtypeOPERAND_;
13941       e->token = ffeexpr_tokens_[0];
13942       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13943                                         (ffeexpr_tokens_[0]));
13944       ffebld_set_info (e->u.operand,
13945       ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13946                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13947       ffeexpr_exprstack_push_operand_ (e);
13948       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13949       ffelex_token_kill (ffeexpr_tokens_[1]);
13950       return (ffelexHandler) (*nexthandler) (t);
13951     }
13952
13953   ffeexpr_tokens_[2] = ffelex_token_use (t);
13954   return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13955 }
13956
13957 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13958
13959    Return a pointer to this function to the lexer (ffelex), which will
13960    invoke it for the next token.
13961
13962    Make sure token is a NUMBER, make a real constant out of all we have and
13963    push it onto the expression stack.  Else issue diagnostic and pretend
13964    exponent field was a zero.  */
13965
13966 static ffelexHandler
13967 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13968 {
13969   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13970     {
13971       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13972         {
13973           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13974                        ffelex_token_where_column (ffeexpr_tokens_[1]));
13975           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13976           ffebad_finish ();
13977         }
13978
13979       ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13980                                  ffeexpr_tokens_[0], NULL, NULL,
13981                                  ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13982                                  NULL);
13983
13984       ffelex_token_kill (ffeexpr_tokens_[0]);
13985       ffelex_token_kill (ffeexpr_tokens_[1]);
13986       ffelex_token_kill (ffeexpr_tokens_[2]);
13987       return (ffelexHandler) ffeexpr_token_binary_ (t);
13988     }
13989
13990   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13991                              ffeexpr_tokens_[0], NULL, NULL,
13992                              ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13993
13994   ffelex_token_kill (ffeexpr_tokens_[0]);
13995   ffelex_token_kill (ffeexpr_tokens_[1]);
13996   ffelex_token_kill (ffeexpr_tokens_[2]);
13997   return (ffelexHandler) ffeexpr_token_binary_;
13998 }
13999
14000 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14001
14002    Return a pointer to this function to the lexer (ffelex), which will
14003    invoke it for the next token.
14004
14005    Handle a period detected following a number at rhs state.  Must begin a
14006    floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
14007
14008 static ffelexHandler
14009 ffeexpr_token_number_period_ (ffelexToken t)
14010 {
14011   ffeexprExpr_ e;
14012   ffelexHandler nexthandler;
14013   const char *p;
14014   char d;
14015
14016   switch (ffelex_token_type (t))
14017     {
14018     case FFELEX_typeNAME:
14019     case FFELEX_typeNAMES:
14020       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14021                                    'D', 'd')
14022            || ffesrc_char_match_init (d, 'E', 'e')
14023            || ffesrc_char_match_init (d, 'Q', 'q'))
14024           && ffeexpr_isdigits_ (++p))
14025         {
14026
14027           /* Just exponent character by itself?  In which case, PLUS or MINUS
14028              must surely be next, followed by a NUMBER token. */
14029
14030           if (*p == '\0')
14031             {
14032               ffeexpr_tokens_[2] = ffelex_token_use (t);
14033               return (ffelexHandler) ffeexpr_token_number_per_exp_;
14034             }
14035           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14036                                      ffeexpr_tokens_[1], NULL, t, NULL,
14037                                      NULL);
14038
14039           ffelex_token_kill (ffeexpr_tokens_[0]);
14040           ffelex_token_kill (ffeexpr_tokens_[1]);
14041           return (ffelexHandler) ffeexpr_token_binary_;
14042         }
14043       /* A name not representing an exponent, so assume it will be something
14044          like EQ, make an integer from the number, pass the period to binary
14045          state and the current token to the resulting state. */
14046
14047       e = ffeexpr_expr_new_ ();
14048       e->type = FFEEXPR_exprtypeOPERAND_;
14049       e->token = ffeexpr_tokens_[0];
14050       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14051                                         (ffeexpr_tokens_[0]));
14052       ffebld_set_info (e->u.operand,
14053                        ffeinfo_new (FFEINFO_basictypeINTEGER,
14054                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
14055                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14056                                     FFETARGET_charactersizeNONE));
14057       ffeexpr_exprstack_push_operand_ (e);
14058       nexthandler = (ffelexHandler) ffeexpr_token_binary_
14059         (ffeexpr_tokens_[1]);
14060       ffelex_token_kill (ffeexpr_tokens_[1]);
14061       return (ffelexHandler) (*nexthandler) (t);
14062
14063     case FFELEX_typeNUMBER:
14064       ffeexpr_tokens_[2] = ffelex_token_use (t);
14065       return (ffelexHandler) ffeexpr_token_number_real_;
14066
14067     default:
14068       break;
14069     }
14070
14071   /* Nothing specific we were looking for, so make a real number and pass the
14072      period and then the current token to the binary state. */
14073
14074   ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14075                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14076                              NULL, NULL, NULL, NULL);
14077
14078   ffelex_token_kill (ffeexpr_tokens_[0]);
14079   ffelex_token_kill (ffeexpr_tokens_[1]);
14080   return (ffelexHandler) ffeexpr_token_binary_ (t);
14081 }
14082
14083 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14084
14085    Return a pointer to this function to the lexer (ffelex), which will
14086    invoke it for the next token.
14087
14088    Ensures this token is PLUS or MINUS, preserves it, goes to final state
14089    for real number (exponent digits).  Else treats number as real, passes
14090    name to binary, passes current token to subsequent handler.  */
14091
14092 static ffelexHandler
14093 ffeexpr_token_number_per_exp_ (ffelexToken t)
14094 {
14095   if ((ffelex_token_type (t) != FFELEX_typePLUS)
14096       && (ffelex_token_type (t) != FFELEX_typeMINUS))
14097     {
14098       ffelexHandler nexthandler;
14099
14100       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14101                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14102                                  NULL, NULL, NULL, NULL);
14103
14104       ffelex_token_kill (ffeexpr_tokens_[0]);
14105       ffelex_token_kill (ffeexpr_tokens_[1]);
14106       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14107       ffelex_token_kill (ffeexpr_tokens_[2]);
14108       return (ffelexHandler) (*nexthandler) (t);
14109     }
14110
14111   ffeexpr_tokens_[3] = ffelex_token_use (t);
14112   return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14113 }
14114
14115 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14116
14117    Return a pointer to this function to the lexer (ffelex), which will
14118    invoke it for the next token.
14119
14120    After a number, period, and number, check next token for possible
14121    exponent designation (D, E, or Q as first/only character) and continue
14122    real-number handling accordingly.  Else form basic real constant, push
14123    onto expression stack, and enter binary state using current token (which,
14124    if it is a name not beginning with D, E, or Q, will certainly result
14125    in an error, but that's not for this routine to deal with).  */
14126
14127 static ffelexHandler
14128 ffeexpr_token_number_real_ (ffelexToken t)
14129 {
14130   char d;
14131   const char *p;
14132
14133   if (((ffelex_token_type (t) != FFELEX_typeNAME)
14134        && (ffelex_token_type (t) != FFELEX_typeNAMES))
14135       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14136                                      'D', 'd')
14137              || ffesrc_char_match_init (d, 'E', 'e')
14138              || ffesrc_char_match_init (d, 'Q', 'q')))
14139            && ffeexpr_isdigits_ (++p)))
14140     {
14141 #if 0
14142       /* This code has been removed because it seems inconsistent to
14143          produce a diagnostic in this case, but not all of the other
14144          ones that look for an exponent and cannot recognize one.  */
14145       if (((ffelex_token_type (t) == FFELEX_typeNAME)
14146            || (ffelex_token_type (t) == FFELEX_typeNAMES))
14147           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14148         {
14149           char bad[2];
14150
14151           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14152           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14153                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14154           bad[0] = *(p - 1);
14155           bad[1] = '\0';
14156           ffebad_string (bad);
14157           ffebad_finish ();
14158         }
14159 #endif
14160       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14161                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14162                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
14163
14164       ffelex_token_kill (ffeexpr_tokens_[0]);
14165       ffelex_token_kill (ffeexpr_tokens_[1]);
14166       ffelex_token_kill (ffeexpr_tokens_[2]);
14167       return (ffelexHandler) ffeexpr_token_binary_ (t);
14168     }
14169
14170   /* Just exponent character by itself?  In which case, PLUS or MINUS must
14171      surely be next, followed by a NUMBER token. */
14172
14173   if (*p == '\0')
14174     {
14175       ffeexpr_tokens_[3] = ffelex_token_use (t);
14176       return (ffelexHandler) ffeexpr_token_number_real_exp_;
14177     }
14178
14179   ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14180                              ffeexpr_tokens_[2], t, NULL, NULL);
14181
14182   ffelex_token_kill (ffeexpr_tokens_[0]);
14183   ffelex_token_kill (ffeexpr_tokens_[1]);
14184   ffelex_token_kill (ffeexpr_tokens_[2]);
14185   return (ffelexHandler) ffeexpr_token_binary_;
14186 }
14187
14188 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14189
14190    Return a pointer to this function to the lexer (ffelex), which will
14191    invoke it for the next token.
14192
14193    Make sure token is a NUMBER, make a real constant out of all we have and
14194    push it onto the expression stack.  Else issue diagnostic and pretend
14195    exponent field was a zero.  */
14196
14197 static ffelexHandler
14198 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14199 {
14200   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14201     {
14202       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14203         {
14204           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14205                        ffelex_token_where_column (ffeexpr_tokens_[2]));
14206           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14207           ffebad_finish ();
14208         }
14209
14210       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14211                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14212                                  NULL, NULL, NULL, NULL);
14213
14214       ffelex_token_kill (ffeexpr_tokens_[0]);
14215       ffelex_token_kill (ffeexpr_tokens_[1]);
14216       ffelex_token_kill (ffeexpr_tokens_[2]);
14217       ffelex_token_kill (ffeexpr_tokens_[3]);
14218       return (ffelexHandler) ffeexpr_token_binary_ (t);
14219     }
14220
14221   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14222                              ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14223                              ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14224
14225   ffelex_token_kill (ffeexpr_tokens_[0]);
14226   ffelex_token_kill (ffeexpr_tokens_[1]);
14227   ffelex_token_kill (ffeexpr_tokens_[2]);
14228   ffelex_token_kill (ffeexpr_tokens_[3]);
14229   return (ffelexHandler) ffeexpr_token_binary_;
14230 }
14231
14232 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14233
14234    Return a pointer to this function to the lexer (ffelex), which will
14235    invoke it for the next token.
14236
14237    Ensures this token is PLUS or MINUS, preserves it, goes to final state
14238    for real number (exponent digits).  Else issues diagnostic, assumes a
14239    zero exponent field for number, passes token on to binary state as if
14240    previous token had been "E0" instead of "E", for example.  */
14241
14242 static ffelexHandler
14243 ffeexpr_token_number_real_exp_ (ffelexToken t)
14244 {
14245   if ((ffelex_token_type (t) != FFELEX_typePLUS)
14246       && (ffelex_token_type (t) != FFELEX_typeMINUS))
14247     {
14248       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14249         {
14250           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14251                        ffelex_token_where_column (ffeexpr_tokens_[3]));
14252           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14253           ffebad_finish ();
14254         }
14255
14256       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14257                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14258                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
14259
14260       ffelex_token_kill (ffeexpr_tokens_[0]);
14261       ffelex_token_kill (ffeexpr_tokens_[1]);
14262       ffelex_token_kill (ffeexpr_tokens_[2]);
14263       ffelex_token_kill (ffeexpr_tokens_[3]);
14264       return (ffelexHandler) ffeexpr_token_binary_ (t);
14265     }
14266
14267   ffeexpr_tokens_[4] = ffelex_token_use (t);
14268   return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14269 }
14270
14271 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14272                                   PLUS/MINUS
14273
14274    Return a pointer to this function to the lexer (ffelex), which will
14275    invoke it for the next token.
14276
14277    Make sure token is a NUMBER, make a real constant out of all we have and
14278    push it onto the expression stack.  Else issue diagnostic and pretend
14279    exponent field was a zero.  */
14280
14281 static ffelexHandler
14282 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14283 {
14284   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14285     {
14286       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14287         {
14288           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14289                        ffelex_token_where_column (ffeexpr_tokens_[3]));
14290           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14291           ffebad_finish ();
14292         }
14293
14294       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14295                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14296                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
14297
14298       ffelex_token_kill (ffeexpr_tokens_[0]);
14299       ffelex_token_kill (ffeexpr_tokens_[1]);
14300       ffelex_token_kill (ffeexpr_tokens_[2]);
14301       ffelex_token_kill (ffeexpr_tokens_[3]);
14302       ffelex_token_kill (ffeexpr_tokens_[4]);
14303       return (ffelexHandler) ffeexpr_token_binary_ (t);
14304     }
14305
14306   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14307                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14308                              ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14309                              ffeexpr_tokens_[4], t);
14310
14311   ffelex_token_kill (ffeexpr_tokens_[0]);
14312   ffelex_token_kill (ffeexpr_tokens_[1]);
14313   ffelex_token_kill (ffeexpr_tokens_[2]);
14314   ffelex_token_kill (ffeexpr_tokens_[3]);
14315   ffelex_token_kill (ffeexpr_tokens_[4]);
14316   return (ffelexHandler) ffeexpr_token_binary_;
14317 }
14318
14319 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14320
14321    Return a pointer to this function to the lexer (ffelex), which will
14322    invoke it for the next token.
14323
14324    The possibility of a binary operator is handled here, meaning the previous
14325    token was an operand.  */
14326
14327 static ffelexHandler
14328 ffeexpr_token_binary_ (ffelexToken t)
14329 {
14330   ffeexprExpr_ e;
14331
14332   if (!ffeexpr_stack_->is_rhs)
14333     return (ffelexHandler) ffeexpr_finished_ (t);       /* For now. */
14334
14335   switch (ffelex_token_type (t))
14336     {
14337     case FFELEX_typePLUS:
14338       e = ffeexpr_expr_new_ ();
14339       e->type = FFEEXPR_exprtypeBINARY_;
14340       e->token = ffelex_token_use (t);
14341       e->u.operator.op = FFEEXPR_operatorADD_;
14342       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14343       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14344       ffeexpr_exprstack_push_binary_ (e);
14345       return (ffelexHandler) ffeexpr_token_rhs_;
14346
14347     case FFELEX_typeMINUS:
14348       e = ffeexpr_expr_new_ ();
14349       e->type = FFEEXPR_exprtypeBINARY_;
14350       e->token = ffelex_token_use (t);
14351       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14352       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14353       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14354       ffeexpr_exprstack_push_binary_ (e);
14355       return (ffelexHandler) ffeexpr_token_rhs_;
14356
14357     case FFELEX_typeASTERISK:
14358       switch (ffeexpr_stack_->context)
14359         {
14360         case FFEEXPR_contextDATA:
14361           return (ffelexHandler) ffeexpr_finished_ (t);
14362
14363         default:
14364           break;
14365         }
14366       e = ffeexpr_expr_new_ ();
14367       e->type = FFEEXPR_exprtypeBINARY_;
14368       e->token = ffelex_token_use (t);
14369       e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14370       e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14371       e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14372       ffeexpr_exprstack_push_binary_ (e);
14373       return (ffelexHandler) ffeexpr_token_rhs_;
14374
14375     case FFELEX_typeSLASH:
14376       switch (ffeexpr_stack_->context)
14377         {
14378         case FFEEXPR_contextDATA:
14379           return (ffelexHandler) ffeexpr_finished_ (t);
14380
14381         default:
14382           break;
14383         }
14384       e = ffeexpr_expr_new_ ();
14385       e->type = FFEEXPR_exprtypeBINARY_;
14386       e->token = ffelex_token_use (t);
14387       e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14388       e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14389       e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14390       ffeexpr_exprstack_push_binary_ (e);
14391       return (ffelexHandler) ffeexpr_token_rhs_;
14392
14393     case FFELEX_typePOWER:
14394       e = ffeexpr_expr_new_ ();
14395       e->type = FFEEXPR_exprtypeBINARY_;
14396       e->token = ffelex_token_use (t);
14397       e->u.operator.op = FFEEXPR_operatorPOWER_;
14398       e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14399       e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14400       ffeexpr_exprstack_push_binary_ (e);
14401       return (ffelexHandler) ffeexpr_token_rhs_;
14402
14403     case FFELEX_typeCONCAT:
14404       e = ffeexpr_expr_new_ ();
14405       e->type = FFEEXPR_exprtypeBINARY_;
14406       e->token = ffelex_token_use (t);
14407       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14408       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14409       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14410       ffeexpr_exprstack_push_binary_ (e);
14411       return (ffelexHandler) ffeexpr_token_rhs_;
14412
14413     case FFELEX_typeOPEN_ANGLE:
14414       switch (ffeexpr_stack_->context)
14415         {
14416         case FFEEXPR_contextFORMAT:
14417           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14418           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14419           ffebad_finish ();
14420           break;
14421
14422         default:
14423           break;
14424         }
14425       e = ffeexpr_expr_new_ ();
14426       e->type = FFEEXPR_exprtypeBINARY_;
14427       e->token = ffelex_token_use (t);
14428       e->u.operator.op = FFEEXPR_operatorLT_;
14429       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14430       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14431       ffeexpr_exprstack_push_binary_ (e);
14432       return (ffelexHandler) ffeexpr_token_rhs_;
14433
14434     case FFELEX_typeCLOSE_ANGLE:
14435       switch (ffeexpr_stack_->context)
14436         {
14437         case FFEEXPR_contextFORMAT:
14438           return ffeexpr_finished_ (t);
14439
14440         default:
14441           break;
14442         }
14443       e = ffeexpr_expr_new_ ();
14444       e->type = FFEEXPR_exprtypeBINARY_;
14445       e->token = ffelex_token_use (t);
14446       e->u.operator.op = FFEEXPR_operatorGT_;
14447       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14448       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14449       ffeexpr_exprstack_push_binary_ (e);
14450       return (ffelexHandler) ffeexpr_token_rhs_;
14451
14452     case FFELEX_typeREL_EQ:
14453       switch (ffeexpr_stack_->context)
14454         {
14455         case FFEEXPR_contextFORMAT:
14456           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14457           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14458           ffebad_finish ();
14459           break;
14460
14461         default:
14462           break;
14463         }
14464       e = ffeexpr_expr_new_ ();
14465       e->type = FFEEXPR_exprtypeBINARY_;
14466       e->token = ffelex_token_use (t);
14467       e->u.operator.op = FFEEXPR_operatorEQ_;
14468       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14469       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14470       ffeexpr_exprstack_push_binary_ (e);
14471       return (ffelexHandler) ffeexpr_token_rhs_;
14472
14473     case FFELEX_typeREL_NE:
14474       switch (ffeexpr_stack_->context)
14475         {
14476         case FFEEXPR_contextFORMAT:
14477           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14478           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14479           ffebad_finish ();
14480           break;
14481
14482         default:
14483           break;
14484         }
14485       e = ffeexpr_expr_new_ ();
14486       e->type = FFEEXPR_exprtypeBINARY_;
14487       e->token = ffelex_token_use (t);
14488       e->u.operator.op = FFEEXPR_operatorNE_;
14489       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14490       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14491       ffeexpr_exprstack_push_binary_ (e);
14492       return (ffelexHandler) ffeexpr_token_rhs_;
14493
14494     case FFELEX_typeREL_LE:
14495       switch (ffeexpr_stack_->context)
14496         {
14497         case FFEEXPR_contextFORMAT:
14498           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14499           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14500           ffebad_finish ();
14501           break;
14502
14503         default:
14504           break;
14505         }
14506       e = ffeexpr_expr_new_ ();
14507       e->type = FFEEXPR_exprtypeBINARY_;
14508       e->token = ffelex_token_use (t);
14509       e->u.operator.op = FFEEXPR_operatorLE_;
14510       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14511       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14512       ffeexpr_exprstack_push_binary_ (e);
14513       return (ffelexHandler) ffeexpr_token_rhs_;
14514
14515     case FFELEX_typeREL_GE:
14516       switch (ffeexpr_stack_->context)
14517         {
14518         case FFEEXPR_contextFORMAT:
14519           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14520           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14521           ffebad_finish ();
14522           break;
14523
14524         default:
14525           break;
14526         }
14527       e = ffeexpr_expr_new_ ();
14528       e->type = FFEEXPR_exprtypeBINARY_;
14529       e->token = ffelex_token_use (t);
14530       e->u.operator.op = FFEEXPR_operatorGE_;
14531       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14532       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14533       ffeexpr_exprstack_push_binary_ (e);
14534       return (ffelexHandler) ffeexpr_token_rhs_;
14535
14536     case FFELEX_typePERIOD:
14537       ffeexpr_tokens_[0] = ffelex_token_use (t);
14538       return (ffelexHandler) ffeexpr_token_binary_period_;
14539
14540 #if 0
14541     case FFELEX_typeOPEN_PAREN:
14542     case FFELEX_typeCLOSE_PAREN:
14543     case FFELEX_typeEQUALS:
14544     case FFELEX_typePOINTS:
14545     case FFELEX_typeCOMMA:
14546     case FFELEX_typeCOLON:
14547     case FFELEX_typeEOS:
14548     case FFELEX_typeSEMICOLON:
14549     case FFELEX_typeNAME:
14550     case FFELEX_typeNAMES:
14551 #endif
14552     default:
14553       return (ffelexHandler) ffeexpr_finished_ (t);
14554     }
14555 }
14556
14557 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14558
14559    Return a pointer to this function to the lexer (ffelex), which will
14560    invoke it for the next token.
14561
14562    Handle a period detected at binary (expecting binary op or end) state.
14563    Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14564    valid.  */
14565
14566 static ffelexHandler
14567 ffeexpr_token_binary_period_ (ffelexToken t)
14568 {
14569   ffeexprExpr_ operand;
14570
14571   switch (ffelex_token_type (t))
14572     {
14573     case FFELEX_typeNAME:
14574     case FFELEX_typeNAMES:
14575       ffeexpr_current_dotdot_ = ffestr_other (t);
14576       switch (ffeexpr_current_dotdot_)
14577         {
14578         case FFESTR_otherTRUE:
14579         case FFESTR_otherFALSE:
14580         case FFESTR_otherNOT:
14581           if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14582             {
14583               operand = ffeexpr_stack_->exprstack;
14584               assert (operand != NULL);
14585               assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14586               ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14587               ffebad_here (1, ffelex_token_where_line (t),
14588                            ffelex_token_where_column (t));
14589               ffebad_finish ();
14590             }
14591           ffelex_token_kill (ffeexpr_tokens_[0]);
14592           return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14593
14594         default:
14595           ffeexpr_tokens_[1] = ffelex_token_use (t);
14596           return (ffelexHandler) ffeexpr_token_binary_end_per_;
14597         }
14598       break;                    /* Nothing really reaches here. */
14599
14600     default:
14601       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14602         {
14603           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14604                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14605           ffebad_finish ();
14606         }
14607       ffelex_token_kill (ffeexpr_tokens_[0]);
14608       return (ffelexHandler) ffeexpr_token_binary_ (t);
14609     }
14610 }
14611
14612 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14613
14614    Return a pointer to this function to the lexer (ffelex), which will
14615    invoke it for the next token.
14616
14617    Expecting a period to close a dot-dot at binary (binary op
14618    or operator) state.  If period isn't found, issue a diagnostic but
14619    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
14620    dotdot representation of the name in between the two PERIOD tokens.  */
14621
14622 static ffelexHandler
14623 ffeexpr_token_binary_end_per_ (ffelexToken t)
14624 {
14625   ffeexprExpr_ e;
14626
14627   e = ffeexpr_expr_new_ ();
14628   e->type = FFEEXPR_exprtypeBINARY_;
14629   e->token = ffeexpr_tokens_[0];
14630
14631   switch (ffeexpr_current_dotdot_)
14632     {
14633     case FFESTR_otherAND:
14634       e->u.operator.op = FFEEXPR_operatorAND_;
14635       e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14636       e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14637       break;
14638
14639     case FFESTR_otherOR:
14640       e->u.operator.op = FFEEXPR_operatorOR_;
14641       e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14642       e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14643       break;
14644
14645     case FFESTR_otherXOR:
14646       e->u.operator.op = FFEEXPR_operatorXOR_;
14647       e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14648       e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14649       break;
14650
14651     case FFESTR_otherEQV:
14652       e->u.operator.op = FFEEXPR_operatorEQV_;
14653       e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14654       e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14655       break;
14656
14657     case FFESTR_otherNEQV:
14658       e->u.operator.op = FFEEXPR_operatorNEQV_;
14659       e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14660       e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14661       break;
14662
14663     case FFESTR_otherLT:
14664       e->u.operator.op = FFEEXPR_operatorLT_;
14665       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14666       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14667       break;
14668
14669     case FFESTR_otherLE:
14670       e->u.operator.op = FFEEXPR_operatorLE_;
14671       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14672       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14673       break;
14674
14675     case FFESTR_otherEQ:
14676       e->u.operator.op = FFEEXPR_operatorEQ_;
14677       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14678       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14679       break;
14680
14681     case FFESTR_otherNE:
14682       e->u.operator.op = FFEEXPR_operatorNE_;
14683       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14684       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14685       break;
14686
14687     case FFESTR_otherGT:
14688       e->u.operator.op = FFEEXPR_operatorGT_;
14689       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14690       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14691       break;
14692
14693     case FFESTR_otherGE:
14694       e->u.operator.op = FFEEXPR_operatorGE_;
14695       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14696       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14697       break;
14698
14699     default:
14700       if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14701         {
14702           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14703                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14704           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14705           ffebad_finish ();
14706         }
14707       e->u.operator.op = FFEEXPR_operatorEQ_;
14708       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14709       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14710       break;
14711     }
14712
14713   ffeexpr_exprstack_push_binary_ (e);
14714
14715   if (ffelex_token_type (t) != FFELEX_typePERIOD)
14716     {
14717       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14718         {
14719           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14720                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14721           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14722           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14723           ffebad_finish ();
14724         }
14725       ffelex_token_kill (ffeexpr_tokens_[1]);   /* Kill dot-dot token. */
14726       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14727     }
14728
14729   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill dot-dot token. */
14730   return (ffelexHandler) ffeexpr_token_rhs_;
14731 }
14732
14733 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14734
14735    Return a pointer to this function to the lexer (ffelex), which will
14736    invoke it for the next token.
14737
14738    A diagnostic has already been issued; just swallow a period if there is
14739    one, then continue with ffeexpr_token_binary_.  */
14740
14741 static ffelexHandler
14742 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14743 {
14744   if (ffelex_token_type (t) != FFELEX_typePERIOD)
14745     return (ffelexHandler) ffeexpr_token_binary_ (t);
14746
14747   return (ffelexHandler) ffeexpr_token_binary_;
14748 }
14749
14750 /* ffeexpr_token_quote_ -- Rhs QUOTE
14751
14752    Return a pointer to this function to the lexer (ffelex), which will
14753    invoke it for the next token.
14754
14755    Expecting a NUMBER that we'll treat as an octal integer.  */
14756
14757 static ffelexHandler
14758 ffeexpr_token_quote_ (ffelexToken t)
14759 {
14760   ffeexprExpr_ e;
14761   ffebld anyexpr;
14762
14763   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14764     {
14765       if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14766         {
14767           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14768                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14769           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14770           ffebad_finish ();
14771         }
14772       ffelex_token_kill (ffeexpr_tokens_[0]);
14773       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14774     }
14775
14776   /* This is kind of a kludge to prevent any whining about magical numbers
14777      that start out as these octal integers, so "20000000000 (on a 32-bit
14778      2's-complement machine) by itself won't produce an error. */
14779
14780   anyexpr = ffebld_new_any ();
14781   ffebld_set_info (anyexpr, ffeinfo_new_any ());
14782
14783   e = ffeexpr_expr_new_ ();
14784   e->type = FFEEXPR_exprtypeOPERAND_;
14785   e->token = ffeexpr_tokens_[0];
14786   e->u.operand = ffebld_new_conter_with_orig
14787     (ffebld_constant_new_integeroctal (t), anyexpr);
14788   ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14789                       FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14790                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14791   ffeexpr_exprstack_push_operand_ (e);
14792   return (ffelexHandler) ffeexpr_token_binary_;
14793 }
14794
14795 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14796
14797    Return a pointer to this function to the lexer (ffelex), which will
14798    invoke it for the next token.
14799
14800    Handle an open-apostrophe, which begins either a character ('char-const'),
14801    typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14802    'hex-const'X) constant.  */
14803
14804 static ffelexHandler
14805 ffeexpr_token_apostrophe_ (ffelexToken t)
14806 {
14807   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14808   if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14809     {
14810       ffebad_start (FFEBAD_NULL_CHAR_CONST);
14811       ffebad_here (0, ffelex_token_where_line (t),
14812                    ffelex_token_where_column (t));
14813       ffebad_finish ();
14814     }
14815   ffeexpr_tokens_[1] = ffelex_token_use (t);
14816   return (ffelexHandler) ffeexpr_token_apos_char_;
14817 }
14818
14819 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14820
14821    Return a pointer to this function to the lexer (ffelex), which will
14822    invoke it for the next token.
14823
14824    Close-apostrophe is implicit; if this token is NAME, it is a possible
14825    typeless-constant radix specifier.  */
14826
14827 static ffelexHandler
14828 ffeexpr_token_apos_char_ (ffelexToken t)
14829 {
14830   ffeexprExpr_ e;
14831   ffeinfo ni;
14832   char c;
14833   ffetargetCharacterSize size;
14834
14835   if ((ffelex_token_type (t) == FFELEX_typeNAME)
14836       || (ffelex_token_type (t) == FFELEX_typeNAMES))
14837     {
14838       if ((ffelex_token_length (t) == 1)
14839           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14840                                       'b')
14841               || ffesrc_char_match_init (c, 'O', 'o')
14842               || ffesrc_char_match_init (c, 'X', 'x')
14843               || ffesrc_char_match_init (c, 'Z', 'z')))
14844         {
14845           e = ffeexpr_expr_new_ ();
14846           e->type = FFEEXPR_exprtypeOPERAND_;
14847           e->token = ffeexpr_tokens_[0];
14848           switch (c)
14849             {
14850             case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14851               e->u.operand = ffebld_new_conter
14852                 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14853               size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14854               break;
14855
14856             case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14857               e->u.operand = ffebld_new_conter
14858                 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14859               size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14860               break;
14861
14862             case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14863               e->u.operand = ffebld_new_conter
14864                 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14865               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14866               break;
14867
14868             case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14869               e->u.operand = ffebld_new_conter
14870                 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14871               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14872               break;
14873
14874             default:
14875             no_match:           /* :::::::::::::::::::: */
14876               assert ("not BOXZ!" == NULL);
14877               size = 0;
14878               break;
14879             }
14880           ffebld_set_info (e->u.operand,
14881                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14882                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14883           ffeexpr_exprstack_push_operand_ (e);
14884           ffelex_token_kill (ffeexpr_tokens_[1]);
14885           return (ffelexHandler) ffeexpr_token_binary_;
14886         }
14887     }
14888   e = ffeexpr_expr_new_ ();
14889   e->type = FFEEXPR_exprtypeOPERAND_;
14890   e->token = ffeexpr_tokens_[0];
14891   e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14892                                     (ffeexpr_tokens_[1]));
14893   ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14894                     0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14895                     ffelex_token_length (ffeexpr_tokens_[1]));
14896   ffebld_set_info (e->u.operand, ni);
14897   ffelex_token_kill (ffeexpr_tokens_[1]);
14898   ffeexpr_exprstack_push_operand_ (e);
14899   if ((ffelex_token_type (t) == FFELEX_typeNAME)
14900       || (ffelex_token_type (t) == FFELEX_typeNAMES))
14901     {
14902       if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14903         {
14904           ffebad_string (ffelex_token_text (t));
14905           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14906           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14907                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14908           ffebad_finish ();
14909         }
14910       e = ffeexpr_expr_new_ ();
14911       e->type = FFEEXPR_exprtypeBINARY_;
14912       e->token = ffelex_token_use (t);
14913       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14914       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14915       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14916       ffeexpr_exprstack_push_binary_ (e);
14917       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14918     }
14919   ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();   /* Allow "'hello'(3:5)". */
14920   return (ffelexHandler) ffeexpr_token_substrp_ (t);
14921 }
14922
14923 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14924
14925    Return a pointer to this function to the lexer (ffelex), which will
14926    invoke it for the next token.
14927
14928    Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14929    (RECORD%MEMBER), or nothing at all.  */
14930
14931 static ffelexHandler
14932 ffeexpr_token_name_lhs_ (ffelexToken t)
14933 {
14934   ffeexprExpr_ e;
14935   ffeexprParenType_ paren_type;
14936   ffesymbol s;
14937   ffebld expr;
14938   ffeinfo info;
14939
14940   switch (ffelex_token_type (t))
14941     {
14942     case FFELEX_typeOPEN_PAREN:
14943       switch (ffeexpr_stack_->context)
14944         {
14945         case FFEEXPR_contextASSIGN:
14946         case FFEEXPR_contextAGOTO:
14947         case FFEEXPR_contextFILEUNIT_DF:
14948           goto just_name;       /* :::::::::::::::::::: */
14949
14950         default:
14951           break;
14952         }
14953       e = ffeexpr_expr_new_ ();
14954       e->type = FFEEXPR_exprtypeOPERAND_;
14955       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14956       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14957                                           &paren_type);
14958
14959       switch (ffesymbol_where (s))
14960         {
14961         case FFEINFO_whereLOCAL:
14962           if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14963             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Recursion. */
14964           break;
14965
14966         case FFEINFO_whereINTRINSIC:
14967         case FFEINFO_whereGLOBAL:
14968           if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14969             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Can call intrin. */
14970           break;
14971
14972         case FFEINFO_whereCOMMON:
14973         case FFEINFO_whereDUMMY:
14974         case FFEINFO_whereRESULT:
14975           break;
14976
14977         case FFEINFO_whereNONE:
14978         case FFEINFO_whereANY:
14979           break;
14980
14981         default:
14982           ffesymbol_error (s, ffeexpr_tokens_[0]);
14983           break;
14984         }
14985
14986       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14987         {
14988           e->u.operand = ffebld_new_any ();
14989           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14990         }
14991       else
14992         {
14993           e->u.operand = ffebld_new_symter (s,
14994                                             ffesymbol_generic (s),
14995                                             ffesymbol_specific (s),
14996                                             ffesymbol_implementation (s));
14997           ffebld_set_info (e->u.operand, ffesymbol_info (s));
14998         }
14999       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
15000       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15001       switch (paren_type)
15002         {
15003         case FFEEXPR_parentypeSUBROUTINE_:
15004           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15005           return
15006             (ffelexHandler)
15007             ffeexpr_rhs (ffeexpr_stack_->pool,
15008                          FFEEXPR_contextACTUALARG_,
15009                          ffeexpr_token_arguments_);
15010
15011         case FFEEXPR_parentypeARRAY_:
15012           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15013           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15014           ffeexpr_stack_->rank = 0;
15015           ffeexpr_stack_->constant = TRUE;
15016           ffeexpr_stack_->immediate = TRUE;
15017           switch (ffeexpr_stack_->context)
15018             {
15019             case FFEEXPR_contextDATAIMPDOITEM_:
15020               return
15021                 (ffelexHandler)
15022                 ffeexpr_rhs (ffeexpr_stack_->pool,
15023                              FFEEXPR_contextDATAIMPDOINDEX_,
15024                              ffeexpr_token_elements_);
15025
15026             case FFEEXPR_contextEQUIVALENCE:
15027               return
15028                 (ffelexHandler)
15029                 ffeexpr_rhs (ffeexpr_stack_->pool,
15030                              FFEEXPR_contextEQVINDEX_,
15031                              ffeexpr_token_elements_);
15032
15033             default:
15034               return
15035                 (ffelexHandler)
15036                 ffeexpr_rhs (ffeexpr_stack_->pool,
15037                              FFEEXPR_contextINDEX_,
15038                              ffeexpr_token_elements_);
15039             }
15040
15041         case FFEEXPR_parentypeSUBSTRING_:
15042           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15043                                                   ffeexpr_tokens_[0]);
15044           return
15045             (ffelexHandler)
15046             ffeexpr_rhs (ffeexpr_stack_->pool,
15047                          FFEEXPR_contextINDEX_,
15048                          ffeexpr_token_substring_);
15049
15050         case FFEEXPR_parentypeEQUIVALENCE_:
15051           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15052           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15053           ffeexpr_stack_->rank = 0;
15054           ffeexpr_stack_->constant = TRUE;
15055           ffeexpr_stack_->immediate = TRUE;
15056           return
15057             (ffelexHandler)
15058             ffeexpr_rhs (ffeexpr_stack_->pool,
15059                          FFEEXPR_contextEQVINDEX_,
15060                          ffeexpr_token_equivalence_);
15061
15062         case FFEEXPR_parentypeFUNCTION_:        /* Invalid case. */
15063         case FFEEXPR_parentypeFUNSUBSTR_:       /* Invalid case. */
15064           ffesymbol_error (s, ffeexpr_tokens_[0]);
15065           /* Fall through. */
15066         case FFEEXPR_parentypeANY_:
15067           e->u.operand = ffebld_new_any ();
15068           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15069           return
15070             (ffelexHandler)
15071             ffeexpr_rhs (ffeexpr_stack_->pool,
15072                          FFEEXPR_contextACTUALARG_,
15073                          ffeexpr_token_anything_);
15074
15075         default:
15076           assert ("bad paren type" == NULL);
15077           break;
15078         }
15079
15080     case FFELEX_typeEQUALS:     /* As in "VAR=". */
15081       switch (ffeexpr_stack_->context)
15082         {
15083         case FFEEXPR_contextIMPDOITEM_: /* within
15084                                                    "(,VAR=start,end[,incr])". */
15085         case FFEEXPR_contextIMPDOITEMDF_:
15086           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15087           break;
15088
15089         case FFEEXPR_contextDATAIMPDOITEM_:
15090           ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15091           break;
15092
15093         default:
15094           break;
15095         }
15096       break;
15097
15098 #if 0
15099     case FFELEX_typePERIOD:
15100     case FFELEX_typePERCENT:
15101       assert ("FOO%, FOO. not yet supported!~~" == NULL);
15102       break;
15103 #endif
15104
15105     default:
15106       break;
15107     }
15108
15109 just_name:                      /* :::::::::::::::::::: */
15110   e = ffeexpr_expr_new_ ();
15111   e->type = FFEEXPR_exprtypeOPERAND_;
15112   e->token = ffeexpr_tokens_[0];
15113   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15114                                   (ffeexpr_stack_->context
15115                                    == FFEEXPR_contextSUBROUTINEREF));
15116
15117   switch (ffesymbol_where (s))
15118     {
15119     case FFEINFO_whereCONSTANT:
15120       if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15121           || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15122         ffesymbol_error (s, ffeexpr_tokens_[0]);
15123       break;
15124
15125     case FFEINFO_whereIMMEDIATE:
15126       if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15127           && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15128         ffesymbol_error (s, ffeexpr_tokens_[0]);
15129       break;
15130
15131     case FFEINFO_whereLOCAL:
15132       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15133         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Recurse!. */
15134       break;
15135
15136     case FFEINFO_whereINTRINSIC:
15137       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15138         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Can call intrin. */
15139       break;
15140
15141     default:
15142       break;
15143     }
15144
15145   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15146     {
15147       expr = ffebld_new_any ();
15148       info = ffeinfo_new_any ();
15149       ffebld_set_info (expr, info);
15150     }
15151   else
15152     {
15153       expr = ffebld_new_symter (s,
15154                                 ffesymbol_generic (s),
15155                                 ffesymbol_specific (s),
15156                                 ffesymbol_implementation (s));
15157       info = ffesymbol_info (s);
15158       ffebld_set_info (expr, info);
15159       if (ffesymbol_is_doiter (s))
15160         {
15161           ffebad_start (FFEBAD_DOITER);
15162           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15163                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15164           ffest_ffebad_here_doiter (1, s);
15165           ffebad_string (ffesymbol_text (s));
15166           ffebad_finish ();
15167         }
15168       expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15169     }
15170
15171   if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15172     {
15173       if (ffebld_op (expr) == FFEBLD_opANY)
15174         {
15175           expr = ffebld_new_any ();
15176           ffebld_set_info (expr, ffeinfo_new_any ());
15177         }
15178       else
15179         {
15180           expr = ffebld_new_subrref (expr, NULL);       /* No argument list. */
15181           if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15182             ffeintrin_fulfill_generic (&expr, &info, e->token);
15183           else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15184             ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15185           else
15186             ffeexpr_fulfill_call_ (&expr, e->token);
15187
15188           if (ffebld_op (expr) != FFEBLD_opANY)
15189             ffebld_set_info (expr,
15190                              ffeinfo_new (ffeinfo_basictype (info),
15191                                           ffeinfo_kindtype (info),
15192                                           0,
15193                                           FFEINFO_kindENTITY,
15194                                           FFEINFO_whereFLEETING,
15195                                           ffeinfo_size (info)));
15196           else
15197             ffebld_set_info (expr, ffeinfo_new_any ());
15198         }
15199     }
15200
15201   e->u.operand = expr;
15202   ffeexpr_exprstack_push_operand_ (e);
15203   return (ffelexHandler) ffeexpr_finished_ (t);
15204 }
15205
15206 /* ffeexpr_token_name_arg_ -- Rhs NAME
15207
15208    Return a pointer to this function to the lexer (ffelex), which will
15209    invoke it for the next token.
15210
15211    Handle first token in an actual-arg (or possible actual-arg) context
15212    being a NAME, and use second token to refine the context.  */
15213
15214 static ffelexHandler
15215 ffeexpr_token_name_arg_ (ffelexToken t)
15216 {
15217   switch (ffelex_token_type (t))
15218     {
15219     case FFELEX_typeCLOSE_PAREN:
15220     case FFELEX_typeCOMMA:
15221       switch (ffeexpr_stack_->context)
15222         {
15223         case FFEEXPR_contextINDEXORACTUALARG_:
15224           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15225           break;
15226
15227         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15228           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15229           break;
15230
15231         default:
15232           break;
15233         }
15234       break;
15235
15236     default:
15237       switch (ffeexpr_stack_->context)
15238         {
15239         case FFEEXPR_contextACTUALARG_:
15240           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15241           break;
15242
15243         case FFEEXPR_contextINDEXORACTUALARG_:
15244           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15245           break;
15246
15247         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15248           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15249           break;
15250
15251         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15252           ffeexpr_stack_->context
15253             = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15254           break;
15255
15256         default:
15257           assert ("bad context in _name_arg_" == NULL);
15258           break;
15259         }
15260       break;
15261     }
15262
15263   return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15264 }
15265
15266 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15267
15268    Return a pointer to this function to the lexer (ffelex), which will
15269    invoke it for the next token.
15270
15271    Handle a name followed by open-paren, apostrophe (O'octal-const',
15272    Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15273
15274    26-Nov-91  JCB  1.2
15275       When followed by apostrophe or quote, set lex hexnum flag on so
15276       [0-9] as first char of next token seen as starting a potentially
15277       hex number (NAME).
15278    04-Oct-91  JCB  1.1
15279       In case of intrinsic, decorate its SYMTER with the type info for
15280       the specific intrinsic.  */
15281
15282 static ffelexHandler
15283 ffeexpr_token_name_rhs_ (ffelexToken t)
15284 {
15285   ffeexprExpr_ e;
15286   ffeexprParenType_ paren_type;
15287   ffesymbol s;
15288   bool sfdef;
15289
15290   switch (ffelex_token_type (t))
15291     {
15292     case FFELEX_typeQUOTE:
15293     case FFELEX_typeAPOSTROPHE:
15294       ffeexpr_tokens_[1] = ffelex_token_use (t);
15295       ffelex_set_hexnum (TRUE);
15296       return (ffelexHandler) ffeexpr_token_name_apos_;
15297
15298     case FFELEX_typeOPEN_PAREN:
15299       e = ffeexpr_expr_new_ ();
15300       e->type = FFEEXPR_exprtypeOPERAND_;
15301       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15302       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15303                                           &paren_type);
15304       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15305         e->u.operand = ffebld_new_any ();
15306       else
15307         e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15308                                           ffesymbol_specific (s),
15309                                           ffesymbol_implementation (s));
15310       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
15311       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15312       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15313         {
15314         case FFEEXPR_contextSFUNCDEF:
15315         case FFEEXPR_contextSFUNCDEFINDEX_:
15316         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15317         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15318           sfdef = TRUE;
15319           break;
15320
15321         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15322         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15323           assert ("weird context!" == NULL);
15324           sfdef = FALSE;
15325           break;
15326
15327         default:
15328           sfdef = FALSE;
15329           break;
15330         }
15331       switch (paren_type)
15332         {
15333         case FFEEXPR_parentypeFUNCTION_:
15334           ffebld_set_info (e->u.operand, ffesymbol_info (s));
15335           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15336           if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15337             {                   /* A statement function. */
15338               ffeexpr_stack_->num_args
15339                 = ffebld_list_length
15340                   (ffeexpr_stack_->next_dummy
15341                    = ffesymbol_dummyargs (s));
15342               ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15343             }
15344           else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15345                    && !ffe_is_pedantic_not_90 ()
15346                    && ((ffesymbol_implementation (s)
15347                         == FFEINTRIN_impICHAR)
15348                        || (ffesymbol_implementation (s)
15349                            == FFEINTRIN_impIACHAR)
15350                        || (ffesymbol_implementation (s)
15351                            == FFEINTRIN_impLEN)))
15352             {                   /* Allow arbitrary concatenations. */
15353               return
15354                 (ffelexHandler)
15355                   ffeexpr_rhs (ffeexpr_stack_->pool,
15356                                sfdef
15357                                ? FFEEXPR_contextSFUNCDEF
15358                                : FFEEXPR_contextLET,
15359                                ffeexpr_token_arguments_);
15360             }
15361           return
15362             (ffelexHandler)
15363             ffeexpr_rhs (ffeexpr_stack_->pool,
15364                          sfdef
15365                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
15366                          : FFEEXPR_contextACTUALARG_,
15367                          ffeexpr_token_arguments_);
15368
15369         case FFEEXPR_parentypeARRAY_:
15370           ffebld_set_info (e->u.operand,
15371                            ffesymbol_info (ffebld_symter (e->u.operand)));
15372           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15373           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15374           ffeexpr_stack_->rank = 0;
15375           ffeexpr_stack_->constant = TRUE;
15376           ffeexpr_stack_->immediate = TRUE;
15377           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15378                                               sfdef
15379                                               ? FFEEXPR_contextSFUNCDEFINDEX_
15380                                               : FFEEXPR_contextINDEX_,
15381                                               ffeexpr_token_elements_);
15382
15383         case FFEEXPR_parentypeSUBSTRING_:
15384           ffebld_set_info (e->u.operand,
15385                            ffesymbol_info (ffebld_symter (e->u.operand)));
15386           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15387                                                   ffeexpr_tokens_[0]);
15388           return
15389             (ffelexHandler)
15390             ffeexpr_rhs (ffeexpr_stack_->pool,
15391                          sfdef
15392                          ? FFEEXPR_contextSFUNCDEFINDEX_
15393                          : FFEEXPR_contextINDEX_,
15394                          ffeexpr_token_substring_);
15395
15396         case FFEEXPR_parentypeFUNSUBSTR_:
15397           return
15398             (ffelexHandler)
15399             ffeexpr_rhs (ffeexpr_stack_->pool,
15400                          sfdef
15401                          ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15402                          : FFEEXPR_contextINDEXORACTUALARG_,
15403                          ffeexpr_token_funsubstr_);
15404
15405         case FFEEXPR_parentypeANY_:
15406           ffebld_set_info (e->u.operand, ffesymbol_info (s));
15407           return
15408             (ffelexHandler)
15409             ffeexpr_rhs (ffeexpr_stack_->pool,
15410                          sfdef
15411                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
15412                          : FFEEXPR_contextACTUALARG_,
15413                          ffeexpr_token_anything_);
15414
15415         default:
15416           assert ("bad paren type" == NULL);
15417           break;
15418         }
15419
15420     case FFELEX_typeEQUALS:     /* As in "VAR=". */
15421       switch (ffeexpr_stack_->context)
15422         {
15423         case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15424         case FFEEXPR_contextIMPDOITEMDF_:
15425           ffeexpr_stack_->is_rhs = FALSE;       /* Really an lhs construct. */
15426           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15427           break;
15428
15429         default:
15430           break;
15431         }
15432       break;
15433
15434 #if 0
15435     case FFELEX_typePERIOD:
15436     case FFELEX_typePERCENT:
15437       ~~Support these two someday, though not required
15438         assert ("FOO%, FOO. not yet supported!~~" == NULL);
15439       break;
15440 #endif
15441
15442     default:
15443       break;
15444     }
15445
15446   switch (ffeexpr_stack_->context)
15447     {
15448     case FFEEXPR_contextINDEXORACTUALARG_:
15449     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15450       assert ("strange context" == NULL);
15451       break;
15452
15453     default:
15454       break;
15455     }
15456
15457   e = ffeexpr_expr_new_ ();
15458   e->type = FFEEXPR_exprtypeOPERAND_;
15459   e->token = ffeexpr_tokens_[0];
15460   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15461   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15462     {
15463       e->u.operand = ffebld_new_any ();
15464       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15465     }
15466   else
15467     {
15468       e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15469                                         ffesymbol_specific (s),
15470                                         ffesymbol_implementation (s));
15471       if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15472         ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15473       else
15474         {                       /* Decorate the SYMTER with the actual type
15475                                    of the intrinsic. */
15476           ffebld_set_info (e->u.operand, ffeinfo_new
15477                         (ffeintrin_basictype (ffesymbol_specific (s)),
15478                          ffeintrin_kindtype (ffesymbol_specific (s)),
15479                          0,
15480                          ffesymbol_kind (s),
15481                          ffesymbol_where (s),
15482                          FFETARGET_charactersizeNONE));
15483         }
15484       if (ffesymbol_is_doiter (s))
15485         ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15486       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15487                                               ffeexpr_tokens_[0]);
15488     }
15489   ffeexpr_exprstack_push_operand_ (e);
15490   return (ffelexHandler) ffeexpr_token_binary_ (t);
15491 }
15492
15493 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15494
15495    Return a pointer to this function to the lexer (ffelex), which will
15496    invoke it for the next token.
15497
15498    Expecting a NAME token, analyze the previous NAME token to see what kind,
15499    if any, typeless constant we've got.
15500
15501    01-Sep-90  JCB  1.1
15502       Expect a NAME instead of CHARACTER in this situation.  */
15503
15504 static ffelexHandler
15505 ffeexpr_token_name_apos_ (ffelexToken t)
15506 {
15507   ffeexprExpr_ e;
15508
15509   ffelex_set_hexnum (FALSE);
15510
15511   switch (ffelex_token_type (t))
15512     {
15513     case FFELEX_typeNAME:
15514       ffeexpr_tokens_[2] = ffelex_token_use (t);
15515       return (ffelexHandler) ffeexpr_token_name_apos_name_;
15516
15517     default:
15518       break;
15519     }
15520
15521   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15522     {
15523       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15524       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15525                    ffelex_token_where_column (ffeexpr_tokens_[0]));
15526       ffebad_here (1, ffelex_token_where_line (t),
15527                    ffelex_token_where_column (t));
15528       ffebad_finish ();
15529     }
15530
15531   ffelex_token_kill (ffeexpr_tokens_[1]);
15532
15533   e = ffeexpr_expr_new_ ();
15534   e->type = FFEEXPR_exprtypeOPERAND_;
15535   e->u.operand = ffebld_new_any ();
15536   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15537   e->token = ffeexpr_tokens_[0];
15538   ffeexpr_exprstack_push_operand_ (e);
15539
15540   return (ffelexHandler) ffeexpr_token_binary_ (t);
15541 }
15542
15543 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15544
15545    Return a pointer to this function to the lexer (ffelex), which will
15546    invoke it for the next token.
15547
15548    Expecting an APOSTROPHE token, analyze the previous NAME token to see
15549    what kind, if any, typeless constant we've got.  */
15550
15551 static ffelexHandler
15552 ffeexpr_token_name_apos_name_ (ffelexToken t)
15553 {
15554   ffeexprExpr_ e;
15555   char c;
15556
15557   e = ffeexpr_expr_new_ ();
15558   e->type = FFEEXPR_exprtypeOPERAND_;
15559   e->token = ffeexpr_tokens_[0];
15560
15561   if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15562       && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15563       && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15564                                   'B', 'b')
15565           || ffesrc_char_match_init (c, 'O', 'o')
15566           || ffesrc_char_match_init (c, 'X', 'x')
15567           || ffesrc_char_match_init (c, 'Z', 'z')))
15568     {
15569       ffetargetCharacterSize size;
15570
15571       if (!ffe_is_typeless_boz ()) {
15572
15573       switch (c)
15574         {
15575         case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15576           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15577                                             (ffeexpr_tokens_[2]));
15578           break;
15579
15580         case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15581           e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15582                                             (ffeexpr_tokens_[2]));
15583           break;
15584
15585         case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15586           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15587                                             (ffeexpr_tokens_[2]));
15588           break;
15589
15590         case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15591           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15592                                             (ffeexpr_tokens_[2]));
15593           break;
15594
15595         default:
15596         no_imatch:              /* :::::::::::::::::::: */
15597           assert ("not BOXZ!" == NULL);
15598           abort ();
15599         }
15600
15601         ffebld_set_info (e->u.operand,
15602                          ffeinfo_new (FFEINFO_basictypeINTEGER,
15603                                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
15604                                       FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15605                                       FFETARGET_charactersizeNONE));
15606         ffeexpr_exprstack_push_operand_ (e);
15607         ffelex_token_kill (ffeexpr_tokens_[1]);
15608         ffelex_token_kill (ffeexpr_tokens_[2]);
15609         return (ffelexHandler) ffeexpr_token_binary_;
15610       }
15611
15612       switch (c)
15613         {
15614         case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15615           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15616                                             (ffeexpr_tokens_[2]));
15617           size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15618           break;
15619
15620         case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15621           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15622                                             (ffeexpr_tokens_[2]));
15623           size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15624           break;
15625
15626         case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15627           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15628                                             (ffeexpr_tokens_[2]));
15629           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15630           break;
15631
15632         case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15633           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15634                                             (ffeexpr_tokens_[2]));
15635           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15636           break;
15637
15638         default:
15639         no_match:               /* :::::::::::::::::::: */
15640           assert ("not BOXZ!" == NULL);
15641           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15642                                             (ffeexpr_tokens_[2]));
15643           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15644           break;
15645         }
15646       ffebld_set_info (e->u.operand,
15647                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15648                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15649       ffeexpr_exprstack_push_operand_ (e);
15650       ffelex_token_kill (ffeexpr_tokens_[1]);
15651       ffelex_token_kill (ffeexpr_tokens_[2]);
15652       return (ffelexHandler) ffeexpr_token_binary_;
15653     }
15654
15655   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15656     {
15657       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15658       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15659                    ffelex_token_where_column (ffeexpr_tokens_[0]));
15660       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15661       ffebad_finish ();
15662     }
15663
15664   ffelex_token_kill (ffeexpr_tokens_[1]);
15665   ffelex_token_kill (ffeexpr_tokens_[2]);
15666
15667   e->type = FFEEXPR_exprtypeOPERAND_;
15668   e->u.operand = ffebld_new_any ();
15669   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15670   e->token = ffeexpr_tokens_[0];
15671   ffeexpr_exprstack_push_operand_ (e);
15672
15673   switch (ffelex_token_type (t))
15674     {
15675     case FFELEX_typeAPOSTROPHE:
15676     case FFELEX_typeQUOTE:
15677       return (ffelexHandler) ffeexpr_token_binary_;
15678
15679     default:
15680       return (ffelexHandler) ffeexpr_token_binary_ (t);
15681     }
15682 }
15683
15684 /* ffeexpr_token_percent_ -- Rhs PERCENT
15685
15686    Handle a percent sign possibly followed by "LOC".  If followed instead
15687    by "VAL", "REF", or "DESCR", issue an error message and substitute
15688    "LOC".  If followed by something else, treat the percent sign as a
15689    spurious incorrect token and reprocess the token via _rhs_.  */
15690
15691 static ffelexHandler
15692 ffeexpr_token_percent_ (ffelexToken t)
15693 {
15694   switch (ffelex_token_type (t))
15695     {
15696     case FFELEX_typeNAME:
15697     case FFELEX_typeNAMES:
15698       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15699       ffeexpr_tokens_[1] = ffelex_token_use (t);
15700       return (ffelexHandler) ffeexpr_token_percent_name_;
15701
15702     default:
15703       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15704         {
15705           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15706                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15707           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15708                    ffelex_token_where_column (ffeexpr_stack_->first_token));
15709           ffebad_finish ();
15710         }
15711       ffelex_token_kill (ffeexpr_tokens_[0]);
15712       return (ffelexHandler) ffeexpr_token_rhs_ (t);
15713     }
15714 }
15715
15716 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15717
15718    Make sure the token is OPEN_PAREN and prepare for the one-item list of
15719    LHS expressions.  Else display an error message.  */
15720
15721 static ffelexHandler
15722 ffeexpr_token_percent_name_ (ffelexToken t)
15723 {
15724   ffelexHandler nexthandler;
15725
15726   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15727     {
15728       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15729         {
15730           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15731                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15732           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15733                    ffelex_token_where_column (ffeexpr_stack_->first_token));
15734           ffebad_finish ();
15735         }
15736       ffelex_token_kill (ffeexpr_tokens_[0]);
15737       nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15738       ffelex_token_kill (ffeexpr_tokens_[1]);
15739       return (ffelexHandler) (*nexthandler) (t);
15740     }
15741
15742   switch (ffeexpr_stack_->percent)
15743     {
15744     default:
15745       if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15746         {
15747           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15748                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15749           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15750           ffebad_finish ();
15751         }
15752       ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15753       /* Fall through. */
15754     case FFEEXPR_percentLOC_:
15755       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15756       ffelex_token_kill (ffeexpr_tokens_[1]);
15757       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15758       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15759                                           FFEEXPR_contextLOC_,
15760                                           ffeexpr_cb_end_loc_);
15761     }
15762 }
15763
15764 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15765
15766    See prototype.
15767
15768    Pass 'E', 'D', or 'Q' for exponent letter.  */
15769
15770 static void
15771 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15772                            ffelexToken decimal, ffelexToken fraction,
15773                            ffelexToken exponent, ffelexToken exponent_sign,
15774                            ffelexToken exponent_digits)
15775 {
15776   ffeexprExpr_ e;
15777
15778   e = ffeexpr_expr_new_ ();
15779   e->type = FFEEXPR_exprtypeOPERAND_;
15780   if (integer != NULL)
15781     e->token = ffelex_token_use (integer);
15782   else
15783     {
15784       assert (decimal != NULL);
15785       e->token = ffelex_token_use (decimal);
15786     }
15787
15788   switch (exp_letter)
15789     {
15790 #if !FFETARGET_okREALQUAD
15791     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15792       if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15793         {
15794           ffebad_here (0, ffelex_token_where_line (e->token),
15795                        ffelex_token_where_column (e->token));
15796           ffebad_finish ();
15797         }
15798       goto match_d;             /* The FFESRC_CASE_* macros don't
15799                                    allow fall-through! */
15800 #endif
15801
15802     case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15803       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15804                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15805       ffebld_set_info (e->u.operand,
15806              ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15807                           0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15808       break;
15809
15810     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15811       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15812                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15813       ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15814                          FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15815                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15816       break;
15817
15818 #if FFETARGET_okREALQUAD
15819     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15820       e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15821                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15822       ffebld_set_info (e->u.operand,
15823                ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15824                             0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15825       break;
15826 #endif
15827
15828     case 'I':   /* Make an integer. */
15829       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15830                                         (ffeexpr_tokens_[0]));
15831       ffebld_set_info (e->u.operand,
15832                        ffeinfo_new (FFEINFO_basictypeINTEGER,
15833                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
15834                                     FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15835                                     FFETARGET_charactersizeNONE));
15836       break;
15837
15838     default:
15839     no_match:                   /* :::::::::::::::::::: */
15840       assert ("Lost the exponent letter!" == NULL);
15841     }
15842
15843   ffeexpr_exprstack_push_operand_ (e);
15844 }
15845
15846 /* Just like ffesymbol_declare_local, except performs any implicit info
15847    assignment necessary.  */
15848
15849 static ffesymbol
15850 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15851 {
15852   ffesymbol s;
15853   ffeinfoKind k;
15854   bool bad;
15855
15856   s = ffesymbol_declare_local (t, maybe_intrin);
15857
15858   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15859     /* Special-case these since they can involve a different concept
15860        of "state" (in the stmtfunc name space).  */
15861     {
15862     case FFEEXPR_contextDATAIMPDOINDEX_:
15863     case FFEEXPR_contextDATAIMPDOCTRL_:
15864       if (ffeexpr_context_outer_ (ffeexpr_stack_)
15865           == FFEEXPR_contextDATAIMPDOINDEX_)
15866         s = ffeexpr_sym_impdoitem_ (s, t);
15867       else
15868         if (ffeexpr_stack_->is_rhs)
15869           s = ffeexpr_sym_impdoitem_ (s, t);
15870         else
15871           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15872       bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15873         || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15874             && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15875       if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15876         ffesymbol_error (s, t);
15877       return s;
15878
15879     default:
15880       break;
15881     }
15882
15883   switch ((ffesymbol_sfdummyparent (s) == NULL)
15884           ? ffesymbol_state (s)
15885           : FFESYMBOL_stateUNDERSTOOD)
15886     {
15887     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
15888                                    context. */
15889       if (!ffest_seen_first_exec ())
15890         goto seen;              /* :::::::::::::::::::: */
15891       /* Fall through. */
15892     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
15893       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15894         {
15895         case FFEEXPR_contextSUBROUTINEREF:
15896           s = ffeexpr_sym_lhs_call_ (s, t);
15897           break;
15898
15899         case FFEEXPR_contextFILEEXTFUNC:
15900           s = ffeexpr_sym_lhs_extfunc_ (s, t);
15901           break;
15902
15903         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15904           s = ffecom_sym_exec_transition (s);
15905           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15906             goto understood;    /* :::::::::::::::::::: */
15907           /* Fall through. */
15908         case FFEEXPR_contextACTUALARG_:
15909           s = ffeexpr_sym_rhs_actualarg_ (s, t);
15910           break;
15911
15912         case FFEEXPR_contextDATA:
15913           if (ffeexpr_stack_->is_rhs)
15914             s = ffeexpr_sym_rhs_let_ (s, t);
15915           else
15916             s = ffeexpr_sym_lhs_data_ (s, t);
15917           break;
15918
15919         case FFEEXPR_contextDATAIMPDOITEM_:
15920           s = ffeexpr_sym_lhs_data_ (s, t);
15921           break;
15922
15923         case FFEEXPR_contextSFUNCDEF:
15924         case FFEEXPR_contextSFUNCDEFINDEX_:
15925         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15926         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15927           s = ffecom_sym_exec_transition (s);
15928           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15929             goto understood;    /* :::::::::::::::::::: */
15930           /* Fall through. */
15931         case FFEEXPR_contextLET:
15932         case FFEEXPR_contextPAREN_:
15933         case FFEEXPR_contextACTUALARGEXPR_:
15934         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15935         case FFEEXPR_contextASSIGN:
15936         case FFEEXPR_contextIOLIST:
15937         case FFEEXPR_contextIOLISTDF:
15938         case FFEEXPR_contextDO:
15939         case FFEEXPR_contextDOWHILE:
15940         case FFEEXPR_contextAGOTO:
15941         case FFEEXPR_contextCGOTO:
15942         case FFEEXPR_contextIF:
15943         case FFEEXPR_contextARITHIF:
15944         case FFEEXPR_contextFORMAT:
15945         case FFEEXPR_contextSTOP:
15946         case FFEEXPR_contextRETURN:
15947         case FFEEXPR_contextSELECTCASE:
15948         case FFEEXPR_contextCASE:
15949         case FFEEXPR_contextFILEASSOC:
15950         case FFEEXPR_contextFILEINT:
15951         case FFEEXPR_contextFILEDFINT:
15952         case FFEEXPR_contextFILELOG:
15953         case FFEEXPR_contextFILENUM:
15954         case FFEEXPR_contextFILENUMAMBIG:
15955         case FFEEXPR_contextFILECHAR:
15956         case FFEEXPR_contextFILENUMCHAR:
15957         case FFEEXPR_contextFILEDFCHAR:
15958         case FFEEXPR_contextFILEKEY:
15959         case FFEEXPR_contextFILEUNIT:
15960         case FFEEXPR_contextFILEUNIT_DF:
15961         case FFEEXPR_contextFILEUNITAMBIG:
15962         case FFEEXPR_contextFILEFORMAT:
15963         case FFEEXPR_contextFILENAMELIST:
15964         case FFEEXPR_contextFILEVXTCODE:
15965         case FFEEXPR_contextINDEX_:
15966         case FFEEXPR_contextIMPDOITEM_:
15967         case FFEEXPR_contextIMPDOITEMDF_:
15968         case FFEEXPR_contextIMPDOCTRL_:
15969         case FFEEXPR_contextLOC_:
15970           if (ffeexpr_stack_->is_rhs)
15971             s = ffeexpr_sym_rhs_let_ (s, t);
15972           else
15973             s = ffeexpr_sym_lhs_let_ (s, t);
15974           break;
15975
15976         case FFEEXPR_contextCHARACTERSIZE:
15977         case FFEEXPR_contextEQUIVALENCE:
15978         case FFEEXPR_contextINCLUDE:
15979         case FFEEXPR_contextPARAMETER:
15980         case FFEEXPR_contextDIMLIST:
15981         case FFEEXPR_contextDIMLISTCOMMON:
15982         case FFEEXPR_contextKINDTYPE:
15983         case FFEEXPR_contextINITVAL:
15984         case FFEEXPR_contextEQVINDEX_:
15985           break;                /* Will turn into errors below. */
15986
15987         default:
15988           ffesymbol_error (s, t);
15989           break;
15990         }
15991       /* Fall through. */
15992     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
15993     understood:         /* :::::::::::::::::::: */
15994       k = ffesymbol_kind (s);
15995       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15996         {
15997         case FFEEXPR_contextSUBROUTINEREF:
15998           bad = ((k != FFEINFO_kindSUBROUTINE)
15999                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16000                      || (k != FFEINFO_kindNONE)));
16001           break;
16002
16003         case FFEEXPR_contextFILEEXTFUNC:
16004           bad = (k != FFEINFO_kindFUNCTION)
16005             || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16006           break;
16007
16008         case FFEEXPR_contextSFUNCDEFACTUALARG_:
16009         case FFEEXPR_contextACTUALARG_:
16010           switch (k)
16011             {
16012             case FFEINFO_kindENTITY:
16013               bad = FALSE;
16014               break;
16015
16016             case FFEINFO_kindFUNCTION:
16017             case FFEINFO_kindSUBROUTINE:
16018               bad
16019                 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16020                    && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16021                    && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16022                        || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16023               break;
16024
16025             case FFEINFO_kindNONE:
16026               if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16027                 {
16028                   bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16029                   break;
16030                 }
16031
16032               /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16033                  and in the former case, attrsTYPE is set, so we
16034                  see this as an error as we should, since CHAR*(*)
16035                  cannot be actually referenced in a main/block data
16036                  program unit.  */
16037
16038               if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16039                                           | FFESYMBOL_attrsEXTERNAL
16040                                           | FFESYMBOL_attrsTYPE))
16041                   == FFESYMBOL_attrsEXTERNAL)
16042                 bad = FALSE;
16043               else
16044                 bad = TRUE;
16045               break;
16046
16047             default:
16048               bad = TRUE;
16049               break;
16050             }
16051           break;
16052
16053         case FFEEXPR_contextDATA:
16054           if (ffeexpr_stack_->is_rhs)
16055             bad = (k != FFEINFO_kindENTITY)
16056               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16057           else
16058             bad = (k != FFEINFO_kindENTITY)
16059               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16060                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16061                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16062           break;
16063
16064         case FFEEXPR_contextDATAIMPDOITEM_:
16065           bad = TRUE;           /* Unadorned item never valid. */
16066           break;
16067
16068         case FFEEXPR_contextSFUNCDEF:
16069         case FFEEXPR_contextSFUNCDEFINDEX_:
16070         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16071         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16072         case FFEEXPR_contextLET:
16073         case FFEEXPR_contextPAREN_:
16074         case FFEEXPR_contextACTUALARGEXPR_:
16075         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16076         case FFEEXPR_contextASSIGN:
16077         case FFEEXPR_contextIOLIST:
16078         case FFEEXPR_contextIOLISTDF:
16079         case FFEEXPR_contextDO:
16080         case FFEEXPR_contextDOWHILE:
16081         case FFEEXPR_contextAGOTO:
16082         case FFEEXPR_contextCGOTO:
16083         case FFEEXPR_contextIF:
16084         case FFEEXPR_contextARITHIF:
16085         case FFEEXPR_contextFORMAT:
16086         case FFEEXPR_contextSTOP:
16087         case FFEEXPR_contextRETURN:
16088         case FFEEXPR_contextSELECTCASE:
16089         case FFEEXPR_contextCASE:
16090         case FFEEXPR_contextFILEASSOC:
16091         case FFEEXPR_contextFILEINT:
16092         case FFEEXPR_contextFILEDFINT:
16093         case FFEEXPR_contextFILELOG:
16094         case FFEEXPR_contextFILENUM:
16095         case FFEEXPR_contextFILENUMAMBIG:
16096         case FFEEXPR_contextFILECHAR:
16097         case FFEEXPR_contextFILENUMCHAR:
16098         case FFEEXPR_contextFILEDFCHAR:
16099         case FFEEXPR_contextFILEKEY:
16100         case FFEEXPR_contextFILEUNIT:
16101         case FFEEXPR_contextFILEUNIT_DF:
16102         case FFEEXPR_contextFILEUNITAMBIG:
16103         case FFEEXPR_contextFILEFORMAT:
16104         case FFEEXPR_contextFILENAMELIST:
16105         case FFEEXPR_contextFILEVXTCODE:
16106         case FFEEXPR_contextINDEX_:
16107         case FFEEXPR_contextIMPDOITEM_:
16108         case FFEEXPR_contextIMPDOITEMDF_:
16109         case FFEEXPR_contextIMPDOCTRL_:
16110         case FFEEXPR_contextLOC_:
16111           bad = (k != FFEINFO_kindENTITY);      /* This catches "SUBROUTINE
16112                                                    X(A);EXTERNAL A;CALL
16113                                                    Y(A);B=A", for example. */
16114           break;
16115
16116         case FFEEXPR_contextCHARACTERSIZE:
16117         case FFEEXPR_contextEQUIVALENCE:
16118         case FFEEXPR_contextPARAMETER:
16119         case FFEEXPR_contextDIMLIST:
16120         case FFEEXPR_contextDIMLISTCOMMON:
16121         case FFEEXPR_contextKINDTYPE:
16122         case FFEEXPR_contextINITVAL:
16123         case FFEEXPR_contextEQVINDEX_:
16124           bad = (k != FFEINFO_kindENTITY)
16125             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16126           break;
16127
16128         case FFEEXPR_contextINCLUDE:
16129           bad = TRUE;
16130           break;
16131
16132         default:
16133           bad = TRUE;
16134           break;
16135         }
16136       if (bad && (k != FFEINFO_kindANY))
16137         ffesymbol_error (s, t);
16138       return s;
16139
16140     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
16141     seen:                       /* :::::::::::::::::::: */
16142       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16143         {
16144         case FFEEXPR_contextPARAMETER:
16145           if (ffeexpr_stack_->is_rhs)
16146             ffesymbol_error (s, t);
16147           else
16148             s = ffeexpr_sym_lhs_parameter_ (s, t);
16149           break;
16150
16151         case FFEEXPR_contextDATA:
16152           s = ffecom_sym_exec_transition (s);
16153           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16154             goto understood;    /* :::::::::::::::::::: */
16155           if (ffeexpr_stack_->is_rhs)
16156             ffesymbol_error (s, t);
16157           else
16158             s = ffeexpr_sym_lhs_data_ (s, t);
16159           goto understood;      /* :::::::::::::::::::: */
16160
16161         case FFEEXPR_contextDATAIMPDOITEM_:
16162           s = ffecom_sym_exec_transition (s);
16163           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16164             goto understood;    /* :::::::::::::::::::: */
16165           s = ffeexpr_sym_lhs_data_ (s, t);
16166           goto understood;      /* :::::::::::::::::::: */
16167
16168         case FFEEXPR_contextEQUIVALENCE:
16169           s = ffeexpr_sym_lhs_equivalence_ (s, t);
16170           break;
16171
16172         case FFEEXPR_contextDIMLIST:
16173           s = ffeexpr_sym_rhs_dimlist_ (s, t);
16174           break;
16175
16176         case FFEEXPR_contextCHARACTERSIZE:
16177         case FFEEXPR_contextKINDTYPE:
16178         case FFEEXPR_contextDIMLISTCOMMON:
16179         case FFEEXPR_contextINITVAL:
16180         case FFEEXPR_contextEQVINDEX_:
16181           ffesymbol_error (s, t);
16182           break;
16183
16184         case FFEEXPR_contextINCLUDE:
16185           ffesymbol_error (s, t);
16186           break;
16187
16188         case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16189         case FFEEXPR_contextSFUNCDEFACTUALARG_:
16190           s = ffecom_sym_exec_transition (s);
16191           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16192             goto understood;    /* :::::::::::::::::::: */
16193           s = ffeexpr_sym_rhs_actualarg_ (s, t);
16194           goto understood;      /* :::::::::::::::::::: */
16195
16196         case FFEEXPR_contextINDEX_:
16197         case FFEEXPR_contextACTUALARGEXPR_:
16198         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16199         case FFEEXPR_contextSFUNCDEF:
16200         case FFEEXPR_contextSFUNCDEFINDEX_:
16201         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16202         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16203           assert (ffeexpr_stack_->is_rhs);
16204           s = ffecom_sym_exec_transition (s);
16205           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16206             goto understood;    /* :::::::::::::::::::: */
16207           s = ffeexpr_sym_rhs_let_ (s, t);
16208           goto understood;      /* :::::::::::::::::::: */
16209
16210         default:
16211           ffesymbol_error (s, t);
16212           break;
16213         }
16214       return s;
16215
16216     default:
16217       assert ("bad symbol state" == NULL);
16218       return NULL;
16219       break;
16220     }
16221 }
16222
16223 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16224    Could be found via the "statement-function" name space (in which case
16225    it should become an iterator) or the local name space (in which case
16226    it should be either a named constant, or a variable that will have an
16227    sfunc name space sibling that should become an iterator).  */
16228
16229 static ffesymbol
16230 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16231 {
16232   ffesymbol s;
16233   ffesymbolAttrs sa;
16234   ffesymbolAttrs na;
16235   ffesymbolState ss;
16236   ffesymbolState ns;
16237   ffeinfoKind kind;
16238   ffeinfoWhere where;
16239
16240   ss = ffesymbol_state (sp);
16241
16242   if (ffesymbol_sfdummyparent (sp) != NULL)
16243     {                           /* Have symbol in sfunc name space. */
16244       switch (ss)
16245         {
16246         case FFESYMBOL_stateNONE:       /* Used as iterator already. */
16247           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16248             ffesymbol_error (sp, t);    /* Can't use dead iterator. */
16249           else
16250             {                   /* Can use dead iterator because we're at at
16251                                    least an innermore (higher-numbered) level
16252                                    than the iterator's outermost
16253                                    (lowest-numbered) level. */
16254               ffesymbol_signal_change (sp);
16255               ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16256               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16257               ffesymbol_signal_unreported (sp);
16258             }
16259           break;
16260
16261         case FFESYMBOL_stateSEEN:       /* Seen already in this or other
16262                                            implied-DO.  Set symbol level
16263                                            number to outermost value, as that
16264                                            tells us we can see it as iterator
16265                                            at that level at the innermost. */
16266           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16267             {
16268               ffesymbol_signal_change (sp);
16269               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16270               ffesymbol_signal_unreported (sp);
16271             }
16272           break;
16273
16274         case FFESYMBOL_stateUNCERTAIN:  /* Iterator. */
16275           assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16276           ffesymbol_error (sp, t);      /* (,,,I=I,10). */
16277           break;
16278
16279         case FFESYMBOL_stateUNDERSTOOD:
16280           break;                /* ANY. */
16281
16282         default:
16283           assert ("Foo Bar!!" == NULL);
16284           break;
16285         }
16286
16287       return sp;
16288     }
16289
16290   /* Got symbol in local name space, so we haven't seen it in impdo yet.
16291      First, if it is brand-new and we're in executable statements, set the
16292      attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16293      Second, if it is now a constant (PARAMETER), then just return it, it
16294      can't be an implied-do iterator.  If it is understood, complain if it is
16295      not a valid variable, but make the inner name space iterator anyway and
16296      return that.  If it is not understood, improve understanding of the
16297      symbol accordingly, complain accordingly, in either case make the inner
16298      name space iterator and return that.  */
16299
16300   sa = ffesymbol_attrs (sp);
16301
16302   if (ffesymbol_state_is_specable (ss)
16303       && ffest_seen_first_exec ())
16304     {
16305       assert (sa == FFESYMBOL_attrsetNONE);
16306       ffesymbol_signal_change (sp);
16307       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16308       ffesymbol_resolve_intrin (sp);
16309       if (ffeimplic_establish_symbol (sp))
16310         ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16311       else
16312         ffesymbol_error (sp, t);
16313
16314       /* After the exec transition, the state will either be UNCERTAIN (could
16315          be a dummy or local var) or UNDERSTOOD (local var, because this is a
16316          PROGRAM/BLOCKDATA program unit).  */
16317
16318       sp = ffecom_sym_exec_transition (sp);
16319       sa = ffesymbol_attrs (sp);
16320       ss = ffesymbol_state (sp);
16321     }
16322
16323   ns = ss;
16324   kind = ffesymbol_kind (sp);
16325   where = ffesymbol_where (sp);
16326
16327   if (ss == FFESYMBOL_stateUNDERSTOOD)
16328     {
16329       if (kind != FFEINFO_kindENTITY)
16330         ffesymbol_error (sp, t);
16331       if (where == FFEINFO_whereCONSTANT)
16332         return sp;
16333     }
16334   else
16335     {
16336       /* Enhance understanding of local symbol.  This used to imply exec
16337          transition, but that doesn't seem necessary, since the local symbol
16338          doesn't actually get put into an ffebld tree here -- we just learn
16339          more about it, just like when we see a local symbol's name in the
16340          dummy-arg list of a statement function.  */
16341
16342       if (ss != FFESYMBOL_stateUNCERTAIN)
16343         {
16344           /* Figure out what kind of object we've got based on previous
16345              declarations of or references to the object. */
16346
16347           ns = FFESYMBOL_stateSEEN;
16348
16349           if (sa & FFESYMBOL_attrsANY)
16350             na = sa;
16351           else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16352                             | FFESYMBOL_attrsANY
16353                             | FFESYMBOL_attrsCOMMON
16354                             | FFESYMBOL_attrsDUMMY
16355                             | FFESYMBOL_attrsEQUIV
16356                             | FFESYMBOL_attrsINIT
16357                             | FFESYMBOL_attrsNAMELIST
16358                             | FFESYMBOL_attrsRESULT
16359                             | FFESYMBOL_attrsSAVE
16360                             | FFESYMBOL_attrsSFARG
16361                             | FFESYMBOL_attrsTYPE)))
16362             na = sa | FFESYMBOL_attrsSFARG;
16363           else
16364             na = FFESYMBOL_attrsetNONE;
16365         }
16366       else
16367         {                       /* stateUNCERTAIN. */
16368           na = sa | FFESYMBOL_attrsSFARG;
16369           ns = FFESYMBOL_stateUNDERSTOOD;
16370
16371           assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16372                            | FFESYMBOL_attrsADJUSTABLE
16373                            | FFESYMBOL_attrsANYLEN
16374                            | FFESYMBOL_attrsARRAY
16375                            | FFESYMBOL_attrsDUMMY
16376                            | FFESYMBOL_attrsEXTERNAL
16377                            | FFESYMBOL_attrsSFARG
16378                            | FFESYMBOL_attrsTYPE)));
16379
16380           if (sa & FFESYMBOL_attrsEXTERNAL)
16381             {
16382               assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16383                                | FFESYMBOL_attrsDUMMY
16384                                | FFESYMBOL_attrsEXTERNAL
16385                                | FFESYMBOL_attrsTYPE)));
16386
16387               na = FFESYMBOL_attrsetNONE;
16388             }
16389           else if (sa & FFESYMBOL_attrsDUMMY)
16390             {
16391               assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16392               assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16393                                | FFESYMBOL_attrsEXTERNAL
16394                                | FFESYMBOL_attrsTYPE)));
16395
16396               kind = FFEINFO_kindENTITY;
16397             }
16398           else if (sa & FFESYMBOL_attrsARRAY)
16399             {
16400               assert (!(sa & ~(FFESYMBOL_attrsARRAY
16401                                | FFESYMBOL_attrsADJUSTABLE
16402                                | FFESYMBOL_attrsTYPE)));
16403
16404               na = FFESYMBOL_attrsetNONE;
16405             }
16406           else if (sa & FFESYMBOL_attrsSFARG)
16407             {
16408               assert (!(sa & ~(FFESYMBOL_attrsSFARG
16409                                | FFESYMBOL_attrsTYPE)));
16410
16411               ns = FFESYMBOL_stateUNCERTAIN;
16412             }
16413           else if (sa & FFESYMBOL_attrsTYPE)
16414             {
16415               assert (!(sa & (FFESYMBOL_attrsARRAY
16416                               | FFESYMBOL_attrsDUMMY
16417                               | FFESYMBOL_attrsEXTERNAL
16418                               | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16419               assert (!(sa & ~(FFESYMBOL_attrsTYPE
16420                                | FFESYMBOL_attrsADJUSTABLE
16421                                | FFESYMBOL_attrsANYLEN
16422                                | FFESYMBOL_attrsARRAY
16423                                | FFESYMBOL_attrsDUMMY
16424                                | FFESYMBOL_attrsEXTERNAL
16425                                | FFESYMBOL_attrsSFARG)));
16426
16427               kind = FFEINFO_kindENTITY;
16428
16429               if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16430                 na = FFESYMBOL_attrsetNONE;
16431               else if (ffest_is_entry_valid ())
16432                 ns = FFESYMBOL_stateUNCERTAIN;  /* Could be DUMMY or LOCAL. */
16433               else
16434                 where = FFEINFO_whereLOCAL;
16435             }
16436           else
16437             na = FFESYMBOL_attrsetNONE; /* Error. */
16438         }
16439
16440       /* Now see what we've got for a new object: NONE means a new error
16441          cropped up; ANY means an old error to be ignored; otherwise,
16442          everything's ok, update the object (symbol) and continue on. */
16443
16444       if (na == FFESYMBOL_attrsetNONE)
16445         ffesymbol_error (sp, t);
16446       else if (!(na & FFESYMBOL_attrsANY))
16447         {
16448           ffesymbol_signal_change (sp); /* May need to back up to previous
16449                                            version. */
16450           if (!ffeimplic_establish_symbol (sp))
16451             ffesymbol_error (sp, t);
16452           else
16453             {
16454               ffesymbol_set_info (sp,
16455                                   ffeinfo_new (ffesymbol_basictype (sp),
16456                                                ffesymbol_kindtype (sp),
16457                                                ffesymbol_rank (sp),
16458                                                kind,
16459                                                where,
16460                                                ffesymbol_size (sp)));
16461               ffesymbol_set_attrs (sp, na);
16462               ffesymbol_set_state (sp, ns);
16463               ffesymbol_resolve_intrin (sp);
16464               if (!ffesymbol_state_is_specable (ns))
16465                 sp = ffecom_sym_learned (sp);
16466               ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16467             }
16468         }
16469     }
16470
16471   /* Here we create the sfunc-name-space symbol representing what should
16472      become an iterator in this name space at this or an outermore (lower-
16473      numbered) expression level, else the implied-DO construct is in error.  */
16474
16475   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
16476                                            also sets sfa_dummy_parent to
16477                                            parent symbol. */
16478   assert (sp == ffesymbol_sfdummyparent (s));
16479
16480   ffesymbol_signal_change (s);
16481   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16482   ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16483   ffesymbol_set_info (s,
16484                       ffeinfo_new (FFEINFO_basictypeINTEGER,
16485                                    FFEINFO_kindtypeINTEGERDEFAULT,
16486                                    0,
16487                                    FFEINFO_kindENTITY,
16488                                    FFEINFO_whereIMMEDIATE,
16489                                    FFETARGET_charactersizeNONE));
16490   ffesymbol_signal_unreported (s);
16491
16492   if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16493        && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16494       || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
16495           && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
16496     ffesymbol_error (s, t);
16497
16498   return s;
16499 }
16500
16501 /* Have FOO in CALL FOO.  Local name space, executable context only.  */
16502
16503 static ffesymbol
16504 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16505 {
16506   ffesymbolAttrs sa;
16507   ffesymbolAttrs na;
16508   ffeinfoKind kind;
16509   ffeinfoWhere where;
16510   ffeintrinGen gen;
16511   ffeintrinSpec spec;
16512   ffeintrinImp imp;
16513   bool error = FALSE;
16514
16515   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16516           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16517
16518   na = sa = ffesymbol_attrs (s);
16519
16520   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16521                    | FFESYMBOL_attrsADJUSTABLE
16522                    | FFESYMBOL_attrsANYLEN
16523                    | FFESYMBOL_attrsARRAY
16524                    | FFESYMBOL_attrsDUMMY
16525                    | FFESYMBOL_attrsEXTERNAL
16526                    | FFESYMBOL_attrsSFARG
16527                    | FFESYMBOL_attrsTYPE)));
16528
16529   kind = ffesymbol_kind (s);
16530   where = ffesymbol_where (s);
16531
16532   /* Figure out what kind of object we've got based on previous declarations
16533      of or references to the object. */
16534
16535   if (sa & FFESYMBOL_attrsEXTERNAL)
16536     {
16537       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16538                        | FFESYMBOL_attrsDUMMY
16539                        | FFESYMBOL_attrsEXTERNAL
16540                        | FFESYMBOL_attrsTYPE)));
16541
16542       if (sa & FFESYMBOL_attrsTYPE)
16543         error = TRUE;
16544       else
16545         /* Not TYPE. */
16546         {
16547           kind = FFEINFO_kindSUBROUTINE;
16548
16549           if (sa & FFESYMBOL_attrsDUMMY)
16550             ;                   /* Not TYPE. */
16551           else if (sa & FFESYMBOL_attrsACTUALARG)
16552             ;                   /* Not DUMMY or TYPE. */
16553           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
16554             where = FFEINFO_whereGLOBAL;
16555         }
16556     }
16557   else if (sa & FFESYMBOL_attrsDUMMY)
16558     {
16559       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16560       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16561                        | FFESYMBOL_attrsEXTERNAL
16562                        | FFESYMBOL_attrsTYPE)));
16563
16564       if (sa & FFESYMBOL_attrsTYPE)
16565         error = TRUE;
16566       else
16567         kind = FFEINFO_kindSUBROUTINE;
16568     }
16569   else if (sa & FFESYMBOL_attrsARRAY)
16570     {
16571       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16572                        | FFESYMBOL_attrsADJUSTABLE
16573                        | FFESYMBOL_attrsTYPE)));
16574
16575       error = TRUE;
16576     }
16577   else if (sa & FFESYMBOL_attrsSFARG)
16578     {
16579       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16580                        | FFESYMBOL_attrsTYPE)));
16581
16582       error = TRUE;
16583     }
16584   else if (sa & FFESYMBOL_attrsTYPE)
16585     {
16586       assert (!(sa & (FFESYMBOL_attrsARRAY
16587                       | FFESYMBOL_attrsDUMMY
16588                       | FFESYMBOL_attrsEXTERNAL
16589                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16590       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16591                        | FFESYMBOL_attrsADJUSTABLE
16592                        | FFESYMBOL_attrsANYLEN
16593                        | FFESYMBOL_attrsARRAY
16594                        | FFESYMBOL_attrsDUMMY
16595                        | FFESYMBOL_attrsEXTERNAL
16596                        | FFESYMBOL_attrsSFARG)));
16597
16598       error = TRUE;
16599     }
16600   else if (sa == FFESYMBOL_attrsetNONE)
16601     {
16602       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16603
16604       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16605                                   &gen, &spec, &imp))
16606         {
16607           ffesymbol_signal_change (s);  /* May need to back up to previous
16608                                            version. */
16609           ffesymbol_set_generic (s, gen);
16610           ffesymbol_set_specific (s, spec);
16611           ffesymbol_set_implementation (s, imp);
16612           ffesymbol_set_info (s,
16613                               ffeinfo_new (FFEINFO_basictypeNONE,
16614                                            FFEINFO_kindtypeNONE,
16615                                            0,
16616                                            FFEINFO_kindSUBROUTINE,
16617                                            FFEINFO_whereINTRINSIC,
16618                                            FFETARGET_charactersizeNONE));
16619           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16620           ffesymbol_resolve_intrin (s);
16621           ffesymbol_reference (s, t, FALSE);
16622           s = ffecom_sym_learned (s);
16623           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
16624
16625           return s;
16626         }
16627
16628       kind = FFEINFO_kindSUBROUTINE;
16629       where = FFEINFO_whereGLOBAL;
16630     }
16631   else
16632     error = TRUE;
16633
16634   /* Now see what we've got for a new object: NONE means a new error cropped
16635      up; ANY means an old error to be ignored; otherwise, everything's ok,
16636      update the object (symbol) and continue on. */
16637
16638   if (error)
16639     ffesymbol_error (s, t);
16640   else if (!(na & FFESYMBOL_attrsANY))
16641     {
16642       ffesymbol_signal_change (s);      /* May need to back up to previous
16643                                            version. */
16644       ffesymbol_set_info (s,
16645                           ffeinfo_new (ffesymbol_basictype (s),
16646                                        ffesymbol_kindtype (s),
16647                                        ffesymbol_rank (s),
16648                                        kind,    /* SUBROUTINE. */
16649                                        where,   /* GLOBAL or DUMMY. */
16650                                        ffesymbol_size (s)));
16651       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16652       ffesymbol_resolve_intrin (s);
16653       ffesymbol_reference (s, t, FALSE);
16654       s = ffecom_sym_learned (s);
16655       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16656     }
16657
16658   return s;
16659 }
16660
16661 /* Have FOO in DATA FOO/.../.  Local name space and executable context
16662    only.  (This will change in the future when DATA FOO may be followed
16663    by COMMON FOO or even INTEGER FOO(10), etc.)  */
16664
16665 static ffesymbol
16666 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16667 {
16668   ffesymbolAttrs sa;
16669   ffesymbolAttrs na;
16670   ffeinfoKind kind;
16671   ffeinfoWhere where;
16672   bool error = FALSE;
16673
16674   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16675           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16676
16677   na = sa = ffesymbol_attrs (s);
16678
16679   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16680                    | FFESYMBOL_attrsADJUSTABLE
16681                    | FFESYMBOL_attrsANYLEN
16682                    | FFESYMBOL_attrsARRAY
16683                    | FFESYMBOL_attrsDUMMY
16684                    | FFESYMBOL_attrsEXTERNAL
16685                    | FFESYMBOL_attrsSFARG
16686                    | FFESYMBOL_attrsTYPE)));
16687
16688   kind = ffesymbol_kind (s);
16689   where = ffesymbol_where (s);
16690
16691   /* Figure out what kind of object we've got based on previous declarations
16692      of or references to the object. */
16693
16694   if (sa & FFESYMBOL_attrsEXTERNAL)
16695     {
16696       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16697                        | FFESYMBOL_attrsDUMMY
16698                        | FFESYMBOL_attrsEXTERNAL
16699                        | FFESYMBOL_attrsTYPE)));
16700
16701       error = TRUE;
16702     }
16703   else if (sa & FFESYMBOL_attrsDUMMY)
16704     {
16705       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16706       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16707                        | FFESYMBOL_attrsEXTERNAL
16708                        | FFESYMBOL_attrsTYPE)));
16709
16710       error = TRUE;
16711     }
16712   else if (sa & FFESYMBOL_attrsARRAY)
16713     {
16714       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16715                        | FFESYMBOL_attrsADJUSTABLE
16716                        | FFESYMBOL_attrsTYPE)));
16717
16718       if (sa & FFESYMBOL_attrsADJUSTABLE)
16719         error = TRUE;
16720       where = FFEINFO_whereLOCAL;
16721     }
16722   else if (sa & FFESYMBOL_attrsSFARG)
16723     {
16724       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16725                        | FFESYMBOL_attrsTYPE)));
16726
16727       where = FFEINFO_whereLOCAL;
16728     }
16729   else if (sa & FFESYMBOL_attrsTYPE)
16730     {
16731       assert (!(sa & (FFESYMBOL_attrsARRAY
16732                       | FFESYMBOL_attrsDUMMY
16733                       | FFESYMBOL_attrsEXTERNAL
16734                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16735       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16736                        | FFESYMBOL_attrsADJUSTABLE
16737                        | FFESYMBOL_attrsANYLEN
16738                        | FFESYMBOL_attrsARRAY
16739                        | FFESYMBOL_attrsDUMMY
16740                        | FFESYMBOL_attrsEXTERNAL
16741                        | FFESYMBOL_attrsSFARG)));
16742
16743       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16744         error = TRUE;
16745       else
16746         {
16747           kind = FFEINFO_kindENTITY;
16748           where = FFEINFO_whereLOCAL;
16749         }
16750     }
16751   else if (sa == FFESYMBOL_attrsetNONE)
16752     {
16753       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16754       kind = FFEINFO_kindENTITY;
16755       where = FFEINFO_whereLOCAL;
16756     }
16757   else
16758     error = TRUE;
16759
16760   /* Now see what we've got for a new object: NONE means a new error cropped
16761      up; ANY means an old error to be ignored; otherwise, everything's ok,
16762      update the object (symbol) and continue on. */
16763
16764   if (error)
16765     ffesymbol_error (s, t);
16766   else if (!(na & FFESYMBOL_attrsANY))
16767     {
16768       ffesymbol_signal_change (s);      /* May need to back up to previous
16769                                            version. */
16770       if (!ffeimplic_establish_symbol (s))
16771         {
16772           ffesymbol_error (s, t);
16773           return s;
16774         }
16775       ffesymbol_set_info (s,
16776                           ffeinfo_new (ffesymbol_basictype (s),
16777                                        ffesymbol_kindtype (s),
16778                                        ffesymbol_rank (s),
16779                                        kind,    /* ENTITY. */
16780                                        where,   /* LOCAL. */
16781                                        ffesymbol_size (s)));
16782       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16783       ffesymbol_resolve_intrin (s);
16784       s = ffecom_sym_learned (s);
16785       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16786     }
16787
16788   return s;
16789 }
16790
16791 /* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
16792    EQUIVALENCE (...,BAR(FOO),...).  */
16793
16794 static ffesymbol
16795 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16796 {
16797   ffesymbolAttrs sa;
16798   ffesymbolAttrs na;
16799   ffeinfoKind kind;
16800   ffeinfoWhere where;
16801
16802   na = sa = ffesymbol_attrs (s);
16803   kind = FFEINFO_kindENTITY;
16804   where = ffesymbol_where (s);
16805
16806   /* Figure out what kind of object we've got based on previous declarations
16807      of or references to the object. */
16808
16809   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16810                | FFESYMBOL_attrsARRAY
16811                | FFESYMBOL_attrsCOMMON
16812                | FFESYMBOL_attrsEQUIV
16813                | FFESYMBOL_attrsINIT
16814                | FFESYMBOL_attrsNAMELIST
16815                | FFESYMBOL_attrsSAVE
16816                | FFESYMBOL_attrsSFARG
16817                | FFESYMBOL_attrsTYPE)))
16818     na = sa | FFESYMBOL_attrsEQUIV;
16819   else
16820     na = FFESYMBOL_attrsetNONE;
16821
16822   /* Don't know why we're bothering to set kind and where in this code, but
16823      added the following to make it complete, in case it's really important.
16824      Generally this is left up to symbol exec transition.  */
16825
16826   if (where == FFEINFO_whereNONE)
16827     {
16828       if (na & (FFESYMBOL_attrsADJUSTS
16829                 | FFESYMBOL_attrsCOMMON))
16830         where = FFEINFO_whereCOMMON;
16831       else if (na & FFESYMBOL_attrsSAVE)
16832         where = FFEINFO_whereLOCAL;
16833     }
16834
16835   /* Now see what we've got for a new object: NONE means a new error cropped
16836      up; ANY means an old error to be ignored; otherwise, everything's ok,
16837      update the object (symbol) and continue on. */
16838
16839   if (na == FFESYMBOL_attrsetNONE)
16840     ffesymbol_error (s, t);
16841   else if (!(na & FFESYMBOL_attrsANY))
16842     {
16843       ffesymbol_signal_change (s);      /* May need to back up to previous
16844                                            version. */
16845       ffesymbol_set_info (s,
16846                           ffeinfo_new (ffesymbol_basictype (s),
16847                                        ffesymbol_kindtype (s),
16848                                        ffesymbol_rank (s),
16849                                        kind,    /* Always ENTITY. */
16850                                        where,   /* NONE, COMMON, or LOCAL. */
16851                                        ffesymbol_size (s)));
16852       ffesymbol_set_attrs (s, na);
16853       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16854       ffesymbol_resolve_intrin (s);
16855       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16856     }
16857
16858   return s;
16859 }
16860
16861 /* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
16862
16863    Note that I think this should be considered semantically similar to
16864    doing CALL XYZ(FOO), in that it should be considered like an
16865    ACTUALARG context.  In particular, without EXTERNAL being specified,
16866    it should not be allowed.  */
16867
16868 static ffesymbol
16869 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16870 {
16871   ffesymbolAttrs sa;
16872   ffesymbolAttrs na;
16873   ffeinfoKind kind;
16874   ffeinfoWhere where;
16875   bool needs_type = FALSE;
16876   bool error = FALSE;
16877
16878   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16879           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16880
16881   na = sa = ffesymbol_attrs (s);
16882
16883   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16884                    | FFESYMBOL_attrsADJUSTABLE
16885                    | FFESYMBOL_attrsANYLEN
16886                    | FFESYMBOL_attrsARRAY
16887                    | FFESYMBOL_attrsDUMMY
16888                    | FFESYMBOL_attrsEXTERNAL
16889                    | FFESYMBOL_attrsSFARG
16890                    | FFESYMBOL_attrsTYPE)));
16891
16892   kind = ffesymbol_kind (s);
16893   where = ffesymbol_where (s);
16894
16895   /* Figure out what kind of object we've got based on previous declarations
16896      of or references to the object. */
16897
16898   if (sa & FFESYMBOL_attrsEXTERNAL)
16899     {
16900       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16901                        | FFESYMBOL_attrsDUMMY
16902                        | FFESYMBOL_attrsEXTERNAL
16903                        | FFESYMBOL_attrsTYPE)));
16904
16905       if (sa & FFESYMBOL_attrsTYPE)
16906         where = FFEINFO_whereGLOBAL;
16907       else
16908         /* Not TYPE. */
16909         {
16910           kind = FFEINFO_kindFUNCTION;
16911           needs_type = TRUE;
16912
16913           if (sa & FFESYMBOL_attrsDUMMY)
16914             ;                   /* Not TYPE. */
16915           else if (sa & FFESYMBOL_attrsACTUALARG)
16916             ;                   /* Not DUMMY or TYPE. */
16917           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
16918             where = FFEINFO_whereGLOBAL;
16919         }
16920     }
16921   else if (sa & FFESYMBOL_attrsDUMMY)
16922     {
16923       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16924       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16925                        | FFESYMBOL_attrsEXTERNAL
16926                        | FFESYMBOL_attrsTYPE)));
16927
16928       kind = FFEINFO_kindFUNCTION;
16929       if (!(sa & FFESYMBOL_attrsTYPE))
16930         needs_type = TRUE;
16931     }
16932   else if (sa & FFESYMBOL_attrsARRAY)
16933     {
16934       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16935                        | FFESYMBOL_attrsADJUSTABLE
16936                        | FFESYMBOL_attrsTYPE)));
16937
16938       error = TRUE;
16939     }
16940   else if (sa & FFESYMBOL_attrsSFARG)
16941     {
16942       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16943                        | FFESYMBOL_attrsTYPE)));
16944
16945       error = TRUE;
16946     }
16947   else if (sa & FFESYMBOL_attrsTYPE)
16948     {
16949       assert (!(sa & (FFESYMBOL_attrsARRAY
16950                       | FFESYMBOL_attrsDUMMY
16951                       | FFESYMBOL_attrsEXTERNAL
16952                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16953       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16954                        | FFESYMBOL_attrsADJUSTABLE
16955                        | FFESYMBOL_attrsANYLEN
16956                        | FFESYMBOL_attrsARRAY
16957                        | FFESYMBOL_attrsDUMMY
16958                        | FFESYMBOL_attrsEXTERNAL
16959                        | FFESYMBOL_attrsSFARG)));
16960
16961       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16962         error = TRUE;
16963       else
16964         {
16965           kind = FFEINFO_kindFUNCTION;
16966           where = FFEINFO_whereGLOBAL;
16967         }
16968     }
16969   else if (sa == FFESYMBOL_attrsetNONE)
16970     {
16971       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16972       kind = FFEINFO_kindFUNCTION;
16973       where = FFEINFO_whereGLOBAL;
16974       needs_type = TRUE;
16975     }
16976   else
16977     error = TRUE;
16978
16979   /* Now see what we've got for a new object: NONE means a new error cropped
16980      up; ANY means an old error to be ignored; otherwise, everything's ok,
16981      update the object (symbol) and continue on. */
16982
16983   if (error)
16984     ffesymbol_error (s, t);
16985   else if (!(na & FFESYMBOL_attrsANY))
16986     {
16987       ffesymbol_signal_change (s);      /* May need to back up to previous
16988                                            version. */
16989       if (needs_type && !ffeimplic_establish_symbol (s))
16990         {
16991           ffesymbol_error (s, t);
16992           return s;
16993         }
16994       if (!ffesymbol_explicitwhere (s))
16995         {
16996           ffebad_start (FFEBAD_NEED_EXTERNAL);
16997           ffebad_here (0, ffelex_token_where_line (t),
16998                        ffelex_token_where_column (t));
16999           ffebad_string (ffesymbol_text (s));
17000           ffebad_finish ();
17001           ffesymbol_set_explicitwhere (s, TRUE);
17002         }
17003       ffesymbol_set_info (s,
17004                           ffeinfo_new (ffesymbol_basictype (s),
17005                                        ffesymbol_kindtype (s),
17006                                        ffesymbol_rank (s),
17007                                        kind,    /* FUNCTION. */
17008                                        where,   /* GLOBAL or DUMMY. */
17009                                        ffesymbol_size (s)));
17010       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17011       ffesymbol_resolve_intrin (s);
17012       ffesymbol_reference (s, t, FALSE);
17013       s = ffecom_sym_learned (s);
17014       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17015     }
17016
17017   return s;
17018 }
17019
17020 /* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
17021
17022 static ffesymbol
17023 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17024 {
17025   ffesymbolState ss;
17026
17027   /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17028      reference to it already within the imp-DO construct at this level, so as
17029      to get a symbol that is in the sfunc name space. But this is an
17030      erroneous construct, and should be caught elsewhere.  */
17031
17032   if (ffesymbol_sfdummyparent (s) == NULL)
17033     {
17034       s = ffeexpr_sym_impdoitem_ (s, t);
17035       if (ffesymbol_sfdummyparent (s) == NULL)
17036         {                       /* PARAMETER FOO...DATA (A(I),FOO=...). */
17037           ffesymbol_error (s, t);
17038           return s;
17039         }
17040     }
17041
17042   ss = ffesymbol_state (s);
17043
17044   switch (ss)
17045     {
17046     case FFESYMBOL_stateNONE:   /* Used as iterator already. */
17047       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17048         ffesymbol_error (s, t); /* Can't reuse dead iterator.  F90 disallows
17049                                    this; F77 allows it but it is a stupid
17050                                    feature. */
17051       else
17052         {                       /* Can use dead iterator because we're at at
17053                                    least a innermore (higher-numbered) level
17054                                    than the iterator's outermost
17055                                    (lowest-numbered) level.  This should be
17056                                    diagnosed later, because it means an item
17057                                    in this list didn't reference this
17058                                    iterator. */
17059 #if 1
17060           ffesymbol_error (s, t);       /* For now, complain. */
17061 #else /* Someday will detect all cases where initializer doesn't reference
17062          all applicable iterators, in which case reenable this code. */
17063           ffesymbol_signal_change (s);
17064           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17065           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17066           ffesymbol_signal_unreported (s);
17067 #endif
17068         }
17069       break;
17070
17071     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
17072                                    If seen in outermore level, can't be an
17073                                    iterator here, so complain.  If not seen
17074                                    at current level, complain for now,
17075                                    because that indicates something F90
17076                                    rejects (though we currently don't detect
17077                                    all such cases for now). */
17078       if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17079         {
17080           ffesymbol_signal_change (s);
17081           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17082           ffesymbol_signal_unreported (s);
17083         }
17084       else
17085         ffesymbol_error (s, t);
17086       break;
17087
17088     case FFESYMBOL_stateUNCERTAIN:      /* Already iterator! */
17089       assert ("DATA implied-DO control var seen twice!!" == NULL);
17090       ffesymbol_error (s, t);
17091       break;
17092
17093     case FFESYMBOL_stateUNDERSTOOD:
17094       break;                    /* ANY. */
17095
17096     default:
17097       assert ("Foo Bletch!!" == NULL);
17098       break;
17099     }
17100
17101   return s;
17102 }
17103
17104 /* Have FOO in PARAMETER (FOO=...).  */
17105
17106 static ffesymbol
17107 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17108 {
17109   ffesymbolAttrs sa;
17110
17111   sa = ffesymbol_attrs (s);
17112
17113   /* Figure out what kind of object we've got based on previous declarations
17114      of or references to the object. */
17115
17116   if (sa & ~(FFESYMBOL_attrsANYLEN
17117              | FFESYMBOL_attrsTYPE))
17118     {
17119       if (!(sa & FFESYMBOL_attrsANY))
17120         ffesymbol_error (s, t);
17121     }
17122   else
17123     {
17124       ffesymbol_signal_change (s);      /* May need to back up to previous
17125                                            version. */
17126       if (!ffeimplic_establish_symbol (s))
17127         {
17128           ffesymbol_error (s, t);
17129           return s;
17130         }
17131       ffesymbol_set_info (s,
17132                           ffeinfo_new (ffesymbol_basictype (s),
17133                                        ffesymbol_kindtype (s),
17134                                        ffesymbol_rank (s),
17135                                        FFEINFO_kindENTITY,
17136                                        FFEINFO_whereCONSTANT,
17137                                        ffesymbol_size (s)));
17138       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17139       ffesymbol_resolve_intrin (s);
17140       s = ffecom_sym_learned (s);
17141       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17142     }
17143
17144   return s;
17145 }
17146
17147 /* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
17148    embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
17149
17150 static ffesymbol
17151 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17152 {
17153   ffesymbolAttrs sa;
17154   ffesymbolAttrs na;
17155   ffeinfoKind kind;
17156   ffeinfoWhere where;
17157   ffesymbolState ns;
17158   bool needs_type = FALSE;
17159
17160   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17161           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17162
17163   na = sa = ffesymbol_attrs (s);
17164
17165   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17166                    | FFESYMBOL_attrsADJUSTABLE
17167                    | FFESYMBOL_attrsANYLEN
17168                    | FFESYMBOL_attrsARRAY
17169                    | FFESYMBOL_attrsDUMMY
17170                    | FFESYMBOL_attrsEXTERNAL
17171                    | FFESYMBOL_attrsSFARG
17172                    | FFESYMBOL_attrsTYPE)));
17173
17174   kind = ffesymbol_kind (s);
17175   where = ffesymbol_where (s);
17176
17177   /* Figure out what kind of object we've got based on previous declarations
17178      of or references to the object. */
17179
17180   ns = FFESYMBOL_stateUNDERSTOOD;
17181
17182   if (sa & FFESYMBOL_attrsEXTERNAL)
17183     {
17184       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17185                        | FFESYMBOL_attrsDUMMY
17186                        | FFESYMBOL_attrsEXTERNAL
17187                        | FFESYMBOL_attrsTYPE)));
17188
17189       if (sa & FFESYMBOL_attrsTYPE)
17190         where = FFEINFO_whereGLOBAL;
17191       else
17192         /* Not TYPE. */
17193         {
17194           ns = FFESYMBOL_stateUNCERTAIN;
17195
17196           if (sa & FFESYMBOL_attrsDUMMY)
17197             assert (kind == FFEINFO_kindNONE);  /* FUNCTION, SUBROUTINE. */
17198           else if (sa & FFESYMBOL_attrsACTUALARG)
17199             ;                   /* Not DUMMY or TYPE. */
17200           else
17201             /* Not ACTUALARG, DUMMY, or TYPE. */
17202             {
17203               assert (kind == FFEINFO_kindNONE);        /* FUNCTION, SUBROUTINE. */
17204               na |= FFESYMBOL_attrsACTUALARG;
17205               where = FFEINFO_whereGLOBAL;
17206             }
17207         }
17208     }
17209   else if (sa & FFESYMBOL_attrsDUMMY)
17210     {
17211       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17212       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17213                        | FFESYMBOL_attrsEXTERNAL
17214                        | FFESYMBOL_attrsTYPE)));
17215
17216       kind = FFEINFO_kindENTITY;
17217       if (!(sa & FFESYMBOL_attrsTYPE))
17218         needs_type = TRUE;
17219     }
17220   else if (sa & FFESYMBOL_attrsARRAY)
17221     {
17222       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17223                        | FFESYMBOL_attrsADJUSTABLE
17224                        | FFESYMBOL_attrsTYPE)));
17225
17226       where = FFEINFO_whereLOCAL;
17227     }
17228   else if (sa & FFESYMBOL_attrsSFARG)
17229     {
17230       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17231                        | FFESYMBOL_attrsTYPE)));
17232
17233       where = FFEINFO_whereLOCAL;
17234     }
17235   else if (sa & FFESYMBOL_attrsTYPE)
17236     {
17237       assert (!(sa & (FFESYMBOL_attrsARRAY
17238                       | FFESYMBOL_attrsDUMMY
17239                       | FFESYMBOL_attrsEXTERNAL
17240                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
17241       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17242                        | FFESYMBOL_attrsADJUSTABLE
17243                        | FFESYMBOL_attrsANYLEN
17244                        | FFESYMBOL_attrsARRAY
17245                        | FFESYMBOL_attrsDUMMY
17246                        | FFESYMBOL_attrsEXTERNAL
17247                        | FFESYMBOL_attrsSFARG)));
17248
17249       if (sa & FFESYMBOL_attrsANYLEN)
17250         ns = FFESYMBOL_stateNONE;
17251       else
17252         {
17253           kind = FFEINFO_kindENTITY;
17254           where = FFEINFO_whereLOCAL;
17255         }
17256     }
17257   else if (sa == FFESYMBOL_attrsetNONE)
17258     {
17259       /* New state is left empty because there isn't any state flag to
17260          set for this case, and it's UNDERSTOOD after all.  */
17261       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17262       kind = FFEINFO_kindENTITY;
17263       where = FFEINFO_whereLOCAL;
17264       needs_type = TRUE;
17265     }
17266   else
17267     ns = FFESYMBOL_stateNONE;   /* Error. */
17268
17269   /* Now see what we've got for a new object: NONE means a new error cropped
17270      up; ANY means an old error to be ignored; otherwise, everything's ok,
17271      update the object (symbol) and continue on. */
17272
17273   if (ns == FFESYMBOL_stateNONE)
17274     ffesymbol_error (s, t);
17275   else if (!(na & FFESYMBOL_attrsANY))
17276     {
17277       ffesymbol_signal_change (s);      /* May need to back up to previous
17278                                            version. */
17279       if (needs_type && !ffeimplic_establish_symbol (s))
17280         {
17281           ffesymbol_error (s, t);
17282           return s;
17283         }
17284       ffesymbol_set_info (s,
17285                           ffeinfo_new (ffesymbol_basictype (s),
17286                                        ffesymbol_kindtype (s),
17287                                        ffesymbol_rank (s),
17288                                        kind,
17289                                        where,
17290                                        ffesymbol_size (s)));
17291       ffesymbol_set_attrs (s, na);
17292       ffesymbol_set_state (s, ns);
17293       s = ffecom_sym_learned (s);
17294       ffesymbol_reference (s, t, FALSE);
17295       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17296     }
17297
17298   return s;
17299 }
17300
17301 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17302    a reference to FOO.  */
17303
17304 static ffesymbol
17305 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17306 {
17307   ffesymbolAttrs sa;
17308   ffesymbolAttrs na;
17309   ffeinfoKind kind;
17310   ffeinfoWhere where;
17311
17312   na = sa = ffesymbol_attrs (s);
17313   kind = FFEINFO_kindENTITY;
17314   where = ffesymbol_where (s);
17315
17316   /* Figure out what kind of object we've got based on previous declarations
17317      of or references to the object. */
17318
17319   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17320                | FFESYMBOL_attrsCOMMON
17321                | FFESYMBOL_attrsDUMMY
17322                | FFESYMBOL_attrsEQUIV
17323                | FFESYMBOL_attrsINIT
17324                | FFESYMBOL_attrsNAMELIST
17325                | FFESYMBOL_attrsSFARG
17326                | FFESYMBOL_attrsTYPE)))
17327     na = sa | FFESYMBOL_attrsADJUSTS;
17328   else
17329     na = FFESYMBOL_attrsetNONE;
17330
17331   /* Since this symbol definitely is going into an expression (the
17332      dimension-list for some dummy array, presumably), figure out WHERE if
17333      possible.  */
17334
17335   if (where == FFEINFO_whereNONE)
17336     {
17337       if (na & (FFESYMBOL_attrsCOMMON
17338                 | FFESYMBOL_attrsEQUIV
17339                 | FFESYMBOL_attrsINIT
17340                 | FFESYMBOL_attrsNAMELIST))
17341         where = FFEINFO_whereCOMMON;
17342       else if (na & FFESYMBOL_attrsDUMMY)
17343         where = FFEINFO_whereDUMMY;
17344     }
17345
17346   /* Now see what we've got for a new object: NONE means a new error cropped
17347      up; ANY means an old error to be ignored; otherwise, everything's ok,
17348      update the object (symbol) and continue on. */
17349
17350   if (na == FFESYMBOL_attrsetNONE)
17351     ffesymbol_error (s, t);
17352   else if (!(na & FFESYMBOL_attrsANY))
17353     {
17354       ffesymbol_signal_change (s);      /* May need to back up to previous
17355                                            version. */
17356       if (!ffeimplic_establish_symbol (s))
17357         {
17358           ffesymbol_error (s, t);
17359           return s;
17360         }
17361       ffesymbol_set_info (s,
17362                           ffeinfo_new (ffesymbol_basictype (s),
17363                                        ffesymbol_kindtype (s),
17364                                        ffesymbol_rank (s),
17365                                        kind,    /* Always ENTITY. */
17366                                        where,   /* NONE, COMMON, or DUMMY. */
17367                                        ffesymbol_size (s)));
17368       ffesymbol_set_attrs (s, na);
17369       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17370       ffesymbol_resolve_intrin (s);
17371       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17372     }
17373
17374   return s;
17375 }
17376
17377 /* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
17378    XYZ = BAR(FOO), as such cases are handled elsewhere.  */
17379
17380 static ffesymbol
17381 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17382 {
17383   ffesymbolAttrs sa;
17384   ffesymbolAttrs na;
17385   ffeinfoKind kind;
17386   ffeinfoWhere where;
17387   bool error = FALSE;
17388
17389   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17390           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17391
17392   na = sa = ffesymbol_attrs (s);
17393
17394   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17395                    | FFESYMBOL_attrsADJUSTABLE
17396                    | FFESYMBOL_attrsANYLEN
17397                    | FFESYMBOL_attrsARRAY
17398                    | FFESYMBOL_attrsDUMMY
17399                    | FFESYMBOL_attrsEXTERNAL
17400                    | FFESYMBOL_attrsSFARG
17401                    | FFESYMBOL_attrsTYPE)));
17402
17403   kind = ffesymbol_kind (s);
17404   where = ffesymbol_where (s);
17405
17406   /* Figure out what kind of object we've got based on previous declarations
17407      of or references to the object. */
17408
17409   if (sa & FFESYMBOL_attrsEXTERNAL)
17410     {
17411       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17412                        | FFESYMBOL_attrsDUMMY
17413                        | FFESYMBOL_attrsEXTERNAL
17414                        | FFESYMBOL_attrsTYPE)));
17415
17416       error = TRUE;
17417     }
17418   else if (sa & FFESYMBOL_attrsDUMMY)
17419     {
17420       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17421       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17422                        | FFESYMBOL_attrsEXTERNAL
17423                        | FFESYMBOL_attrsTYPE)));
17424
17425       kind = FFEINFO_kindENTITY;
17426     }
17427   else if (sa & FFESYMBOL_attrsARRAY)
17428     {
17429       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17430                        | FFESYMBOL_attrsADJUSTABLE
17431                        | FFESYMBOL_attrsTYPE)));
17432
17433       where = FFEINFO_whereLOCAL;
17434     }
17435   else if (sa & FFESYMBOL_attrsSFARG)
17436     {
17437       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17438                        | FFESYMBOL_attrsTYPE)));
17439
17440       where = FFEINFO_whereLOCAL;
17441     }
17442   else if (sa & FFESYMBOL_attrsTYPE)
17443     {
17444       assert (!(sa & (FFESYMBOL_attrsARRAY
17445                       | FFESYMBOL_attrsDUMMY
17446                       | FFESYMBOL_attrsEXTERNAL
17447                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
17448       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17449                        | FFESYMBOL_attrsADJUSTABLE
17450                        | FFESYMBOL_attrsANYLEN
17451                        | FFESYMBOL_attrsARRAY
17452                        | FFESYMBOL_attrsDUMMY
17453                        | FFESYMBOL_attrsEXTERNAL
17454                        | FFESYMBOL_attrsSFARG)));
17455
17456       if (sa & FFESYMBOL_attrsANYLEN)
17457         error = TRUE;
17458       else
17459         {
17460           kind = FFEINFO_kindENTITY;
17461           where = FFEINFO_whereLOCAL;
17462         }
17463     }
17464   else if (sa == FFESYMBOL_attrsetNONE)
17465     {
17466       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17467       kind = FFEINFO_kindENTITY;
17468       where = FFEINFO_whereLOCAL;
17469     }
17470   else
17471     error = TRUE;
17472
17473   /* Now see what we've got for a new object: NONE means a new error cropped
17474      up; ANY means an old error to be ignored; otherwise, everything's ok,
17475      update the object (symbol) and continue on. */
17476
17477   if (error)
17478     ffesymbol_error (s, t);
17479   else if (!(na & FFESYMBOL_attrsANY))
17480     {
17481       ffesymbol_signal_change (s);      /* May need to back up to previous
17482                                            version. */
17483       if (!ffeimplic_establish_symbol (s))
17484         {
17485           ffesymbol_error (s, t);
17486           return s;
17487         }
17488       ffesymbol_set_info (s,
17489                           ffeinfo_new (ffesymbol_basictype (s),
17490                                        ffesymbol_kindtype (s),
17491                                        ffesymbol_rank (s),
17492                                        kind,    /* ENTITY. */
17493                                        where,   /* LOCAL. */
17494                                        ffesymbol_size (s)));
17495       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17496       ffesymbol_resolve_intrin (s);
17497       s = ffecom_sym_learned (s);
17498       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17499     }
17500
17501   return s;
17502 }
17503
17504 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17505
17506    ffelexToken t;
17507    bool maybe_intrin;
17508    ffeexprParenType_ paren_type;
17509    ffesymbol s;
17510    s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17511
17512    Just like ffesymbol_declare_local, except performs any implicit info
17513    assignment necessary, and it returns the type of the parenthesized list
17514    (list of function args, list of array args, or substring spec).  */
17515
17516 static ffesymbol
17517 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17518                                 ffeexprParenType_ *paren_type)
17519 {
17520   ffesymbol s;
17521   ffesymbolState st;            /* Effective state. */
17522   ffeinfoKind k;
17523   bool bad;
17524
17525   if (maybe_intrin && ffesrc_check_symbol ())
17526     {                           /* Knock off some easy cases. */
17527       switch (ffeexpr_stack_->context)
17528         {
17529         case FFEEXPR_contextSUBROUTINEREF:
17530         case FFEEXPR_contextDATA:
17531         case FFEEXPR_contextDATAIMPDOINDEX_:
17532         case FFEEXPR_contextSFUNCDEF:
17533         case FFEEXPR_contextSFUNCDEFINDEX_:
17534         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17535         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17536         case FFEEXPR_contextLET:
17537         case FFEEXPR_contextPAREN_:
17538         case FFEEXPR_contextACTUALARGEXPR_:
17539         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17540         case FFEEXPR_contextIOLIST:
17541         case FFEEXPR_contextIOLISTDF:
17542         case FFEEXPR_contextDO:
17543         case FFEEXPR_contextDOWHILE:
17544         case FFEEXPR_contextACTUALARG_:
17545         case FFEEXPR_contextCGOTO:
17546         case FFEEXPR_contextIF:
17547         case FFEEXPR_contextARITHIF:
17548         case FFEEXPR_contextFORMAT:
17549         case FFEEXPR_contextSTOP:
17550         case FFEEXPR_contextRETURN:
17551         case FFEEXPR_contextSELECTCASE:
17552         case FFEEXPR_contextCASE:
17553         case FFEEXPR_contextFILEASSOC:
17554         case FFEEXPR_contextFILEINT:
17555         case FFEEXPR_contextFILEDFINT:
17556         case FFEEXPR_contextFILELOG:
17557         case FFEEXPR_contextFILENUM:
17558         case FFEEXPR_contextFILENUMAMBIG:
17559         case FFEEXPR_contextFILECHAR:
17560         case FFEEXPR_contextFILENUMCHAR:
17561         case FFEEXPR_contextFILEDFCHAR:
17562         case FFEEXPR_contextFILEKEY:
17563         case FFEEXPR_contextFILEUNIT:
17564         case FFEEXPR_contextFILEUNIT_DF:
17565         case FFEEXPR_contextFILEUNITAMBIG:
17566         case FFEEXPR_contextFILEFORMAT:
17567         case FFEEXPR_contextFILENAMELIST:
17568         case FFEEXPR_contextFILEVXTCODE:
17569         case FFEEXPR_contextINDEX_:
17570         case FFEEXPR_contextIMPDOITEM_:
17571         case FFEEXPR_contextIMPDOITEMDF_:
17572         case FFEEXPR_contextIMPDOCTRL_:
17573         case FFEEXPR_contextDATAIMPDOCTRL_:
17574         case FFEEXPR_contextCHARACTERSIZE:
17575         case FFEEXPR_contextPARAMETER:
17576         case FFEEXPR_contextDIMLIST:
17577         case FFEEXPR_contextDIMLISTCOMMON:
17578         case FFEEXPR_contextKINDTYPE:
17579         case FFEEXPR_contextINITVAL:
17580         case FFEEXPR_contextEQVINDEX_:
17581           break;                /* These could be intrinsic invocations. */
17582
17583         case FFEEXPR_contextAGOTO:
17584         case FFEEXPR_contextFILEFORMATNML:
17585         case FFEEXPR_contextALLOCATE:
17586         case FFEEXPR_contextDEALLOCATE:
17587         case FFEEXPR_contextHEAPSTAT:
17588         case FFEEXPR_contextNULLIFY:
17589         case FFEEXPR_contextINCLUDE:
17590         case FFEEXPR_contextDATAIMPDOITEM_:
17591         case FFEEXPR_contextLOC_:
17592         case FFEEXPR_contextINDEXORACTUALARG_:
17593         case FFEEXPR_contextSFUNCDEFACTUALARG_:
17594         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17595         case FFEEXPR_contextPARENFILENUM_:
17596         case FFEEXPR_contextPARENFILEUNIT_:
17597           maybe_intrin = FALSE;
17598           break;                /* Can't be intrinsic invocation. */
17599
17600         default:
17601           assert ("blah! blah! waaauuggh!" == NULL);
17602           break;
17603         }
17604     }
17605
17606   s = ffesymbol_declare_local (t, maybe_intrin);
17607
17608   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17609     /* Special-case these since they can involve a different concept
17610        of "state" (in the stmtfunc name space).  */
17611     {
17612     case FFEEXPR_contextDATAIMPDOINDEX_:
17613     case FFEEXPR_contextDATAIMPDOCTRL_:
17614       if (ffeexpr_context_outer_ (ffeexpr_stack_)
17615           == FFEEXPR_contextDATAIMPDOINDEX_)
17616         s = ffeexpr_sym_impdoitem_ (s, t);
17617       else
17618         if (ffeexpr_stack_->is_rhs)
17619           s = ffeexpr_sym_impdoitem_ (s, t);
17620         else
17621           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17622       if (ffesymbol_kind (s) != FFEINFO_kindANY)
17623         ffesymbol_error (s, t);
17624       return s;
17625
17626     default:
17627       break;
17628     }
17629
17630   switch ((ffesymbol_sfdummyparent (s) == NULL)
17631           ? ffesymbol_state (s)
17632           : FFESYMBOL_stateUNDERSTOOD)
17633     {
17634     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
17635                                    context. */
17636       if (!ffest_seen_first_exec ())
17637         goto seen;              /* :::::::::::::::::::: */
17638       /* Fall through. */
17639     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
17640       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17641         {
17642         case FFEEXPR_contextSUBROUTINEREF:
17643           s = ffeexpr_sym_lhs_call_ (s, t);     /* "CALL FOO"=="CALL
17644                                                    FOO(...)". */
17645           break;
17646
17647         case FFEEXPR_contextDATA:
17648           if (ffeexpr_stack_->is_rhs)
17649             s = ffeexpr_sym_rhs_let_ (s, t);
17650           else
17651             s = ffeexpr_sym_lhs_data_ (s, t);
17652           break;
17653
17654         case FFEEXPR_contextDATAIMPDOITEM_:
17655           s = ffeexpr_sym_lhs_data_ (s, t);
17656           break;
17657
17658         case FFEEXPR_contextSFUNCDEF:
17659         case FFEEXPR_contextSFUNCDEFINDEX_:
17660         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17661         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17662           s = ffecom_sym_exec_transition (s);
17663           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17664             goto understood;    /* :::::::::::::::::::: */
17665           /* Fall through. */
17666         case FFEEXPR_contextLET:
17667         case FFEEXPR_contextPAREN_:
17668         case FFEEXPR_contextACTUALARGEXPR_:
17669         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17670         case FFEEXPR_contextIOLIST:
17671         case FFEEXPR_contextIOLISTDF:
17672         case FFEEXPR_contextDO:
17673         case FFEEXPR_contextDOWHILE:
17674         case FFEEXPR_contextACTUALARG_:
17675         case FFEEXPR_contextCGOTO:
17676         case FFEEXPR_contextIF:
17677         case FFEEXPR_contextARITHIF:
17678         case FFEEXPR_contextFORMAT:
17679         case FFEEXPR_contextSTOP:
17680         case FFEEXPR_contextRETURN:
17681         case FFEEXPR_contextSELECTCASE:
17682         case FFEEXPR_contextCASE:
17683         case FFEEXPR_contextFILEASSOC:
17684         case FFEEXPR_contextFILEINT:
17685         case FFEEXPR_contextFILEDFINT:
17686         case FFEEXPR_contextFILELOG:
17687         case FFEEXPR_contextFILENUM:
17688         case FFEEXPR_contextFILENUMAMBIG:
17689         case FFEEXPR_contextFILECHAR:
17690         case FFEEXPR_contextFILENUMCHAR:
17691         case FFEEXPR_contextFILEDFCHAR:
17692         case FFEEXPR_contextFILEKEY:
17693         case FFEEXPR_contextFILEUNIT:
17694         case FFEEXPR_contextFILEUNIT_DF:
17695         case FFEEXPR_contextFILEUNITAMBIG:
17696         case FFEEXPR_contextFILEFORMAT:
17697         case FFEEXPR_contextFILENAMELIST:
17698         case FFEEXPR_contextFILEVXTCODE:
17699         case FFEEXPR_contextINDEX_:
17700         case FFEEXPR_contextIMPDOITEM_:
17701         case FFEEXPR_contextIMPDOITEMDF_:
17702         case FFEEXPR_contextIMPDOCTRL_:
17703         case FFEEXPR_contextLOC_:
17704           if (ffeexpr_stack_->is_rhs)
17705             s = ffeexpr_paren_rhs_let_ (s, t);
17706           else
17707             s = ffeexpr_paren_lhs_let_ (s, t);
17708           break;
17709
17710         case FFEEXPR_contextASSIGN:
17711         case FFEEXPR_contextAGOTO:
17712         case FFEEXPR_contextCHARACTERSIZE:
17713         case FFEEXPR_contextEQUIVALENCE:
17714         case FFEEXPR_contextINCLUDE:
17715         case FFEEXPR_contextPARAMETER:
17716         case FFEEXPR_contextDIMLIST:
17717         case FFEEXPR_contextDIMLISTCOMMON:
17718         case FFEEXPR_contextKINDTYPE:
17719         case FFEEXPR_contextINITVAL:
17720         case FFEEXPR_contextEQVINDEX_:
17721           break;                /* Will turn into errors below. */
17722
17723         default:
17724           ffesymbol_error (s, t);
17725           break;
17726         }
17727       /* Fall through. */
17728     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
17729     understood:         /* :::::::::::::::::::: */
17730
17731       /* State might have changed, update it.  */
17732       st = ((ffesymbol_sfdummyparent (s) == NULL)
17733             ? ffesymbol_state (s)
17734             : FFESYMBOL_stateUNDERSTOOD);
17735
17736       k = ffesymbol_kind (s);
17737       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17738         {
17739         case FFEEXPR_contextSUBROUTINEREF:
17740           bad = ((k != FFEINFO_kindSUBROUTINE)
17741                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17742                      || (k != FFEINFO_kindNONE)));
17743           break;
17744
17745         case FFEEXPR_contextDATA:
17746           if (ffeexpr_stack_->is_rhs)
17747             bad = (k != FFEINFO_kindENTITY)
17748               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17749           else
17750             bad = (k != FFEINFO_kindENTITY)
17751               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17752                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17753                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17754           break;
17755
17756         case FFEEXPR_contextDATAIMPDOITEM_:
17757           bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17758             || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17759                 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17760                 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17761           break;
17762
17763         case FFEEXPR_contextSFUNCDEF:
17764         case FFEEXPR_contextSFUNCDEFINDEX_:
17765         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17766         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17767         case FFEEXPR_contextLET:
17768         case FFEEXPR_contextPAREN_:
17769         case FFEEXPR_contextACTUALARGEXPR_:
17770         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17771         case FFEEXPR_contextIOLIST:
17772         case FFEEXPR_contextIOLISTDF:
17773         case FFEEXPR_contextDO:
17774         case FFEEXPR_contextDOWHILE:
17775         case FFEEXPR_contextACTUALARG_:
17776         case FFEEXPR_contextCGOTO:
17777         case FFEEXPR_contextIF:
17778         case FFEEXPR_contextARITHIF:
17779         case FFEEXPR_contextFORMAT:
17780         case FFEEXPR_contextSTOP:
17781         case FFEEXPR_contextRETURN:
17782         case FFEEXPR_contextSELECTCASE:
17783         case FFEEXPR_contextCASE:
17784         case FFEEXPR_contextFILEASSOC:
17785         case FFEEXPR_contextFILEINT:
17786         case FFEEXPR_contextFILEDFINT:
17787         case FFEEXPR_contextFILELOG:
17788         case FFEEXPR_contextFILENUM:
17789         case FFEEXPR_contextFILENUMAMBIG:
17790         case FFEEXPR_contextFILECHAR:
17791         case FFEEXPR_contextFILENUMCHAR:
17792         case FFEEXPR_contextFILEDFCHAR:
17793         case FFEEXPR_contextFILEKEY:
17794         case FFEEXPR_contextFILEUNIT:
17795         case FFEEXPR_contextFILEUNIT_DF:
17796         case FFEEXPR_contextFILEUNITAMBIG:
17797         case FFEEXPR_contextFILEFORMAT:
17798         case FFEEXPR_contextFILENAMELIST:
17799         case FFEEXPR_contextFILEVXTCODE:
17800         case FFEEXPR_contextINDEX_:
17801         case FFEEXPR_contextIMPDOITEM_:
17802         case FFEEXPR_contextIMPDOITEMDF_:
17803         case FFEEXPR_contextIMPDOCTRL_:
17804         case FFEEXPR_contextLOC_:
17805           bad = FALSE;          /* Let paren-switch handle the cases. */
17806           break;
17807
17808         case FFEEXPR_contextASSIGN:
17809         case FFEEXPR_contextAGOTO:
17810         case FFEEXPR_contextCHARACTERSIZE:
17811         case FFEEXPR_contextEQUIVALENCE:
17812         case FFEEXPR_contextPARAMETER:
17813         case FFEEXPR_contextDIMLIST:
17814         case FFEEXPR_contextDIMLISTCOMMON:
17815         case FFEEXPR_contextKINDTYPE:
17816         case FFEEXPR_contextINITVAL:
17817         case FFEEXPR_contextEQVINDEX_:
17818           bad = (k != FFEINFO_kindENTITY)
17819             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17820           break;
17821
17822         case FFEEXPR_contextINCLUDE:
17823           bad = TRUE;
17824           break;
17825
17826         default:
17827           bad = TRUE;
17828           break;
17829         }
17830
17831       switch (bad ? FFEINFO_kindANY : k)
17832         {
17833         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
17834           if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17835             {
17836               if (ffeexpr_context_outer_ (ffeexpr_stack_)
17837                   == FFEEXPR_contextSUBROUTINEREF)
17838                 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17839               else
17840                 *paren_type = FFEEXPR_parentypeFUNCTION_;
17841               break;
17842             }
17843           if (st == FFESYMBOL_stateUNDERSTOOD)
17844             {
17845               bad = TRUE;
17846               *paren_type = FFEEXPR_parentypeANY_;
17847             }
17848           else
17849             *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17850           break;
17851
17852         case FFEINFO_kindFUNCTION:
17853           *paren_type = FFEEXPR_parentypeFUNCTION_;
17854           switch (ffesymbol_where (s))
17855             {
17856             case FFEINFO_whereLOCAL:
17857               bad = TRUE;       /* Attempt to recurse! */
17858               break;
17859
17860             case FFEINFO_whereCONSTANT:
17861               bad = ((ffesymbol_sfexpr (s) == NULL)
17862                      || (ffebld_op (ffesymbol_sfexpr (s))
17863                          == FFEBLD_opANY));     /* Attempt to recurse! */
17864               break;
17865
17866             default:
17867               break;
17868             }
17869           break;
17870
17871         case FFEINFO_kindSUBROUTINE:
17872           if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17873               || (ffeexpr_stack_->previous != NULL))
17874             {
17875               bad = TRUE;
17876               *paren_type = FFEEXPR_parentypeANY_;
17877               break;
17878             }
17879
17880           *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17881           switch (ffesymbol_where (s))
17882             {
17883             case FFEINFO_whereLOCAL:
17884             case FFEINFO_whereCONSTANT:
17885               bad = TRUE;       /* Attempt to recurse! */
17886               break;
17887
17888             default:
17889               break;
17890             }
17891           break;
17892
17893         case FFEINFO_kindENTITY:
17894           if (ffesymbol_rank (s) == 0)
17895             {
17896               if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17897                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17898               else
17899                 {
17900                   bad = TRUE;
17901                   *paren_type = FFEEXPR_parentypeANY_;
17902                 }
17903             }
17904           else
17905             *paren_type = FFEEXPR_parentypeARRAY_;
17906           break;
17907
17908         default:
17909         case FFEINFO_kindANY:
17910           bad = TRUE;
17911           *paren_type = FFEEXPR_parentypeANY_;
17912           break;
17913         }
17914
17915       if (bad)
17916         {
17917           if (k == FFEINFO_kindANY)
17918             ffest_shutdown ();
17919           else
17920             ffesymbol_error (s, t);
17921         }
17922
17923       return s;
17924
17925     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
17926     seen:                       /* :::::::::::::::::::: */
17927       bad = TRUE;
17928       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17929         {
17930         case FFEEXPR_contextPARAMETER:
17931           if (ffeexpr_stack_->is_rhs)
17932             ffesymbol_error (s, t);
17933           else
17934             s = ffeexpr_sym_lhs_parameter_ (s, t);
17935           break;
17936
17937         case FFEEXPR_contextDATA:
17938           s = ffecom_sym_exec_transition (s);
17939           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17940             goto understood;    /* :::::::::::::::::::: */
17941           if (ffeexpr_stack_->is_rhs)
17942             ffesymbol_error (s, t);
17943           else
17944             s = ffeexpr_sym_lhs_data_ (s, t);
17945           goto understood;      /* :::::::::::::::::::: */
17946
17947         case FFEEXPR_contextDATAIMPDOITEM_:
17948           s = ffecom_sym_exec_transition (s);
17949           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17950             goto understood;    /* :::::::::::::::::::: */
17951           s = ffeexpr_sym_lhs_data_ (s, t);
17952           goto understood;      /* :::::::::::::::::::: */
17953
17954         case FFEEXPR_contextEQUIVALENCE:
17955           s = ffeexpr_sym_lhs_equivalence_ (s, t);
17956           bad = FALSE;
17957           break;
17958
17959         case FFEEXPR_contextDIMLIST:
17960           s = ffeexpr_sym_rhs_dimlist_ (s, t);
17961           break;
17962
17963         case FFEEXPR_contextCHARACTERSIZE:
17964         case FFEEXPR_contextKINDTYPE:
17965         case FFEEXPR_contextDIMLISTCOMMON:
17966         case FFEEXPR_contextINITVAL:
17967         case FFEEXPR_contextEQVINDEX_:
17968           break;
17969
17970         case FFEEXPR_contextINCLUDE:
17971           break;
17972
17973         case FFEEXPR_contextINDEX_:
17974         case FFEEXPR_contextACTUALARGEXPR_:
17975         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17976         case FFEEXPR_contextSFUNCDEF:
17977         case FFEEXPR_contextSFUNCDEFINDEX_:
17978         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17979         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17980           assert (ffeexpr_stack_->is_rhs);
17981           s = ffecom_sym_exec_transition (s);
17982           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17983             goto understood;    /* :::::::::::::::::::: */
17984           s = ffeexpr_paren_rhs_let_ (s, t);
17985           goto understood;      /* :::::::::::::::::::: */
17986
17987         default:
17988           break;
17989         }
17990       k = ffesymbol_kind (s);
17991       switch (bad ? FFEINFO_kindANY : k)
17992         {
17993         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
17994           *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17995           break;
17996
17997         case FFEINFO_kindFUNCTION:
17998           *paren_type = FFEEXPR_parentypeFUNCTION_;
17999           switch (ffesymbol_where (s))
18000             {
18001             case FFEINFO_whereLOCAL:
18002               bad = TRUE;       /* Attempt to recurse! */
18003               break;
18004
18005             case FFEINFO_whereCONSTANT:
18006               bad = ((ffesymbol_sfexpr (s) == NULL)
18007                      || (ffebld_op (ffesymbol_sfexpr (s))
18008                          == FFEBLD_opANY));     /* Attempt to recurse! */
18009               break;
18010
18011             default:
18012               break;
18013             }
18014           break;
18015
18016         case FFEINFO_kindSUBROUTINE:
18017           *paren_type = FFEEXPR_parentypeANY_;
18018           bad = TRUE;           /* Cannot possibly be in
18019                                    contextSUBROUTINEREF. */
18020           break;
18021
18022         case FFEINFO_kindENTITY:
18023           if (ffesymbol_rank (s) == 0)
18024             {
18025               if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18026                 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18027               else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18028                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18029               else
18030                 {
18031                   bad = TRUE;
18032                   *paren_type = FFEEXPR_parentypeANY_;
18033                 }
18034             }
18035           else
18036             *paren_type = FFEEXPR_parentypeARRAY_;
18037           break;
18038
18039         default:
18040         case FFEINFO_kindANY:
18041           bad = TRUE;
18042           *paren_type = FFEEXPR_parentypeANY_;
18043           break;
18044         }
18045
18046       if (bad)
18047         {
18048           if (k == FFEINFO_kindANY)
18049             ffest_shutdown ();
18050           else
18051             ffesymbol_error (s, t);
18052         }
18053
18054       return s;
18055
18056     default:
18057       assert ("bad symbol state" == NULL);
18058       return NULL;
18059     }
18060 }
18061
18062 /* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
18063
18064 static ffesymbol
18065 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18066 {
18067   ffesymbolAttrs sa;
18068   ffesymbolAttrs na;
18069   ffeinfoKind kind;
18070   ffeinfoWhere where;
18071   ffeintrinGen gen;
18072   ffeintrinSpec spec;
18073   ffeintrinImp imp;
18074   bool maybe_ambig = FALSE;
18075   bool error = FALSE;
18076
18077   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18078           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18079
18080   na = sa = ffesymbol_attrs (s);
18081
18082   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18083                    | FFESYMBOL_attrsADJUSTABLE
18084                    | FFESYMBOL_attrsANYLEN
18085                    | FFESYMBOL_attrsARRAY
18086                    | FFESYMBOL_attrsDUMMY
18087                    | FFESYMBOL_attrsEXTERNAL
18088                    | FFESYMBOL_attrsSFARG
18089                    | FFESYMBOL_attrsTYPE)));
18090
18091   kind = ffesymbol_kind (s);
18092   where = ffesymbol_where (s);
18093
18094   /* Figure out what kind of object we've got based on previous declarations
18095      of or references to the object. */
18096
18097   if (sa & FFESYMBOL_attrsEXTERNAL)
18098     {
18099       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18100                        | FFESYMBOL_attrsDUMMY
18101                        | FFESYMBOL_attrsEXTERNAL
18102                        | FFESYMBOL_attrsTYPE)));
18103
18104       if (sa & FFESYMBOL_attrsTYPE)
18105         where = FFEINFO_whereGLOBAL;
18106       else
18107         /* Not TYPE. */
18108         {
18109           kind = FFEINFO_kindFUNCTION;
18110
18111           if (sa & FFESYMBOL_attrsDUMMY)
18112             ;                   /* Not TYPE. */
18113           else if (sa & FFESYMBOL_attrsACTUALARG)
18114             ;                   /* Not DUMMY or TYPE. */
18115           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
18116             where = FFEINFO_whereGLOBAL;
18117         }
18118     }
18119   else if (sa & FFESYMBOL_attrsDUMMY)
18120     {
18121       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18122       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18123                        | FFESYMBOL_attrsEXTERNAL
18124                        | FFESYMBOL_attrsTYPE)));
18125
18126       kind = FFEINFO_kindFUNCTION;
18127       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure; kind
18128                                    could be ENTITY w/substring ref. */
18129     }
18130   else if (sa & FFESYMBOL_attrsARRAY)
18131     {
18132       assert (!(sa & ~(FFESYMBOL_attrsARRAY
18133                        | FFESYMBOL_attrsADJUSTABLE
18134                        | FFESYMBOL_attrsTYPE)));
18135
18136       where = FFEINFO_whereLOCAL;
18137     }
18138   else if (sa & FFESYMBOL_attrsSFARG)
18139     {
18140       assert (!(sa & ~(FFESYMBOL_attrsSFARG
18141                        | FFESYMBOL_attrsTYPE)));
18142
18143       where = FFEINFO_whereLOCAL;       /* Actually an error, but at least we
18144                                            know it's a local var. */
18145     }
18146   else if (sa & FFESYMBOL_attrsTYPE)
18147     {
18148       assert (!(sa & (FFESYMBOL_attrsARRAY
18149                       | FFESYMBOL_attrsDUMMY
18150                       | FFESYMBOL_attrsEXTERNAL
18151                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
18152       assert (!(sa & ~(FFESYMBOL_attrsTYPE
18153                        | FFESYMBOL_attrsADJUSTABLE
18154                        | FFESYMBOL_attrsANYLEN
18155                        | FFESYMBOL_attrsARRAY
18156                        | FFESYMBOL_attrsDUMMY
18157                        | FFESYMBOL_attrsEXTERNAL
18158                        | FFESYMBOL_attrsSFARG)));
18159
18160       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18161                                   &gen, &spec, &imp))
18162         {
18163           if (!(sa & FFESYMBOL_attrsANYLEN)
18164               && (ffeimplic_peek_symbol_type (s, NULL)
18165                   == FFEINFO_basictypeCHARACTER))
18166             return s;           /* Haven't learned anything yet. */
18167
18168           ffesymbol_signal_change (s);  /* May need to back up to previous
18169                                            version. */
18170           ffesymbol_set_generic (s, gen);
18171           ffesymbol_set_specific (s, spec);
18172           ffesymbol_set_implementation (s, imp);
18173           ffesymbol_set_info (s,
18174                               ffeinfo_new (ffesymbol_basictype (s),
18175                                            ffesymbol_kindtype (s),
18176                                            0,
18177                                            FFEINFO_kindFUNCTION,
18178                                            FFEINFO_whereINTRINSIC,
18179                                            ffesymbol_size (s)));
18180           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18181           ffesymbol_resolve_intrin (s);
18182           ffesymbol_reference (s, t, FALSE);
18183           s = ffecom_sym_learned (s);
18184           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
18185
18186           return s;
18187         }
18188       if (sa & FFESYMBOL_attrsANYLEN)
18189         error = TRUE;           /* Error, since the only way we can,
18190                                    given CHARACTER*(*) FOO, accept
18191                                    FOO(...) is for FOO to be a dummy
18192                                    arg or constant, but it can't
18193                                    become either now. */
18194       else if (sa & FFESYMBOL_attrsADJUSTABLE)
18195         {
18196           kind = FFEINFO_kindENTITY;
18197           where = FFEINFO_whereLOCAL;
18198         }
18199       else
18200         {
18201           kind = FFEINFO_kindFUNCTION;
18202           where = FFEINFO_whereGLOBAL;
18203           maybe_ambig = TRUE;   /* If basictypeCHARACTER, can't be sure;
18204                                    could be ENTITY/LOCAL w/substring ref. */
18205         }
18206     }
18207   else if (sa == FFESYMBOL_attrsetNONE)
18208     {
18209       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18210
18211       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18212                                   &gen, &spec, &imp))
18213         {
18214           if (ffeimplic_peek_symbol_type (s, NULL)
18215               == FFEINFO_basictypeCHARACTER)
18216             return s;           /* Haven't learned anything yet. */
18217
18218           ffesymbol_signal_change (s);  /* May need to back up to previous
18219                                            version. */
18220           ffesymbol_set_generic (s, gen);
18221           ffesymbol_set_specific (s, spec);
18222           ffesymbol_set_implementation (s, imp);
18223           ffesymbol_set_info (s,
18224                               ffeinfo_new (ffesymbol_basictype (s),
18225                                            ffesymbol_kindtype (s),
18226                                            0,
18227                                            FFEINFO_kindFUNCTION,
18228                                            FFEINFO_whereINTRINSIC,
18229                                            ffesymbol_size (s)));
18230           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18231           ffesymbol_resolve_intrin (s);
18232           s = ffecom_sym_learned (s);
18233           ffesymbol_reference (s, t, FALSE);
18234           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
18235           return s;
18236         }
18237
18238       kind = FFEINFO_kindFUNCTION;
18239       where = FFEINFO_whereGLOBAL;
18240       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure;
18241                                    could be ENTITY/LOCAL w/substring ref. */
18242     }
18243   else
18244     error = TRUE;
18245
18246   /* Now see what we've got for a new object: NONE means a new error cropped
18247      up; ANY means an old error to be ignored; otherwise, everything's ok,
18248      update the object (symbol) and continue on. */
18249
18250   if (error)
18251     ffesymbol_error (s, t);
18252   else if (!(na & FFESYMBOL_attrsANY))
18253     {
18254       ffesymbol_signal_change (s);      /* May need to back up to previous
18255                                            version. */
18256       if (!ffeimplic_establish_symbol (s))
18257         {
18258           ffesymbol_error (s, t);
18259           return s;
18260         }
18261       if (maybe_ambig
18262           && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18263         return s;               /* Still not sure, let caller deal with it
18264                                    based on (...). */
18265
18266       ffesymbol_set_info (s,
18267                           ffeinfo_new (ffesymbol_basictype (s),
18268                                        ffesymbol_kindtype (s),
18269                                        ffesymbol_rank (s),
18270                                        kind,
18271                                        where,
18272                                        ffesymbol_size (s)));
18273       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18274       ffesymbol_resolve_intrin (s);
18275       s = ffecom_sym_learned (s);
18276       ffesymbol_reference (s, t, FALSE);
18277       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
18278     }
18279
18280   return s;
18281 }
18282
18283 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18284
18285    Return a pointer to this function to the lexer (ffelex), which will
18286    invoke it for the next token.
18287
18288    Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
18289
18290 static ffelexHandler
18291 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18292 {
18293   ffeexprExpr_ procedure;
18294   ffebld reduced;
18295   ffeinfo info;
18296   ffeexprContext ctx;
18297   bool check_intrin = FALSE;    /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18298
18299   procedure = ffeexpr_stack_->exprstack;
18300   info = ffebld_info (procedure->u.operand);
18301
18302   /* Is there an expression to add?  If the expression is nil,
18303      it might still be an argument.  It is if:
18304
18305        -  The current token is comma, or
18306
18307        -  The -fugly-comma flag was specified *and* the procedure
18308           being invoked is external.
18309
18310      Otherwise, if neither of the above is the case, just
18311      ignore this (nil) expression.  */
18312
18313   if ((expr != NULL)
18314       || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18315       || (ffe_is_ugly_comma ()
18316           && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18317     {
18318       /* This expression, even if nil, is apparently intended as an argument.  */
18319
18320       /* Internal procedure (CONTAINS, or statement function)?  */
18321
18322       if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18323         {
18324           if ((expr == NULL)
18325               && ffebad_start (FFEBAD_NULL_ARGUMENT))
18326             {
18327               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18328                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18329               ffebad_here (1, ffelex_token_where_line (t),
18330                            ffelex_token_where_column (t));
18331               ffebad_finish ();
18332             }
18333
18334           if (expr == NULL)
18335             ;
18336           else
18337             {
18338               if (ffeexpr_stack_->next_dummy == NULL)
18339                 {                       /* Report later which was the first extra argument. */
18340                   if (ffeexpr_stack_->tokens[1] == NULL)
18341                     {
18342                       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18343                       ffeexpr_stack_->num_args = 0;
18344                     }
18345                   ++ffeexpr_stack_->num_args;   /* Count # of extra arguments. */
18346                 }
18347               else
18348                 {
18349                   if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18350                       && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18351                     {
18352                       ffebad_here (0,
18353                                    ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18354                                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18355                       ffebad_here (1, ffelex_token_where_line (ft),
18356                                    ffelex_token_where_column (ft));
18357                       ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18358                                                      (ffebld_symter (ffebld_head
18359                                                                      (ffeexpr_stack_->next_dummy)))));
18360                       ffebad_finish ();
18361                     }
18362                   else
18363                     {
18364                       expr = ffeexpr_convert_expr (expr, ft,
18365                                                    ffebld_head (ffeexpr_stack_->next_dummy),
18366                                                    ffeexpr_stack_->tokens[0],
18367                                                    FFEEXPR_contextLET);
18368                       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18369                     }
18370                   --ffeexpr_stack_->num_args;   /* Count down # of args. */
18371                   ffeexpr_stack_->next_dummy
18372                     = ffebld_trail (ffeexpr_stack_->next_dummy);
18373                 }
18374             }
18375         }
18376       else
18377         {
18378           if ((expr == NULL)
18379               && ffe_is_pedantic ()
18380               && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18381             {
18382               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18383                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18384               ffebad_here (1, ffelex_token_where_line (t),
18385                            ffelex_token_where_column (t));
18386               ffebad_finish ();
18387             }
18388           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18389         }
18390     }
18391
18392   switch (ffelex_token_type (t))
18393     {
18394     case FFELEX_typeCOMMA:
18395       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18396         {
18397         case FFEEXPR_contextSFUNCDEF:
18398         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18399         case FFEEXPR_contextSFUNCDEFINDEX_:
18400         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18401           ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18402           break;
18403
18404         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18405         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18406           assert ("bad context" == NULL);
18407           ctx = FFEEXPR_context;
18408           break;
18409
18410         default:
18411           ctx = FFEEXPR_contextACTUALARG_;
18412           break;
18413         }
18414       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18415                                           ffeexpr_token_arguments_);
18416
18417     default:
18418       break;
18419     }
18420
18421   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18422       && (ffeexpr_stack_->next_dummy != NULL))
18423     {                           /* Too few arguments. */
18424       if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18425         {
18426           char num[10];
18427
18428           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18429
18430           ffebad_here (0, ffelex_token_where_line (t),
18431                        ffelex_token_where_column (t));
18432           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18433                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18434           ffebad_string (num);
18435           ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18436                               (ffebld_head (ffeexpr_stack_->next_dummy)))));
18437           ffebad_finish ();
18438         }
18439       for (;
18440            ffeexpr_stack_->next_dummy != NULL;
18441            ffeexpr_stack_->next_dummy
18442            = ffebld_trail (ffeexpr_stack_->next_dummy))
18443         {
18444           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18445           ffebld_set_info (expr, ffeinfo_new_any ());
18446           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18447         }
18448     }
18449
18450   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18451       && (ffeexpr_stack_->tokens[1] != NULL))
18452     {                           /* Too many arguments to statement function. */
18453       if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18454         {
18455           char num[10];
18456
18457           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18458
18459           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18460                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18461           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18462                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18463           ffebad_string (num);
18464           ffebad_finish ();
18465         }
18466       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18467     }
18468   ffebld_end_list (&ffeexpr_stack_->bottom);
18469
18470   if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18471     {
18472       reduced = ffebld_new_any ();
18473       ffebld_set_info (reduced, ffeinfo_new_any ());
18474     }
18475   else
18476     {
18477       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18478         reduced = ffebld_new_funcref (procedure->u.operand,
18479                                       ffeexpr_stack_->expr);
18480       else
18481         reduced = ffebld_new_subrref (procedure->u.operand,
18482                                       ffeexpr_stack_->expr);
18483       if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18484         ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18485       else if (ffebld_symter_specific (procedure->u.operand)
18486                != FFEINTRIN_specNONE)
18487         ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18488                                     ffeexpr_stack_->tokens[0]);
18489       else
18490         ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18491
18492       if (ffebld_op (reduced) != FFEBLD_opANY)
18493         ffebld_set_info (reduced,
18494                          ffeinfo_new (ffeinfo_basictype (info),
18495                                       ffeinfo_kindtype (info),
18496                                       0,
18497                                       FFEINFO_kindENTITY,
18498                                       FFEINFO_whereFLEETING,
18499                                       ffeinfo_size (info)));
18500       else
18501         ffebld_set_info (reduced, ffeinfo_new_any ());
18502     }
18503   if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18504     reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18505   ffeexpr_stack_->exprstack = procedure->previous;      /* Pops
18506                                                            not-quite-operand off
18507                                                            stack. */
18508   procedure->u.operand = reduced;       /* Save the line/column ffewhere
18509                                            info. */
18510   ffeexpr_exprstack_push_operand_ (procedure);  /* Push it back on stack. */
18511   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18512     {
18513       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18514       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FUNC(3)(1:1)".... */
18515
18516       /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18517          Z is DOUBLE COMPLEX), and a command-line option doesn't already
18518          establish interpretation, probably complain.  */
18519
18520       if (check_intrin
18521           && !ffe_is_90 ()
18522           && !ffe_is_ugly_complex ())
18523         {
18524           /* If the outer expression is REAL(me...), issue diagnostic
18525              only if next token isn't the close-paren for REAL(me).  */
18526
18527           if ((ffeexpr_stack_->previous != NULL)
18528               && (ffeexpr_stack_->previous->exprstack != NULL)
18529               && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18530               && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18531               && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18532               && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18533             return (ffelexHandler) ffeexpr_token_intrincheck_;
18534
18535           /* Diagnose the ambiguity now.  */
18536
18537           if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18538             {
18539               ffebad_string (ffeintrin_name_implementation
18540                              (ffebld_symter_implementation
18541                               (ffebld_left
18542                                (ffeexpr_stack_->exprstack->u.operand))));
18543               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18544                            ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18545               ffebad_finish ();
18546             }
18547         }
18548       return (ffelexHandler) ffeexpr_token_substrp_;
18549     }
18550
18551   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18552     {
18553       ffebad_here (0, ffelex_token_where_line (t),
18554                    ffelex_token_where_column (t));
18555       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18556                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18557       ffebad_finish ();
18558     }
18559   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18560   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18561   return
18562     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18563                                                (ffelexHandler)
18564                                                ffeexpr_token_substrp_);
18565 }
18566
18567 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18568
18569    Return a pointer to this array to the lexer (ffelex), which will
18570    invoke it for the next token.
18571
18572    Handle expression and COMMA or CLOSE_PAREN.  */
18573
18574 static ffelexHandler
18575 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18576 {
18577   ffeexprExpr_ array;
18578   ffebld reduced;
18579   ffeinfo info;
18580   ffeinfoWhere where;
18581   ffetargetIntegerDefault val;
18582   ffetargetIntegerDefault lval = 0;
18583   ffetargetIntegerDefault uval = 0;
18584   ffebld lbound;
18585   ffebld ubound;
18586   bool lcheck;
18587   bool ucheck;
18588
18589   array = ffeexpr_stack_->exprstack;
18590   info = ffebld_info (array->u.operand);
18591
18592   if ((expr == NULL)            /* && ((ffeexpr_stack_->rank != 0) ||
18593                                    (ffelex_token_type(t) ==
18594          FFELEX_typeCOMMA)) */ )
18595     {
18596       if (ffebad_start (FFEBAD_NULL_ELEMENT))
18597         {
18598           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18599                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18600           ffebad_here (1, ffelex_token_where_line (t),
18601                        ffelex_token_where_column (t));
18602           ffebad_finish ();
18603         }
18604       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18605         {                       /* Don't bother if we're going to complain
18606                                    later! */
18607           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18608           ffebld_set_info (expr, ffeinfo_new_any ());
18609         }
18610     }
18611
18612   if (expr == NULL)
18613     ;
18614   else if (ffeinfo_rank (info) == 0)
18615     {                           /* In EQUIVALENCE context, ffeinfo_rank(info)
18616                                    may == 0. */
18617       ++ffeexpr_stack_->rank;   /* Track anyway, may need for new VXT
18618                                    feature. */
18619       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18620     }
18621   else
18622     {
18623       ++ffeexpr_stack_->rank;
18624       if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18625         {                       /* Report later which was the first extra
18626                                    element. */
18627           if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18628             ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18629         }
18630       else
18631         {
18632           switch (ffeinfo_where (ffebld_info (expr)))
18633             {
18634             case FFEINFO_whereCONSTANT:
18635               break;
18636
18637             case FFEINFO_whereIMMEDIATE:
18638               ffeexpr_stack_->constant = FALSE;
18639               break;
18640
18641             default:
18642               ffeexpr_stack_->constant = FALSE;
18643               ffeexpr_stack_->immediate = FALSE;
18644               break;
18645             }
18646           if (ffebld_op (expr) == FFEBLD_opCONTER
18647               && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18648             {
18649               val = ffebld_constant_integerdefault (ffebld_conter (expr));
18650
18651               lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18652               if (lbound == NULL)
18653                 {
18654                   lcheck = TRUE;
18655                   lval = 1;
18656                 }
18657               else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18658                 {
18659                   lcheck = TRUE;
18660                   lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18661                 }
18662               else
18663                 lcheck = FALSE;
18664
18665               ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18666               assert (ubound != NULL);
18667               if (ffebld_op (ubound) == FFEBLD_opCONTER)
18668                 {
18669                   ucheck = TRUE;
18670                   uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18671                 }
18672               else
18673                 ucheck = FALSE;
18674
18675               if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18676                 {
18677                   ffebad_start (FFEBAD_RANGE_ARRAY);
18678                   ffebad_here (0, ffelex_token_where_line (ft),
18679                                ffelex_token_where_column (ft));
18680                   ffebad_finish ();
18681                 }
18682             }
18683           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18684           ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18685         }
18686     }
18687
18688   switch (ffelex_token_type (t))
18689     {
18690     case FFELEX_typeCOMMA:
18691       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18692         {
18693         case FFEEXPR_contextDATAIMPDOITEM_:
18694           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18695                                               FFEEXPR_contextDATAIMPDOINDEX_,
18696                                               ffeexpr_token_elements_);
18697
18698         case FFEEXPR_contextEQUIVALENCE:
18699           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18700                                               FFEEXPR_contextEQVINDEX_,
18701                                               ffeexpr_token_elements_);
18702
18703         case FFEEXPR_contextSFUNCDEF:
18704         case FFEEXPR_contextSFUNCDEFINDEX_:
18705           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18706                                               FFEEXPR_contextSFUNCDEFINDEX_,
18707                                               ffeexpr_token_elements_);
18708
18709         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18710         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18711           assert ("bad context" == NULL);
18712           break;
18713
18714         default:
18715           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18716                                               FFEEXPR_contextINDEX_,
18717                                               ffeexpr_token_elements_);
18718         }
18719
18720     default:
18721       break;
18722     }
18723
18724   if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18725       && (ffeinfo_rank (info) != 0))
18726     {
18727       char num[10];
18728
18729       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18730         {
18731           if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18732             {
18733               sprintf (num, "%d",
18734                        (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18735
18736               ffebad_here (0, ffelex_token_where_line (t),
18737                            ffelex_token_where_column (t));
18738               ffebad_here (1,
18739                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18740                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18741               ffebad_string (num);
18742               ffebad_finish ();
18743             }
18744         }
18745       else
18746         {
18747           if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18748             {
18749               sprintf (num, "%d",
18750                        (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18751
18752               ffebad_here (0,
18753                         ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18754                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18755               ffebad_here (1,
18756                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18757                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18758               ffebad_string (num);
18759               ffebad_finish ();
18760             }
18761           ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18762         }
18763       while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18764         {
18765           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18766           ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18767                                               FFEINFO_kindtypeINTEGERDEFAULT,
18768                                               0, FFEINFO_kindENTITY,
18769                                               FFEINFO_whereCONSTANT,
18770                                               FFETARGET_charactersizeNONE));
18771           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18772         }
18773     }
18774   ffebld_end_list (&ffeexpr_stack_->bottom);
18775
18776   if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18777     {
18778       reduced = ffebld_new_any ();
18779       ffebld_set_info (reduced, ffeinfo_new_any ());
18780     }
18781   else
18782     {
18783       reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18784       if (ffeexpr_stack_->constant)
18785         where = FFEINFO_whereFLEETING_CADDR;
18786       else if (ffeexpr_stack_->immediate)
18787         where = FFEINFO_whereFLEETING_IADDR;
18788       else
18789         where = FFEINFO_whereFLEETING;
18790       ffebld_set_info (reduced,
18791                        ffeinfo_new (ffeinfo_basictype (info),
18792                                     ffeinfo_kindtype (info),
18793                                     0,
18794                                     FFEINFO_kindENTITY,
18795                                     where,
18796                                     ffeinfo_size (info)));
18797       reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18798     }
18799
18800   ffeexpr_stack_->exprstack = array->previous;  /* Pops not-quite-operand off
18801                                                    stack. */
18802   array->u.operand = reduced;   /* Save the line/column ffewhere info. */
18803   ffeexpr_exprstack_push_operand_ (array);      /* Push it back on stack. */
18804
18805   switch (ffeinfo_basictype (info))
18806     {
18807     case FFEINFO_basictypeCHARACTER:
18808       ffeexpr_is_substr_ok_ = TRUE;     /* Everyone likes "FOO(3)(1:1)".... */
18809       break;
18810
18811     case FFEINFO_basictypeNONE:
18812       ffeexpr_is_substr_ok_ = TRUE;
18813       assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18814       break;
18815
18816     default:
18817       ffeexpr_is_substr_ok_ = FALSE;
18818       break;
18819     }
18820
18821   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18822     {
18823       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18824       return (ffelexHandler) ffeexpr_token_substrp_;
18825     }
18826
18827   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18828     {
18829       ffebad_here (0, ffelex_token_where_line (t),
18830                    ffelex_token_where_column (t));
18831       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18832                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18833       ffebad_finish ();
18834     }
18835   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18836   return
18837     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18838                                                (ffelexHandler)
18839                                                ffeexpr_token_substrp_);
18840 }
18841
18842 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18843
18844    Return a pointer to this array to the lexer (ffelex), which will
18845    invoke it for the next token.
18846
18847    If token is COLON, pass off to _substr_, else init list and pass off
18848    to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
18849    ? marks the token, and where FOO's rank/type has not yet been established,
18850    meaning we could be in a list of indices or in a substring
18851    specification.  */
18852
18853 static ffelexHandler
18854 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18855 {
18856   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18857     return ffeexpr_token_substring_ (ft, expr, t);
18858
18859   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18860   return ffeexpr_token_elements_ (ft, expr, t);
18861 }
18862
18863 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18864
18865    Return a pointer to this function to the lexer (ffelex), which will
18866    invoke it for the next token.
18867
18868    Handle expression (which may be null) and COLON.  */
18869
18870 static ffelexHandler
18871 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18872 {
18873   ffeexprExpr_ string;
18874   ffeinfo info;
18875   ffetargetIntegerDefault i;
18876   ffeexprContext ctx;
18877   ffetargetCharacterSize size;
18878
18879   string = ffeexpr_stack_->exprstack;
18880   info = ffebld_info (string->u.operand);
18881   size = ffebld_size_max (string->u.operand);
18882
18883   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18884     {
18885       if ((expr != NULL)
18886           && (ffebld_op (expr) == FFEBLD_opCONTER)
18887           && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18888                < 1)
18889               || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18890         {
18891           ffebad_start (FFEBAD_RANGE_SUBSTR);
18892           ffebad_here (0, ffelex_token_where_line (ft),
18893                        ffelex_token_where_column (ft));
18894           ffebad_finish ();
18895         }
18896       ffeexpr_stack_->expr = expr;
18897
18898       switch (ffeexpr_stack_->context)
18899         {
18900         case FFEEXPR_contextSFUNCDEF:
18901         case FFEEXPR_contextSFUNCDEFINDEX_:
18902           ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18903           break;
18904
18905         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18906         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18907           assert ("bad context" == NULL);
18908           ctx = FFEEXPR_context;
18909           break;
18910
18911         default:
18912           ctx = FFEEXPR_contextINDEX_;
18913           break;
18914         }
18915
18916       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18917                                           ffeexpr_token_substring_1_);
18918     }
18919
18920   if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18921     {
18922       ffebad_here (0, ffelex_token_where_line (t),
18923                    ffelex_token_where_column (t));
18924       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18925                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18926       ffebad_finish ();
18927     }
18928
18929   ffeexpr_stack_->expr = NULL;
18930   return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18931 }
18932
18933 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18934
18935    Return a pointer to this function to the lexer (ffelex), which will
18936    invoke it for the next token.
18937
18938    Handle expression (which might be null) and CLOSE_PAREN.  */
18939
18940 static ffelexHandler
18941 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18942 {
18943   ffeexprExpr_ string;
18944   ffebld reduced;
18945   ffebld substrlist;
18946   ffebld first = ffeexpr_stack_->expr;
18947   ffebld strop;
18948   ffeinfo info;
18949   ffeinfoWhere lwh;
18950   ffeinfoWhere rwh;
18951   ffeinfoWhere where;
18952   ffeinfoKindtype first_kt;
18953   ffeinfoKindtype last_kt;
18954   ffetargetIntegerDefault first_val;
18955   ffetargetIntegerDefault last_val;
18956   ffetargetCharacterSize size;
18957   ffetargetCharacterSize strop_size_max;
18958   bool first_known;
18959
18960   string = ffeexpr_stack_->exprstack;
18961   strop = string->u.operand;
18962   info = ffebld_info (strop);
18963
18964   if (first == NULL
18965       || (ffebld_op (first) == FFEBLD_opCONTER
18966           && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18967     {                           /* The starting point is known. */
18968       first_val = (first == NULL) ? 1
18969         : ffebld_constant_integerdefault (ffebld_conter (first));
18970       first_known = TRUE;
18971     }
18972   else
18973     {                           /* Assume start of the entity. */
18974       first_val = 1;
18975       first_known = FALSE;
18976     }
18977
18978   if (last != NULL
18979       && (ffebld_op (last) == FFEBLD_opCONTER
18980           && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18981     {                           /* The ending point is known. */
18982       last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18983
18984       if (first_known)
18985         {                       /* The beginning point is a constant. */
18986           if (first_val <= last_val)
18987             size = last_val - first_val + 1;
18988           else
18989             {
18990               if (0 && ffe_is_90 ())
18991                 size = 0;
18992               else
18993                 {
18994                   size = 1;
18995                   ffebad_start (FFEBAD_ZERO_SIZE);
18996                   ffebad_here (0, ffelex_token_where_line (ft),
18997                                ffelex_token_where_column (ft));
18998                   ffebad_finish ();
18999                 }
19000             }
19001         }
19002       else
19003         size = FFETARGET_charactersizeNONE;
19004
19005       strop_size_max = ffebld_size_max (strop);
19006
19007       if ((strop_size_max != FFETARGET_charactersizeNONE)
19008           && (last_val > strop_size_max))
19009         {                       /* Beyond maximum possible end of string. */
19010           ffebad_start (FFEBAD_RANGE_SUBSTR);
19011           ffebad_here (0, ffelex_token_where_line (ft),
19012                        ffelex_token_where_column (ft));
19013           ffebad_finish ();
19014         }
19015     }
19016   else
19017     size = FFETARGET_charactersizeNONE; /* The size is not known. */
19018
19019 #if 0                           /* Don't do this, or "is size of target
19020                                    known?" would no longer be easily
19021                                    answerable.  To see if there is a max
19022                                    size, use ffebld_size_max; to get only the
19023                                    known size, else NONE, use
19024                                    ffebld_size_known; use ffebld_size if
19025                                    values are sure to be the same (not
19026                                    opSUBSTR or opCONCATENATE or known to have
19027                                    known length). By getting rid of this
19028                                    "useful info" stuff, we don't end up
19029                                    blank-padding the constant in the
19030                                    assignment "A(I:J)='XYZ'" to the known
19031                                    length of A. */
19032   if (size == FFETARGET_charactersizeNONE)
19033     size = strop_size_max;      /* Assume we use the entire string. */
19034 #endif
19035
19036   substrlist
19037     = ffebld_new_item
19038     (first,
19039      ffebld_new_item
19040      (last,
19041       NULL
19042      )
19043     )
19044     ;
19045
19046   if (first == NULL)
19047     lwh = FFEINFO_whereCONSTANT;
19048   else
19049     lwh = ffeinfo_where (ffebld_info (first));
19050   if (last == NULL)
19051     rwh = FFEINFO_whereCONSTANT;
19052   else
19053     rwh = ffeinfo_where (ffebld_info (last));
19054
19055   switch (lwh)
19056     {
19057     case FFEINFO_whereCONSTANT:
19058       switch (rwh)
19059         {
19060         case FFEINFO_whereCONSTANT:
19061           where = FFEINFO_whereCONSTANT;
19062           break;
19063
19064         case FFEINFO_whereIMMEDIATE:
19065           where = FFEINFO_whereIMMEDIATE;
19066           break;
19067
19068         default:
19069           where = FFEINFO_whereFLEETING;
19070           break;
19071         }
19072       break;
19073
19074     case FFEINFO_whereIMMEDIATE:
19075       switch (rwh)
19076         {
19077         case FFEINFO_whereCONSTANT:
19078         case FFEINFO_whereIMMEDIATE:
19079           where = FFEINFO_whereIMMEDIATE;
19080           break;
19081
19082         default:
19083           where = FFEINFO_whereFLEETING;
19084           break;
19085         }
19086       break;
19087
19088     default:
19089       where = FFEINFO_whereFLEETING;
19090       break;
19091     }
19092
19093   if (first == NULL)
19094     first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19095   else
19096     first_kt = ffeinfo_kindtype (ffebld_info (first));
19097   if (last == NULL)
19098     last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19099   else
19100     last_kt = ffeinfo_kindtype (ffebld_info (last));
19101
19102   switch (where)
19103     {
19104     case FFEINFO_whereCONSTANT:
19105       switch (ffeinfo_where (info))
19106         {
19107         case FFEINFO_whereCONSTANT:
19108           break;
19109
19110         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
19111           where = FFEINFO_whereIMMEDIATE;
19112           break;
19113
19114         default:
19115           where = FFEINFO_whereFLEETING_CADDR;
19116           break;
19117         }
19118       break;
19119
19120     case FFEINFO_whereIMMEDIATE:
19121       switch (ffeinfo_where (info))
19122         {
19123         case FFEINFO_whereCONSTANT:
19124         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
19125           break;
19126
19127         default:
19128           where = FFEINFO_whereFLEETING_IADDR;
19129           break;
19130         }
19131       break;
19132
19133     default:
19134       switch (ffeinfo_where (info))
19135         {
19136         case FFEINFO_whereCONSTANT:
19137           where = FFEINFO_whereCONSTANT_SUBOBJECT;      /* An F90 concept. */
19138           break;
19139
19140         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
19141         default:
19142           where = FFEINFO_whereFLEETING;
19143           break;
19144         }
19145       break;
19146     }
19147
19148   if (ffebld_op (strop) == FFEBLD_opANY)
19149     {
19150       reduced = ffebld_new_any ();
19151       ffebld_set_info (reduced, ffeinfo_new_any ());
19152     }
19153   else
19154     {
19155       reduced = ffebld_new_substr (strop, substrlist);
19156       ffebld_set_info (reduced, ffeinfo_new
19157                        (FFEINFO_basictypeCHARACTER,
19158                         ffeinfo_kindtype (info),
19159                         0,
19160                         FFEINFO_kindENTITY,
19161                         where,
19162                         size));
19163       reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19164     }
19165
19166   ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19167                                                    stack. */
19168   string->u.operand = reduced;  /* Save the line/column ffewhere info. */
19169   ffeexpr_exprstack_push_operand_ (string);     /* Push it back on stack. */
19170
19171   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19172     {
19173       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19174       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FOO(3:5)(1:1)".... */
19175       return (ffelexHandler) ffeexpr_token_substrp_;
19176     }
19177
19178   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19179     {
19180       ffebad_here (0, ffelex_token_where_line (t),
19181                    ffelex_token_where_column (t));
19182       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19183                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19184       ffebad_finish ();
19185     }
19186
19187   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19188   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19189   return
19190     (ffelexHandler) ffeexpr_find_close_paren_ (t,
19191                                                (ffelexHandler)
19192                                                ffeexpr_token_substrp_);
19193 }
19194
19195 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19196
19197    Return a pointer to this function to the lexer (ffelex), which will
19198    invoke it for the next token.
19199
19200    If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19201    issue error message if flag (serves as argument) is set.  Else, just
19202    forward token to binary_.  */
19203
19204 static ffelexHandler
19205 ffeexpr_token_substrp_ (ffelexToken t)
19206 {
19207   ffeexprContext ctx;
19208
19209   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19210     return (ffelexHandler) ffeexpr_token_binary_ (t);
19211
19212   ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19213
19214   switch (ffeexpr_stack_->context)
19215     {
19216     case FFEEXPR_contextSFUNCDEF:
19217     case FFEEXPR_contextSFUNCDEFINDEX_:
19218       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19219       break;
19220
19221     case FFEEXPR_contextSFUNCDEFACTUALARG_:
19222     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19223       assert ("bad context" == NULL);
19224       ctx = FFEEXPR_context;
19225       break;
19226
19227     default:
19228       ctx = FFEEXPR_contextINDEX_;
19229       break;
19230     }
19231
19232   if (!ffeexpr_is_substr_ok_)
19233     {
19234       if (ffebad_start (FFEBAD_BAD_SUBSTR))
19235         {
19236           ffebad_here (0, ffelex_token_where_line (t),
19237                        ffelex_token_where_column (t));
19238           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19239                        ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19240           ffebad_finish ();
19241         }
19242
19243       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19244                                           ffeexpr_token_anything_);
19245     }
19246
19247   return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19248                                       ffeexpr_token_substring_);
19249 }
19250
19251 static ffelexHandler
19252 ffeexpr_token_intrincheck_ (ffelexToken t)
19253 {
19254   if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19255       && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19256     {
19257       ffebad_string (ffeintrin_name_implementation
19258                      (ffebld_symter_implementation
19259                       (ffebld_left
19260                        (ffeexpr_stack_->exprstack->u.operand))));
19261       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19262                    ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19263       ffebad_finish ();
19264     }
19265
19266   return (ffelexHandler) ffeexpr_token_substrp_ (t);
19267 }
19268
19269 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19270
19271    Return a pointer to this function to the lexer (ffelex), which will
19272    invoke it for the next token.
19273
19274    If COLON, do everything we would have done since _parenthesized_ if
19275    we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19276    If not COLON, do likewise for kindFUNCTION instead.  */
19277
19278 static ffelexHandler
19279 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19280 {
19281   ffeinfoWhere where;
19282   ffesymbol s;
19283   ffesymbolAttrs sa;
19284   ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19285   bool needs_type;
19286   ffeintrinGen gen;
19287   ffeintrinSpec spec;
19288   ffeintrinImp imp;
19289
19290   s = ffebld_symter (symter);
19291   sa = ffesymbol_attrs (s);
19292   where = ffesymbol_where (s);
19293
19294   /* We get here only if we don't already know enough about FOO when seeing a
19295      FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
19296      "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19297      Else FOO is a function, either intrinsic or external.  If intrinsic, it
19298      wouldn't necessarily be CHARACTER type, so unless it has already been
19299      declared DUMMY, it hasn't had its type established yet.  It can't be
19300      CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
19301
19302   assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19303                    | FFESYMBOL_attrsTYPE)));
19304
19305   needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19306
19307   ffesymbol_signal_change (s);  /* Probably already done, but in case.... */
19308
19309   if (ffelex_token_type (t) == FFELEX_typeCOLON)
19310     {                           /* Definitely an ENTITY (char substring). */
19311       if (needs_type && !ffeimplic_establish_symbol (s))
19312         {
19313           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19314           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19315         }
19316
19317       ffesymbol_set_info (s,
19318                           ffeinfo_new (ffesymbol_basictype (s),
19319                                        ffesymbol_kindtype (s),
19320                                        ffesymbol_rank (s),
19321                                        FFEINFO_kindENTITY,
19322                                        (where == FFEINFO_whereNONE)
19323                                        ? FFEINFO_whereLOCAL
19324                                        : where,
19325                                        ffesymbol_size (s)));
19326       ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19327
19328       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19329       ffesymbol_resolve_intrin (s);
19330       s = ffecom_sym_learned (s);
19331       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
19332
19333       ffeexpr_stack_->exprstack->u.operand
19334         = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19335
19336       return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19337     }
19338
19339   /* The "stuff" isn't a substring notation, so we now know the overall
19340      reference is to a function.  */
19341
19342   if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19343                               FALSE, &gen, &spec, &imp))
19344     {
19345       ffebld_symter_set_generic (symter, gen);
19346       ffebld_symter_set_specific (symter, spec);
19347       ffebld_symter_set_implementation (symter, imp);
19348       ffesymbol_set_generic (s, gen);
19349       ffesymbol_set_specific (s, spec);
19350       ffesymbol_set_implementation (s, imp);
19351       ffesymbol_set_info (s,
19352                           ffeinfo_new (ffesymbol_basictype (s),
19353                                        ffesymbol_kindtype (s),
19354                                        0,
19355                                        FFEINFO_kindFUNCTION,
19356                                        FFEINFO_whereINTRINSIC,
19357                                        ffesymbol_size (s)));
19358     }
19359   else
19360     {                           /* Not intrinsic, now needs CHAR type. */
19361       if (!ffeimplic_establish_symbol (s))
19362         {
19363           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19364           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19365         }
19366
19367       ffesymbol_set_info (s,
19368                           ffeinfo_new (ffesymbol_basictype (s),
19369                                        ffesymbol_kindtype (s),
19370                                        ffesymbol_rank (s),
19371                                        FFEINFO_kindFUNCTION,
19372                                        (where == FFEINFO_whereNONE)
19373                                        ? FFEINFO_whereGLOBAL
19374                                        : where,
19375                                        ffesymbol_size (s)));
19376     }
19377
19378   ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19379
19380   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19381   ffesymbol_resolve_intrin (s);
19382   s = ffecom_sym_learned (s);
19383   ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19384   ffesymbol_signal_unreported (s);      /* For debugging purposes. */
19385   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19386   return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19387 }
19388
19389 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19390
19391    Handle basically any expression, looking for CLOSE_PAREN.  */
19392
19393 static ffelexHandler
19394 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19395                          ffelexToken t)
19396 {
19397   ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19398
19399   switch (ffelex_token_type (t))
19400     {
19401     case FFELEX_typeCOMMA:
19402     case FFELEX_typeCOLON:
19403       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19404                                           FFEEXPR_contextACTUALARG_,
19405                                           ffeexpr_token_anything_);
19406
19407     default:
19408       e->u.operand = ffebld_new_any ();
19409       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19410       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19411       ffeexpr_is_substr_ok_ = FALSE;
19412       if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19413         return (ffelexHandler) ffeexpr_token_substrp_;
19414       return (ffelexHandler) ffeexpr_token_substrp_ (t);
19415     }
19416 }
19417
19418 /* Terminate module.  */
19419
19420 void
19421 ffeexpr_terminate_2 ()
19422 {
19423   assert (ffeexpr_stack_ == NULL);
19424   assert (ffeexpr_level_ == 0);
19425 }